slime-2.20/000077500000000000000000000000001315100173500125425ustar00rootroot00000000000000slime-2.20/.gitref000066400000000000000000000000501315100173500140160ustar00rootroot00000000000000f223388c78ea51ce7717e9bbae14c50ad2386c2cslime-2.20/.travis.yml000066400000000000000000000025401315100173500146540ustar00rootroot00000000000000language: emacs env: # we test emacs23 with sbcl only - "CHECK_TARGET=check LISP=sbcl EMACS=emacs23" - "CHECK_TARGET=check-fancy LISP=sbcl EMACS=emacs23" # for emacs24, use more combinations - "CHECK_TARGET=check LISP=sbcl EMACS=emacs24" #- "CHECK_TARGET=check LISP=cmucl EMACS=emacs24" - "CHECK_TARGET=check LISP=ccl EMACS=emacs24" - "CHECK_TARGET=check-fancy LISP=sbcl EMACS=emacs24" #- "CHECK_TARGET=check-fancy LISP=cmucl EMACS=emacs24" - "CHECK_TARGET=check-fancy LISP=ccl EMACS=emacs24" # also, for emacs24/sbcl test some more contribs in isolation - "CHECK_TARGET=check-repl LISP=sbcl EMACS=emacs24" - "CHECK_TARGET=check-indentation LISP=sbcl EMACS=emacs24" install: - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | bash - if [ "$EMACS" = "emacs23" ]; then sudo apt-get -qq update && sudo apt-get -qq -f install && sudo apt-get -qq install emacs23-nox; fi - if [ "$EMACS" = "emacs24" ]; then sudo add-apt-repository -y ppa:cassou/emacs && sudo apt-get -qq update && sudo apt-get -qq -f install && sudo apt-get -qq install emacs24-nox; fi script: - make LISP=$LISP EMACS=$EMACS $CHECK_TARGET notifications: email: recipients: - slime-cvs@common-lisp.net # on_success: always # for testing slime-2.20/CONTRIBUTING.md000066400000000000000000000127551315100173500150050ustar00rootroot00000000000000# The SLIME Hacker's Handbook ## Lisp code file structure The Lisp code is organised into these files: * `swank-backend.lisp`: Definition of the interface to non-portable features. Stand-alone. * `swank-.lisp`: Backend implementation for a specific Common Lisp system. Uses swank-backend.lisp. * `swank.lisp`: The top-level server program, built from the other components. Uses swank-backend.lisp as an interface to the actual backends. * `slime.el`: The Superior Lisp Inferior Mode for Emacs, i.e. the Emacs frontend that the user actually interacts with and that connects to the SWANK server to send expressions to, and retrieve information from the running Common Lisp system. * `contrib/*.lisp`: Lisp related code for add-ons to SLIME that are maintained by their respective authors. Consult contrib/README for more information. ## Test Suite The Makefile includes a `check` target to run the ERT-based test suite. This can give a pretty good sanity-check for your changes Some backends do not pass the full test suite because of missing features. In these cases the test suite is still useful to ensure that changes don't introduce new errors. CMUCL historically passes the full test suite so it makes a good sanity check for fundamental changes (e.g. to the protocol). Running the test suite, adding new cases, and increasing the number of cases that backends support are all very good for karma. ## Source code layout We use a special source file layout to take advantage of some fancy Emacs features: outline-mode and "narrowing". ### Outline structure Our source files have a hierarchical structure using comments like these: ```el ;;;; Heading ;;;;; Subheading ... etc ``` We do this as a nice way to structure the program. We try to keep each (sub)section small enough to fit in your head: typically around 50-200 lines of code each. Each section usually begins with a brief introduction, followed by its highest-level functions, followed by their subroutines. This is a pleasing shape for a source file to have. Of course the comments mean something to Emacs too. One handy usage is to bring up a hyperlinked "table of contents" for the source file using this command: ```el (defun show-outline-structure () "Show the outline-mode structure of the current buffer." (interactive) (occur (concat "^" outline-regexp))) ``` Another is to use `outline-minor-mode` to fold away certain parts of the buffer. See the `Outline Mode` section of the Emacs manual for details about that. ### Pagebreak characters (^L) We partition source files into chunks using pagebreak characters. Each chunk is a substantial piece of code that can be considered in isolation, that could perhaps be a separate source file if we were fanatical about small source files (rather than big ones!) The page breaks usually go in the same place as top-level outline-mode headings, but they don't have to. They're flexible. In the old days, when `slime.el` was less than 100 pages long, these page breaks were helpful when printing it out to read. Now they're useful for something else: narrowing. You can use `C-x n p` (`narrow-to-page`) to "zoom in" on a pagebreak-delimited section of the file as if it were a separate buffer in itself. You can then use `C-x n w` (`widen`) to "zoom out" and see the whole file again. This is tremendously helpful for focusing your attention on one part of the program as if it were its own file. (This file contains some page break characters. If you're reading in Emacs you can press `C-x n p` to narrow to this page, and then later `C-x n w` to make the whole buffer visible again.) ## Coding style We like the fact that each function in SLIME will fit on a single screen (80x20), and would like to preserve this property! Beyond that we're not dogmatic :-) In early discussions we all made happy noises about the advice in Norvig and Pitman's [Tutorial on Good Lisp Programming Style](http://www.norvig.com/luv-slides.ps). For Emacs Lisp, we try to follow the _Tips and Conventions_ in Appendix D of the GNU Emacs Lisp Reference Manual (see Info file `elisp`, node `Tips`). We use Emacs conventions for docstrings: the first line should be a complete sentence to make the output of `apropos` look good. We also use imperative verbs. Now that XEmacs support is gone, rewrites using packages in GNU Emacs's core get extra karma. Customization variables complicate testing and therefore we only add new ones after careful consideration. Adding new customization variables is bad for karma. We generally neither use nor recommend eval-after-load. The biggest problem with SLIME's code base is feature creep. Keep in mind that the Right Thing isn't always the Smart Thing. If you can't find an elegant solution to a problem then you're probably solving the wrong problem. It's often a good idea to simplify the problem and to ignore rarely needed cases. _Remember that to rewrite a program better is the sincerest form of code appreciation. When you can see a way to rewrite a part of SLIME better, please do so!_ ## Pull requests * Read [how to properly contribute to open source projects on Github][1]. * Use a topic branch to easily amend a pull request later, if necessary. * Open a [pull request][2] that relates to *only* one subject with a clear title and description in grammatically correct, complete sentences. * Write [good commit messages][3]. [1]: http://gun.io/blog/how-to-github-fork-branch-and-pull-request [2]: https://help.github.com/articles/using-pull-requests [3]: http://chris.beams.io/posts/git-commit/ slime-2.20/Makefile000066400000000000000000000046431315100173500142110ustar00rootroot00000000000000### Makefile for SLIME # # This file is in the public domain. # Variables # EMACS=emacs LISP=sbcl LOAD_PATH=-L . ELFILES := slime.el slime-autoloads.el slime-tests.el $(wildcard lib/*.el) ELCFILES := $(ELFILES:.el=.elc) default: compile contrib-compile all: compile help: @printf "\ Main targets\n\ all -- see compile\n\ compile -- compile .el files\n\ check -- run tests in batch mode\n\ clean -- delete generated files\n\ doc-help -- print help about doc targets\n\ help-vars -- print info about variables\n\ help -- print this message\n" help-vars: @printf "\ Main make variables:\n\ EMACS -- program to start Emacs ($(EMACS))\n\ LISP -- program to start Lisp ($(LISP))\n\ SELECTOR -- selector for ERT tests ($(SELECTOR))\n" # Compilation # slime.elc: slime.el lib/hyperspec.elc %.elc: %.el $(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $< compile: $(ELCFILES) # Automated tests # SELECTOR=t check: compile $(EMACS) -Q --batch $(LOAD_PATH) \ --eval "(require 'slime-tests)" \ --eval "(slime-setup)" \ --eval "(setq inferior-lisp-program \"$(LISP)\")" \ --eval '(slime-batch-test (quote $(SELECTOR)))' # run tests interactively # # FIXME: Not terribly useful until bugs in ert-run-tests-interactively # are fixed. test: compile $(EMACS) -Q -nw $(LOAD_PATH) \ --eval "(require 'slime-tests)" \ --eval "(slime-setup)" \ --eval "(setq inferior-lisp-program \"$(LISP)\")" \ --eval '(slime-batch-test (quote $(SELECTOR)))' compile-swank: echo '(load "swank-loader.lisp")' '(swank-loader:init :setup nil)' \ | $(LISP) run-swank: { echo \ '(load "swank-loader.lisp")' \ '(swank-loader:init)' \ '(swank:create-server)' \ && cat; } \ | $(LISP) elpa-slime: echo "Not implemented yet: elpa-slime target" && exit 255 elpa: elpa-slime contrib-elpa # Cleanup # FASLREGEX = .*\.\(fasl\|ufasl\|sse2f\|lx32fsl\|abcl\|fas\|lib\|trace\)$$ clean-fasls: find . -regex '$(FASLREGEX)' -exec rm -v {} \; [ ! -d ~/.slime/fasl ] || rm -rf ~/.slime/fasl clean: clean-fasls find . -iname '*.elc' -exec rm {} \; # Contrib stuff. Should probably also go to contrib/ # MAKECONTRIB=$(MAKE) -C contrib EMACS="$(EMACS)" LISP="$(LISP)" contrib-check-% check-%: $(MAKECONTRIB) $(@:contrib-%=%) contrib-elpa: $(MAKECONTRIB) elpa-all contrib-compile: $(MAKECONTRIB) compile # Doc # doc-%: $(MAKE) -C doc $(@:doc-%=%) doc: doc-help .PHONY: clean elpa compile check doc dist slime-2.20/NEWS000066400000000000000000000464241315100173500132530ustar00rootroot00000000000000* SLIME News -*- mode: outline; coding: utf-8 -*- * 2.20 (August 2017) ** Core *** More secure handling of ~/.slime-secret ** SBCL backend *** Compatiblity with the latest SBCL and older SBCL. ** ECL backend *** Numerous enhancements * 2.19 (February 2017) ** Core *** Function `create-server` now accepts optional `interface` argument. Swank will bind the PORT on this interface. By default, interface is 127.0.0.1. This argument can be used, for example, to bind swank on IPv6 interface "::1". ** SBCL backend *** Now swank can be bound to IPv6 interface and can work on IPv6-only machines. *** Compatiblity with the latest SBCL * 2.18 (May 2016) *** Mostly bug fixes and compatibility with newer implementations * 2.17 (February 2016) ** Contribs *** New contrib, slime-macrostep, for more advanced in-place macroexpansion. *** New contrib, slime-quicklisp. * 2.16 (January 2016) *** Auto-completion now supports package-local nicknames on SBCL and ABCL. *** Bug fixes and updates for newer implementations. * 2.15 (August 2015) ** Core *** Completions are now displayed with `completion-at-point'. The new variable `slime-completion-at-point-functions' should now be used to customize completion. The old variable `slime-complete-symbol-function' still works, but it is considered obsolete and will be removed eventually. ** SBCL backend *** M-. can locate forms within PROGN/MACROLET/etc. Needs SBCL 1.2.15 * 2.14 (June 2015) ** Core *** Rationals are displayed in the echo area as floats too *** Some of SLDB's faces now have MORE COLOR *** Clicking with mouse-1 within inspector does things As do mouse-6 and mouse-7. (Thanks to Attila Lendvai.) ** slime-c-p-c (Compound Prefix Completion) *** Now takes a better guess at symbol case (issue #233) ** slime-fancy *** slime-mdot-fu is now enabled by default ** SBCL backend *** Now able to jump to ir1-translators, declaims and alien types *** Various updates supporting SBCL 1.2.12 ** ABCL backend *** Fixed inspection of frame-locals in the debugger (Thanks to Mark Evenson.) * 2.13 (March 2015) ** Core *** slime-cycle-connections has been deprecated It has been replaced by slime-next-connection and slime-prev-connection. A shortcut for the latter has been added to slime-selector. ** slime-mdot-fu The slime-mdot-fu contrib has been brought back to life. (Thanks to Charles Zhang. Issues #8, #231 and #232.) ** slime-typeout-frame The slime-typeout-frame contrib has been restored. (Issue #221.) ** SBCL backend *** Fixed xrefs coming from C-c C-c Issue #227. ** CMUCL, SBCL and SCL backends *** Better support for custom readtables Functionality that depends on SWANK's source-path-parser, such as `slime-find-definition', now works properly in face of custom readtables by honoring SWANK:*READTABLE-ALIST*. (Thanks to Gábor Melis. PR #244.) ** Kawa backend *** Updated for Kawa version 2.0 * 2.12 (January 2015) ** Core A couple of regressions introduced in version 2.10 were fixed. *** slime-compile-buffer (C-c C-k) no longer tries to save every buffer *** slime-autodoc-mode doesn't spam the minibuffer anymore ** SWANK *** CREATE-SERVER provides interactive restarts when port is taken Thanks to Adlai Chandrasekhar. (PR #204.) ** slime-fuzzy New variable *FUZZY-DUPLICATE-SYMBOL-FILTER* allows customization of how symbols accessible from multiple packages should be canonicalized. Defaults to :NEAREST-PACKAGE, a departure from the previous default behaviour which is still available using :HOME-PACKAGE. The new behaviour expands "ui:e-l" to "uiop:ensure-list" rather than "uiop/utility:ensure-list". Consult the manual for other options and other details. Thanks to Ivan Shvedunov. (PR #205.) * 2.11 (December 2014) ** MELPA is now an officially supported installation method Various bugs involving installation and upgrading via package.el were fixed. See the README for more details. (Issues #125, #195, #208.) ** Core *** Compilation via the xref buffer now works again ** slime-repl / slime-presentations Only text to the left of the cursor should limit the scope of history navigation. Fixed a long-standing bug that violated this when slime-presentations was enabled. (Thanks to Ivan Shvedunov. PR #207.) ** slime-package-fu Now handles strings as symbol designators, is mindful of trailing whitespace and properly handles an :export clause immediately following the package name. (Thanks to Leo Liu. PR #145.) ** slime-indentation The edge case handling described in slime-cl-indent.el:958 have been has been restored. ** Allegro CL backend Support for mlisp was restored. It had been broken by the previous release. (Reported by Alexandre Rademaker. Issue #209.) ** New experimental SWANK backend for MLWorks ** SWANK swank-listener-hooks was restored. (Thanks to Ivan Shvedunov. PR #210.) * 2.10.1 (October 2014) *** The SWANK-BACKEND nickname has been added to the SWANK/BACKEND package This should ease the migration of external projects that depend on the SWANK-BACKEND package. However, note that SWANK/BACKEND (as well as the other SWANK/* packages) are internal packages. Please refer to Conium for a project that purports to offer a stable API for debugger- and compiler-related tasks in Common Lisp. * 2.10 (October 2014) ** Core *** The SWANK-BACKEND package has been renamed to SWANK/BACKEND Furthermore, implementations of the SWANK-BACKEND interface have individual packages such as SWANK/SBCL, SWANK/CCL, etc. Other packages such as SWANK-RPC, SWANK-GRAY have likewise had their hyphens turned into slashes. *** slime-compile-file is now aware of compilation-ask-about-save When set to nil, SLIME will save modified buffers without asking. compilation-save-buffers-predicate can be used to customize which buffers should be automatically saved. ** slime-repl *** Clearing REPL output no longer deletes the prompt (issue #183) ** slime-autodoc This contrib has been rewritten. Please report any regressions you may find. ** ABCL backend *** Inspecting CLOS objects works properly again *** SLDB frame arguments have become inspectable ** SBCL backend *** Source locations involving the #. reader macro The aforementioned mechanism was adapted to recent changes in the internals of the SBCL reader. *** Breakage involving recent versions of SBCL on Windows was fixed (issue #192) We no longer assume SB-SYS:ENABLE-INTERRUPT exists on Windows SBCL. ** MKCL backend New backend for ManKai Common Lisp. ** CMUCL backend *** Support for versions prior to 20c has been removed ** MIT Scheme backend *** Updated and now requires MIT Scheme 9.2 * 2.9 (August 2014) ** Core *** Various display-related bugfixes ** CMUCL *** M-. now works on condition classes * 2.8 (July 2014) ** Core *** Inspector fixes and improvements for SBCL. ** Contribs *** Kawa backend supports Kawa 1.14. * 2.7 (June 2014) ** Core *** SWANK now tries harder to send double-floats to Emacs ** Allegro CL Backend *** Added implementation for FUNCTION-NAME and FIND-SOURCE-LOCATION interfaces Notably, this means that pressing "." in the SLIME inspector now works on Allegro CL. (Thanks to Gábor Melis.) * 2.6 (May 2014) ** Core *** *print-readably* bound to nil when displaying condition messages *** Issue #144: Removed nicknames and short package names The STD nickname for SWANK-TRACE-DIALOG was removed. MONITOR was renamed to SWANK-MONITOR and its nickname MON removed. *** Issues #135, #154: slime-to-lisp-filename used more pervasively Now used for the both the port-file and loader file when announced from Emacs to the lisp backend. Allows a user-written `slime-to-lisp-filename-function' that supports Cygwin lisps with non-Cygwin Emacsen or vice-versa. See #135 for an example of such a function. *** Issue #155: Stale SLDB buffers are now properly removed Indirect exits from an SLDB buffer that was not selected in a window would leave a stale buffer behind, leading to an inconsistent state and unexpected errors. ** Contribs *** Issue #139: Restored "copy to REPL" for slime-presentations `slime-copy-presentation-at-point-to-repl' will copy a presentation to the REPL, place it at point, and _not_ set *, ** and ***. This behaviour restored after refactorings of "copy to REPL" behaviour of previous versions. *** Issue #140: Improvements in the "copy to REPL" behaviour With or without the slime-presentations contrib, M-RET will copy/return values to REPL from both Inspector and SLDB buffers, setting *, ** and *** . If the slime-presentations contrib is enabled, the returned part will be an interactive presentation. The protocol for copying down parts to REPL has been reworked to not assume a CL backend . *** Now supports more CLHS references: :type, :system-class, :ansi-cl *** Issue #133: Fixed links to the SBCL manual ** Backend improvements *** SBCL **** `slime-set-default-directory' now calls chdir This propagates its effects to subprocesses. * 2.5 (April 2014) ** Backend improvements *** Clozure CL **** `slime-set-default-directory' now calls chdir This propagates its effects to subprocesses. *** Allegro CL **** swank-compile-string no longer binds *default-pathname-defaults* This was inconsistent with the behaviour of other backends and caused strange issues with SYS:TEMPORARY-DIRECTORY. **** Improved source file recording Whenever possible interactive definition compilation is mapped to the actual source file rather than the buffer name to avoid breakage when the the buffer name changes or is closed. ** SLIME Trace Dialog *** (Un)Tracing a definition automatically updates the trace status ** slime-repl *** Inspecting * in REPL no longer inspects ** (issue #137) ** slime-autodoc *** Multiline arglists in `slime-autodoc' no longer imply a newline (issue #7) ** Core Bugfixes *** SWANK port file name defined in more portable fashion Bug reported by Mirko Vukovic on slime-devel. *** inferior-lisp-program can now hold paths with spaces (issue #116) * 2.4 (March 2014) ** New contrib SLIME Trace Dialog included in `slime-fancy' Interactive interface to tracing functions and methods. See manual for details. ** New contrib `slime-fancy-trace', included in `slime-fancy' If your implementation allows it, trace complex method signatures, labels, etc... ** New options in `slime-cl-indent.el' used by the `slime-indentation' contrib New variables are `lisp-loop-body-forms-indentation' and `lisp-loop-body-forms-indentation'. ** New command `sldb-copy-down-to-repl' bound to M-RET in debugger Copies the frame variable under point to the REPL, much as `slime-inspector-copy-down-to-repl' does. ** New command `slime-delete-package' ** UTF8 encoding SLIME now uses only UTF8 to encode strings on the wire. Customization variables like `slime-net-coding-system' or `swank:*coding-system*' are now useless. ** Setup recipe In preparation for a more decentralized approach to SLIME contribs, the setup recipe has been slightly changed, hopefully in a backwards compatible way. Calling `slime-setup' is no longer required. Instead, the `slime-contribs' variable can be customized with a list of contribs to be loaded when `M-x slime' is first executed. See section `8.1 Loading Contrib Packages' of the SLIME Manual for more details. ** Bugfixes and stability improvements since the move to Github *** Issue #9: new REPL output respectes existing REPL results or presentations. *** Issue #17: TAB no longer freezes the REPL in "read-mode" *** Issue #42: compiles on Emacs 24 *** Issue #43: `just-one-space' no longer breaks REPL *** Issue #34: "Error in timer" error when starting slime on emacs24 *** Printing conditions is now a bit safer in the debugger (git:bafeb86) *** Fix undo behavior in the REPL (git:af354d7) Previously, undo would obliterate previous prompts. *** Fix REPL type-ahead behaviour when presentations active (git:38a1826) Input typed before your lisp responds is appended to the result when it arrives. *** Fix package and dir synch when no process buffer (git:dc88935) Sometimes process buffer has been killed, but connection is still active. *** M-p on any part of the REPL buffer no longer errors (git:dc88935) *** slime-presentations can be enabled in inspector (git:647c3c3, 2f57b34) Set `slime-inspector-insert-ispec-function' to `slime-presentation-inspector-insert-ispec' to use them. *** M-. on a presentation on the REPL now longer errors This happened when `slime-presentations' was enabled, either by itself or by `slime-fancy'. *** M-. on the first position of a *slime-apropos* buffer no longer fails. This happened with the `slime-fancy-inspector.el' contrib. *** RET on no part in *inspector* buffer no longer errors *** slime-repsentations properly recognized when at very beginning of buffer Fix by Attila Lendvai *** Avoid loading `swank-asdf.lisp' if there's a good chance it will break SWANK `swank-asdf.lisp' aborts the connection if it finds an old ASDF version. *** In ABCL, `slime-describe-function' now works for both macros and functions. ** SLIME builds on Travis CI See https://travis-ci.org/slime/slime for the build status and history. ** Testing framework refactored to use ERT `def-slime-test' creates regular ERT tests. `define-slime-ert-test' is a lighter convenience macro which automatically sets some tags for the new tests. ** Top-level Makefile For hackers or users using the latest version, there is now a top-level Makefile. Use "make help" to learn about targets. ** Moved to Github SLIME now lives in Github. The documentation and the README.md file were updated. HACKING was renamed to CONTRIBUTING.md and updated with Github specific instructions. ** Bugfixes and stability improvements Since the last release and before move to Github, many bugfixes and other changes were commited, too many to list here. See Changelog for details. * 2.3 (October 2011) ** REPL no longer loaded by default SLIME has a REPL which communicates exclusively over SLIME's socket. This REPL is no longer loaded by default. The default REPL is now the one by the Lisp implementation in the *inferior-lisp* buffer. The simplest way to enable the old REPL is: (slime-setup '(slime-repl)) ** Precise source tracking in Clozure CL Recent versions of the CCL compiler support source-location tracking. This makes the sldb-show-source command much more useful and M-. works better too. ** Environment variables for Lisp process slime-lisp-implementations can be used to specify a list of strings to augment the process environment of the Lisp process. E.g.: (sbcl-cvs ("/home/me/sbcl-cvs/src/runtime/sbcl" "--core" "/home/me/sbcl-cvs/output/sbcl.core") :env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/")) * 2.1 ** Removed Features Some of the more esoteric features, like presentations or fuzzy completion, are no longer enabled by default. A new directory "contrib/" contains the code for these packages. To use them, you must make some changes to your ~/.emacs. For details see, section "Contributed Packages" in the manual. ** Stepper Juho Snellman implemented stepping commands for SBCL. ** Completions SLIME can now complete keywords and character names (like #\newline). * 2.0 (April 2006) ** In-place macro expansion Marco Baringer wrote a new minor mode to incrementally expand macros. ** Improved arglist display SLIME now recognizes `make-instance' calls and displays the correct arglist if the classname is present. Similarly, for `defmethod' forms SLIME displays the arguments of the generic function. ** Persistent REPL history SLIME now saves the command history from REPL buffers in a file and reloads it for newly created REPL buffers. ** Scieneer Common Lisp Douglas Crosher added support for Scieneer Common Lisp. ** SBCL Various improvements to make SLIME work well with current SBCL versions. ** Corman Common Lisp Espen Wiborg added support for Corman Common Lisp. ** Presentations A new feature which associates objects in Lisp with their textual represetation in Emacs. The text is clickable and operations on the associated object can be invoked from a pop-up menu. ** Security SLIME has now a simple authentication mechanism: if the file ~/.slime-secret exists we verify that Emacs and Lisp can access it. Since both parties have access to the same file system, we assume that we can trust each other. * 1.2 (March 2005) ** New inspector The lisp side now returns a specially formated list of "things" to format which are then passed to emacs and rendered in the inspector buffer. Things can be either text, recursivly inspectable values, or functions to call. The new inspector has much better support CLOS objects and methods. ** Unicode It's now possible to send non-ascii characters to Emacs, if the communication channel is configured properly. See the variable `slime-net-coding-system'. ** Arglist lookup while debugging Previously, arglist lookup was disabled while debugging. This restriction was removed. ** Extended tracing command It's now possible to trace individual a single methods or all methods of a generic function. Also tracing can be restricted to situations in which the traced function is called from a specific function. ** M-x slime-browse-classes A simple class browser was added. ** FASL files The fasl files for different Lisp/OS/hardware combinations are now placed in different directories. ** Many other small improvements and bugfixes * 1.0 (September 2004) ** slime-interrupt The default key binding for slime-interrupt is now C-c C-b. ** sldb-inspect-condition In SLDB 'C' is now bound to sldb-inspect-condition. ** More Menus SLDB and the REPL have now pull-down menus. ** Global debugger hook. A new configurable *global-debugger* to control whether swank-debugger-hook should be installed globally is available. True by default. ** When you call sldb-eval-in-frame with a prefix argument, the result is now inserted in the REPL buffer. ** Compile function For Allegro M-. works now for functions compiled with C-c C-c. ** slime-edit-definition Better support for Allegro: works now for different type of definitions not only. So M-. now works for e.g. classes in Allegro. ** SBCL 0.8.13 SBCL 0.8.12 is no longer supported. Support for 0.8.12 was broken for for some time now. * 1.0 beta (August 2004) ** autodoc global variables The slime-autodoc-mode will now automatically show the value of a global variable at point. ** Customize group The customize group is expanded and better-organised. ** slime-interactive-eval Interactive-eval commands now print their results to the REPL when given a prefix argument. ** slime-conservative-indentation New Elisp variable. Non-nil means that we exclude def* and with-* from indentation-learning. The default is t. ** (slime-setup) New function to streamline setup in ~/.emacs ** Modeline package The package name in the modeline is now updated on an idle timer. The message should now be more meaningful when moving around in files containing multiple IN-PACKAGE forms. ** XREF bugfix The XREF commands did not find symbols in the right package. ** REPL prompt The package name in the REPL's prompt is now abbreviated to the last `.'-delimited token, e.g. MY.COMPANY.PACKAGE would be PACKAGE. This can be disabled by setting SWANK::*AUTO-ABBREVIATE-DOTTED-PACKAGES* to NIL. ** CMUCL source cache The source cache is now populated on `first-change-hook'. This makes M-. work accurately in more file modification scenarios. ** SBCL compiler errors Detect compiler errors and make some noise. Previously certain problems (e.g. reader-errors) could slip by quietly. * 1.0 alpha (June 2004) The first preview release of SLIME. slime-2.20/PROBLEMS000066400000000000000000000064441315100173500137200ustar00rootroot00000000000000Known problems with SLIME -*- outline -*- * Common to all backends ** Caution: network security The `M-x slime' command has Lisp listen on a TCP socket and wait for Emacs to connect, which typically takes on the order of one second. If someone else were to connect to this socket then they could use the SLIME protocol to control the Lisp process. The listen socket is bound on the loopback interface in all Lisps that support this. This way remote hosts are unable to connect. ** READ-CHAR-NO-HANG is broken READ-CHAR-NO-HANG doesn't work properly for slime-input-streams. Due to the way we request input from Emacs it's not possible to repeatedly poll for input. To get any input you have to call READ-CHAR (or a function which calls READ-CHAR). * Backend-specific problems ** CMUCL The default communication style :SIGIO is reportedly unreliable with certain libraries (like libSDL) and certain platforms (like Solaris on Sparc). It generally works very well on x86 so it remains the default. ** SBCL The latest released version of SBCL at the time of packaging should work. Older or newer SBCLs may or may not work. Do not use multithreading with unpatched 2.4 Linux kernels. There are also problems with kernel versions 2.6.5 - 2.6.10. The (v)iew-source command in the debugger can only locate exact source forms for code compiled at (debug 2) or higher. The default level is lower and SBCL itself is compiled at a lower setting. Thus only defun-granularity is available with default policies. ** LispWorks On Windows, SLIME hangs when calling foreign functions or certain other functions. The reason for this problem is unknown. We only support latin1 encoding. (Unicode wouldn't be hard to add.) ** Allegro CL Interrupting Allegro with C-c C-b can be slow. This is caused by the a relatively large process-quantum: 2 seconds by default. Allegro responds much faster if mp:*default-process-quantum* is set to 0.1. ** CLISP We require version 2.49 or higher. We also require socket support, so you may have to start CLISP with "clisp -K full". Under Windows, interrupting (with C-c C-b) doesn't work. Emacs sends a SIGINT signal, but the signal is either ignored or CLISP exits immediately. On Windows, CLISP may refuse to parse filenames like "C:\\DOCUME~1\\johndoe\\LOCALS~1\\Temp\\slime.1424" when we actually mean C:\Documents and Settings\johndoe\Local Settings\slime.1424. As a workaround, you could set slime-to-lisp-filename-function to some function that returns a string that is accepted by CLISP. Function arguments and local variables aren't displayed properly in the backtrace. Changes to CLISP's C code are needed to fix this problem. Interpreted code is usually easer to debug. M-. (find-definition) only works if the fasl file is in the same directory as the source file. The arglist doesn't include the proper names only "fake symbols" like `arg1'. ** Armed Bear Common Lisp The ABCL support is still new and experimental. ** Corman Common Lisp We require version 2.51 or higher, with several patches (available at http://www.grumblesmurf.org/lisp/corman-patches). The only communication style currently supported is NIL. Interrupting (with C-c C-b) doesn't work. The tracing, stepping and XREF commands are not implemented along with some debugger functionality. slime-2.20/README.md000066400000000000000000000053071315100173500140260ustar00rootroot00000000000000[![Build Status](https://img.shields.io/travis/slime/slime/master.svg)](https://travis-ci.org/slime/slime) [![MELPA](http://melpa.org/packages/slime-badge.svg?)](http://melpa.org/#/slime) [![MELPA Stable](http://stable.melpa.org/packages/slime-badge.svg?)](http://stable.melpa.org/#/slime) Overview -------- SLIME is the Superior Lisp Interaction Mode for Emacs. SLIME extends Emacs with support for interactive programming in Common Lisp. The features are centered around slime-mode, an Emacs minor-mode that complements the standard lisp-mode. While lisp-mode supports editing Lisp source files, slime-mode adds support for interacting with a running Common Lisp process for compilation, debugging, documentation lookup, and so on. For much more information, consult [the manual][1]. Quick setup instructions ------------------------ 1. [Set up the MELPA repository][2], if you haven't already, and install SLIME using `M-x package-install RET slime RET`. 2. Add the following lines to your `~/.emacs` file, filling in in the appropriate filenames: ```el ;; Set your lisp system and, optionally, some contribs (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") (setq slime-contribs '(slime-fancy)) ``` 3. Use `M-x slime` to fire up and connect to an inferior Lisp. SLIME will now automatically be available in your Lisp source buffers. If you'd like to contribute to SLIME, you will want to instead follow the manual's instructions on [how to install SLIME via Git][7]. Contribs -------- SLIME comes with additional contributed packages or "contribs". Contribs can be selected via the `slime-contribs` list. The most-often used contrib is `slime-fancy`, which primarily installs a popular set of other contributed packages. It includes a better REPL, and many more nice features. License ------- SLIME is free software. All files, unless explicitly stated otherwise, are public domain. Contact ------- If you have problems, first have a look at the list of [known issues and workarounds][6]. Questions and comments are best directed to the mailing list at `slime-devel@common-lisp.net`, but you have to [subscribe][3] first. The mailing list archive is also available on [Gmane][4]. See the [CONTRIBUTING.md][5] file for instructions on how to contribute. [1]: http://common-lisp.net/project/slime/doc/html/ [2]: http://melpa.org/#/getting-started [3]: http://www.common-lisp.net/project/slime/#mailinglist [4]: http://news.gmane.org/gmane.lisp.slime.devel [5]: https://github.com/slime/slime/blob/master/CONTRIBUTING.md [6]: https://github.com/slime/slime/issues?labels=workaround&state=closed [7]: http://common-lisp.net/project/slime/doc/html/Installation.html#Installing-from-Git slime-2.20/contrib/000077500000000000000000000000001315100173500142025ustar00rootroot00000000000000slime-2.20/contrib/Makefile000066400000000000000000000100751315100173500156450ustar00rootroot00000000000000### Makefile for contribs # # This file is in the public domain. EMACS=emacs LISP=sbcl LOAD_PATH=-L . -L .. CONTRIBS = $(patsubst slime-%.el,%,$(wildcard slime-*.el)) CONTRIB_TESTS = $(patsubst test/slime-%-tests.el,%,$(wildcard test/slime-*.el)) SLIME_VERSION=$(shell grep "Version:" ../slime.el | grep -E -o "[0-9.]+$$") ELFILES := $(shell find . -type f -iname "*.el") ELCFILES := $(patsubst %.el,%.elc,$(ELFILES)) %.elc: %.el $(EMACS) -Q $(LOAD_PATH) --batch -f batch-byte-compile $< compile: $(ELCFILES) $(EMACS) -Q --batch $(LOAD_PATH) \ --eval "(batch-byte-recompile-directory 0)" . # ELPA builds for contribs # $(CONTRIBS:%=elpa-%): CONTRIB=$(@:elpa-%=%) $(CONTRIBS:%=elpa-%): CONTRIB_EL=$(CONTRIB:%=slime-%.el) $(CONTRIBS:%=elpa-%): CONTRIB_CL=$(CONTRIB:%=swank-%.lisp) $(CONTRIBS:%=elpa-%): CONTRIB_VERSION=$(shell ( \ grep "Version:" $(CONTRIB_EL) \ || echo $(SLIME_VERSION) \ ) | grep -E -o "[0-9.]+$$" ) $(CONTRIBS:%=elpa-%): PACKAGE=$(CONTRIB:%=slime-%-$(CONTRIB_VERSION)) $(CONTRIBS:%=elpa-%): PACKAGE_EL=$(CONTRIB:%=slime-%-pkg.el) $(CONTRIBS:%=elpa-%): ELPA_DIR=elpa/$(PACKAGE) $(CONTRIBS:%=elpa-%): compile elpa_dir=$(ELPA_DIR) mkdir -p $$elpa_dir; \ emacs --batch $(CONTRIB_EL) \ --eval "(require 'cl-lib)" \ --eval "(search-forward \"define-slime-contrib\")" \ --eval "(up-list -1)" \ --eval "(pp \ (pcase (read (point-marker)) \ (\`(define-slime-contrib ,name ,docstring . ,rest) \ \`(define-package ,name \"$(CONTRIB_VERSION)\" \ ,docstring \ ,(cons '(slime \"$(SLIME_VERSION)\") \ (cl-loop for form in rest \ when (eq :slime-dependencies (car form)) \ append (cl-loop for contrib in (cdr form) \ if (atom contrib) \ collect \ \`(,contrib \"$(SLIME_VERSION)\") \ else \ collect contrib))))))))" > \ $$elpa_dir/$(PACKAGE_EL); \ cp $(CONTRIB_EL) $$elpa_dir; \ [ -r $(CONTRIB_CL) ] && cp $(CONTRIB_CL) $$elpa_dir; \ ls $$elpa_dir cd elpa && tar cvf $(PACKAGE).tar $(PACKAGE) rm -rf $(ELPA_DIR) elpa-all: $(CONTRIBS:%=elpa-%) $(CONTRIB_TESTS:%=check-%): CONTRIB_NAME=$(patsubst check-%,slime-%,$@) $(CONTRIB_TESTS:%=check-%): SELECTOR=(quote (tag contrib)) $(CONTRIB_TESTS:%=check-%): compile $(EMACS) -Q --batch $(LOAD_PATH) -L test \ --eval "(require (quote slime))" \ --eval "(slime-setup (quote ($(CONTRIB_NAME))))" \ --eval "(require \ (intern \ (format \"%s-tests\" (quote $(CONTRIB_NAME)))))" \ --eval '(setq inferior-lisp-program "$(LISP)")' \ --eval "(slime-batch-test $(SELECTOR))" check-all: $(CONTRIB_TESTS:%=check-%) check-fancy: compile $(EMACS) -Q --batch $(LOAD_PATH) -L test \ --eval "(setq debug-on-error t)" \ --eval "(require (quote slime))" \ --eval "(slime-setup (quote (slime-fancy)))" \ --eval "(mapc (lambda (sym) \ (require \ (intern (format \"%s-tests\" sym)) \ nil t)) \ (slime-contrib-all-dependencies \ (quote slime-fancy)))" \ --eval '(setq inferior-lisp-program "$(LISP)")' \ --eval '(slime-batch-test (quote (tag contrib)))' slime-2.20/contrib/README.md000066400000000000000000000013221315100173500154570ustar00rootroot00000000000000This directory contains source code which may be useful to some Slime users. `*.el` files are Emacs Lisp source and `*.lisp` files contain Common Lisp source code. If not otherwise stated in the file itself, the files are placed in the Public Domain. The components in this directory are more or less detached from the rest of Slime. They are essentially "add-ons". But Slime can also be used without them. The code is maintained by the respective authors. See the top level README.md for how to use packages in this directory. Finally, the contrib `slime-fancy` is specially noteworthy, as it represents a meta-contrib that'll load a bunch of commonly used contribs. Look into `slime-fancy.el` to find out which. slime-2.20/contrib/bridge.el000066400000000000000000000415071315100173500157670ustar00rootroot00000000000000;;; -*-Emacs-Lisp-*- ;;;%Header ;;; Bridge process filter, V1.0 ;;; Copyright (C) 1991 Chris McConnell, ccm@cs.cmu.edu ;;; ;;; Send mail to ilisp@cons.org if you have problems. ;;; ;;; Send mail to majordomo@cons.org if you want to be on the ;;; ilisp mailing list. ;;; This file is part of GNU Emacs. ;;; GNU Emacs is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY. No author or distributor ;;; accepts responsibility to anyone for the consequences of using it ;;; or for whether it serves any particular purpose or works at all, ;;; unless he says so in writing. Refer to the GNU Emacs General Public ;;; License for full details. ;;; Everyone is granted permission to copy, modify and redistribute ;;; GNU Emacs, but only under the conditions described in the ;;; GNU Emacs General Public License. A copy of this license is ;;; supposed to have been given to you along with GNU Emacs so you ;;; can know your rights and responsibilities. It should be in a ;;; file named COPYING. Among other things, the copyright notice ;;; and this notice must be preserved on all copies. ;;; Send any bugs or comments. Thanks to Todd Kaufmann for rewriting ;;; the process filter for continuous handlers. ;;; USAGE: M-x install-bridge will add a process output filter to the ;;; current buffer. Any output that the process does between ;;; bridge-start-regexp and bridge-end-regexp will be bundled up and ;;; passed to the first handler on bridge-handlers that matches the ;;; output using string-match. If bridge-prompt-regexp shows up ;;; before bridge-end-regexp, the bridge will be cancelled. If no ;;; handler matches the output, the first symbol in the output is ;;; assumed to be a buffer name and the rest of the output will be ;;; sent to that buffer's process. This can be used to communicate ;;; between processes or to set up two way interactions between Emacs ;;; and an inferior process. ;;; You can write handlers that process the output in special ways. ;;; See bridge-send-handler for the default handler. The command ;;; hand-bridge is useful for testing. Keep in mind that all ;;; variables are buffer local. ;;; YOUR .EMACS FILE: ;;; ;;; ;;; Set up load path to include bridge ;;; (setq load-path (cons "/bridge-directory/" load-path)) ;;; (autoload 'install-bridge "bridge" "Install a process bridge." t) ;;; (setq bridge-hook ;;; '(lambda () ;;; ;; Example options ;;; (setq bridge-source-insert nil) ;Don't insert in source buffer ;;; (setq bridge-destination-insert nil) ;Don't insert in dest buffer ;;; ;; Handle copy-it messages yourself ;;; (setq bridge-handlers ;;; '(("copy-it" . my-copy-handler))))) ;;; EXAMPLE: ;;; # This pipes stdin to the named buffer in a Unix shell ;;; alias devgnu '(echo -n "\!* "; cat -; echo -n "")' ;;; ;;; ls | devgnu *scratch* (eval-when-compile (require 'cl)) ;;;%Parameters (defvar bridge-hook nil "Hook called when a bridge is installed by install-hook.") (defvar bridge-start-regexp "" "*Regular expression to match the start of a process bridge in process output. It should be followed by a buffer name, the data to be sent and a bridge-end-regexp.") (defvar bridge-end-regexp "" "*Regular expression to match the end of a process bridge in process output.") (defvar bridge-prompt-regexp nil "*Regular expression for detecting a prompt. If there is a comint-prompt-regexp, it will be initialized to that. A prompt before a bridge-end-regexp will stop the process bridge.") (defvar bridge-handlers nil "Alist of (regexp . handler) for handling process output delimited by bridge-start-regexp and bridge-end-regexp. The first entry on the list whose regexp matches the output will be called on the process and the delimited output.") (defvar bridge-source-insert t "*T to insert bridge input in the source buffer minus delimiters.") (defvar bridge-destination-insert t "*T for bridge-send-handler to insert bridge input into the destination buffer minus delimiters.") (defvar bridge-chunk-size 512 "*Long inputs send to comint processes are broken up into chunks of this size. If your process is choking on big inputs, try lowering the value.") ;;;%Internal variables (defvar bridge-old-filter nil "Old filter for a bridged process buffer.") (defvar bridge-string nil "The current output in the process bridge.") (defvar bridge-in-progress nil "The current handler function, if any, that bridge passes strings on to, or nil if none.") (defvar bridge-leftovers nil "Because of chunking you might get an incomplete bridge signal - start but the end is in the next packet. Save the overhanging text here.") (defvar bridge-send-to-buffer nil "The buffer that the default bridge-handler (bridge-send-handler) is currently sending to, or nil if it hasn't started yet. Your handler function can use this variable also.") (defvar bridge-last-failure () "Last thing that broke the bridge handler. First item is function call (eval'able); last item is error condition which resulted. This is provided to help handler-writers in their debugging.") (defvar bridge-insert-function nil "If non-nil use this instead of `bridge-insert'") ;;;%Utilities (defun bridge-insert (output &optional _dummy) "Insert process OUTPUT into the current buffer." (if bridge-insert-function (funcall bridge-insert-function output) (if output (let* ((buffer (current-buffer)) (process (get-buffer-process buffer)) (mark (process-mark process)) (window (selected-window)) (at-end nil)) (if (eq (window-buffer window) buffer) (setq at-end (= (point) mark)) (setq window (get-buffer-window buffer))) (save-excursion (goto-char mark) (insert output) (set-marker mark (point))) (if window (progn (if at-end (goto-char mark)) (if (not (pos-visible-in-window-p (point) window)) (let ((original (selected-window))) (save-excursion (select-window window) (recenter '(center)) (select-window original)))))))))) ;;; ;(defun bridge-send-string (process string) ; "Send PROCESS the contents of STRING as input. ;This is equivalent to process-send-string, except that long input strings ;are broken up into chunks of size comint-input-chunk-size. Processes ;are given a chance to output between chunks. This can help prevent processes ;from hanging when you send them long inputs on some OS's." ; (let* ((len (length string)) ; (i (min len bridge-chunk-size))) ; (process-send-string process (substring string 0 i)) ; (while (< i len) ; (let ((next-i (+ i bridge-chunk-size))) ; (accept-process-output) ; (process-send-string process (substring string i (min len next-i))) ; (setq i next-i))))) ;;; (defun bridge-call-handler (handler proc string) "Funcall HANDLER on PROC, STRING carefully. Error is caught if happens, and user is signaled. State is put in bridge-last-failure. Returns t if handler executed without error." (let ((inhibit-quit nil) (failed nil)) (condition-case err (funcall handler proc string) (error (ding) (setq failed t) (message "bridge-handler \"%s\" failed %s (see bridge-last-failure)" handler err) (setq bridge-last-failure `((funcall ',handler ',proc ,string) "Caused: " ,err)))) (not failed))) ;;;%Handlers (defun bridge-send-handler (process input) "Send PROCESS INPUT to the buffer name found at the start of the input. The input after the buffer name is sent to the buffer's process if it has one. If bridge-destination-insert is T, the input will be inserted into the buffer. If it does not have a process, it will be inserted at the end of the buffer." (if (null input) (setq bridge-send-to-buffer nil) ; end of bridge (let (buffer-and-start buffer-name dest to) ;; if this is first time, get the buffer out of the first line (cond ((not bridge-send-to-buffer) (setq buffer-and-start (read-from-string input) buffer-name (format "%s" (car (read-from-string input))) dest (get-buffer buffer-name) to (get-buffer-process dest) input (substring input (cdr buffer-and-start))) (setq bridge-send-to-buffer dest)) (t (setq buffer-name bridge-send-to-buffer dest (get-buffer buffer-name) to (get-buffer-process dest) ))) (if dest (let ((buffer (current-buffer))) (if bridge-destination-insert (unwind-protect (progn (set-buffer dest) (if to (bridge-insert process input) (goto-char (point-max)) (insert input))) (set-buffer buffer))) (if to ;; (bridge-send-string to input) (process-send-string to input) )) (error "%s is not a buffer" buffer-name))))) ;;;%Filter (defun bridge-filter (process output) "Given PROCESS and some OUTPUT, check for the presence of bridge-start-regexp. Everything prior to this will be passed to the normal filter function or inserted in the buffer if it is nil. The output up to bridge-end-regexp will be sent to the first handler on bridge-handlers that matches the string. If no handlers match, the input will be sent to bridge-send-handler. If bridge-prompt-regexp is encountered before the bridge-end-regexp, the bridge will be cancelled." (let ((inhibit-quit t) (match-data (match-data)) (buffer (current-buffer)) (process-buffer (process-buffer process)) (case-fold-search t) (start 0) (end 0) function b-start b-start-end b-end) (set-buffer process-buffer) ;; access locals ;; Handle bridge messages that straddle a packet by prepending ;; them to this packet. (when bridge-leftovers (setq output (concat bridge-leftovers output)) (setq bridge-leftovers nil)) (setq function bridge-in-progress) ;; How it works: ;; ;; start, end delimit the part of string we are interested in; ;; initially both 0; after an iteration we move them to next string. ;; b-start, b-end delimit part of string to bridge (possibly whole string); ;; this will be string between corresponding regexps. ;; There are two main cases when we come into loop: ;; bridge in progress ;;0 setq b-start = start ;;1 setq b-end (or end-pattern end) ;;4 process string ;;5 remove handler if end found ;; no bridge in progress ;;0 setq b-start if see start-pattern ;;1 setq b-end if bstart to (or end-pattern end) ;;2 send (substring start b-start) to normal place ;;3 find handler (in b-start, b-end) if not set ;;4 process string ;;5 remove handler if end found ;; equivalent sections have the same numbers here; ;; we fold them together in this code. (block bridge-filter (unwind-protect (while (< end (length output)) ;;0 setq b-start if find (setq b-start (cond (bridge-in-progress (setq b-start-end start) start) ((string-match bridge-start-regexp output start) (setq b-start-end (match-end 0)) (match-beginning 0)) (t nil))) ;;1 setq b-end (setq b-end (if b-start (let ((end-seen (string-match bridge-end-regexp output b-start-end))) (if end-seen (setq end (match-end 0))) end-seen))) ;; Detect and save partial bridge messages (when (and b-start b-start-end (not b-end)) (setq bridge-leftovers (substring output b-start)) ) (if (and b-start (not b-end)) (setq end b-start) (if (not b-end) (setq end (length output)))) ;;1.5 - if see prompt before end, remove current (if (and b-start b-end) (let ((prompt (string-match bridge-prompt-regexp output b-start-end))) (if (and prompt (<= (match-end 0) b-end)) (setq b-start nil ; b-start-end start b-end start end (match-end 0) bridge-in-progress nil )))) ;;2 send (substring start b-start) to old filter, if any (when (not (equal start (or b-start end))) ; don't bother on empty string (let ((pass-on (substring output start (or b-start end)))) (if bridge-old-filter (let ((old bridge-old-filter)) (store-match-data match-data) (funcall old process pass-on) ;; if filter changed, re-install ourselves (let ((new (process-filter process))) (if (not (eq new 'bridge-filter)) (progn (setq bridge-old-filter new) (set-process-filter process 'bridge-filter))))) (set-buffer process-buffer) (bridge-insert pass-on)))) (if (and b-start-end (not b-end)) (return-from bridge-filter t) ; when last bit has prematurely ending message, exit early. (progn ;;3 find handler (in b-start, b-end) if none current (if (and b-start (not bridge-in-progress)) (let ((handlers bridge-handlers)) (while (and handlers (not function)) (let* ((handler (car handlers)) (m (string-match (car handler) output b-start-end))) (if (and m (< m b-end)) (setq function (cdr handler)) (setq handlers (cdr handlers))))) ;; Set default handler if none (if (null function) (setq function 'bridge-send-handler)) (setq bridge-in-progress function))) ;;4 process strin (if function (let ((ok t)) (if (/= b-start-end b-end) (let ((send (substring output b-start-end b-end))) ;; also, insert the stuff in buffer between ;; iff bridge-source-insert. (if bridge-source-insert (bridge-insert send)) ;; call handler on string (setq ok (bridge-call-handler function process send)))) ;;5 remove handler if end found ;; if function removed then tell it that's all (if (or (not ok) (/= b-end end)) ;; saw end before end-of-string (progn (bridge-call-handler function process nil) ;; have to remove function too for next time around (setq function nil bridge-in-progress nil) )) )) ;; continue looping, in case there's more string (setq start end)) )) ;; protected forms: restore buffer, match-data (set-buffer buffer) (store-match-data match-data) )))) ;;;%Interface (defun install-bridge () "Set up a process bridge in the current buffer." (interactive) (if (not (get-buffer-process (current-buffer))) (error "%s does not have a process" (buffer-name (current-buffer))) (make-local-variable 'bridge-start-regexp) (make-local-variable 'bridge-end-regexp) (make-local-variable 'bridge-prompt-regexp) (make-local-variable 'bridge-handlers) (make-local-variable 'bridge-source-insert) (make-local-variable 'bridge-destination-insert) (make-local-variable 'bridge-chunk-size) (make-local-variable 'bridge-old-filter) (make-local-variable 'bridge-string) (make-local-variable 'bridge-in-progress) (make-local-variable 'bridge-send-to-buffer) (make-local-variable 'bridge-leftovers) (setq bridge-string nil bridge-in-progress nil bridge-send-to-buffer nil) (if (boundp 'comint-prompt-regexp) (setq bridge-prompt-regexp comint-prompt-regexp)) (let ((process (get-buffer-process (current-buffer)))) (if process (if (not (eq (process-filter process) 'bridge-filter)) (progn (setq bridge-old-filter (process-filter process)) (set-process-filter process 'bridge-filter))) (error "%s does not have a process" (buffer-name (current-buffer))))) (run-hooks 'bridge-hook) (message "Process bridge is installed"))) ;;; (defun reset-bridge () "Must be called from the process's buffer. Removes any active bridge." (interactive) ;; for when things get wedged (if bridge-in-progress (unwind-protect (funcall bridge-in-progress (get-buffer-process (current-buffer)) nil) (setq bridge-in-progress nil)) (message "No bridge in progress."))) ;;; (defun remove-bridge () "Remove bridge from the current buffer." (interactive) (let ((process (get-buffer-process (current-buffer)))) (if (or (not process) (not (eq (process-filter process) 'bridge-filter))) (error "%s has no bridge" (buffer-name (current-buffer))) ;; remove any bridge-in-progress (reset-bridge) (set-process-filter process bridge-old-filter) (funcall bridge-old-filter process bridge-string) (message "Process bridge is removed.")))) ;;;% Utility for testing (defun hand-bridge (start end) "With point at bridge-start, sends bridge-start + string + bridge-end to bridge-filter. With prefix, use current region to send." (interactive "r") (let ((p0 (if current-prefix-arg (min start end) (if (looking-at bridge-start-regexp) (point) (error "Not looking at bridge-start-regexp")))) (p1 (if current-prefix-arg (max start end) (if (re-search-forward bridge-end-regexp nil t) (point) (error "Didn't see bridge-end-regexp"))))) (bridge-filter (get-buffer-process (current-buffer)) (buffer-substring-no-properties p0 p1)) )) (provide 'bridge) slime-2.20/contrib/inferior-slime.el000066400000000000000000000110741315100173500174530ustar00rootroot00000000000000;;; inferior-slime.el --- Minor mode with Slime keys for comint buffers ;; ;; Author: Luke Gorrie ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation: ;; ;; Add something like this to your .emacs: ;; ;; (add-to-list 'load-path "") ;; (add-hook 'slime-load-hook (lambda () (require 'inferior-slime))) ;; (add-hook 'inferior-lisp-mode-hook (lambda () (inferior-slime-mode 1))) (require 'slime) (require 'cl-lib) (define-minor-mode inferior-slime-mode "\\\ Inferior SLIME mode: The Inferior Superior Lisp Mode for Emacs. This mode is intended for use with `inferior-lisp-mode'. It provides a subset of the bindings from `slime-mode'. \\{inferior-slime-mode-map}" :keymap ;; Fake binding to coax `define-minor-mode' to create the keymap '((" " 'undefined)) (slime-setup-completion) (setq-local tab-always-indent 'complete)) (defun inferior-slime-return () "Handle the return key in the inferior-lisp buffer. The current input should only be sent if a whole expression has been entered, i.e. the parenthesis are matched. A prefix argument disables this behaviour." (interactive) (if (or current-prefix-arg (inferior-slime-input-complete-p)) (comint-send-input) (insert "\n") (inferior-slime-indent-line))) (defun inferior-slime-indent-line () "Indent the current line, ignoring everything before the prompt." (interactive) (save-restriction (let ((indent-start (save-excursion (goto-char (process-mark (get-buffer-process (current-buffer)))) (let ((inhibit-field-text-motion t)) (beginning-of-line 1)) (point)))) (narrow-to-region indent-start (point-max))) (lisp-indent-line))) (defun inferior-slime-input-complete-p () "Return true if the input is complete in the inferior lisp buffer." (slime-input-complete-p (process-mark (get-buffer-process (current-buffer))) (point-max))) (defun inferior-slime-closing-return () "Send the current expression to Lisp after closing any open lists." (interactive) (goto-char (point-max)) (save-restriction (narrow-to-region (process-mark (get-buffer-process (current-buffer))) (point-max)) (while (ignore-errors (save-excursion (backward-up-list 1) t)) (insert ")"))) (comint-send-input)) (defun inferior-slime-change-directory (directory) "Set default-directory in the *inferior-lisp* buffer to DIRECTORY." (let* ((proc (slime-process)) (buffer (and proc (process-buffer proc)))) (when buffer (with-current-buffer buffer (cd-absolute directory))))) (defun inferior-slime-init-keymap () (let ((map inferior-slime-mode-map)) (set-keymap-parent map slime-parent-map) (slime-define-keys map ([return] 'inferior-slime-return) ([(control return)] 'inferior-slime-closing-return) ([(meta control ?m)] 'inferior-slime-closing-return) ;;("\t" 'slime-indent-and-complete-symbol) (" " 'slime-space)))) (inferior-slime-init-keymap) (defun inferior-slime-hook-function () (inferior-slime-mode 1)) (defun inferior-slime-switch-to-repl-buffer () (switch-to-buffer (process-buffer (slime-inferior-process)))) (defun inferior-slime-show-transcript (string) (remove-hook 'comint-output-filter-functions 'inferior-slime-show-transcript t) (with-current-buffer (process-buffer (slime-inferior-process)) (let ((window (display-buffer (current-buffer) t))) (set-window-point window (point-max))))) (defun inferior-slime-start-transcript () (let ((proc (slime-inferior-process))) (when proc (with-current-buffer (process-buffer proc) (add-hook 'comint-output-filter-functions 'inferior-slime-show-transcript nil t))))) (defun inferior-slime-stop-transcript () (let ((proc (slime-inferior-process))) (when proc (with-current-buffer (process-buffer (slime-inferior-process)) (run-with-timer 0.2 nil (lambda (buffer) (with-current-buffer buffer (remove-hook 'comint-output-filter-functions 'inferior-slime-show-transcript t))) (current-buffer)))))) (defun inferior-slime-init () (add-hook 'slime-inferior-process-start-hook 'inferior-slime-hook-function) (add-hook 'slime-change-directory-hooks 'inferior-slime-change-directory) (add-hook 'slime-transcript-start-hook 'inferior-slime-start-transcript) (add-hook 'slime-transcript-stop-hook 'inferior-slime-stop-transcript) (def-slime-selector-method ?r "SLIME Read-Eval-Print-Loop." (process-buffer (slime-inferior-process)))) (provide 'inferior-slime) slime-2.20/contrib/slime-asdf.el000066400000000000000000000306001315100173500165470ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (require 'grep) (define-slime-contrib slime-asdf "ASDF support." (:authors "Daniel Barlow " "Marco Baringer " "Edi Weitz " "Stas Boukarev " "Tobias C Rittweiler ") (:license "GPL") (:slime-dependencies slime-repl) (:swank-dependencies swank-asdf) (:on-load (add-to-list 'slime-edit-uses-xrefs :depends-on t) (define-key slime-who-map [?d] 'slime-who-depends-on))) ;;; NOTE: `system-name' is a predefined variable in Emacs. Try to ;;; avoid it as local variable name. ;;; Utilities (defgroup slime-asdf nil "ASDF support for Slime." :prefix "slime-asdf-" :group 'slime) (defvar slime-system-history nil "History list for ASDF system names.") (defun slime-read-system-name (&optional prompt default-value determine-default-accurately) "Read a system name from the minibuffer, prompting with PROMPT. If no `default-value' is given, one is tried to be determined: if `determine-default-accurately' is true, by an RPC request which grovels through all defined systems; if it's not true, by looking in the directory of the current buffer." (let* ((completion-ignore-case nil) (prompt (or prompt "System")) (system-names (slime-eval `(swank:list-asdf-systems))) (default-value (or default-value (if determine-default-accurately (slime-determine-asdf-system (buffer-file-name) (slime-current-package)) (slime-find-asd-file (or default-directory (buffer-file-name)) system-names)))) (prompt (concat prompt (if default-value (format " (default `%s'): " default-value) ": ")))) (completing-read prompt (slime-bogus-completion-alist system-names) nil nil nil 'slime-system-history default-value))) (defun slime-find-asd-file (directory system-names) "Tries to find an ASDF system definition file in the `directory' and returns it if it's in `system-names'." (let ((asd-files (directory-files (file-name-directory directory) nil "\.asd$"))) (cl-loop for system in asd-files for candidate = (file-name-sans-extension system) when (cl-find candidate system-names :test #'string-equal) do (cl-return candidate)))) (defun slime-determine-asdf-system (filename buffer-package) "Try to determine the asdf system that `filename' belongs to." (slime-eval `(swank:asdf-determine-system ,(and filename (slime-to-lisp-filename filename)) ,buffer-package))) (defun slime-who-depends-on-rpc (system) (slime-eval `(swank:who-depends-on ,system))) (defcustom slime-asdf-collect-notes t "Collect and display notes produced by the compiler. See also `slime-highlight-compiler-notes' and `slime-compilation-finished-hook'." :group 'slime-asdf) (defun slime-asdf-operation-finished-function (system) (if slime-asdf-collect-notes #'slime-compilation-finished (slime-curry (lambda (system result) (let (slime-highlight-compiler-notes slime-compilation-finished-hook) (slime-compilation-finished result))) system))) (defun slime-oos (system operation &rest keyword-args) "Operate On System." (slime-save-some-lisp-buffers) (slime-display-output-buffer) (message "Performing ASDF %S%s on system %S" operation (if keyword-args (format " %S" keyword-args) "") system) (slime-repl-shortcut-eval-async `(swank:operate-on-system-for-emacs ,system ',operation ,@keyword-args) (slime-asdf-operation-finished-function system))) ;;; Interactive functions (defun slime-load-system (&optional system) "Compile and load an ASDF system. Default system name is taken from first file matching *.asd in current buffer's working directory" (interactive (list (slime-read-system-name))) (slime-oos system 'load-op)) (defun slime-open-system (name &optional load interactive) "Open all files in an ASDF system." (interactive (list (slime-read-system-name) nil t)) (when (or load (and interactive (not (slime-eval `(swank:asdf-system-loaded-p ,name))) (y-or-n-p "Load it? "))) (slime-load-system name)) (slime-eval-async `(swank:asdf-system-files ,name) (lambda (files) (when files (let ((files (mapcar 'slime-from-lisp-filename (nreverse files)))) (find-file-other-window (car files)) (mapc 'find-file (cdr files))))))) (defun slime-browse-system (name) "Browse files in an ASDF system using Dired." (interactive (list (slime-read-system-name))) (slime-eval-async `(swank:asdf-system-directory ,name) (lambda (directory) (when directory (dired (slime-from-lisp-filename directory)))))) (if (fboundp 'rgrep) (defun slime-rgrep-system (sys-name regexp) "Run `rgrep' on the base directory of an ASDF system." (interactive (progn (grep-compute-defaults) (list (slime-read-system-name nil nil t) (grep-read-regexp)))) (rgrep regexp "*.lisp" (slime-from-lisp-filename (slime-eval `(swank:asdf-system-directory ,sys-name))))) (defun slime-rgrep-system () (interactive) (error "This command is only supported on GNU Emacs >21.x."))) (if (boundp 'multi-isearch-next-buffer-function) (defun slime-isearch-system (sys-name) "Run `isearch-forward' on the files of an ASDF system." (interactive (list (slime-read-system-name nil nil t))) (let* ((files (mapcar 'slime-from-lisp-filename (slime-eval `(swank:asdf-system-files ,sys-name)))) (multi-isearch-next-buffer-function (lexical-let* ((buffers-forward (mapcar #'find-file-noselect files)) (buffers-backward (reverse buffers-forward))) #'(lambda (current-buffer wrap) ;; Contrarily to the docstring of ;; `multi-isearch-next-buffer-function', the first ;; arg is not necessarily a buffer. Report sent ;; upstream. (2009-11-17) (setq current-buffer (or current-buffer (current-buffer))) (let* ((buffers (if isearch-forward buffers-forward buffers-backward))) (if wrap (car buffers) (second (memq current-buffer buffers)))))))) (isearch-forward))) (defun slime-isearch-system () (interactive) (error "This command is only supported on GNU Emacs >23.1.x."))) (defun slime-read-query-replace-args (format-string &rest format-args) (let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook)) (minibuffer-local-map slime-minibuffer-map) (common (query-replace-read-args (apply #'format format-string format-args) t t))) (list (nth 0 common) (nth 1 common) (nth 2 common)))) (defun slime-query-replace-system (name from to &optional delimited) "Run `query-replace' on an ASDF system." (interactive (let ((system (slime-read-system-name nil nil t))) (cons system (slime-read-query-replace-args "Query replace throughout `%s'" system)))) (condition-case c ;; `tags-query-replace' actually uses `query-replace-regexp' ;; internally. (tags-query-replace (regexp-quote from) to delimited '(mapcar 'slime-from-lisp-filename (slime-eval `(swank:asdf-system-files ,name)))) (error ;; Kludge: `tags-query-replace' does not actually return but ;; signals an unnamed error with the below error ;; message. (<=23.1.2, at least.) (unless (string-equal (error-message-string c) "All files processed") (signal (car c) (cdr c))) ; resignal t))) (defun slime-query-replace-system-and-dependents (name from to &optional delimited) "Run `query-replace' on an ASDF system and all the systems depending on it." (interactive (let ((system (slime-read-system-name nil nil t))) (cons system (slime-read-query-replace-args "Query replace throughout `%s'+dependencies" system)))) (slime-query-replace-system name from to delimited) (dolist (dep (slime-who-depends-on-rpc name)) (when (y-or-n-p (format "Descend into system `%s'? " dep)) (slime-query-replace-system dep from to delimited)))) (defun slime-delete-system-fasls (name) "Delete FASLs produced by compiling a system." (interactive (list (slime-read-system-name))) (slime-repl-shortcut-eval-async `(swank:delete-system-fasls ,name) 'message)) (defun slime-reload-system (system) "Reload an ASDF system without reloading its dependencies." (interactive (list (slime-read-system-name))) (slime-save-some-lisp-buffers) (slime-display-output-buffer) (message "Performing ASDF LOAD-OP on system %S" system) (slime-repl-shortcut-eval-async `(swank:reload-system ,system) (slime-asdf-operation-finished-function system))) (defun slime-who-depends-on (system-name) (interactive (list (slime-read-system-name))) (slime-xref :depends-on system-name)) (defun slime-save-system (system) "Save files belonging to an ASDF system." (interactive (list (slime-read-system-name))) (slime-eval-async `(swank:asdf-system-files ,system) (lambda (files) (dolist (file files) (let ((buffer (get-file-buffer (slime-from-lisp-filename file)))) (when buffer (with-current-buffer buffer (save-buffer buffer))))) (message "Done.")))) ;;; REPL shortcuts (defslime-repl-shortcut slime-repl-load/force-system ("force-load-system") (:handler (lambda () (interactive) (slime-oos (slime-read-system-name) 'load-op :force t))) (:one-liner "Recompile and load an ASDF system.")) (defslime-repl-shortcut slime-repl-load-system ("load-system") (:handler (lambda () (interactive) (slime-oos (slime-read-system-name) 'load-op))) (:one-liner "Compile (as needed) and load an ASDF system.")) (defslime-repl-shortcut slime-repl-test/force-system ("force-test-system") (:handler (lambda () (interactive) (slime-oos (slime-read-system-name) 'test-op :force t))) (:one-liner "Recompile and test an ASDF system.")) (defslime-repl-shortcut slime-repl-test-system ("test-system") (:handler (lambda () (interactive) (slime-oos (slime-read-system-name) 'test-op))) (:one-liner "Compile (as needed) and test an ASDF system.")) (defslime-repl-shortcut slime-repl-compile-system ("compile-system") (:handler (lambda () (interactive) (slime-oos (slime-read-system-name) 'compile-op))) (:one-liner "Compile (but not load) an ASDF system.")) (defslime-repl-shortcut slime-repl-compile/force-system ("force-compile-system") (:handler (lambda () (interactive) (slime-oos (slime-read-system-name) 'compile-op :force t))) (:one-liner "Recompile (but not completely load) an ASDF system.")) (defslime-repl-shortcut slime-repl-open-system ("open-system") (:handler 'slime-open-system) (:one-liner "Open all files in an ASDF system.")) (defslime-repl-shortcut slime-repl-browse-system ("browse-system") (:handler 'slime-browse-system) (:one-liner "Browse files in an ASDF system using Dired.")) (defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls") (:handler 'slime-delete-system-fasls) (:one-liner "Delete FASLs of an ASDF system.")) (defslime-repl-shortcut slime-repl-reload-system ("reload-system") (:handler 'slime-reload-system) (:one-liner "Recompile and load an ASDF system.")) (provide 'slime-asdf) slime-2.20/contrib/slime-autodoc.el000066400000000000000000000160361315100173500172770ustar00rootroot00000000000000(require 'slime) (require 'eldoc) (require 'cl-lib) (require 'slime-parse) (define-slime-contrib slime-autodoc "Show fancy arglist in echo area." (:license "GPL") (:authors "Luke Gorrie " "Lawrence Mitchell " "Matthias Koeppe " "Tobias C. Rittweiler ") (:slime-dependencies slime-parse) (:swank-dependencies swank-arglists) (:on-load (slime-autodoc--enable)) (:on-unload (slime-autodoc--disable))) (defcustom slime-autodoc-accuracy-depth 10 "Number of paren levels that autodoc takes into account for context-sensitive arglist display (local functions. etc)" :type 'integer :group 'slime-ui) (defun slime-arglist (name) "Show the argument list for NAME." (interactive (list (slime-read-symbol-name "Arglist of: " t))) (let ((arglist (slime-retrieve-arglist name))) (if (eq arglist :not-available) (error "Arglist not available") (message "%s" (slime-autodoc--fontify arglist))))) ;; used also in slime-c-p-c.el. (defun slime-retrieve-arglist (name) (let ((name (cl-etypecase name (string name) (symbol (symbol-name name))))) (car (slime-eval `(swank:autodoc '(,name ,slime-cursor-marker)))))) (defun slime-autodoc-manually () "Like autodoc informtion forcing multiline display." (interactive) (let ((doc (slime-autodoc t))) (cond (doc (eldoc-message "%s" doc)) (t (eldoc-message nil))))) ;; Must call eldoc-add-command otherwise (eldoc-display-message-p) ;; returns nil and eldoc clears the echo area instead. (eldoc-add-command 'slime-autodoc-manually) (defun slime-autodoc-space (n) "Like `slime-space' but nicer." (interactive "p") (self-insert-command n) (let ((doc (slime-autodoc))) (when doc (eldoc-message "%s" doc)))) (eldoc-add-command 'slime-autodoc-space) ;;;; Autodoc cache (defvar slime-autodoc--cache-last-context nil) (defvar slime-autodoc--cache-last-autodoc nil) (defun slime-autodoc--cache-get (context) "Return the cached autodoc documentation for `context', or nil." (and (equal context slime-autodoc--cache-last-context) slime-autodoc--cache-last-autodoc)) (defun slime-autodoc--cache-put (context autodoc) "Update the autodoc cache for CONTEXT with AUTODOC." (setq slime-autodoc--cache-last-context context) (setq slime-autodoc--cache-last-autodoc autodoc)) ;;;; Formatting autodoc (defsubst slime-autodoc--canonicalize-whitespace (string) (replace-regexp-in-string "[ \n\t]+" " " string)) (defun slime-autodoc--format (doc multilinep) (let ((doc (slime-autodoc--fontify doc))) (cond (multilinep doc) (t (slime-oneliner (slime-autodoc--canonicalize-whitespace doc)))))) (defun slime-autodoc--fontify (string) "Fontify STRING as `font-lock-mode' does in Lisp mode." (with-current-buffer (get-buffer-create (slime-buffer-name :fontify 'hidden)) (erase-buffer) (unless (eq major-mode 'lisp-mode) ;; Just calling (lisp-mode) will turn slime-mode on in that buffer, ;; which may interfere with this function (setq major-mode 'lisp-mode) (lisp-mode-variables t)) (insert string) (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) (goto-char (point-min)) (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t) (let ((highlight (match-string 1))) ;; Can't use (replace-match highlight) here -- broken in Emacs 21 (delete-region (match-beginning 0) (match-end 0)) (slime-insert-propertized '(face eldoc-highlight-function-argument) highlight))) (buffer-substring (point-min) (point-max)))) (define-obsolete-function-alias 'slime-fontify-string 'slime-autodoc--fontify "SLIME 2.10") ;;;; Autodocs (automatic context-sensitive help) (defun slime-autodoc (&optional force-multiline) "Returns the cached arglist information as string, or nil. If it's not in the cache, the cache will be updated asynchronously." (save-excursion (save-match-data (let ((context (slime-autodoc--parse-context))) (when context (let* ((cached (slime-autodoc--cache-get context)) (multilinep (or force-multiline eldoc-echo-area-use-multiline-p))) (cond (cached (slime-autodoc--format cached multilinep)) (t (when (slime-background-activities-enabled-p) (slime-autodoc--async context multilinep)) nil)))))))) ;; Return the context around point that can be passed to ;; swank:autodoc. nil is returned if nothing reasonable could be ;; found. (defun slime-autodoc--parse-context () (and (slime-autodoc--parsing-safe-p) (let ((levels slime-autodoc-accuracy-depth)) (slime-parse-form-upto-point levels)))) (defun slime-autodoc--parsing-safe-p () (cond ((fboundp 'slime-repl-inside-string-or-comment-p) (not (slime-repl-inside-string-or-comment-p))) (t (not (slime-inside-string-or-comment-p))))) (defun slime-autodoc--async (context multilinep) (slime-eval-async `(swank:autodoc ',context ;; FIXME: misuse of quote :print-right-margin ,(window-width (minibuffer-window))) (slime-curry #'slime-autodoc--async% context multilinep))) (defun slime-autodoc--async% (context multilinep doc) (cl-destructuring-bind (doc cache-p) doc (unless (eq doc :not-available) (when cache-p (slime-autodoc--cache-put context doc)) ;; Now that we've got our information, ;; get it to the user ASAP. (when (eldoc-display-message-p) (eldoc-message "%s" (slime-autodoc--format doc multilinep)))))) ;;; Minor mode definition ;; Compute the prefix for slime-doc-map, usually this is C-c C-d. (defun slime-autodoc--doc-map-prefix () (concat (car (rassoc '(slime-prefix-map) slime-parent-bindings)) (car (rassoc '(slime-doc-map) slime-prefix-bindings)))) (define-minor-mode slime-autodoc-mode "Toggle echo area display of Lisp objects at point." :keymap (let ((prefix (slime-autodoc--doc-map-prefix))) `((,(concat prefix "A") . slime-autodoc-manually) (,(concat prefix (kbd "C-A")) . slime-autodoc-manually) (,(kbd "SPC") . slime-autodoc-space))) (set (make-local-variable 'eldoc-documentation-function) 'slime-autodoc) (set (make-local-variable 'eldoc-minor-mode-string) " adoc") (setq slime-autodoc-mode (eldoc-mode arg)) (when (called-interactively-p 'interactive) (message "Slime autodoc mode %s." (if slime-autodoc-mode "enabled" "disabled")))) ;;; Noise to enable/disable slime-autodoc-mode (defun slime-autodoc--on () (slime-autodoc-mode 1)) (defun slime-autodoc--off () (slime-autodoc-mode 0)) (defvar slime-autodoc--relevant-hooks '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook)) (defun slime-autodoc--enable () (dolist (h slime-autodoc--relevant-hooks) (add-hook h 'slime-autodoc--on)) (dolist (b (buffer-list)) (with-current-buffer b (when slime-mode (slime-autodoc--on))))) (defun slime-autodoc--disable () (dolist (h slime-autodoc--relevant-hooks) (remove-hook h 'slime-autodoc--on)) (dolist (b (buffer-list)) (with-current-buffer b (when slime-autodoc-mode (slime-autodoc--off))))) (provide 'slime-autodoc) slime-2.20/contrib/slime-banner.el000066400000000000000000000023071315100173500171020ustar00rootroot00000000000000(require 'slime) (require 'slime-repl) (define-slime-contrib slime-banner "Persistent header line and startup animation." (:authors "Helmut Eller " "Luke Gorrie ") (:license "GPL") (:on-load (setq slime-repl-banner-function 'slime-startup-message)) (:on-unload (setq slime-repl-banner-function 'slime-repl-insert-banner))) (defcustom slime-startup-animation (fboundp 'animate-string) "Enable the startup animation." :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) :group 'slime-ui) (defcustom slime-header-line-p (boundp 'header-line-format) "If non-nil, display a header line in Slime buffers." :type 'boolean :group 'slime-repl) (defun slime-startup-message () (when slime-header-line-p (setq header-line-format (format "%s Port: %s Pid: %s" (slime-lisp-implementation-type) (slime-connection-port (slime-connection)) (slime-pid)))) (when (zerop (buffer-size)) (let ((welcome (concat "; SLIME " slime-version))) (if slime-startup-animation (animate-string welcome 0 0) (insert welcome))))) (provide 'slime-banner) slime-2.20/contrib/slime-c-p-c.el000066400000000000000000000305241315100173500165360ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (defvar slime-c-p-c-init-undo-stack nil) (define-slime-contrib slime-c-p-c "ILISP style Compound Prefix Completion." (:authors "Luke Gorrie " "Edi Weitz " "Matthias Koeppe " "Tobias C. Rittweiler ") (:license "GPL") (:slime-dependencies slime-parse slime-editing-commands slime-autodoc) (:swank-dependencies swank-c-p-c) (:on-load (push `(progn (remove-hook 'slime-completion-at-point-functions #'slime-c-p-c-completion-at-point) (remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect) ,@(when (featurep 'slime-repl) `((define-key slime-mode-map "\C-c\C-s" ',(lookup-key slime-mode-map "\C-c\C-s")) (define-key slime-repl-mode-map "\C-c\C-s" ',(lookup-key slime-repl-mode-map "\C-c\C-s"))))) slime-c-p-c-init-undo-stack) (add-hook 'slime-completion-at-point-functions #'slime-c-p-c-completion-at-point) (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form) (when (featurep 'slime-repl) (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form))) (:on-unload (while slime-c-p-c-init-undo-stack (eval (pop slime-c-p-c-init-undo-stack))))) (defcustom slime-c-p-c-unambiguous-prefix-p t "If true, set point after the unambigous prefix. If false, move point to the end of the inserted text." :type 'boolean :group 'slime-ui) (defcustom slime-complete-symbol*-fancy nil "Use information from argument lists for DWIM'ish symbol completion." :group 'slime-mode :type 'boolean) ;; FIXME: this is the old code to display completions. Remove it once ;; `slime-complete-symbol*' and `slime-fuzzy-complete-symbol' can be ;; used together with `completion-at-point'. (defvar slime-completions-buffer-name "*Completions*") ;; FIXME: can probably use quit-window instead (make-variable-buffer-local (defvar slime-complete-saved-window-configuration nil "Window configuration before we show the *Completions* buffer. This is buffer local in the buffer where the completion is performed.")) (make-variable-buffer-local (defvar slime-completions-window nil "The window displaying *Completions* after saving window configuration. If this window is no longer active or displaying the completions buffer then we can ignore `slime-complete-saved-window-configuration'.")) (defun slime-complete-maybe-save-window-configuration () "Maybe save the current window configuration. Return true if the configuration was saved." (unless (or slime-complete-saved-window-configuration (get-buffer-window slime-completions-buffer-name)) (setq slime-complete-saved-window-configuration (current-window-configuration)) t)) (defun slime-complete-delay-restoration () (add-hook 'pre-command-hook 'slime-complete-maybe-restore-window-configuration 'append 'local)) (defun slime-complete-forget-window-configuration () (setq slime-complete-saved-window-configuration nil) (setq slime-completions-window nil)) (defun slime-complete-restore-window-configuration () "Restore the window config if available." (remove-hook 'pre-command-hook 'slime-complete-maybe-restore-window-configuration) (when (and slime-complete-saved-window-configuration (slime-completion-window-active-p)) (save-excursion (set-window-configuration slime-complete-saved-window-configuration)) (setq slime-complete-saved-window-configuration nil) (when (buffer-live-p slime-completions-buffer-name) (kill-buffer slime-completions-buffer-name)))) (defun slime-complete-maybe-restore-window-configuration () "Restore the window configuration, if the following command terminates a current completion." (remove-hook 'pre-command-hook 'slime-complete-maybe-restore-window-configuration) (condition-case err (cond ((cl-find last-command-event "()\"'`,# \r\n:") (slime-complete-restore-window-configuration)) ((not (slime-completion-window-active-p)) (slime-complete-forget-window-configuration)) (t (slime-complete-delay-restoration))) (error ;; Because this is called on the pre-command-hook, we mustn't let ;; errors propagate. (message "Error in slime-complete-restore-window-configuration: %S" err)))) (defun slime-completion-window-active-p () "Is the completion window currently active?" (and (window-live-p slime-completions-window) (equal (buffer-name (window-buffer slime-completions-window)) slime-completions-buffer-name))) (defun slime-display-completion-list (completions 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-position 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-minibuffer-respecting-message (format &rest format-args) "Display TEXT as a message, without hiding any minibuffer contents." (let ((text (format " [%s]" (apply #'format format format-args)))) (if (minibuffer-window-active-p (minibuffer-window)) (minibuffer-message text) (message "%s" text)))) (defun slime-maybe-complete-as-filename () "If point is at a string starting with \", complete it as filename. Return nil if point is not at filename." (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" (max (point-min) (- (point) 1000)) t)) (let ((comint-completion-addsuffix '("/" . "\""))) (comint-replace-by-expanded-filename) t))) (defun slime-complete-symbol* () "Expand abbreviations and complete the symbol at point." ;; NB: It is only the name part of the symbol that we actually want ;; to complete -- the package prefix, if given, is just context. (or (slime-maybe-complete-as-filename) (slime-expand-abbreviations-and-complete))) (defun slime-c-p-c-completion-at-point () #'slime-complete-symbol*) ;; FIXME: factorize (defun slime-expand-abbreviations-and-complete () (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) (beg (move-marker (make-marker) (slime-symbol-start-pos))) (prefix (buffer-substring-no-properties beg end)) (completion-result (slime-contextual-completions beg end)) (completion-set (cl-first completion-result)) (completed-prefix (cl-second completion-result))) (if (null completion-set) (progn (slime-minibuffer-respecting-message "Can't find completion for \"%s\"" prefix) (ding) (slime-complete-restore-window-configuration)) ;; some XEmacs issue makes this distinction necessary (cond ((> (length completed-prefix) (- end beg)) (goto-char end) (insert-and-inherit completed-prefix) (delete-region beg end) (goto-char (+ beg (length completed-prefix)))) (t nil)) (cond ((and (member completed-prefix completion-set) (slime-length= completion-set 1)) (slime-minibuffer-respecting-message "Sole completion") (when slime-complete-symbol*-fancy (slime-complete-symbol*-fancy-bit)) (slime-complete-restore-window-configuration)) ;; Incomplete (t (when (member completed-prefix completion-set) (slime-minibuffer-respecting-message "Complete but not unique")) (when slime-c-p-c-unambiguous-prefix-p (let ((unambiguous-completion-length (cl-loop for c in completion-set minimizing (or (cl-mismatch completed-prefix c) (length completed-prefix))))) (goto-char (+ beg unambiguous-completion-length)))) (slime-display-or-scroll-completions completion-set 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-retrieve-arglist (slime-symbol-at-point)))) (unless (eq arglist :not-available) (let ((args ;; Don't intern these symbols (let ((obarray (make-vector 10 0))) (cdr (read arglist)))) (function-call-position-p (save-excursion (backward-sexp) (equal (char-before) ?\()))) (when function-call-position-p (if (null args) (execute-kbd-macro ")") (execute-kbd-macro " ") (when (and (slime-background-activities-enabled-p) (not (minibuffer-window-active-p (minibuffer-window)))) (slime-echo-arglist)))))))) (cl-defun slime-contextual-completions (beg end) "Return a list of completions of the token from BEG to END in the current buffer." (let ((token (buffer-substring-no-properties beg end))) (cond ((and (< beg (point-max)) (string= (buffer-substring-no-properties beg (1+ beg)) ":")) ;; Contextual keyword completion (let ((completions (slime-completions-for-keyword token (save-excursion (goto-char beg) (slime-parse-form-upto-point))))) (when (cl-first completions) (cl-return-from slime-contextual-completions completions)) ;; If no matching keyword was found, do regular symbol ;; completion. )) ((and (>= (length token) 2) (string= (cl-subseq token 0 2) "#\\")) ;; Character name completion (cl-return-from slime-contextual-completions (slime-completions-for-character token)))) ;; Regular symbol completion (slime-completions token))) (defun slime-completions (prefix) (slime-eval `(swank:completions ,prefix ',(slime-current-package)))) (defun slime-completions-for-keyword (prefix buffer-form) (slime-eval `(swank:completions-for-keyword ,prefix ',buffer-form))) (defun slime-completions-for-character (prefix) (cl-labels ((append-char-syntax (string) (concat "#\\" string))) (let ((result (slime-eval `(swank:completions-for-character ,(cl-subseq prefix 2))))) (when (car result) (list (mapcar #'append-char-syntax (car result)) (append-char-syntax (cadr result))))))) ;;; Complete form (defun slime-complete-form () "Complete the form at point. This is a superset of the functionality of `slime-insert-arglist'." (interactive) ;; Find the (possibly incomplete) form around point. (let ((buffer-form (slime-parse-form-upto-point))) (let ((result (slime-eval `(swank:complete-form ',buffer-form)))) (if (eq result :not-available) (error "Could not generate completion for the form `%s'" buffer-form) (progn (just-one-space (if (looking-back "\\s(" (1- (point))) 0 1)) (save-excursion (insert result) (let ((slime-close-parens-limit 1)) (slime-close-all-parens-in-sexp))) (save-excursion (backward-up-list 1) (indent-sexp))))))) (provide 'slime-c-p-c) slime-2.20/contrib/slime-cl-indent.el000066400000000000000000002200751315100173500175160ustar00rootroot00000000000000;;; slime-cl-indent.el --- enhanced lisp-indent mode ;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc. ;; Author: Richard Mlynarik ;; Created: July 1987 ;; Maintainer: FSF ;; Keywords: lisp, tools ;; Package: emacs ;; This file is forked from cl-indent.el, which is part of 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 3 of the License, 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. If not, see . ;;; Commentary: ;; This package supplies a single entry point, common-lisp-indent-function, ;; which performs indentation in the preferred style for Common Lisp code. ;; To enable it: ;; ;; (setq lisp-indent-function 'common-lisp-indent-function) ;; ;; This file is substantially patched from original cl-indent.el, ;; which is in Emacs proper. It does not require SLIME, but is instead ;; required by one of it's contribs, `slime-indentation'. ;; ;; Before making modifications to this file, consider adding them to ;; Emacs's own `cl-indent' and refactoring this file to be an ;; extension of Emacs's. ;;; Code: (require 'slime) ; only for its cl-lib loading smartness (require 'cl-lib) (eval-when-compile (require 'cl)) (defgroup lisp-indent nil "Indentation in Lisp." :group 'lisp) (defcustom lisp-indent-maximum-backtracking 6 "Maximum depth to backtrack out from a sublist for structured indentation. If this variable is 0, no backtracking will occur and forms such as `flet' may not be correctly indented if this value is less than 4." :type 'integer :group 'lisp-indent) (defcustom lisp-tag-indentation 1 "Indentation of tags relative to containing list. This variable is used by the function `lisp-indent-tagbody'." :type 'integer :group 'lisp-indent) (defcustom lisp-tag-body-indentation 3 "Indentation of non-tagged lines relative to containing list. This variable is used by the function `lisp-indent-tagbody' to indent normal lines (lines without tags). The indentation is relative to the indentation of the parenthesis enclosing the special form. If the value is t, the body of tags will be indented as a block at the same indentation as the first s-expression following the tag. In this case, any forms before the first tag are indented by `lisp-body-indent'." :type 'integer :group 'lisp-indent) (defcustom lisp-backquote-indentation t "Whether or not to indent backquoted lists as code. If nil, indent backquoted lists as data, i.e., like quoted lists." :type 'boolean :group 'lisp-indent) (defcustom lisp-loop-indent-subclauses t "Whether or not to indent loop subclauses." :type 'boolean :group 'lisp-indent) (defcustom lisp-simple-loop-indentation 2 "Indentation of forms in simple loop forms." :type 'integer :group 'lisp-indent) (defcustom lisp-loop-clauses-indentation 2 "Indentation of loop clauses if `loop' is immediately followed by a newline." :type 'integer :group 'lisp-indent) (defcustom lisp-loop-indent-body-forms-relative-to-loop-start nil "When true, indent loop body clauses relative to the open paren of the loop form, instead of the keyword position." :type 'boolean :group 'lisp-indent) (defcustom lisp-loop-body-forms-indentation 3 "Indentation of loop body clauses." :type 'integer :group 'lisp-indent) (defcustom lisp-loop-indent-forms-like-keywords nil "Whether or not to indent loop subforms just like loop keywords. Only matters when `lisp-loop-indent-subclauses' is nil." :type 'boolean :group 'lisp-indent) (defcustom lisp-align-keywords-in-calls t "Whether to align keyword arguments vertically or not. If t (the default), keywords in contexts where no other indentation rule takes precedence are aligned like this: \(make-instance 'foo :bar t :quux 42) If nil, they are indented like any other function call arguments: \(make-instance 'foo :bar t :quux 42)" :type 'boolean :group 'lisp-indent) (defcustom lisp-lambda-list-indentation t "Whether to indent lambda-lists specially. Defaults to t. Setting this to nil makes `lisp-lambda-list-keyword-alignment', `lisp-lambda-list-keyword-parameter-alignment', and `lisp-lambda-list-keyword-parameter-indentation' meaningless, causing lambda-lists to be indented as if they were data: \(defun example (a b &optional o1 o2 o3 o4 &rest r &key k1 k2 k3 k4) #|...|#)" :type 'boolean :group 'lisp-indent) (defcustom lisp-lambda-list-keyword-alignment nil "Whether to vertically align lambda-list keywords together. If nil (the default), keyworded lambda-list parts are aligned with the initial mandatory arguments, like this: \(defun foo (arg1 arg2 &rest rest &key key1 key2) #|...|#) If non-nil, alignment is done with the first keyword \(or falls back to the previous case), as in: \(defun foo (arg1 arg2 &rest rest &key key1 key2) #|...|#)" :type 'boolean :group 'lisp-indent) (defcustom lisp-lambda-list-keyword-parameter-indentation 2 "Indentation of lambda list keyword parameters. See `lisp-lambda-list-keyword-parameter-alignment' for more information." :type 'integer :group 'lisp-indent) (defcustom lisp-lambda-list-keyword-parameter-alignment nil "Whether to vertically align lambda-list keyword parameters together. If nil (the default), the parameters are aligned with their corresponding keyword, plus the value of `lisp-lambda-list-keyword-parameter-indentation', like this: \(defun foo (arg1 arg2 &key key1 key2 key3 key4) #|...|#) If non-nil, alignment is done with the first parameter \(or falls back to the previous case), as in: \(defun foo (arg1 arg2 &key key1 key2 key3 key4) #|...|#)" :type 'boolean :group 'lisp-indent) (defvar lisp-indent-defun-method '(4 &lambda &body) "Defun-like indentation method. This applies when the value of the `common-lisp-indent-function' property is set to `defun'.") ;;;; Named styles. ;;;; ;;;; -*- common-lisp-style: foo -*- ;;;; ;;;; sets the style for the buffer. ;;;; ;;;; A Common Lisp style is a list of the form: ;;;; ;;;; (NAME INHERIT VARIABLES INDENTATION HOOK DOCSTRING) ;;;; ;;;; where NAME is a symbol naming the style, INHERIT is the name of the style ;;;; it inherits from, VARIABLES is an alist specifying buffer local variables ;;;; for the style, and INDENTATION is an alist specifying non-standard ;;;; indentations for Common Lisp symbols. HOOK is a function to call when ;;;; activating the style. DOCSTRING is the documentation for the style. ;;;; ;;;; Convenience accessors `common-lisp-style-name', &co exist. ;;;; ;;;; `common-lisp-style' stores the name of the current style. ;;;; ;;;; `common-lisp-style-default' stores the name of the style to use when none ;;;; has been specified. ;;;; ;;;; `common-lisp-active-style' stores a cons of the list specifying the ;;;; current style, and a hash-table containing all indentation methods of ;;;; that style and any styles it inherits from. Whenever we're indenting, we ;;;; check that this is up to date, and recompute when necessary. ;;;; ;;;; Just setting the buffer local common-lisp-style will be enough to have ;;;; the style take effect. `common-lisp-set-style' can also be called ;;;; explicitly, however, and offers name completion, etc. ;;; Convenience accessors (defun common-lisp-style-name (style) (first style)) (defun common-lisp-style-inherits (style) (second style)) (defun common-lisp-style-variables (style) (third style)) (defun common-lisp-style-indentation (style) (fourth style)) (defun common-lisp-style-hook (style) (fifth style)) (defun common-lisp-style-docstring (style) (sixth style)) (defun common-lisp-make-style (stylename inherits variables indentation hook documentation) (list stylename inherits variables indentation hook documentation)) (defvar common-lisp-style nil) ;;; `define-common-lisp-style' updates the docstring of ;;; `common-lisp-style', using this as the base. (put 'common-lisp-style 'common-lisp-style-base-doc "Name of the Common Lisp indentation style used in the current buffer. Set this by giving eg. ;; -*- common-lisp-style: sbcl -*- in the first line of the file, or by calling `common-lisp-set-style'. If buffer has no style specified, but `common-lisp-style-default' is set, that style is used instead. Use `define-common-lisp-style' to define new styles.") (make-variable-buffer-local 'common-lisp-style) (set-default 'common-lisp-style nil) ;;; `lisp-mode' kills all buffer-local variables. Setting the ;;; `permanent-local' property allows us to retain the style. (put 'common-lisp-style 'permanent-local t) ;;; Mark as safe when the style doesn't evaluate arbitrary code. (put 'common-lisp-style 'safe-local-variable 'common-lisp-safe-style-p) ;;; Common Lisp indentation style specifications. (defvar common-lisp-styles (make-hash-table :test 'equal)) (defun common-lisp-delete-style (stylename) (remhash stylename common-lisp-styles)) (defun common-lisp-find-style (stylename) (let ((name (if (symbolp stylename) (symbol-name stylename) stylename))) (or (gethash name common-lisp-styles) (error "Unknown Common Lisp style: %s" name)))) (defun common-lisp-safe-style-p (stylename) "True for known Common Lisp style without an :EVAL option. Ie. styles that will not evaluate arbitrary code on activation." (let* ((style (ignore-errors (common-lisp-find-style stylename))) (base (common-lisp-style-inherits style))) (and style (not (common-lisp-style-hook style)) (or (not base) (common-lisp-safe-style-p base))))) (defun common-lisp-add-style (stylename inherits variables indentation hooks documentation) ;; Invalidate indentation methods cached in common-lisp-active-style. (maphash (lambda (k v) (puthash k (cl-copy-list v) common-lisp-styles)) common-lisp-styles) ;; Add/Redefine the specified style. (puthash stylename (common-lisp-make-style stylename inherits variables indentation hooks documentation) common-lisp-styles) ;; Frob `common-lisp-style' docstring. (let ((doc (get 'common-lisp-style 'common-lisp-style-base-doc)) (all nil)) (setq doc (concat doc "\n\nAvailable styles are:\n")) (maphash (lambda (name style) (push (list name (common-lisp-style-docstring style)) all)) common-lisp-styles) (dolist (info (sort all (lambda (a b) (string< (car a) (car b))))) (let ((style-name (first info)) (style-doc (second info))) (if style-doc (setq doc (concat doc "\n " style-name "\n" " " style-doc "\n")) (setq doc (concat doc "\n " style-name " (undocumented)\n"))))) (put 'common-lisp-style 'variable-documentation doc)) stylename) ;;; Activate STYLENAME, adding its indentation methods to METHODS -- and ;;; recurse on style inherited from. (defun common-lisp-activate-style (stylename methods) (let* ((style (common-lisp-find-style stylename)) (basename (common-lisp-style-inherits style))) ;; Recurse on parent. (when basename (common-lisp-activate-style basename methods)) ;; Copy methods (dolist (spec (common-lisp-style-indentation style)) (puthash (first spec) (second spec) methods)) ;; Bind variables. (dolist (var (common-lisp-style-variables style)) (set (make-local-variable (first var)) (second var))) ;; Run hook. (let ((hook (common-lisp-style-hook style))) (when hook (funcall hook))))) ;;; When a style is being used, `common-lisp-active-style' holds a cons ;;; ;;; (STYLE . METHODS) ;;; ;;; where STYLE is the list specifying the currently active style, and ;;; METHODS is the table of indentation methods -- including inherited ;;; ones -- for it. `common-lisp-active-style-methods' is reponsible ;;; for keeping this up to date. (make-variable-buffer-local (defvar common-lisp-active-style nil)) ;;; Makes sure common-lisp-active-style corresponds to common-lisp-style, and ;;; pick up redefinitions, etc. Returns the method table for the currently ;;; active style. (defun common-lisp-active-style-methods () (let* ((name common-lisp-style) (style (when name (common-lisp-find-style name)))) (if (eq style (car common-lisp-active-style)) (cdr common-lisp-active-style) (when style (let ((methods (make-hash-table :test 'equal))) (common-lisp-activate-style name methods) (setq common-lisp-active-style (cons style methods)) methods))))) (defvar common-lisp-set-style-history nil) (defun common-lisp-style-names () (let (names) (maphash (lambda (k v) (push (cons k v) names)) common-lisp-styles) names)) (defun common-lisp-set-style (stylename) "Set current buffer to use the Common Lisp style STYLENAME. STYLENAME, a string, must be an existing Common Lisp style. Styles are added (and updated) using `define-common-lisp-style'. The buffer-local variable `common-lisp-style' will get set to STYLENAME. A Common Lisp style is composed of local variables, indentation specifications, and may also contain arbitrary elisp code to run upon activation." (interactive (list (let ((completion-ignore-case t) (prompt "Specify Common Lisp indentation style: ")) (completing-read prompt (common-lisp-style-names) nil t nil 'common-lisp-set-style-history)))) (setq common-lisp-style (common-lisp-style-name (common-lisp-find-style stylename)) common-lisp-active-style nil) ;; Actually activates the style. (common-lisp-active-style-methods) stylename) (defmacro define-common-lisp-style (name documentation &rest options) "Define a Common Lisp indentation style. NAME is the name of the style. DOCUMENTATION is the docstring for the style, automatically added to the docstring of `common-lisp-style'. OPTIONS are: (:variables (name value) ...) Specifying the buffer local variables associated with the style. (:indentation (symbol spec) ...) Specifying custom indentations associated with the style. SPEC is a normal `common-lisp-indent-function' indentation specification. (:inherit style) Inherit variables and indentations from another Common Lisp style. (:eval form ...) Lisp code to evaluate when activating the style. This can be used to eg. activate other modes. It is possible that over the lifetime of a buffer same style gets activated multiple times, so code in :eval option should cope with that. " (when (consp documentation) (setq options (cons documentation options) documentation nil)) `(common-lisp-add-style ,name ',(cadr (assoc :inherit options)) ',(cdr (assoc :variables options)) ',(cdr (assoc :indentation options)) ,(when (assoc :eval options) `(lambda () ,@(cdr (assoc :eval options)))) ,documentation)) (define-common-lisp-style "basic" "This style merely gives all identation variables their default values, making it easy to create new styles that are proof against user customizations. It also adjusts comment indentation from default. All other predefined modes inherit from basic." (:variables (lisp-indent-maximum-backtracking 6) (lisp-tag-indentation 1) (lisp-tag-body-indentation 3) (lisp-backquote-indentation t) (lisp-loop-indent-subclauses t) (lisp-loop-indent-forms-like-keywords nil) (lisp-simple-loop-indentation 2) (lisp-align-keywords-in-calls t) (lisp-lambda-list-indentation t) (lisp-lambda-list-keyword-alignment nil) (lisp-lambda-list-keyword-parameter-indentation 2) (lisp-lambda-list-keyword-parameter-alignment nil) (lisp-indent-defun-method (4 &lambda &body)) ;; Without these (;;foo would get a space inserted between ;; ( and ; by indent-sexp. (comment-indent-function (lambda () nil)) (lisp-loop-clauses-indentation 2) (lisp-loop-indent-body-forms-relative-to-loop-start nil) (lisp-loop-body-forms-indentation 3))) (define-common-lisp-style "classic" "This style of indentation emulates the most striking features of 1995 vintage cl-indent.el once included as part of Slime: IF indented by two spaces, and CASE clause bodies indentented more deeply than the keys." (:inherit "basic") (:variables (lisp-lambda-list-keyword-parameter-indentation 0)) (:indentation (case (4 &rest (&whole 2 &rest 3))) (if (4 2 2)))) (define-common-lisp-style "modern" "A good general purpose style. Turns on lambda-list keyword and keyword parameter alignment, and turns subclause aware loop indentation off. (Loop indentation so because simpler style is more prevalent in existing sources, not because it is necessarily preferred.)" (:inherit "basic") (:variables (lisp-lambda-list-keyword-alignment t) (lisp-lambda-list-keyword-parameter-alignment t) (lisp-lambda-list-keyword-parameter-indentation 0) (lisp-loop-indent-subclauses nil))) (define-common-lisp-style "sbcl" "Style used in SBCL sources. A good if somewhat intrusive general purpose style based on the \"modern\" style. Adds indentation for a few SBCL specific constructs, sets indentation to use spaces instead of tabs, fill-column to 78, and activates whitespace-mode to show tabs and trailing whitespace." (:inherit "modern") (:eval (whitespace-mode 1)) (:variables (whitespace-style (tabs trailing)) (indent-tabs-mode nil) (comment-fill-column nil) (fill-column 78)) (:indentation (def!constant (as defconstant)) (def!macro (as defmacro)) (def!method (as defmethod)) (def!struct (as defstruct)) (def!type (as deftype)) (defmacro-mundanely (as defmacro)) (define-source-transform (as defun)) (!def-type-translator (as defun)) (!def-debug-command (as defun)))) (defcustom common-lisp-style-default nil "Name of the Common Lisp indentation style to use in lisp-mode buffers if none has been specified." :type `(choice (const :tag "None" nil) ,@(mapcar (lambda (spec) `(const :tag ,(car spec) ,(car spec))) (common-lisp-style-names)) (string :tag "Other")) :group 'lisp-indent) ;;; If style is being used, that's a sufficient invitation to snag ;;; the indentation function. (defun common-lisp-lisp-mode-hook () (let ((style (or common-lisp-style common-lisp-style-default))) (when style (set (make-local-variable 'lisp-indent-function) 'common-lisp-indent-function) (common-lisp-set-style style)))) (add-hook 'lisp-mode-hook 'common-lisp-lisp-mode-hook) ;;;; The indentation specs are stored at three levels. In order of priority: ;;;; ;;;; 1. Indentation as set by current style, from the indentation table ;;;; in the current style. ;;;; ;;;; 2. Globally set indentation, from the `common-lisp-indent-function' ;;;; property of the symbol. ;;;; ;;;; 3. Per-package indentation derived by the system. A live Common Lisp ;;;; system may (via Slime, eg.) add indentation specs to ;;;; common-lisp-system-indentation, where they are associated with ;;;; the package of the symbol. Then we run some lossy heuristics and ;;;; find something that looks promising. ;;;; ;;;; FIXME: for non-system packages the derived indentation should probably ;;;; take precedence. ;;; This maps symbols into lists of (INDENT . PACKAGES) where INDENT is ;;; an indentation spec, and PACKAGES are the names of packages where this ;;; applies. ;;; ;;; We never add stuff here by ourselves: this is for things like Slime to ;;; fill. (defvar common-lisp-system-indentation (make-hash-table :test 'equal)) (defun common-lisp-guess-current-package () (let (pkg) (save-excursion (ignore-errors (when (let ((case-fold-search t)) (search-backward "(in-package ")) (re-search-forward "[ :\"]+") (let ((start (point))) (re-search-forward "[\":)]") (setf pkg (upcase (buffer-substring-no-properties start (1- (point))))))))) pkg)) (defvar common-lisp-current-package-function 'common-lisp-guess-current-package "Used to derive the package name to use for indentation at a given point. Defaults to `common-lisp-guess-current-package'.") (defun common-lisp-symbol-package (string) (if (and (stringp string) (string-match ":" string)) (let ((p (match-beginning 0))) (if (eql 0 p) "KEYWORD" (upcase (substring string 0 p)))) (funcall common-lisp-current-package-function))) (defun common-lisp-get-indentation (name &optional full) "Retrieves the indentation information for NAME." (let ((method (or ;; From style (when common-lisp-style (gethash name (common-lisp-active-style-methods))) ;; From global settings. (get name 'common-lisp-indent-function) ;; From system derived information. (let ((system-info (gethash name common-lisp-system-indentation))) (if (not (cdr system-info)) (caar system-info) (let ((guess nil) (guess-n 0) (package (common-lisp-symbol-package full))) (dolist (info system-info guess) (let* ((pkgs (cdr info)) (n (length pkgs))) (cond ((member package pkgs) ;; This is it. (return (car info))) ((> n guess-n) ;; If we can't find the real thing, go with the one ;; accessible in most packages. (setf guess (car info) guess-n n))))))))))) (if (and (consp method) (eq 'as (car method))) (common-lisp-get-indentation (cadr method)) method))) ;;;; LOOP indentation, the simple version (defun common-lisp-loop-type (loop-start) "Returns the type of the loop form at LOOP-START. Possible types are SIMPLE, SIMPLE/SPLIT, EXTENDED, and EXTENDED/SPLIT. */SPLIT refers to extended loops whose body does not start on the same line as the opening parenthesis of the loop." (let (comment-split) (condition-case () (save-excursion (goto-char loop-start) (let ((line (line-number-at-pos)) (maybe-split t)) (forward-char 1) (forward-sexp 1) (save-excursion (when (looking-at "\\s-*\\\n*;") (search-forward ";") (backward-char 1) (if (= line (line-number-at-pos)) (setq maybe-split nil) (setq comment-split t)))) (forward-sexp 1) (backward-sexp 1) (if (eql (char-after) ?\() (if (or (not maybe-split) (= line (line-number-at-pos))) 'simple 'simple/split) (if (or (not maybe-split) (= line (line-number-at-pos))) 'extended 'extended/split)))) (error (if comment-split 'simple/split 'simple))))) (defun common-lisp-trailing-comment () (ignore-errors ;; If we had a trailing comment just before this, find it. (save-excursion (backward-sexp) (forward-sexp) (when (looking-at "\\s-*;") (search-forward ";") (1- (current-column)))))) ;;;###autoload (defun common-lisp-indent-function (indent-point state) "Function to indent the arguments of a Lisp function call. This is suitable for use as the value of the variable `lisp-indent-function'. INDENT-POINT is the point at which the indentation function is called, and STATE is the `parse-partial-sexp' state at that position. Browse the `lisp-indent' customize group for options affecting the behavior of this function. If the indentation point is in a call to a Lisp function, that function's common-lisp-indent-function property specifies how this function should indent it. Possible values for this property are: * defun, meaning indent according to `lisp-indent-defun-method'; i.e., like (4 &lambda &body), as explained below. * any other symbol, meaning a function to call. The function should take the arguments: PATH STATE INDENT-POINT SEXP-COLUMN NORMAL-INDENT. PATH is a list of integers describing the position of point in terms of list-structure with respect to the containing lists. For example, in ((a b c (d foo) f) g), foo has a path of (0 3 1). In other words, to reach foo take the 0th element of the outermost list, then the 3rd element of the next list, and finally the 1st element. STATE and INDENT-POINT are as in the arguments to `common-lisp-indent-function'. SEXP-COLUMN is the column of the open parenthesis of the innermost containing list. NORMAL-INDENT is the column the indentation point was originally in. This function should behave like `lisp-indent-259'. * an integer N, meaning indent the first N arguments like function arguments, and any further arguments like a body. This is equivalent to (4 4 ... &body). * a list starting with `as' specifies an indirection: indentation is done as if the form being indented had started with the second element of the list. * any other list. The list element in position M specifies how to indent the Mth function argument. If there are fewer elements than function arguments, the last list element applies to all remaining arguments. The accepted list elements are: * nil, meaning the default indentation. * an integer, specifying an explicit indentation. * &lambda. Indent the argument (which may be a list) by 4. * &rest. When used, this must be the penultimate element. The element after this one applies to all remaining arguments. * &body. This is equivalent to &rest lisp-body-indent, i.e., indent all remaining elements by `lisp-body-indent'. * &whole. This must be followed by nil, an integer, or a function symbol. This indentation is applied to the associated argument, and as a base indent for all remaining arguments. For example, an integer P means indent this argument by P, and all remaining arguments by P, plus the value specified by their associated list element. * a symbol. A function to call, with the 6 arguments specified above. * a list, with elements as described above. This applies when the associated function argument is itself a list. Each element of the list specifies how to indent the associated argument. For example, the function `case' has an indent property \(4 &rest (&whole 2 &rest 1)), meaning: * indent the first argument by 4. * arguments after the first should be lists, and there may be any number of them. The first list element has an offset of 2, all the rest have an offset of 2+1=3." (common-lisp-indent-function-1 indent-point state)) ;;; XEmacs doesn't have looking-back, so we define a simple one. Faster to ;;; boot, and sufficient for our needs. (defun common-lisp-looking-back (string) (let ((len (length string))) (dotimes (i len t) (unless (eql (elt string (- len i 1)) (char-before (- (point) i))) (return nil))))) (defvar common-lisp-feature-expr-regexp "#!?\\(+\\|-\\)") ;;; Semi-feature-expression aware keyword check. (defun common-lisp-looking-at-keyword () (or (looking-at ":") (and (looking-at common-lisp-feature-expr-regexp) (save-excursion (forward-sexp) (skip-chars-forward " \t\n") (common-lisp-looking-at-keyword))))) ;;; Semi-feature-expression aware backwards movement for keyword ;;; argument pairs. (defun common-lisp-backward-keyword-argument () (ignore-errors (backward-sexp 2) (when (looking-at common-lisp-feature-expr-regexp) (cond ((ignore-errors (save-excursion (backward-sexp 2) (looking-at common-lisp-feature-expr-regexp))) (common-lisp-backward-keyword-argument)) ((ignore-errors (save-excursion (backward-sexp 1) (looking-at ":"))) (backward-sexp)))) t)) (defun common-lisp-indent-function-1 (indent-point state) ;; If we're looking at a splice, move to the first comma. (when (or (common-lisp-looking-back ",") (common-lisp-looking-back ",@")) (when (re-search-backward "[^,@'],") (forward-char 1))) (let ((normal-indent (current-column))) ;; Walk up list levels until we see something ;; which does special things with subforms. (let ((depth 0) ;; Path describes the position of point in terms of ;; list-structure with respect to containing lists. ;; `foo' has a path of (0 3 1) in `((a b c (d foo) f) g)'. (path ()) ;; set non-nil when somebody works out the indentation to use calculated ;; If non-nil, this is an indentation to use ;; if nothing else specifies it more firmly. tentative-calculated (last-point indent-point) ;; the position of the open-paren of the innermost containing list (containing-form-start (common-lisp-indent-parse-state-start state)) ;; the column of the above sexp-column) ;; Move to start of innermost containing list (goto-char containing-form-start) (setq sexp-column (current-column)) ;; Look over successively less-deep containing forms (while (and (not calculated) (< depth lisp-indent-maximum-backtracking)) (let ((containing-sexp (point))) (forward-char 1) (parse-partial-sexp (point) indent-point 1 t) ;; Move to the car of the relevant containing form (let (tem full function method tentative-defun) (if (not (looking-at "\\sw\\|\\s_")) ;; This form doesn't seem to start with a symbol (setq function nil method nil full nil) (setq tem (point)) (forward-sexp 1) (setq full (downcase (buffer-substring-no-properties tem (point))) function full) (goto-char tem) (setq tem (intern-soft function) method (common-lisp-get-indentation tem)) (cond ((and (null method) (string-match ":[^:]+" function)) ;; The pleblisp package feature (setq function (substring function (1+ (match-beginning 0))) method (common-lisp-get-indentation (intern-soft function) full))) ((and (null method)) ;; backwards compatibility (setq method (common-lisp-get-indentation tem))))) (let ((n 0)) ;; How far into the containing form is the current form? (if (< (point) indent-point) (while (condition-case () (progn (forward-sexp 1) (if (>= (point) indent-point) nil (parse-partial-sexp (point) indent-point 1 t) (setq n (1+ n)) t)) (error nil)))) (setq path (cons n path))) ;; Guess. (when (and (not method) function (null (cdr path))) ;; (package prefix was stripped off above) (cond ((and (string-match "\\`def" function) (not (string-match "\\`default" function)) (not (string-match "\\`definition" function)) (not (string-match "\\`definer" function))) (setq tentative-defun t)) ((string-match (eval-when-compile (concat "\\`\\(" (regexp-opt '("with" "without" "do")) "\\)-")) function) (setq method '(&lambda &body))))) ;; #+ and #- cleverness. (save-excursion (goto-char indent-point) (backward-sexp) (let ((indent (current-column))) (when (or (looking-at common-lisp-feature-expr-regexp) (ignore-errors (backward-sexp) (when (looking-at common-lisp-feature-expr-regexp) (setq indent (current-column)) (let ((line (line-number-at-pos))) (while (ignore-errors (backward-sexp 2) (and (= line (line-number-at-pos)) (looking-at common-lisp-feature-expr-regexp))) (setq indent (current-column)))) t))) (setq calculated (list indent containing-form-start))))) (cond ((and (or (eq (char-after (1- containing-sexp)) ?\') (and (not lisp-backquote-indentation) (eq (char-after (1- containing-sexp)) ?\`))) (not (eq (char-after (- containing-sexp 2)) ?\#))) ;; No indentation for "'(...)" elements (setq calculated (1+ sexp-column))) ((eq (char-after (1- containing-sexp)) ?\#) ;; "#(...)" (setq calculated (1+ sexp-column))) ((null method) ;; If this looks like a call to a `def...' form, ;; think about indenting it as one, but do it ;; tentatively for cases like ;; (flet ((defunp () ;; nil))) ;; Set both normal-indent and tentative-calculated. ;; The latter ensures this value gets used ;; if there are no relevant containing constructs. ;; The former ensures this value gets used ;; if there is a relevant containing construct ;; but we are nested within the structure levels ;; that it specifies indentation for. (if tentative-defun (setq tentative-calculated (common-lisp-indent-call-method function lisp-indent-defun-method path state indent-point sexp-column normal-indent) normal-indent tentative-calculated) (when lisp-align-keywords-in-calls ;; No method so far. If we're looking at a keyword, ;; align with the first keyword in this expression. ;; This gives a reasonable indentation to most things ;; with keyword arguments. (save-excursion (goto-char indent-point) (back-to-indentation) (when (common-lisp-looking-at-keyword) (while (common-lisp-backward-keyword-argument) (when (common-lisp-looking-at-keyword) (setq calculated (list (current-column) containing-form-start))))))))) ((integerp method) ;; convenient top-level hack. ;; (also compatible with lisp-indent-function) ;; The number specifies how many `distinguished' ;; forms there are before the body starts ;; Equivalent to (4 4 ... &body) (setq calculated (cond ((cdr path) normal-indent) ((<= (car path) method) ;; `distinguished' form (list (+ sexp-column 4) containing-form-start)) ((= (car path) (1+ method)) ;; first body form. (+ sexp-column lisp-body-indent)) (t ;; other body form normal-indent)))) (t (setq calculated (common-lisp-indent-call-method function method path state indent-point sexp-column normal-indent))))) (goto-char containing-sexp) (setq last-point containing-sexp) (unless calculated (condition-case () (progn (backward-up-list 1) (setq depth (1+ depth))) (error (setq depth lisp-indent-maximum-backtracking)))))) (or calculated tentative-calculated ;; Fallback. ;; ;; Instead of punting directly to calculate-lisp-indent we ;; handle a few of cases it doesn't deal with: ;; ;; A: (foo ( ;; bar zot ;; quux)) ;; ;; would align QUUX with ZOT. ;; ;; B: ;; (foo (or x ;; y) t ;; z) ;; ;; would align the Z with Y. ;; ;; C: ;; (foo ;; Comment ;; (bar) ;; ;; Comment 2 ;; (quux)) ;; ;; would indent BAR and QUUX by one. (ignore-errors (save-excursion (goto-char indent-point) (back-to-indentation) (let ((p (point))) (goto-char containing-form-start) (down-list) (let ((one (current-column))) (skip-chars-forward " \t") (if (or (eolp) (looking-at ";")) ;; A. (list one containing-form-start) (forward-sexp 2) (backward-sexp) (if (/= p (point)) ;; B. (list (current-column) containing-form-start) (backward-sexp) (forward-sexp) (let ((tmp (+ (current-column) 1))) (skip-chars-forward " \t") (if (looking-at ";") ;; C. (list tmp containing-form-start))))))))))))) (defun common-lisp-indent-call-method (function method path state indent-point sexp-column normal-indent) (let ((lisp-indent-error-function function)) (if (symbolp method) (funcall method path state indent-point sexp-column normal-indent) (lisp-indent-259 method path state indent-point sexp-column normal-indent)))) ;; Dynamically bound in common-lisp-indent-call-method. (defvar lisp-indent-error-function) (defun lisp-indent-report-bad-format (m) (error "%s has a badly-formed %s property: %s" ;; Love those free variable references!! lisp-indent-error-function 'common-lisp-indent-function m)) ;; Lambda-list indentation is now done in LISP-INDENT-LAMBDA-LIST. ;; See also `lisp-lambda-list-keyword-alignment', ;; `lisp-lambda-list-keyword-parameter-alignment' and ;; `lisp-lambda-list-keyword-parameter-indentation' -- dvl (defvar lisp-indent-lambda-list-keywords-regexp "&\\(\ optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|\ environment\\|more\ \\)\\>" "Regular expression matching lambda-list keywords.") (defun lisp-indent-lambda-list (indent-point sexp-column containing-form-start) (if (not lisp-lambda-list-indentation) (1+ sexp-column) (lisp-properly-indent-lambda-list indent-point sexp-column containing-form-start))) (defun lisp-properly-indent-lambda-list (indent-point sexp-column containing-form-start) (let (limit) (cond ((save-excursion (goto-char indent-point) (back-to-indentation) (setq limit (point)) (looking-at lisp-indent-lambda-list-keywords-regexp)) ;; We're facing a lambda-list keyword. (if lisp-lambda-list-keyword-alignment ;; Align to the first keyword if any, or to the beginning of ;; the lambda-list. (save-excursion (goto-char containing-form-start) (down-list) (let ((key-indent nil) (next t)) (while (and next (< (point) indent-point)) (if (looking-at lisp-indent-lambda-list-keywords-regexp) (setq key-indent (current-column) next nil) (setq next (ignore-errors (forward-sexp) t)) (if next (ignore-errors (forward-sexp) (backward-sexp))))) (or key-indent (1+ sexp-column)))) ;; Align to the beginning of the lambda-list. (1+ sexp-column))) (t ;; Otherwise, align to the first argument of the last lambda-list ;; keyword, the keyword itself, or the beginning of the ;; lambda-list. (save-excursion (goto-char indent-point) (let ((indent nil) (next t)) (while (and next (> (point) containing-form-start)) (setq next (ignore-errors (backward-sexp) t)) (let* ((col (current-column)) (pos (save-excursion (ignore-errors (forward-sexp)) (skip-chars-forward " \t") (if (eolp) (+ col lisp-lambda-list-keyword-parameter-indentation) col)))) (if (looking-at lisp-indent-lambda-list-keywords-regexp) (setq indent (if lisp-lambda-list-keyword-parameter-alignment (or indent pos) (+ col lisp-lambda-list-keyword-parameter-indentation)) next nil) (setq indent col)))) (or indent (1+ sexp-column)))))))) (defun common-lisp-lambda-list-initial-value-form-p (point) (let ((state 'x) (point (save-excursion (goto-char point) (back-to-indentation) (point)))) (save-excursion (backward-sexp) (ignore-errors (down-list 1)) (while (and point (< (point) point)) (cond ((or (looking-at "&key") (looking-at "&optional") (looking-at "&aux")) (setq state 'key)) ((looking-at lisp-indent-lambda-list-keywords-regexp) (setq state 'x))) (if (not (ignore-errors (forward-sexp) t)) (setq point nil) (ignore-errors (forward-sexp) (backward-sexp)) (cond ((> (point) point) (backward-sexp) (when (eq state 'var) (setq state 'x)) (or (ignore-errors (down-list 1) (cond ((> (point) point) (backward-up-list)) ((eq 'key state) (setq state 'var))) t) (setq point nil))) ((eq state 'var) (setq state 'form)))))) (eq 'form state))) ;; Blame the crufty control structure on dynamic scoping ;; -- not on me! (defun lisp-indent-259 (method path state indent-point sexp-column normal-indent) (catch 'exit (let* ((p (cdr path)) (containing-form-start (elt state 1)) (n (1- (car path))) tem tail) (if (not (consp method)) (lisp-indent-report-bad-format method)) (while n ;; This while loop is for advancing along a method ;; until the relevant (possibly &rest/&body) pattern ;; is reached. ;; n is set to (1- n) and method to (cdr method) ;; each iteration. (setq tem (car method)) (or (eq tem 'nil) ;default indentation (eq tem '&lambda) ;lambda list (and (eq tem '&body) (null (cdr method))) (and (eq tem '&rest) (consp (cdr method)) (null (cddr method))) (integerp tem) ;explicit indentation specified (and (consp tem) ;destructuring (or (consp (car tem)) (and (eq (car tem) '&whole) (or (symbolp (cadr tem)) (integerp (cadr tem)))))) (and (symbolp tem) ;a function to call to do the work. (null (cdr method))) (lisp-indent-report-bad-format method)) (cond ((eq tem '&body) ;; &body means (&rest ) (throw 'exit (if (null p) (+ sexp-column lisp-body-indent) normal-indent))) ((eq tem '&rest) ;; this pattern holds for all remaining forms (setq tail (> n 0) n 0 method (cdr method))) ((> n 0) ;; try next element of pattern (setq n (1- n) method (cdr method)) (if (< n 0) ;; Too few elements in pattern. (throw 'exit normal-indent))) ((eq tem 'nil) (throw 'exit (if (consp normal-indent) normal-indent (list normal-indent containing-form-start)))) ((eq tem '&lambda) (throw 'exit (cond ((not (common-lisp-looking-back ")")) ;; If it's not a list at all, indent it ;; like body instead. (if (null p) (+ sexp-column lisp-body-indent) normal-indent)) ((common-lisp-lambda-list-initial-value-form-p indent-point) (if (consp normal-indent) normal-indent (list normal-indent containing-form-start))) ((null p) (list (+ sexp-column 4) containing-form-start)) (t ;; Indentation within a lambda-list. -- dvl (list (lisp-indent-lambda-list indent-point sexp-column containing-form-start) containing-form-start))))) ((integerp tem) (throw 'exit (if (null p) ;not in subforms (list (+ sexp-column tem) containing-form-start) normal-indent))) ((symbolp tem) ;a function to call (throw 'exit (funcall tem path state indent-point sexp-column normal-indent))) (t ;; must be a destructing frob (if p ;; descend (setq method (cddr tem) n (car p) p (cdr p) tail nil) (let ((wholep (eq '&whole (car tem)))) (setq tem (cadr tem)) (throw 'exit (cond (tail (if (and wholep (integerp tem) (save-excursion (goto-char indent-point) (back-to-indentation) (looking-at "\\sw"))) ;; There's a further level of ;; destructuring, but we're looking at a ;; word -- indent to sexp. (+ sexp-column tem) normal-indent)) ((not tem) (list normal-indent containing-form-start)) ((integerp tem) (list (+ sexp-column tem) containing-form-start)) (t (funcall tem path state indent-point sexp-column normal-indent)))))))))))) (defun lisp-indent-tagbody (path state indent-point sexp-column normal-indent) (if (not (null (cdr path))) normal-indent (save-excursion (goto-char indent-point) (back-to-indentation) (list (cond ((looking-at "\\sw\\|\\s_") ;; a tagbody tag (+ sexp-column lisp-tag-indentation)) ((integerp lisp-tag-body-indentation) (+ sexp-column lisp-tag-body-indentation)) ((eq lisp-tag-body-indentation 't) (condition-case () (progn (backward-sexp 1) (current-column)) (error (1+ sexp-column)))) (t (+ sexp-column lisp-body-indent))) ; (cond ((integerp lisp-tag-body-indentation) ; (+ sexp-column lisp-tag-body-indentation)) ; ((eq lisp-tag-body-indentation 't) ; normal-indent) ; (t ; (+ sexp-column lisp-body-indent))) (elt state 1) )))) (defun lisp-indent-do (path state indent-point sexp-column normal-indent) (if (>= (car path) 3) (let ((lisp-tag-body-indentation lisp-body-indent)) (funcall (function lisp-indent-tagbody) path state indent-point sexp-column normal-indent)) (funcall (function lisp-indent-259) '((&whole nil &rest ;; the following causes weird indentation ;;(&whole 1 1 2 nil) ) (&whole nil &rest 1)) path state indent-point sexp-column normal-indent))) (defun lisp-indent-defsetf (path state indent-point sexp-column normal-indent) (list (cond ;; Inside the lambda-list in a long-form defsetf. ((and (eql 2 (car path)) (cdr path)) (lisp-indent-lambda-list indent-point sexp-column (elt state 1))) ;; Long form: has a lambda-list. ((or (cdr path) (save-excursion (goto-char (elt state 1)) (ignore-errors (down-list) (forward-sexp 3) (backward-sexp) (looking-at "nil\\|(")))) (+ sexp-column (case (car path) ((1 3) 4) (2 4) (t 2)))) ;; Short form. (t (+ sexp-column (case (car path) (1 4) (2 4) (t 2))))) (elt state 1))) (defun lisp-beginning-of-defmethod-qualifiers () (let ((regexp-1 "(defmethod\\|(DEFMETHOD") (regexp-2 "(:method\\|(:METHOD")) (while (and (not (or (looking-at regexp-1) (looking-at regexp-2))) (ignore-errors (backward-up-list) t))) (cond ((looking-at regexp-1) (forward-char) ;; Skip name. (forward-sexp 2) 1) ((looking-at regexp-2) (forward-char) (forward-sexp 1) 0)))) ;; LISP-INDENT-DEFMETHOD now supports the presence of more than one method ;; qualifier and indents the method's lambda list properly. -- dvl (defun lisp-indent-defmethod (path state indent-point sexp-column normal-indent) (lisp-indent-259 (let ((nskip nil)) (if (save-excursion (when (setq nskip (lisp-beginning-of-defmethod-qualifiers)) (skip-chars-forward " \t\n") (while (looking-at "\\sw\\|\\s_") (incf nskip) (forward-sexp) (skip-chars-forward " \t\n")) t)) (append (make-list nskip 4) '(&lambda &body)) (common-lisp-get-indentation 'defun))) path state indent-point sexp-column normal-indent)) (defun lisp-indent-function-lambda-hack (path state indent-point sexp-column normal-indent) ;; indent (function (lambda () )) kludgily. (if (or (cdr path) ; wtf? (> (car path) 3)) ;; line up under previous body form normal-indent ;; line up under function rather than under lambda in order to ;; conserve horizontal space. (Which is what #' is for.) (condition-case () (save-excursion (backward-up-list 2) (forward-char 1) (if (looking-at "\\(lisp:+\\)?function\\(\\Sw\\|\\S_\\)") (+ lisp-body-indent -1 (current-column)) (+ sexp-column lisp-body-indent))) (error (+ sexp-column lisp-body-indent))))) (defun lisp-indent-loop (path state indent-point sexp-column normal-indent) (if (cdr path) normal-indent (let* ((loop-start (elt state 1)) (type (common-lisp-loop-type loop-start))) (cond ((and lisp-loop-indent-subclauses (member type '(extended extended/split))) (list (common-lisp-indent-loop-macro-1 state indent-point) (common-lisp-indent-parse-state-start state))) (t (common-lisp-loop-part-indentation indent-point state type)))))) ;;;; LOOP indentation, the complex version -- handles subclause indentation ;; Regexps matching various varieties of loop macro keyword ... (defvar common-lisp-body-introducing-loop-macro-keyword "\\(#?:\\)?\\(do\\(ing\\)?\\|finally\\|initially\\)" "Regexp matching loop macro keywords which introduce body forms.") ;; Not currenctly used (defvar common-lisp-accumlation-loop-macro-keyword "\\(#?:\\)?\\(collect\\(ing\\)?\\|append\\(ing\\)?\\|nconc\\(ing\\)?\\|\ count\\(ing\\)?\\|sum\\(ming\\)?\\|maximiz\\(e\\|ing\\)\\|\ minimiz\\(e\\|ing\\)\\)" "Regexp matching loop macro keywords which introduce accumulation clauses.") ;; This is so "and when" and "else when" get handled right ;; (not to mention "else do" !!!) (defvar common-lisp-prefix-loop-macro-keyword "\\(#?:\\)?\\(and\\|else\\)" "Regexp matching loop macro keywords which are prefixes.") (defvar common-lisp-indent-clause-joining-loop-macro-keyword "\\(#?:\\)?and" "Regexp matching 'and', and anything else there ever comes to be like it.") (defvar common-lisp-indent-indented-loop-macro-keyword "\\(#?:\\)?\\(\\(up\\|down\\)?(from\\|to)\\|below\\|above\\|in\\(to\\)?\\|\ on\\|=\\|then\\|across\\|being\\|each\\|the\\|of\\|using\\|\ \\(present-\\|external-\\)?symbols?\\|fixnum\\|float\\|t\\|nil\\|of-type\\)" "Regexp matching keywords introducing loop subclauses. Always indented two.") (defvar common-lisp-indenting-loop-macro-keyword "\\(#?:\\)?\\(when\\|unless\\|if\\)" "Regexp matching keywords introducing conditional clauses. Cause subsequent clauses to be indented.") (defvar common-lisp-loop-macro-else-keyword "\\(#?:\\)?else") ;;; Attempt to indent the loop macro ... (defun common-lisp-indent-parse-state-depth (parse-state) (car parse-state)) (defun common-lisp-indent-parse-state-start (parse-state) (car (cdr parse-state))) (defun common-lisp-indent-parse-state-prev (parse-state) (car (cdr (cdr parse-state)))) (defun common-lisp-loop-part-indentation (indent-point state type) "Compute the indentation of loop form constituents." (let* ((loop-start (elt state 1)) (loop-indentation (save-excursion (goto-char loop-start) (if (eq type 'extended/split) (- (current-column) 4) (current-column)))) (indent nil) (re "\\(\\(#?:\\)?\\sw+\\|)\\|\n\\)")) (goto-char indent-point) (back-to-indentation) (cond ((eq type 'simple/split) (+ loop-indentation lisp-simple-loop-indentation)) ((eq type 'simple) (+ loop-indentation 6)) ;; We are already in a body, with forms in it. ((and (not (looking-at re)) (save-excursion (while (and (ignore-errors (backward-sexp) t) (not (looking-at re))) (setq indent (current-column))) (when (and indent (looking-at common-lisp-body-introducing-loop-macro-keyword)) t))) (list indent loop-start)) ;; Keyword-style or comment outside body ((or lisp-loop-indent-forms-like-keywords (looking-at re) (looking-at ";")) (if (and (looking-at ";") (let ((p (common-lisp-trailing-comment))) (when p (setq loop-indentation p)))) (list loop-indentation loop-start) (list (+ loop-indentation 6) loop-start))) ;; Form-style (t (list (+ loop-indentation 9) loop-start))))) (defun common-lisp-indent-loop-macro-1 (parse-state indent-point) (catch 'return-indentation (save-excursion ;; Find first clause of loop macro, and use it to establish ;; base column for indentation (goto-char (common-lisp-indent-parse-state-start parse-state)) (let ((loop-start-column (current-column))) (common-lisp-loop-advance-past-keyword-on-line) (when (eolp) (forward-line 1) (end-of-line) ;; If indenting first line after "(loop " ;; cop out ... (if (<= indent-point (point)) (throw 'return-indentation (+ lisp-loop-clauses-indentation loop-start-column))) (back-to-indentation)) (let* ((case-fold-search t) (loop-macro-first-clause (point)) (previous-expression-start (common-lisp-indent-parse-state-prev parse-state)) (default-value (current-column)) (loop-body-p nil) (loop-body-indentation nil) (indented-clause-indentation (+ 2 default-value))) ;; Determine context of this loop clause, starting with the ;; expression immediately preceding the line we're trying to indent (goto-char previous-expression-start) ;; Handle a body-introducing-clause which ends a line specially. (if (looking-at common-lisp-body-introducing-loop-macro-keyword) (let ((keyword-position (current-column))) (setq loop-body-p t) (setq loop-body-indentation (if (common-lisp-loop-advance-past-keyword-on-line) (current-column) (back-to-indentation) (if (/= (current-column) keyword-position) (+ 2 (current-column)) (+ lisp-loop-body-forms-indentation (if lisp-loop-indent-body-forms-relative-to-loop-start loop-start-column keyword-position)))))) (back-to-indentation) (if (< (point) loop-macro-first-clause) (goto-char loop-macro-first-clause)) ;; If there's an "and" or "else," advance over it. ;; If it is alone on the line, the next "cond" will treat it ;; as if there were a "when" and indent under it ... (let ((exit nil)) (while (and (null exit) (looking-at common-lisp-prefix-loop-macro-keyword)) (if (null (common-lisp-loop-advance-past-keyword-on-line)) (progn (setq exit t) (back-to-indentation))))) ;; Found start of loop clause preceding the one we're ;; trying to indent. Glean context ... (cond ((looking-at "(") ;; We're in the middle of a clause body ... (setq loop-body-p t) (setq loop-body-indentation (current-column))) ((looking-at common-lisp-body-introducing-loop-macro-keyword) (setq loop-body-p t) ;; Know there's something else on the line (or would ;; have been caught above) (common-lisp-loop-advance-past-keyword-on-line) (setq loop-body-indentation (current-column))) (t (setq loop-body-p nil) (if (or (looking-at common-lisp-indenting-loop-macro-keyword) (looking-at common-lisp-prefix-loop-macro-keyword)) (setq default-value (+ 2 (current-column)))) (setq indented-clause-indentation (+ 2 (current-column))) ;; We still need loop-body-indentation for "syntax errors" ... (goto-char previous-expression-start) (setq loop-body-indentation (current-column))))) ;; Go to first non-blank character of the line we're trying ;; to indent. (if none, wind up poised on the new-line ...) (goto-char indent-point) (back-to-indentation) (cond ((looking-at "(") ;; Clause body ... loop-body-indentation) ((or (eolp) (looking-at ";")) ;; Blank line. If body-p, indent as body, else indent as ;; vanilla clause. (if loop-body-p loop-body-indentation (or (and (looking-at ";") (common-lisp-trailing-comment)) default-value))) ((looking-at common-lisp-indent-indented-loop-macro-keyword) indented-clause-indentation) ((looking-at common-lisp-indent-clause-joining-loop-macro-keyword) (let ((stolen-indent-column nil)) (forward-line -1) (while (and (null stolen-indent-column) (> (point) loop-macro-first-clause)) (back-to-indentation) (if (and (< (current-column) loop-body-indentation) (looking-at "\\(#?:\\)?\\sw")) (progn (if (looking-at common-lisp-loop-macro-else-keyword) (common-lisp-loop-advance-past-keyword-on-line)) (setq stolen-indent-column (current-column))) (forward-line -1))) (if stolen-indent-column stolen-indent-column default-value))) (t default-value))))))) (defun common-lisp-loop-advance-past-keyword-on-line () (forward-word 1) (while (and (looking-at "\\s-") (not (eolp))) (forward-char 1)) (if (eolp) nil (current-column))) ;;;; IF* is not standard, but a plague upon the land ;;;; ...let's at least try to indent it. (defvar common-lisp-indent-if*-keyword "threnret\\|elseif\\|then\\|else" "Regexp matching if* keywords") (defun common-lisp-indent-if* (path parse-state indent-point sexp-column normal-indent) (list (common-lisp-indent-if*-1 parse-state indent-point) (common-lisp-indent-parse-state-start parse-state))) (defun common-lisp-indent-if*-1 (parse-state indent-point) (catch 'return-indentation (save-excursion ;; Find first clause of if* macro, and use it to establish ;; base column for indentation (goto-char (common-lisp-indent-parse-state-start parse-state)) (let ((if*-start-column (current-column))) (common-lisp-indent-if*-advance-past-keyword-on-line) (let* ((case-fold-search t) (if*-first-clause (point)) (previous-expression-start (common-lisp-indent-parse-state-prev parse-state)) (default-value (current-column)) (if*-body-p nil) (if*-body-indentation nil)) ;; Determine context of this if* clause, starting with the ;; expression immediately preceding the line we're trying to indent (goto-char previous-expression-start) ;; Handle a body-introducing-clause which ends a line specially. (back-to-indentation) (if (< (point) if*-first-clause) (goto-char if*-first-clause)) ;; Found start of if* clause preceding the one we're trying ;; to indent. Glean context ... (cond ((looking-at common-lisp-indent-if*-keyword) (setq if*-body-p t) ;; Know there's something else on the line (or would ;; have been caught above) (common-lisp-indent-if*-advance-past-keyword-on-line) (setq if*-body-indentation (current-column))) ((looking-at "#'\\|'\\|(") ;; We're in the middle of a clause body ... (setq if*-body-p t) (setq if*-body-indentation (current-column))) (t (setq if*-body-p nil) ;; We still need if*-body-indentation for "syntax errors" ... (goto-char previous-expression-start) (setq if*-body-indentation (current-column)))) ;; Go to first non-blank character of the line we're trying ;; to indent. (if none, wind up poised on the new-line ...) (goto-char indent-point) (back-to-indentation) (cond ((or (eolp) (looking-at ";")) ;; Blank line. If body-p, indent as body, else indent as ;; vanilla clause. (if if*-body-p if*-body-indentation default-value)) ((not (looking-at common-lisp-indent-if*-keyword)) ;; Clause body ... if*-body-indentation) (t (- (+ 7 if*-start-column) (- (match-end 0) (match-beginning 0)))))))))) (defun common-lisp-indent-if*-advance-past-keyword-on-line () (forward-word 1) (block move-forward (while (and (looking-at "\\s-") (not (eolp))) (forward-char 1))) (if (eolp) nil (current-column))) ;;;; Indentation specs for standard symbols, and a few semistandard ones. (defun common-lisp-init-standard-indentation () (let ((l '((block 1) (case (4 &rest (&whole 2 &rest 1))) (ccase (as case)) (ecase (as case)) (typecase (as case)) (etypecase (as case)) (ctypecase (as case)) (catch 1) (cond (&rest (&whole 2 &rest nil))) ;; for DEFSTRUCT (:constructor (4 &lambda)) (defvar (4 2 2)) (defclass (6 (&whole 4 &rest 1) (&whole 2 &rest 1) (&whole 2 &rest 1))) (defconstant (as defvar)) (defcustom (4 2 2 2)) (defparameter (as defvar)) (defconst (as defcustom)) (define-condition (as defclass)) (define-modify-macro (4 &lambda &body)) (defsetf lisp-indent-defsetf) (defun (4 &lambda &body)) (defgeneric (4 &lambda &body)) (define-setf-method (as defun)) (define-setf-expander (as defun)) (defmacro (as defun)) (defsubst (as defun)) (deftype (as defun)) (defmethod lisp-indent-defmethod) (defpackage (4 2)) (defstruct ((&whole 4 &rest (&whole 2 &rest 1)) &rest (&whole 2 &rest 1))) (destructuring-bind (&lambda 4 &body)) (do lisp-indent-do) (do* (as do)) (dolist ((&whole 4 2 1) &body)) (dotimes (as dolist)) (eval-when 1) (flet ((&whole 4 &rest (&whole 1 4 &lambda &body)) &body)) (labels (as flet)) (macrolet (as flet)) (generic-flet (as flet)) (generic-labels (as flet)) (handler-case (4 &rest (&whole 2 &lambda &body))) (restart-case (as handler-case)) ;; single-else style (then and else equally indented) (if (&rest nil)) (if* common-lisp-indent-if*) (lambda (&lambda &rest lisp-indent-function-lambda-hack)) (let ((&whole 4 &rest (&whole 1 1 2)) &body)) (let* (as let)) (compiler-let (as let)) (handler-bind (as let)) (restart-bind (as let)) (locally 1) (loop lisp-indent-loop) (:method lisp-indent-defmethod) ; in `defgeneric' (multiple-value-bind ((&whole 6 &rest 1) 4 &body)) (multiple-value-call (4 &body)) (multiple-value-prog1 1) (multiple-value-setq (4 2)) (multiple-value-setf (as multiple-value-setq)) (named-lambda (4 &lambda &rest lisp-indent-function-lambda-hack)) (pprint-logical-block (4 2)) (print-unreadable-object ((&whole 4 1 &rest 1) &body)) ;; Combines the worst features of BLOCK, LET and TAGBODY (prog (&lambda &rest lisp-indent-tagbody)) (prog* (as prog)) (prog1 1) (prog2 2) (progn 0) (progv (4 4 &body)) (return 0) (return-from (nil &body)) (symbol-macrolet (as let)) (tagbody lisp-indent-tagbody) (throw 1) (unless 1) (unwind-protect (5 &body)) (when 1) (with-accessors (as multiple-value-bind)) (with-compilation-unit ((&whole 4 &rest 1) &body)) (with-condition-restarts (as multiple-value-bind)) (with-output-to-string (4 2)) (with-slots (as multiple-value-bind)) (with-standard-io-syntax (2))))) (dolist (el l) (let* ((name (car el)) (spec (cdr el)) (indentation (if (symbolp spec) (error "Old style indirect indentation spec: %s" el) (when (cdr spec) (error "Malformed indentation specification: %s" el)) (car spec)))) (unless (symbolp name) (error "Cannot set Common Lisp indentation of a non-symbol: %s" name)) (put name 'common-lisp-indent-function indentation))))) (common-lisp-init-standard-indentation) (provide 'cl-indent) (provide 'slime-cl-indent) ;;; slime-cl-indent.el ends here slime-2.20/contrib/slime-clipboard.el000066400000000000000000000136361315100173500176030ustar00rootroot00000000000000(require 'slime) (require 'slime-repl) (require 'cl-lib) (eval-when-compile (require 'cl)) ; lexical-let (define-slime-contrib slime-clipboard "This add a few commands to put objects into a clipboard and to insert textual references to those objects. The clipboard command prefix is C-c @. C-c @ + adds an object to the clipboard C-c @ @ inserts a reference to an object in the clipboard C-c @ ? displays the clipboard This package also also binds the + key in the inspector and debugger to add the object at point to the clipboard." (:authors "Helmut Eller ") (:license "GPL") (:swank-dependencies swank-clipboard)) (define-derived-mode slime-clipboard-mode fundamental-mode "Slime-Clipboard" "SLIME Clipboad Mode. \\{slime-clipboard-mode-map}") (slime-define-keys slime-clipboard-mode-map ("g" 'slime-clipboard-redisplay) ((kbd "C-k") 'slime-clipboard-delete-entry) ("i" 'slime-clipboard-inspect)) (defvar slime-clipboard-map (make-sparse-keymap)) (slime-define-keys slime-clipboard-map ("?" 'slime-clipboard-display) ("+" 'slime-clipboard-add) ("@" 'slime-clipboard-ref)) (define-key slime-mode-map (kbd "C-c @") slime-clipboard-map) (define-key slime-repl-mode-map (kbd "C-c @") slime-clipboard-map) (slime-define-keys slime-inspector-mode-map ("+" 'slime-clipboard-add-from-inspector)) (slime-define-keys sldb-mode-map ("+" 'slime-clipboard-add-from-sldb)) (defun slime-clipboard-add (exp package) "Add an object to the clipboard." (interactive (list (slime-read-from-minibuffer "Add to clipboard (evaluated): " (slime-sexp-at-point)) (slime-current-package))) (slime-clipboard-add-internal `(:string ,exp ,package))) (defun slime-clipboard-add-internal (datum) (slime-eval-async `(swank-clipboard:add ',datum) (lambda (result) (message "%s" result)))) (defun slime-clipboard-display () "Display the content of the clipboard." (interactive) (slime-eval-async `(swank-clipboard:entries) #'slime-clipboard-display-entries)) (defun slime-clipboard-display-entries (entries) (slime-with-popup-buffer ((slime-buffer-name :clipboard) :mode 'slime-clipboard-mode) (slime-clipboard-insert-entries entries))) (defun slime-clipboard-insert-entries (entries) (let ((fstring "%2s %3s %s\n")) (insert (format fstring "Nr" "Id" "Value") (format fstring "--" "--" "-----" )) (save-excursion (cl-loop for i from 0 for (ref . value) in entries do (slime-insert-propertized `(slime-clipboard-entry ,i slime-clipboard-ref ,ref) (format fstring i ref value)))))) (defun slime-clipboard-redisplay () "Update the clipboard buffer." (interactive) (lexical-let ((saved (point))) (slime-eval-async `(swank-clipboard:entries) (lambda (entries) (let ((inhibit-read-only t)) (erase-buffer) (slime-clipboard-insert-entries entries) (when (< saved (point-max)) (goto-char saved))))))) (defun slime-clipboard-entry-at-point () (or (get-text-property (point) 'slime-clipboard-entry) (error "No clipboard entry at point"))) (defun slime-clipboard-ref-at-point () (or (get-text-property (point) 'slime-clipboard-ref) (error "No clipboard ref at point"))) (defun slime-clipboard-inspect (&optional entry) "Inspect the current clipboard entry." (interactive (list (slime-clipboard-ref-at-point))) (slime-inspect (prin1-to-string `(swank-clipboard::clipboard-ref ,entry)))) (defun slime-clipboard-delete-entry (&optional entry) "Delete the current entry from the clipboard." (interactive (list (slime-clipboard-entry-at-point))) (slime-eval-async `(swank-clipboard:delete-entry ,entry) (lambda (result) (slime-clipboard-redisplay) (message "%s" result)))) (defun slime-clipboard-ref () "Ask for a clipboard entry number and insert a reference to it." (interactive) (slime-clipboard-read-entry-number #'slime-clipboard-insert-ref)) ;; insert a reference to clipboard entry ENTRY at point. The text ;; receives a special 'display property to make it look nicer. We ;; remove this property in a modification when a user tries to modify ;; he real text. (defun slime-clipboard-insert-ref (entry) (cl-destructuring-bind (ref . string) (slime-eval `(swank-clipboard:entry-to-ref ,entry)) (slime-insert-propertized `(display ,(format "#@%d%s" ref string) modification-hooks (slime-clipboard-ref-modified) rear-nonsticky t) (format "(swank-clipboard::clipboard-ref %d)" ref)))) (defun slime-clipboard-ref-modified (start end) (when (get-text-property start 'display) (let ((inhibit-modification-hooks t)) (save-excursion (goto-char start) (cl-destructuring-bind (dstart dend) (slime-property-bounds 'display) (unless (and (= start dstart) (= end dend)) (remove-list-of-text-properties dstart dend '(display modification-hooks)))))))) ;; Read a entry number. ;; Written in CPS because the display the clipboard before reading. (defun slime-clipboard-read-entry-number (k) (slime-eval-async `(swank-clipboard:entries) (slime-rcurry (lambda (entries window-config k) (slime-clipboard-display-entries entries) (let ((entry (unwind-protect (read-from-minibuffer "Entry number: " nil nil t) (set-window-configuration window-config)))) (funcall k entry))) (current-window-configuration) k))) (defun slime-clipboard-add-from-inspector () (interactive) (let ((part (or (get-text-property (point) 'slime-part-number) (error "No part at point")))) (slime-clipboard-add-internal `(:inspector ,part)))) (defun slime-clipboard-add-from-sldb () (interactive) (slime-clipboard-add-internal `(:sldb ,(sldb-frame-number-at-point) ,(sldb-var-number-at-point)))) (provide 'slime-clipboard) slime-2.20/contrib/slime-compiler-notes-tree.el000066400000000000000000000146651315100173500215440ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (define-slime-contrib slime-compiler-notes-tree "Display compiler messages in tree layout. M-x slime-list-compiler-notes display the compiler notes in a tree grouped by severity. `slime-maybe-list-compiler-notes' can be used as `slime-compilation-finished-hook'. " (:authors "Helmut Eller ") (:license "GPL")) (defun slime-maybe-list-compiler-notes (notes) "Show the compiler notes if appropriate." ;; don't pop up a buffer if all notes are already annotated in the ;; buffer itself (unless (cl-every #'slime-note-has-location-p notes) (slime-list-compiler-notes notes))) (defun slime-list-compiler-notes (notes) "Show the compiler notes NOTES in tree view." (interactive (list (slime-compiler-notes))) (with-temp-message "Preparing compiler note tree..." (slime-with-popup-buffer ((slime-buffer-name :notes) :mode 'slime-compiler-notes-mode) (when (null notes) (insert "[no notes]")) (let ((collapsed-p)) (dolist (tree (slime-compiler-notes-to-tree notes)) (when (slime-tree.collapsed-p tree) (setf collapsed-p t)) (slime-tree-insert tree "") (insert "\n")) (goto-char (point-min)))))) (defvar slime-tree-printer 'slime-tree-default-printer) (defun slime-tree-for-note (note) (make-slime-tree :item (slime-note.message note) :plist (list 'note note) :print-fn slime-tree-printer)) (defun slime-tree-for-severity (severity notes collapsed-p) (make-slime-tree :item (format "%s (%d)" (slime-severity-label severity) (length notes)) :kids (mapcar #'slime-tree-for-note notes) :collapsed-p collapsed-p)) (defun slime-compiler-notes-to-tree (notes) (let* ((alist (slime-alistify notes #'slime-note.severity #'eq)) (collapsed-p (slime-length> alist 1))) (cl-loop for (severity . notes) in alist collect (slime-tree-for-severity severity notes collapsed-p)))) (defvar slime-compiler-notes-mode-map) (define-derived-mode slime-compiler-notes-mode fundamental-mode "Compiler-Notes" "\\\ \\{slime-compiler-notes-mode-map} \\{slime-popup-buffer-mode-map} " (slime-set-truncate-lines)) (slime-define-keys slime-compiler-notes-mode-map ((kbd "RET") 'slime-compiler-notes-default-action-or-show-details) ([return] 'slime-compiler-notes-default-action-or-show-details) ([mouse-2] 'slime-compiler-notes-default-action-or-show-details/mouse)) (defun slime-compiler-notes-default-action-or-show-details/mouse (event) "Invoke the action pointed at by the mouse, or show details." (interactive "e") (cl-destructuring-bind (mouse-2 (w pos &rest _) &rest __) event (save-excursion (goto-char pos) (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action))) (if fn (funcall fn) (slime-compiler-notes-show-details)))))) (defun slime-compiler-notes-default-action-or-show-details () "Invoke the action at point, or show details." (interactive) (let ((fn (get-text-property (point) 'slime-compiler-notes-default-action))) (if fn (funcall fn) (slime-compiler-notes-show-details)))) (defun slime-compiler-notes-show-details () (interactive) (let* ((tree (slime-tree-at-point)) (note (plist-get (slime-tree.plist tree) 'note)) (inhibit-read-only t)) (cond ((not (slime-tree-leaf-p tree)) (slime-tree-toggle tree)) (t (slime-show-source-location (slime-note.location note) t))))) ;;;;;; Tree Widget (cl-defstruct (slime-tree (:conc-name slime-tree.)) item (print-fn #'slime-tree-default-printer :type function) (kids '() :type list) (collapsed-p t :type boolean) (prefix "" :type string) (start-mark nil) (end-mark nil) (plist '() :type list)) (defun slime-tree-leaf-p (tree) (not (slime-tree.kids tree))) (defun slime-tree-default-printer (tree) (princ (slime-tree.item tree) (current-buffer))) (defun slime-tree-decoration (tree) (cond ((slime-tree-leaf-p tree) "-- ") ((slime-tree.collapsed-p tree) "[+] ") (t "-+ "))) (defun slime-tree-insert-list (list prefix) "Insert a list of trees." (cl-loop for (elt . rest) on list do (cond (rest (insert prefix " |") (slime-tree-insert elt (concat prefix " |")) (insert "\n")) (t (insert prefix " `") (slime-tree-insert elt (concat prefix " ")))))) (defun slime-tree-insert-decoration (tree) (insert (slime-tree-decoration tree))) (defun slime-tree-indent-item (start end prefix) "Insert PREFIX at the beginning of each but the first line. This is used for labels spanning multiple lines." (save-excursion (goto-char end) (beginning-of-line) (while (< start (point)) (insert-before-markers prefix) (forward-line -1)))) (defun slime-tree-insert (tree prefix) "Insert TREE prefixed with PREFIX at point." (with-struct (slime-tree. print-fn kids collapsed-p start-mark end-mark) tree (let ((line-start (line-beginning-position))) (setf start-mark (point-marker)) (slime-tree-insert-decoration tree) (funcall print-fn tree) (slime-tree-indent-item start-mark (point) (concat prefix " ")) (add-text-properties line-start (point) (list 'slime-tree tree)) (set-marker-insertion-type start-mark t) (when (and kids (not collapsed-p)) (terpri (current-buffer)) (slime-tree-insert-list kids prefix)) (setf (slime-tree.prefix tree) prefix) (setf end-mark (point-marker))))) (defun slime-tree-at-point () (cond ((get-text-property (point) 'slime-tree)) (t (error "No tree at point")))) (defun slime-tree-delete (tree) "Delete the region for TREE." (delete-region (slime-tree.start-mark tree) (slime-tree.end-mark tree))) (defun slime-tree-toggle (tree) "Toggle the visibility of TREE's children." (with-struct (slime-tree. collapsed-p start-mark end-mark prefix) tree (setf collapsed-p (not collapsed-p)) (slime-tree-delete tree) (insert-before-markers " ") ; move parent's end-mark (backward-char 1) (slime-tree-insert tree prefix) (delete-char 1) (goto-char start-mark))) (provide 'slime-compiler-notes-tree) slime-2.20/contrib/slime-editing-commands.el000066400000000000000000000161071315100173500210620ustar00rootroot00000000000000(require 'slime) (require 'slime-repl) (require 'cl-lib) (define-slime-contrib slime-editing-commands "Editing commands without server interaction." (:authors "Thomas F. Burdick " "Luke Gorrie " "Bill Clementson " "Tobias C. Rittweiler ") (:license "GPL") (:on-load (define-key slime-mode-map "\M-\C-a" 'slime-beginning-of-defun) (define-key slime-mode-map "\M-\C-e" 'slime-end-of-defun) (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun) (define-key slime-mode-map "\C-c\C-]" 'slime-close-all-parens-in-sexp))) (defun slime-beginning-of-defun () (interactive) (if (and (boundp 'slime-repl-input-start-mark) slime-repl-input-start-mark) (slime-repl-beginning-of-defun) (let ((this-command 'beginning-of-defun)) ; needed for push-mark (call-interactively 'beginning-of-defun)))) (defun slime-end-of-defun () (interactive) (if (eq major-mode 'slime-repl-mode) (slime-repl-end-of-defun) (end-of-defun))) (defvar slime-comment-start-regexp "\\(\\(^\\|[^\n\\\\]\\)\\([\\\\][\\\\]\\)*\\);+[ \t]*" "Regexp to match the start of a comment.") (defun slime-beginning-of-comment () "Move point to beginning of comment. If point is inside a comment move to beginning of comment and return point. Otherwise leave point unchanged and return NIL." (let ((boundary (point))) (beginning-of-line) (cond ((re-search-forward slime-comment-start-regexp boundary t) (point)) (t (goto-char boundary) nil)))) (defvar slime-close-parens-limit nil "Maxmimum parens for `slime-close-all-sexp' to insert. NIL means to insert as many parentheses as necessary to correctly close the form.") (defun slime-close-all-parens-in-sexp (&optional region) "Balance parentheses of open s-expressions at point. Insert enough right parentheses to balance unmatched left parentheses. Delete extra left parentheses. Reformat trailing parentheses Lisp-stylishly. If REGION is true, operate on the region. Otherwise operate on the top-level sexp before point." (interactive "P") (let ((sexp-level 0) point) (save-excursion (save-restriction (when region (narrow-to-region (region-beginning) (region-end)) (goto-char (point-max))) ;; skip over closing parens, but not into comment (skip-chars-backward ") \t\n") (when (slime-beginning-of-comment) (forward-line) (skip-chars-forward " \t")) (setq point (point)) ;; count sexps until either '(' or comment is found at first column (while (and (not (looking-at "^[(;]")) (ignore-errors (backward-up-list 1) t)) (incf sexp-level)))) (when (> sexp-level 0) ;; insert correct number of right parens (goto-char point) (dotimes (i sexp-level) (insert ")")) ;; delete extra right parens (setq point (point)) (skip-chars-forward " \t\n)") (skip-chars-backward " \t\n") (let* ((deleted-region (delete-and-extract-region point (point))) (deleted-text (substring-no-properties deleted-region)) (prior-parens-count (cl-count ?\) deleted-text))) ;; Remember: we always insert as many parentheses as necessary ;; and only afterwards delete the superfluously-added parens. (when slime-close-parens-limit (let ((missing-parens (- sexp-level prior-parens-count slime-close-parens-limit))) (dotimes (i (max 0 missing-parens)) (delete-char -1)))))))) (defun slime-insert-balanced-comments (arg) "Insert a set of balanced comments around the s-expression containing the point. If this command is invoked repeatedly \(without any other command occurring between invocations), the comment progressively moves outward over enclosing expressions. If invoked with a positive prefix argument, the s-expression arg expressions out is enclosed in a set of balanced comments." (interactive "*p") (save-excursion (when (eq last-command this-command) (when (search-backward "#|" nil t) (save-excursion (delete-char 2) (while (and (< (point) (point-max)) (not (looking-at " *|#"))) (forward-sexp)) (replace-match "")))) (while (> arg 0) (backward-char 1) (cond ((looking-at ")") (incf arg)) ((looking-at "(") (decf arg)))) (insert "#|") (forward-sexp) (insert "|#"))) (defun slime-remove-balanced-comments () "Remove a set of balanced comments enclosing point." (interactive "*") (save-excursion (when (search-backward "#|" nil t) (delete-char 2) (while (and (< (point) (point-max)) (not (looking-at " *|#"))) (forward-sexp)) (replace-match "")))) ;; SLIME-CLOSE-PARENS-AT-POINT is obsolete: ;; It doesn't work correctly on the REPL, because there ;; BEGINNING-OF-DEFUN-FUNCTION and END-OF-DEFUN-FUNCTION is bound to ;; SLIME-REPL-MODE-BEGINNING-OF-DEFUN (and ;; SLIME-REPL-MODE-END-OF-DEFUN respectively) which compromises the ;; way how they're expect to work (i.e. END-OF-DEFUN does not signal ;; an UNBOUND-PARENTHESES error.) ;; Use SLIME-CLOSE-ALL-PARENS-IN-SEXP instead. ;; (defun slime-close-parens-at-point () ;; "Close parenthesis at point to complete the top-level-form. Simply ;; inserts ')' characters at point until `beginning-of-defun' and ;; `end-of-defun' execute without errors, or `slime-close-parens-limit' ;; is exceeded." ;; (interactive) ;; (loop for i from 1 to slime-close-parens-limit ;; until (save-excursion ;; (slime-beginning-of-defun) ;; (ignore-errors (slime-end-of-defun) t)) ;; do (insert ")"))) (defun slime-reindent-defun (&optional force-text-fill) "Reindent the current defun, or refill the current paragraph. If point is inside a comment block, the text around point will be treated as a paragraph and will be filled with `fill-paragraph'. Otherwise, it will be treated as Lisp code, and the current defun will be reindented. If the current defun has unbalanced parens, an attempt will be made to fix it before reindenting. When given a prefix argument, the text around point will always be treated as a paragraph. This is useful for filling docstrings." (interactive "P") (save-excursion (if (or force-text-fill (slime-beginning-of-comment)) (fill-paragraph nil) (let ((start (progn (unless (or (and (zerop (current-column)) (eq ?\( (char-after))) (and slime-repl-input-start-mark (slime-repl-at-prompt-start-p))) (slime-beginning-of-defun)) (point))) (end (ignore-errors (slime-end-of-defun) (point)))) (unless end (forward-paragraph) (slime-close-all-parens-in-sexp) (slime-end-of-defun) (setf end (point))) (indent-region start end nil))))) (provide 'slime-editing-commands) slime-2.20/contrib/slime-enclosing-context.el000066400000000000000000000214741315100173500213060ustar00rootroot00000000000000(require 'slime) (require 'slime-parse) (require 'cl-lib) (define-slime-contrib slime-enclosing-context "Utilities on top of slime-parse." (:authors "Tobias C. Rittweiler ") (:license "GPL")) (defun slime-parse-sexp-at-point (&optional n) "Returns the sexps at point as a list of strings, otherwise nil. \(If there are not as many sexps as N, a list with < N sexps is returned.\) If SKIP-BLANKS-P is true, leading whitespaces &c are skipped. " (interactive "p") (or n (setq n 1)) (save-excursion (let ((result nil)) (dotimes (i n) ;; Is there an additional sexp in front of us? (save-excursion (unless (slime-point-moves-p (ignore-errors (forward-sexp))) (cl-return))) (push (slime-sexp-at-point) result) ;; Skip current sexp (ignore-errors (forward-sexp) (skip-chars-forward "[:space:]"))) (nreverse result)))) (defun slime-has-symbol-syntax-p (string) (if (and string (not (zerop (length string)))) (member (char-syntax (aref string 0)) '(?w ?_ ?\' ?\\)))) (defun slime-beginning-of-string () (let* ((parser-state (slime-current-parser-state)) (inside-string-p (nth 3 parser-state)) (string-start-pos (nth 8 parser-state))) (if inside-string-p (goto-char string-start-pos) (error "We're not within a string")))) (defun slime-enclosing-form-specs (&optional max-levels) "Return the list of ``raw form specs'' of all the forms containing point from right to left. As a secondary value, return a list of indices: Each index tells for each corresponding form spec in what argument position the user's point is. As tertiary value, return the positions of the operators that are contained in the returned form specs. When MAX-LEVELS is non-nil, go up at most this many levels of parens. \(See SWANK::PARSE-FORM-SPEC for more information about what exactly constitutes a ``raw form specs'') Examples: A return value like the following (values ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3)) can be interpreted as follows: The user point is located in the 3rd argument position of a form with the operator name \"quux\" (which starts at P1.) This form is located in the 2nd argument position of a form with the operator name \"bar\" (which starts at P2.) This form again is in the 1st argument position of a form with the operator name \"foo\" (which itself begins at P3.) For instance, the corresponding buffer content could have looked like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point. " (let ((level 1) (parse-sexp-lookup-properties nil) (initial-point (point)) (result '()) (arg-indices '()) (points '())) ;; The expensive lookup of syntax-class text properties is only ;; used for interactive balancing of #<...> in presentations; we ;; do not need them in navigating through the nested lists. ;; This speeds up this function significantly. (ignore-errors (save-excursion ;; Make sure we get the whole thing at point. (if (not (slime-inside-string-p)) (slime-end-of-symbol) (slime-beginning-of-string) (forward-sexp)) (save-restriction ;; Don't parse more than 20000 characters before point, so we don't spend ;; too much time. (narrow-to-region (max (point-min) (- (point) 20000)) (point-max)) (narrow-to-region (save-excursion (beginning-of-defun) (point)) (min (1+ (point)) (point-max))) (while (or (not max-levels) (<= level max-levels)) (let ((arg-index 0)) ;; Move to the beginning of the current sexp if not already there. (if (or (and (char-after) (member (char-syntax (char-after)) '(?\( ?'))) (member (char-syntax (char-before)) '(?\ ?>))) (cl-incf arg-index)) (ignore-errors (backward-sexp 1)) (while (and (< arg-index 64) (ignore-errors (backward-sexp 1) (> (point) (point-min)))) (cl-incf arg-index)) (backward-up-list 1) (when (member (char-syntax (char-after)) '(?\( ?')) (cl-incf level) (forward-char 1) (let ((name (slime-symbol-at-point))) (push (and name `(,name)) result) (push arg-index arg-indices) (push (point) points)) (backward-up-list 1))))))) (cl-values (nreverse result) (nreverse arg-indices) (nreverse points)))) (defvar slime-variable-binding-ops-alist '((let &bindings &body) (let* &bindings &body))) (defvar slime-function-binding-ops-alist '((flet &bindings &body) (labels &bindings &body) (macrolet &bindings &body))) (defun slime-lookup-binding-op (op &optional binding-type) (cl-labels ((lookup-in (list) (cl-assoc op list :test 'cl-equalp :key 'symbol-name))) (cond ((eq binding-type :variable) (lookup-in slime-variable-binding-ops-alist)) ((eq binding-type :function) (lookup-in slime-function-binding-ops-alist)) (t (or (lookup-in slime-variable-binding-ops-alist) (lookup-in slime-function-binding-ops-alist)))))) (defun slime-binding-op-p (op &optional binding-type) (and (slime-lookup-binding-op op binding-type) t)) (defun slime-binding-op-body-pos (op) (let ((special-lambda-list (slime-lookup-binding-op op))) (if special-lambda-list (cl-position '&body special-lambda-list)))) (defun slime-binding-op-bindings-pos (op) (let ((special-lambda-list (slime-lookup-binding-op op))) (if special-lambda-list (cl-position '&bindings special-lambda-list)))) (defun slime-enclosing-bound-names () "Returns all bound function names as first value, and the points where their bindings are established as second value." (cl-multiple-value-call #'slime-find-bound-names (slime-enclosing-form-specs))) (defun slime-find-bound-names (ops indices points) (let ((binding-names) (binding-start-points)) (save-excursion (cl-loop for (op . nil) in ops for index in indices for point in points do (when (and (slime-binding-op-p op) ;; Are the bindings of OP in scope? (>= index (slime-binding-op-body-pos op))) (goto-char point) (forward-sexp (slime-binding-op-bindings-pos op)) (down-list) (ignore-errors (cl-loop (down-list) (push (slime-symbol-at-point) binding-names) (push (save-excursion (backward-up-list) (point)) binding-start-points) (up-list))))) (cl-values (nreverse binding-names) (nreverse binding-start-points))))) (defun slime-enclosing-bound-functions () (cl-multiple-value-call #'slime-find-bound-functions (slime-enclosing-form-specs))) (defun slime-find-bound-functions (ops indices points) (let ((names) (arglists) (start-points)) (save-excursion (cl-loop for (op . nil) in ops for index in indices for point in points do (when (and (slime-binding-op-p op :function) ;; Are the bindings of OP in scope? (>= index (slime-binding-op-body-pos op))) (goto-char point) (forward-sexp (slime-binding-op-bindings-pos op)) (down-list) ;; If we're at the end of the bindings, an error will ;; be signalled by the `down-list' below. (ignore-errors (cl-loop (down-list) (cl-destructuring-bind (name arglist) (slime-parse-sexp-at-point 2) (cl-assert (slime-has-symbol-syntax-p name)) (cl-assert arglist) (push name names) (push arglist arglists) (push (save-excursion (backward-up-list) (point)) start-points)) (up-list))))) (cl-values (nreverse names) (nreverse arglists) (nreverse start-points))))) (defun slime-enclosing-bound-macros () (cl-multiple-value-call #'slime-find-bound-macros (slime-enclosing-form-specs))) (defun slime-find-bound-macros (ops indices points) ;; Kludgy! (let ((slime-function-binding-ops-alist '((macrolet &bindings &body)))) (slime-find-bound-functions ops indices points))) (provide 'slime-enclosing-context) slime-2.20/contrib/slime-fancy-inspector.el000066400000000000000000000030601315100173500207360ustar00rootroot00000000000000(eval-and-compile (require 'slime)) (define-slime-contrib slime-fancy-inspector "Fancy inspector for CLOS objects." (:authors "Marco Baringer and others") (:license "GPL") (:slime-dependencies slime-parse) (:swank-dependencies swank-fancy-inspector) (:on-load (add-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part)) (:on-unload (remove-hook 'slime-edit-definition-hooks 'slime-edit-inspector-part))) (defun slime-inspect-definition () "Inspect definition at point" (interactive) (slime-inspect (slime-definition-at-point))) (defun slime-disassemble-definition () "Disassemble definition at point" (interactive) (slime-eval-describe `(swank:disassemble-form ,(slime-definition-at-point t)))) (defun slime-edit-inspector-part (name &optional where) (and (eq major-mode 'slime-inspector-mode) (cl-destructuring-bind (&optional property value) (slime-inspector-property-at-point) (when (eq property 'slime-part-number) (let ((location (slime-eval `(swank:find-definition-for-thing (swank:inspector-nth-part ,value)))) (name (format "Inspector part %s" value))) (when (and (consp location) (not (eq (car location) :error))) (slime-edit-definition-cont (list (make-slime-xref :dspec `(,name) :location location)) name where))))))) (provide 'slime-fancy-inspector) slime-2.20/contrib/slime-fancy-trace.el000066400000000000000000000057521315100173500200400ustar00rootroot00000000000000(eval-and-compile (require 'slime)) (define-slime-contrib slime-fancy-trace "Enhanced version of slime-trace capable of tracing local functions, methods, setf functions, and other entities supported by specific swank:swank-toggle-trace backends. Invoke via C-u C-t." (:authors "Matthias Koeppe " "Tobias C. Rittweiler ") (:license "GPL") (:slime-dependencies slime-parse)) (defun slime-trace-query (spec) "Ask the user which function to trace; SPEC is the default. The result is a string." (cond ((null spec) (slime-read-from-minibuffer "(Un)trace: ")) ((stringp spec) (slime-read-from-minibuffer "(Un)trace: " spec)) ((symbolp spec) ; `slime-extract-context' can return symbols. (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) (t (slime-dcase spec ((setf n) (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) ((:defun n) (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string n))) ((:defgeneric n) (let* ((name (prin1-to-string n)) (answer (slime-read-from-minibuffer "(Un)trace: " name))) (cond ((and (string= name answer) (y-or-n-p (concat "(Un)trace also all " "methods implementing " name "? "))) (prin1-to-string `(:defgeneric ,n))) (t answer)))) ((:defmethod &rest _) (slime-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) ((:call caller callee) (let* ((callerstr (prin1-to-string caller)) (calleestr (prin1-to-string callee)) (answer (slime-read-from-minibuffer "(Un)trace: " calleestr))) (cond ((and (string= calleestr answer) (y-or-n-p (concat "(Un)trace only when " calleestr " is called by " callerstr "? "))) (prin1-to-string `(:call ,caller ,callee))) (t answer)))) (((:labels :flet) &rest _) (slime-read-from-minibuffer "(Un)trace local function: " (prin1-to-string spec))) (t (error "Don't know how to trace the spec %S" spec)))))) (defun slime-toggle-fancy-trace (&optional using-context-p) "Toggle trace." (interactive "P") (let* ((spec (if using-context-p (slime-extract-context) (slime-symbol-at-point))) (spec (slime-trace-query spec))) (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec))))) ;; override slime-toggle-trace-fdefinition (define-key slime-prefix-map "\C-t" 'slime-toggle-fancy-trace) (provide 'slime-fancy-trace) slime-2.20/contrib/slime-fancy.el000066400000000000000000000022541315100173500167360ustar00rootroot00000000000000(require 'slime) (define-slime-contrib slime-fancy "Make SLIME fancy." (:authors "Matthias Koeppe " "Tobias C Rittweiler ") (:license "GPL") (:slime-dependencies slime-repl slime-autodoc slime-c-p-c slime-editing-commands slime-fancy-inspector slime-fancy-trace slime-fuzzy slime-mdot-fu slime-macrostep slime-presentations slime-scratch slime-references slime-package-fu slime-fontifying-fu slime-trace-dialog) (:on-load (slime-trace-dialog-init) (slime-repl-init) (slime-autodoc-init) (slime-c-p-c-init) (slime-editing-commands-init) (slime-fancy-inspector-init) (slime-fancy-trace-init) (slime-fuzzy-init) (slime-presentations-init) (slime-scratch-init) (slime-references-init) (slime-package-fu-init) (slime-fontifying-fu-init))) (provide 'slime-fancy) slime-2.20/contrib/slime-fontifying-fu.el000066400000000000000000000225341315100173500204250ustar00rootroot00000000000000(require 'slime) (require 'slime-parse) (require 'slime-autodoc) (require 'font-lock) (require 'cl-lib) ;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros. ;;; Fontify CHECK-FOO like CHECK-TYPE. (defvar slime-additional-font-lock-keywords '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face) ("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face))) ;;;; Specially fontify forms suppressed by a reader conditional. (defcustom slime-highlight-suppressed-forms t "Display forms disabled by reader conditionals as comments." :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) :group 'slime-mode) (define-slime-contrib slime-fontifying-fu "Additional fontification tweaks: Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros. Fontify CHECK-FOO like CHECK-TYPE." (:authors "Tobias C. Rittweiler ") (:license "GPL") (:on-load (font-lock-add-keywords 'lisp-mode slime-additional-font-lock-keywords) (when slime-highlight-suppressed-forms (slime-activate-font-lock-magic))) (:on-unload ;; FIXME: remove `slime-search-suppressed-forms', and remove the ;; extend-region hook. (font-lock-remove-keywords 'lisp-mode slime-additional-font-lock-keywords))) (defface slime-reader-conditional-face '((t (:inherit font-lock-comment-face))) "Face for compiler notes while selected." :group 'slime-mode-faces) (defvar slime-search-suppressed-forms-match-data (list nil nil)) (defun slime-search-suppressed-forms-internal (limit) (when (search-forward-regexp slime-reader-conditionals-regexp limit t) (let ((start (match-beginning 0)) ; save match data (state (slime-current-parser-state))) (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? (slime-search-suppressed-forms-internal limit) (let* ((char (char-before)) (expr (read (current-buffer))) (val (slime-eval-feature-expression expr))) (when (<= (point) limit) (if (or (and (eq char ?+) (not val)) (and (eq char ?-) val)) ;; If `slime-extend-region-for-font-lock' did not ;; fully extend the region, the assertion below may ;; fail. This should only happen on XEmacs and older ;; versions of GNU Emacs. (ignore-errors (forward-sexp) (backward-sexp) ;; Try to suppress as far as possible. (slime-forward-sexp) (cl-assert (<= (point) limit)) (let ((md (match-data nil slime-search-suppressed-forms-match-data))) (setf (cl-first md) start) (setf (cl-second md) (point)) (set-match-data md) t)) (slime-search-suppressed-forms-internal limit)))))))) (defun slime-search-suppressed-forms (limit) "Find reader conditionalized forms where the test is false." (when (and slime-highlight-suppressed-forms (slime-connected-p)) (let ((result 'retry)) (while (and (eq result 'retry) (<= (point) limit)) (condition-case condition (setq result (slime-search-suppressed-forms-internal limit)) (end-of-file ; e.g. #+( (setq result nil)) ;; We found a reader conditional we couldn't process for ;; some reason; however, there may still be other reader ;; conditionals before `limit'. (invalid-read-syntax ; e.g. #+#.foo (setq result 'retry)) (scan-error ; e.g. #+nil (foo ... (setq result 'retry)) (slime-incorrect-feature-expression ; e.g. #+(not foo bar) (setq result 'retry)) (slime-unknown-feature-expression ; e.g. #+(foo) (setq result 'retry)) (error (setq result nil) (slime-display-warning (concat "Caught error during fontification while searching for forms\n" "that are suppressed by reader-conditionals. The error was: %S.") condition)))) result))) (defun slime-search-directly-preceding-reader-conditional () "Search for a directly preceding reader conditional. Return its position, or nil." ;;; We search for a preceding reader conditional. Then we check that ;;; between the reader conditional and the point where we started is ;;; no other intervening sexp, and we check that the reader ;;; conditional is at the same nesting level. (condition-case nil (let* ((orig-pt (point)) (reader-conditional-pt (search-backward-regexp slime-reader-conditionals-regexp ;; We restrict the search to the ;; beginning of the /previous/ defun. (save-excursion (beginning-of-defun) (point)) t))) (when reader-conditional-pt (let* ((parser-state (parse-partial-sexp (progn (goto-char (+ reader-conditional-pt 2)) (forward-sexp) ; skip feature expr. (point)) orig-pt)) (paren-depth (car parser-state)) (last-sexp-pt (cl-caddr parser-state))) (if (and paren-depth (not (cl-plusp paren-depth)) ; no '(' in between? (not last-sexp-pt)) ; no complete sexp in between? reader-conditional-pt nil)))) (scan-error nil))) ; improper feature expression ;;; We'll push this onto `font-lock-extend-region-functions'. In past, ;;; we didn't do so which made our reader-conditional font-lock magic ;;; pretty unreliable (it wouldn't highlight all suppressed forms, and ;;; worked quite non-deterministic in general.) ;;; ;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs. ;;; ;;; We make sure that `font-lock-beg' and `font-lock-end' always point ;;; to the beginning or end of a toplevel form. So we never miss a ;;; reader-conditional, or point in mid of one. (defvar font-lock-beg) ; shoosh compiler (defvar font-lock-end) (defun slime-extend-region-for-font-lock () (when slime-highlight-suppressed-forms (condition-case c (let (changedp) (cl-multiple-value-setq (changedp font-lock-beg font-lock-end) (slime-compute-region-for-font-lock font-lock-beg font-lock-end)) changedp) (error (slime-display-warning (concat "Caught error when trying to extend the region for fontification.\n" "The error was: %S\n" "Further: font-lock-beg=%d, font-lock-end=%d.") c font-lock-beg font-lock-end))))) (defun slime-beginning-of-tlf () (let ((pos (syntax-ppss-toplevel-pos (slime-current-parser-state)))) (if pos (goto-char pos)))) (defun slime-compute-region-for-font-lock (orig-beg orig-end) (let ((beg orig-beg) (end orig-end)) (goto-char beg) (inline (slime-beginning-of-tlf)) (cl-assert (not (cl-plusp (nth 0 (slime-current-parser-state))))) (setq beg (let ((pt (point))) (cond ((> (- beg pt) 20000) beg) ((slime-search-directly-preceding-reader-conditional)) (t pt)))) (goto-char end) (while (search-backward-regexp slime-reader-conditionals-regexp beg t) (setq end (max end (save-excursion (ignore-errors (slime-forward-reader-conditional)) (point))))) (cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end))) (defun slime-activate-font-lock-magic () (if (featurep 'xemacs) (let ((pattern `((slime-search-suppressed-forms (0 slime-reader-conditional-face t))))) (dolist (sym '(lisp-font-lock-keywords lisp-font-lock-keywords-1 lisp-font-lock-keywords-2)) (set sym (append (symbol-value sym) pattern)))) (font-lock-add-keywords 'lisp-mode `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t))) (add-hook 'lisp-mode-hook #'(lambda () (add-hook 'font-lock-extend-region-functions 'slime-extend-region-for-font-lock t t))))) (let ((byte-compile-warnings '())) (mapc (lambda (sym) (cond ((fboundp sym) (unless (byte-code-function-p (symbol-function sym)) (byte-compile sym))) (t (error "%S is not fbound" sym)))) '(slime-extend-region-for-font-lock slime-compute-region-for-font-lock slime-search-directly-preceding-reader-conditional slime-search-suppressed-forms slime-beginning-of-tlf))) (cl-defun slime-initialize-lisp-buffer-for-test-suite (&key (font-lock-magic t) (autodoc t)) (let ((hook lisp-mode-hook)) (unwind-protect (progn (set (make-local-variable 'slime-highlight-suppressed-forms) font-lock-magic) (setq lisp-mode-hook nil) (lisp-mode) (slime-mode 1) (when (boundp 'slime-autodoc-mode) (if autodoc (slime-autodoc-mode 1) (slime-autodoc-mode -1)))) (setq lisp-mode-hook hook)))) (provide 'slime-fontifying-fu) slime-2.20/contrib/slime-fuzzy.el000066400000000000000000000606371315100173500170360ustar00rootroot00000000000000(require 'slime) (require 'slime-repl) (require 'slime-c-p-c) (require 'cl-lib) (define-slime-contrib slime-fuzzy "Fuzzy symbol completion." (:authors "Brian Downing " "Tobias C. Rittweiler " "Attila Lendvai ") (:license "GPL") (:swank-dependencies swank-fuzzy) (:on-load (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol) (when (featurep 'slime-repl) (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)))) (defcustom slime-fuzzy-completion-in-place t "When non-NIL the fuzzy symbol completion is done in place as opposed to moving the point to the completion buffer." :group 'slime-mode :type 'boolean) (defcustom slime-fuzzy-completion-limit 300 "Only return and present this many symbols from swank." :group 'slime-mode :type 'integer) (defcustom slime-fuzzy-completion-time-limit-in-msec 1500 "Limit the time spent (given in msec) in swank while gathering comletitions." :group 'slime-mode :type 'integer) (defcustom slime-when-complete-filename-expand nil "Use comint-replace-by-expanded-filename instead of comint-filename-completion to complete file names" :group 'slime-mode :type 'boolean) (defvar slime-fuzzy-target-buffer nil "The buffer that is the target of the completion activities.") (defvar slime-fuzzy-saved-window-configuration nil "The saved window configuration before the fuzzy completion buffer popped up.") (defvar slime-fuzzy-start nil "The beginning of the completion slot in the target buffer. This is a non-advancing marker.") (defvar slime-fuzzy-end nil "The end of the completion slot in the target buffer. This is an advancing marker.") (defvar slime-fuzzy-original-text nil "The original text that was in the completion slot in the target buffer. This is what is put back if completion is aborted.") (defvar slime-fuzzy-text nil "The text that is currently in the completion slot in the target buffer. If this ever doesn't match, the target buffer has been modified and we abort without touching it.") (defvar slime-fuzzy-first nil "The position of the first completion in the completions buffer. The descriptive text and headers are above this.") (defvar slime-fuzzy-last nil "The position of the last completion in the completions buffer. If the time limit has exhausted during generation possible completion choices inside SWANK, an indication is printed below this.") (defvar slime-fuzzy-current-completion nil "The current completion object. If this is the same before and after point moves in the completions buffer, the text is not replaced in the target for efficiency.") (defvar slime-fuzzy-current-completion-overlay nil "The overlay representing the current completion in the completion buffer. This is used to hightlight the text.") ;;;;;;; slime-target-buffer-fuzzy-completions-mode ;; NOTE: this mode has to be able to override key mappings in slime-mode (defvar slime-target-buffer-fuzzy-completions-map (let ((map (make-sparse-keymap))) (cl-labels ((def (keys command) (unless (listp keys) (setq keys (list keys))) (dolist (key keys) (define-key map key command)))) (def `([remap keyboard-quit] ,(kbd "C-g")) 'slime-fuzzy-abort) (def `([remap slime-fuzzy-indent-and-complete-symbol] [remap slime-indent-and-complete-symbol] ,(kbd "")) 'slime-fuzzy-select-or-update-completions) (def `([remap previous-line] ,(kbd "")) 'slime-fuzzy-prev) (def `([remap next-line] ,(kbd "")) 'slime-fuzzy-next) (def `([remap isearch-forward] ,(kbd "C-s")) 'slime-fuzzy-continue-isearch-in-fuzzy-buffer) ;; some unconditional direct bindings (def (list (kbd "") (kbd "RET") (kbd "") "(" ")" "[" "]") 'slime-fuzzy-select-and-process-event-in-target-buffer)) map) "Keymap for slime-target-buffer-fuzzy-completions-mode. This will override the key bindings in the target buffer temporarily during completion.") ;; Make sure slime-fuzzy-target-buffer-completions-mode's map is ;; before everything else. (setf minor-mode-map-alist (cl-stable-sort minor-mode-map-alist (lambda (a b) (eq a 'slime-fuzzy-target-buffer-completions-mode)) :key #'car)) (defun slime-fuzzy-continue-isearch-in-fuzzy-buffer () (interactive) (select-window (get-buffer-window (slime-get-fuzzy-buffer))) (call-interactively 'isearch-forward)) (define-minor-mode slime-fuzzy-target-buffer-completions-mode "This minor mode is intented to override key bindings during fuzzy completions in the target buffer. Most of the bindings will do an implicit select in the completion window and let the keypress be processed in the target buffer." nil nil slime-target-buffer-fuzzy-completions-map) (add-to-list 'minor-mode-alist '(slime-fuzzy-target-buffer-completions-mode " Fuzzy Target Buffer Completions")) (defvar slime-fuzzy-completions-map (let ((map (make-sparse-keymap))) (cl-labels ((def (keys command) (unless (listp keys) (setq keys (list keys))) (dolist (key keys) (define-key map key command)))) (def `([remap keyboard-quit] "q" ,(kbd "C-g")) 'slime-fuzzy-abort) (def `([remap previous-line] "p" "\M-p" ,(kbd "")) 'slime-fuzzy-prev) (def `([remap next-line] "n" "\M-n" ,(kbd "")) 'slime-fuzzy-next) (def "\d" 'scroll-down) (def `([remap slime-fuzzy-indent-and-complete-symbol] [remap slime-indent-and-complete-symbol] ,(kbd "")) 'slime-fuzzy-select) (def (kbd "") 'slime-fuzzy-select/mouse) (def `(,(kbd "RET") ,(kbd "")) 'slime-fuzzy-select)) map) "Keymap for slime-fuzzy-completions-mode when in the completion buffer.") (define-derived-mode slime-fuzzy-completions-mode fundamental-mode "Fuzzy Completions" "Major mode for presenting fuzzy completion results. When you run `slime-fuzzy-complete-symbol', the symbol token at point is completed using the Fuzzy Completion algorithm; this means that the token is taken as a sequence of characters and all the various possibilities that this sequence could meaningfully represent are offered as selectable choices, sorted by how well they deem to be a match for the token. (For instance, the first choice of completing on \"mvb\" would be \"multiple-value-bind\".) Therefore, a new buffer (*Fuzzy Completions*) will pop up that contains the different completion choices. Simultaneously, a special minor-mode will be temporarily enabled in the original buffer where you initiated fuzzy completion (also called the ``target buffer'') in order to navigate through the *Fuzzy Completions* buffer without leaving. With focus in *Fuzzy Completions*: Type `n' and `p' (`UP', `DOWN') to navigate between completions. Type `RET' or `TAB' to select the completion near point. Type `q' to abort. With focus in the target buffer: Type `UP' and `DOWN' to navigate between completions. Type a character that does not constitute a symbol name to insert the current choice and then that character (`(', `)', `SPACE', `RET'.) Use `TAB' to simply insert the current choice. Use C-g to abort. Alternatively, you can click on a completion to select it. Complete listing of keybindings within the target buffer: \\\ \\{slime-target-buffer-fuzzy-completions-map} Complete listing of keybindings with *Fuzzy Completions*: \\\ \\{slime-fuzzy-completions-map}" (use-local-map slime-fuzzy-completions-map) (set (make-local-variable 'slime-fuzzy-current-completion-overlay) (make-overlay (point) (point) nil t nil))) (defun slime-fuzzy-completions (prefix &optional default-package) "Get the list of sorted completion objects from completing `prefix' in `package' from the connected Lisp." (let ((prefix (cl-etypecase prefix (symbol (symbol-name prefix)) (string prefix)))) (slime-eval `(swank:fuzzy-completions ,prefix ,(or default-package (slime-current-package)) :limit ,slime-fuzzy-completion-limit :time-limit-in-msec ,slime-fuzzy-completion-time-limit-in-msec)))) (defun slime-fuzzy-selected (prefix completion) "Tell the connected Lisp that the user selected completion `completion' as the completion for `prefix'." (let ((no-properties (copy-sequence prefix))) (set-text-properties 0 (length no-properties) nil no-properties) (slime-eval `(swank:fuzzy-completion-selected ,no-properties ',completion)))) (defun slime-fuzzy-indent-and-complete-symbol () "Indent the current line and perform fuzzy symbol completion. First indent the line. If indenting doesn't move point, complete the symbol. If there's no symbol at the point, show the arglist for the most recently enclosed macro or function." (interactive) (let ((pos (point))) (unless (get-text-property (line-beginning-position) 'slime-repl-prompt) (lisp-indent-line)) (when (= pos (point)) (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) (slime-fuzzy-complete-symbol)) ((memq (char-before) '(?\t ?\ )) (slime-echo-arglist)))))) (cl-defun slime-fuzzy-complete-symbol () "Fuzzily completes the abbreviation at point into a symbol." (interactive) (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t)) (cl-return-from slime-fuzzy-complete-symbol ;; don't add space after completion (let ((comint-completion-addsuffix '("/" . ""))) (if slime-when-complete-filename-expand (comint-replace-by-expanded-filename) ;; FIXME: use `comint-filename-completion' when dropping emacs23 (funcall (if (>= emacs-major-version 24) 'comint-filename-completion 'comint-dynamic-complete-as-filename)))))) (let* ((end (move-marker (make-marker) (slime-symbol-end-pos))) (beg (move-marker (make-marker) (slime-symbol-start-pos))) (prefix (buffer-substring-no-properties beg end))) (cl-destructuring-bind (completion-set interrupted-p) (slime-fuzzy-completions prefix) (if (null completion-set) (progn (slime-minibuffer-respecting-message "Can't find completion for \"%s\"" prefix) (ding) (slime-fuzzy-done)) (goto-char end) (cond ((slime-length= completion-set 1) ;; insert completed string (insert-and-inherit (caar completion-set)) (delete-region beg end) (goto-char (+ beg (length (caar completion-set)))) (slime-minibuffer-respecting-message "Sole completion") (slime-fuzzy-done)) ;; Incomplete (t (slime-fuzzy-choices-buffer completion-set interrupted-p beg end) (slime-minibuffer-respecting-message "Complete but not unique"))))))) (defun slime-get-fuzzy-buffer () (get-buffer-create "*Fuzzy Completions*")) (defvar slime-fuzzy-explanation "For help on how the use this buffer, see `slime-fuzzy-completions-mode'. Flags: boundp fboundp generic-function class macro special-operator package \n" "The explanation that gets inserted at the beginning of the *Fuzzy Completions* buffer.") (defun slime-fuzzy-insert-completion-choice (completion max-length) "Inserts the completion object `completion' as a formatted completion choice into the current buffer, and mark it with the proper text properties." (cl-destructuring-bind (symbol-name score chunks classification-string) completion (let ((start (point)) (end)) (insert symbol-name) (setq end (point)) (dolist (chunk chunks) (put-text-property (+ start (cl-first chunk)) (+ start (cl-first chunk) (length (cl-second chunk))) 'face 'bold)) (put-text-property start (point) 'mouse-face 'highlight) (dotimes (i (- max-length (- end start))) (insert " ")) (insert (format " %s %s\n" classification-string score)) (put-text-property start (point) 'completion completion)))) (defun slime-fuzzy-insert (text) "Inserts `text' into the target buffer in the completion slot. If the buffer has been modified in the meantime, abort the completion process. Otherwise, update all completion variables so that the new text is present." (with-current-buffer slime-fuzzy-target-buffer (cond ((not (string-equal slime-fuzzy-text (buffer-substring slime-fuzzy-start slime-fuzzy-end))) (slime-fuzzy-done) (beep) (message "Target buffer has been modified!")) (t (goto-char slime-fuzzy-start) (delete-region slime-fuzzy-start slime-fuzzy-end) (insert-and-inherit text) (setq slime-fuzzy-text text) (goto-char slime-fuzzy-end))))) (defun slime-minibuffer-p (buffer) (if (featurep 'xemacs) (eq buffer (window-buffer (minibuffer-window))) (minibufferp buffer))) (defun slime-fuzzy-choices-buffer (completions interrupted-p start end) "Creates (if neccessary), populates, and pops up the *Fuzzy Completions* buffer with the completions from `completions' and the completion slot in the current buffer bounded by `start' and `end'. This saves the window configuration before popping the buffer so that it can possibly be restored when the user is done." (let ((new-completion-buffer (not slime-fuzzy-target-buffer)) (connection (slime-connection))) (when new-completion-buffer (setq slime-fuzzy-saved-window-configuration (current-window-configuration))) (slime-fuzzy-enable-target-buffer-completions-mode) (setq slime-fuzzy-target-buffer (current-buffer)) (setq slime-fuzzy-start (move-marker (make-marker) start)) (setq slime-fuzzy-end (move-marker (make-marker) end)) (set-marker-insertion-type slime-fuzzy-end t) (setq slime-fuzzy-original-text (buffer-substring start end)) (setq slime-fuzzy-text slime-fuzzy-original-text) (slime-fuzzy-fill-completions-buffer completions interrupted-p) (pop-to-buffer (slime-get-fuzzy-buffer)) (slime-fuzzy-next) (setq slime-buffer-connection connection) (when new-completion-buffer ;; Hook to nullify window-config restoration if the user changes ;; the window configuration himself. (when (boundp 'window-configuration-change-hook) (add-hook 'window-configuration-change-hook 'slime-fuzzy-window-configuration-change)) (add-hook 'kill-buffer-hook 'slime-fuzzy-abort 'append t) (set (make-local-variable 'cursor-type) nil) (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc (when slime-fuzzy-completion-in-place ;; switch back to the original buffer (if (slime-minibuffer-p slime-fuzzy-target-buffer) (select-window (minibuffer-window)) (switch-to-buffer-other-window slime-fuzzy-target-buffer))))) (defun slime-fuzzy-fill-completions-buffer (completions interrupted-p) "Erases and fills the completion buffer with the given completions." (with-current-buffer (slime-get-fuzzy-buffer) (setq buffer-read-only nil) (erase-buffer) (slime-fuzzy-completions-mode) (insert slime-fuzzy-explanation) (let ((max-length 12)) (dolist (completion completions) (setf max-length (max max-length (length (cl-first completion))))) (insert "Completion:") (dotimes (i (- max-length 10)) (insert " ")) ;; Flags: Score: ;; ... ------- -------- ;; bfgctmsp (let* ((example-classification-string (cl-fourth (cl-first completions))) (classification-length (length example-classification-string)) (spaces (- classification-length (length "Flags:")))) (insert "Flags:") (dotimes (i spaces) (insert " ")) (insert " Score:\n") (dotimes (i max-length) (insert "-")) (insert " ") (dotimes (i classification-length) (insert "-")) (insert " --------\n") (setq slime-fuzzy-first (point))) (dolist (completion completions) (setq slime-fuzzy-last (point)) ; will eventually become the last entry (slime-fuzzy-insert-completion-choice completion max-length)) (when interrupted-p (insert "...\n") (insert "[Interrupted: time limit exhausted]")) (setq buffer-read-only t)) (setq slime-fuzzy-current-completion (caar completions)) (goto-char 0))) (defun slime-fuzzy-enable-target-buffer-completions-mode () "Store the target buffer's local map, so that we can restore it." (unless slime-fuzzy-target-buffer-completions-mode ; (slime-log-event "Enabling target buffer completions mode") (slime-fuzzy-target-buffer-completions-mode 1))) (defun slime-fuzzy-disable-target-buffer-completions-mode () "Restores the target buffer's local map when completion is finished." (when slime-fuzzy-target-buffer-completions-mode ; (slime-log-event "Disabling target buffer completions mode") (slime-fuzzy-target-buffer-completions-mode 0))) (defun slime-fuzzy-insert-from-point () "Inserts the completion that is under point in the completions buffer into the target buffer. If the completion in question had already been inserted, it does nothing." (with-current-buffer (slime-get-fuzzy-buffer) (let ((current-completion (get-text-property (point) 'completion))) (when (and current-completion (not (eq slime-fuzzy-current-completion current-completion))) (slime-fuzzy-insert (cl-first (get-text-property (point) 'completion))) (setq slime-fuzzy-current-completion current-completion))))) (defun slime-fuzzy-post-command-hook () "The post-command-hook for the *Fuzzy Completions* buffer. This makes sure the completion slot in the target buffer matches the completion that point is on in the completions buffer." (condition-case err (when slime-fuzzy-target-buffer (slime-fuzzy-insert-from-point)) (error ;; Because this is called on the post-command-hook, we mustn't let ;; errors propagate. (message "Error in slime-fuzzy-post-command-hook: %S" err)))) (defun slime-fuzzy-next () "Moves point directly to the next completion in the completions buffer." (interactive) (with-current-buffer (slime-get-fuzzy-buffer) (let ((point (next-single-char-property-change (point) 'completion nil slime-fuzzy-last))) (set-window-point (get-buffer-window (current-buffer)) point) (goto-char point)) (slime-fuzzy-highlight-current-completion))) (defun slime-fuzzy-prev () "Moves point directly to the previous completion in the completions buffer." (interactive) (with-current-buffer (slime-get-fuzzy-buffer) (let ((point (previous-single-char-property-change (point) 'completion nil slime-fuzzy-first))) (set-window-point (get-buffer-window (current-buffer)) point) (goto-char point)) (slime-fuzzy-highlight-current-completion))) (defun slime-fuzzy-highlight-current-completion () "Highlights the current completion, so that the user can see it on the screen." (let ((pos (point))) (when (overlayp slime-fuzzy-current-completion-overlay) (move-overlay slime-fuzzy-current-completion-overlay (point) (1- (search-forward " "))) (overlay-put slime-fuzzy-current-completion-overlay 'face 'secondary-selection)) (goto-char pos))) (defun slime-fuzzy-abort () "Aborts the completion process, setting the completions slot in the target buffer back to its original contents." (interactive) (when slime-fuzzy-target-buffer (slime-fuzzy-done))) (defun slime-fuzzy-select () "Selects the current completion, making sure that it is inserted into the target buffer. This tells the connected Lisp what completion was selected." (interactive) (when slime-fuzzy-target-buffer (with-current-buffer (slime-get-fuzzy-buffer) (let ((completion (get-text-property (point) 'completion))) (when completion (slime-fuzzy-insert (cl-first completion)) (slime-fuzzy-selected slime-fuzzy-original-text completion) (slime-fuzzy-done)))))) (defun slime-fuzzy-select-or-update-completions () "If there were no changes since the last time fuzzy completion was started this function will select the current completion. Otherwise refreshes the completion list based on the changes made." (interactive) ; (slime-log-event "Selecting or updating completions") (if (string-equal slime-fuzzy-original-text (buffer-substring slime-fuzzy-start slime-fuzzy-end)) (slime-fuzzy-select) (slime-fuzzy-complete-symbol))) (defun slime-fuzzy-process-event-in-completions-buffer () "Simply processes the event in the target buffer" (interactive) (with-current-buffer (slime-get-fuzzy-buffer) (push last-input-event unread-command-events))) (defun slime-fuzzy-select-and-process-event-in-target-buffer () "Selects the current completion, making sure that it is inserted into the target buffer and processes the event in the target buffer." (interactive) ; (slime-log-event "Selecting and processing event in target buffer") (when slime-fuzzy-target-buffer (let ((buff slime-fuzzy-target-buffer)) (slime-fuzzy-select) (with-current-buffer buff (slime-fuzzy-disable-target-buffer-completions-mode) (push last-input-event unread-command-events))))) (defun slime-fuzzy-select/mouse (event) "Handle a mouse-2 click on a completion choice as if point were on the completion choice and the slime-fuzzy-select command was run." (interactive "e") (with-current-buffer (window-buffer (posn-window (event-end event))) (save-excursion (goto-char (posn-point (event-end event))) (when (get-text-property (point) 'mouse-face) (slime-fuzzy-insert-from-point) (slime-fuzzy-select))))) (defun slime-fuzzy-done () "Cleans up after the completion process. This removes all hooks, and attempts to restore the window configuration. If this fails, it just burys the completions buffer and leaves the window configuration alone." (when slime-fuzzy-target-buffer (set-buffer slime-fuzzy-target-buffer) (slime-fuzzy-disable-target-buffer-completions-mode) (if (slime-fuzzy-maybe-restore-window-configuration) (bury-buffer (slime-get-fuzzy-buffer)) ;; We couldn't restore the windows, so just bury the fuzzy ;; completions buffer and let something else fill it in. (pop-to-buffer (slime-get-fuzzy-buffer)) (bury-buffer)) (if (slime-minibuffer-p slime-fuzzy-target-buffer) (select-window (minibuffer-window)) (pop-to-buffer slime-fuzzy-target-buffer)) (goto-char slime-fuzzy-end) (setq slime-fuzzy-target-buffer nil) (remove-hook 'window-configuration-change-hook 'slime-fuzzy-window-configuration-change))) (defun slime-fuzzy-maybe-restore-window-configuration () "Restores the saved window configuration if it has not been nullified." (when (boundp 'window-configuration-change-hook) (remove-hook 'window-configuration-change-hook 'slime-fuzzy-window-configuration-change)) (if (not slime-fuzzy-saved-window-configuration) nil (set-window-configuration slime-fuzzy-saved-window-configuration) (setq slime-fuzzy-saved-window-configuration nil) t)) (defun slime-fuzzy-window-configuration-change () "Called on window-configuration-change-hook. Since the window configuration was changed, we nullify our saved configuration." (setq slime-fuzzy-saved-window-configuration nil)) (provide 'slime-fuzzy) slime-2.20/contrib/slime-highlight-edits.el000066400000000000000000000053661315100173500207220ustar00rootroot00000000000000(require 'slime) (require 'slime-parse) (define-slime-contrib slime-highlight-edits "Highlight edited, i.e. not yet compiled, code." (:authors "William Bland ") (:license "GPL") (:on-load (add-hook 'slime-mode-hook 'slime-activate-highlight-edits)) (:on-unload (remove-hook 'slime-mode-hook 'slime-activate-highlight-edits))) (defun slime-activate-highlight-edits () (slime-highlight-edits-mode 1)) (defface slime-highlight-edits-face `((((class color) (background light)) (:background "lightgray")) (((class color) (background dark)) (:background "dimgray")) (t (:background "yellow"))) "Face for displaying edit but not compiled code." :group 'slime-mode-faces) (define-minor-mode slime-highlight-edits-mode "Minor mode to highlight not-yet-compiled code." nil) (add-hook 'slime-highlight-edits-mode-on-hook 'slime-highlight-edits-init-buffer) (add-hook 'slime-highlight-edits-mode-off-hook 'slime-highlight-edits-reset-buffer) (defun slime-highlight-edits-init-buffer () (make-local-variable 'after-change-functions) (add-to-list 'after-change-functions 'slime-highlight-edits) (add-to-list 'slime-before-compile-functions 'slime-highlight-edits-compile-hook)) (defun slime-highlight-edits-reset-buffer () (setq after-change-functions (remove 'slime-highlight-edits after-change-functions)) (slime-remove-edits (point-min) (point-max))) ;; FIXME: what's the LEN arg for? (defun slime-highlight-edits (beg end &optional len) (save-match-data (when (and (slime-connected-p) (not (slime-inside-comment-p)) (not (slime-only-whitespace-p beg end))) (let ((overlay (make-overlay beg end))) (overlay-put overlay 'face 'slime-highlight-edits-face) (overlay-put overlay 'slime-edit t))))) (defun slime-remove-edits (start end) "Delete the existing Slime edit hilights in the current buffer." (save-excursion (goto-char start) (while (< (point) end) (dolist (o (overlays-at (point))) (when (overlay-get o 'slime-edit) (delete-overlay o))) (goto-char (next-overlay-change (point)))))) (defun slime-highlight-edits-compile-hook (start end) (when slime-highlight-edits-mode (let ((start (save-excursion (goto-char start) (skip-chars-backward " \t\n\r") (point))) (end (save-excursion (goto-char end) (skip-chars-forward " \t\n\r") (point)))) (slime-remove-edits start end)))) (defun slime-only-whitespace-p (beg end) "Contains the region from BEG to END only whitespace?" (save-excursion (goto-char beg) (skip-chars-forward " \n\t\r" end) (<= end (point)))) (provide 'slime-highlight-edits) slime-2.20/contrib/slime-hyperdoc.el000066400000000000000000000034121315100173500174500ustar00rootroot00000000000000(require 'slime) (require 'url-http) (require 'browse-url) (eval-when-compile (require 'cl)) ; lexical-let (defvar slime-old-documentation-lookup-function slime-documentation-lookup-function) (define-slime-contrib slime-hyperdoc "Extensible C-c C-d h." (:authors "Tobias C Rittweiler ") (:license "GPL") (:swank-dependencies swank-hyperdoc) (:on-load (setq slime-documentation-lookup-function 'slime-hyperdoc-lookup)) (:on-unload (setq slime-documentation-lookup-function slime-old-documentation-lookup-function))) ;;; TODO: `url-http-file-exists-p' is slow, make it optional behaviour. (defun slime-hyperdoc-lookup-rpc (symbol-name) (slime-eval-async `(swank:hyperdoc ,symbol-name) (lexical-let ((symbol-name symbol-name)) #'(lambda (result) (slime-log-event result) (cl-loop with foundp = nil for (doc-type . url) in result do (when (and url (stringp url) (let ((url-show-status nil)) (url-http-file-exists-p url))) (message "Visiting documentation for %s `%s'..." (substring (symbol-name doc-type) 1) symbol-name) (browse-url url) (setq foundp t)) finally (unless foundp (error "Could not find documentation for `%s'." symbol-name))))))) (defun slime-hyperdoc-lookup (symbol-name) (interactive (list (slime-read-symbol-name "Symbol: "))) (if (memq :hyperdoc (slime-lisp-features)) (slime-hyperdoc-lookup-rpc symbol-name) (slime-hyperspec-lookup symbol-name))) (provide 'slime-hyperdoc) slime-2.20/contrib/slime-indentation.el000066400000000000000000000020751315100173500201530ustar00rootroot00000000000000(require 'slime) (require 'slime-cl-indent) (require 'cl-lib) (define-slime-contrib slime-indentation "Contrib interfacing `slime-cl-indent' and SLIME." (:swank-dependencies swank-indentation) (:on-load (setq common-lisp-current-package-function 'slime-current-package))) (defun slime-update-system-indentation (symbol indent packages) (let ((list (gethash symbol common-lisp-system-indentation)) (ok nil)) (if (not list) (puthash symbol (list (cons indent packages)) common-lisp-system-indentation) (dolist (spec list) (cond ((equal (car spec) indent) (dolist (p packages) (unless (member p (cdr spec)) (push p (cdr spec)))) (setf ok t)) (t (setf (cdr spec) (cl-set-difference (cdr spec) packages :test 'equal))))) (unless ok (puthash symbol (cons (cons indent packages) list) common-lisp-system-indentation))))) (provide 'slime-indentation) slime-2.20/contrib/slime-listener-hooks.el000066400000000000000000000005441315100173500206040ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (define-slime-contrib slime-listener-hooks "Enable slime integration in an application'w event loop" (:authors "Alan Ruttenberg , R. Mattes ") (:license "GPL") (:slime-dependencies slime-repl) (:swank-dependencies swank-listener-hooks)) (provide 'slime-listener-hooks) slime-2.20/contrib/slime-macrostep.el000066400000000000000000000115321315100173500176320ustar00rootroot00000000000000;;; slime-macrostep.el -- fancy macro-expansion via macrostep.el ;; Authors: Luís Oliveira ;; Jon Oddie " "Jon Oddie ") (:license "GPL") (:swank-dependencies swank-macrostep) (:on-load (easy-menu-add-item slime-mode-map '(menu-bar SLIME Debugging) ["Macro stepper..." macrostep-expand (slime-connected-p)] "Create Trace Buffer") (add-hook 'slime-mode-hook #'macrostep-slime-mode-hook) (define-key slime-mode-map (kbd "C-c M-e") #'macrostep-expand) (eval-after-load 'slime-repl '(progn (add-hook 'slime-repl-mode-hook #'macrostep-slime-mode-hook) (define-key slime-repl-mode-map (kbd "C-c M-e") #'macrostep-expand))))) (defun macrostep-slime-mode-hook () (setq macrostep-sexp-at-point-function #'macrostep-slime-sexp-at-point) (setq macrostep-environment-at-point-function #'macrostep-slime-context) (setq macrostep-expand-1-function #'macrostep-slime-expand-1) (setq macrostep-print-function #'macrostep-slime-insert) (setq macrostep-macro-form-p-function #'macrostep-slime-macro-form-p)) (defun macrostep-slime-sexp-at-point (&rest _ignore) (slime-sexp-at-point)) (defun macrostep-slime-context () (let (defun-start defun-end) (save-excursion (while (condition-case nil (progn (backward-up-list) t) (scan-error nil))) (setq defun-start (point)) (setq defun-end (scan-sexps (point) 1))) (list (buffer-substring-no-properties defun-start (point)) (buffer-substring-no-properties (scan-sexps (point) 1) defun-end)))) (defun macrostep-slime-expand-1 (string context) (slime-dcase (slime-eval `(swank-macrostep:macrostep-expand-1 ,string ,macrostep-expand-compiler-macros ',context)) ((:error error-message) (error "%s" error-message)) ((:ok expansion positions) (list expansion positions)))) (defun macrostep-slime-insert (result _ignore) "Insert RESULT at point, indenting to match the current column." (cl-destructuring-bind (expansion positions) result (let ((start (point)) (column-offset (current-column))) (insert expansion) (macrostep-slime--propertize-macros start positions) (indent-rigidly start (point) column-offset)))) (defun macrostep-slime--propertize-macros (start-offset positions) "Put text properties on macro forms." (dolist (position positions) (cl-destructuring-bind (operator type start) position (let ((open-paren-position (+ start-offset start))) (put-text-property open-paren-position (1+ open-paren-position) 'macrostep-macro-start t) ;; this assumes that the operator starts right next to the ;; opening parenthesis. We could probably be more robust. (let ((op-start (1+ open-paren-position))) (put-text-property op-start (+ op-start (length operator)) 'font-lock-face (if (eq type :macro) 'macrostep-macro-face 'macrostep-compiler-macro-face))))))) (defun macrostep-slime-macro-form-p (string context) (slime-dcase (slime-eval `(swank-macrostep:macro-form-p ,string ,macrostep-expand-compiler-macros ',context)) ((:error error-message) (error "%s" error-message)) ((:ok result) result))) (provide 'slime-macrostep) slime-2.20/contrib/slime-mdot-fu.el000066400000000000000000000022471315100173500172130ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (define-slime-contrib slime-mdot-fu "Making M-. work on local functions." (:authors "Tobias C. Rittweiler ") (:license "GPL") (:slime-dependencies slime-enclosing-context) (:on-load (add-hook 'slime-edit-definition-hooks 'slime-edit-local-definition)) (:on-unload (remove-hook 'slime-edit-definition-hooks 'slime-edit-local-definition))) (defun slime-edit-local-definition (name &optional where) "Like `slime-edit-definition', but tries to find the definition in a local function binding near point." (interactive (list (slime-read-symbol-name "Name: "))) (cl-multiple-value-bind (binding-name point) (cl-multiple-value-call #'cl-some #'(lambda (binding-name point) (when (cl-equalp binding-name name) (cl-values binding-name point))) (slime-enclosing-bound-names)) (when (and binding-name point) (slime-edit-definition-cont `((,binding-name ,(make-slime-buffer-location (buffer-name (current-buffer)) point))) name where)))) (provide 'slime-mdot-fu) slime-2.20/contrib/slime-media.el000066400000000000000000000027711315100173500167210ustar00rootroot00000000000000(eval-and-compile (require 'slime)) (define-slime-contrib slime-media "Display things other than text in SLIME buffers" (:authors "Christophe Rhodes ") (:license "GPL") (:slime-dependencies slime-repl) (:swank-dependencies swank-media) (:on-load (add-hook 'slime-event-hooks 'slime-dispatch-media-event))) (defun slime-media-decode-image (image) (mapcar (lambda (image) (if (plist-get image :data) (plist-put image :data (base64-decode-string (plist-get image :data))) image)) image)) (defun slime-dispatch-media-event (event) (slime-dcase event ((:write-image image string) (let ((img (or (find-image (slime-media-decode-image image)) (create-image image)))) (slime-media-insert-image img string)) t) ((:popup-buffer bufname string mode) (slime-with-popup-buffer (bufname :connection t :package t) (when mode (funcall mode)) (princ string) (goto-char (point-min))) t) (t nil))) (defun slime-media-insert-image (image string &optional bol) (with-current-buffer (slime-output-buffer) (let ((marker (slime-output-target-marker :repl-result))) (goto-char marker) (slime-propertize-region `(face slime-repl-result-face rear-nonsticky (face)) (insert-image image string)) ;; Move the input-start marker after the REPL result. (set-marker marker (point))) (slime-repl-show-maximum-output))) (provide 'slime-media) slime-2.20/contrib/slime-mrepl.el000066400000000000000000000121111315100173500167460ustar00rootroot00000000000000;; An experimental implementation of multiple REPLs multiplexed over a ;; single Slime socket. M-x slime-new-mrepl creates a new REPL buffer. ;; (require 'slime) (require 'inferior-slime) ; inferior-slime-indent-lime (require 'cl-lib) (define-slime-contrib slime-mrepl "Multiple REPLs." (:authors "Helmut Eller ") (:license "GPL") (:swank-dependencies swank-mrepl)) (require 'comint) (defvar slime-mrepl-remote-channel nil) (defvar slime-mrepl-expect-sexp nil) (define-derived-mode slime-mrepl-mode comint-mode "mrepl" ;; idea lifted from ielm (unless (get-buffer-process (current-buffer)) (let* ((process-connection-type nil) (proc (start-process "mrepl (dummy)" (current-buffer) "hexl"))) (set-process-query-on-exit-flag proc nil))) (set (make-local-variable 'comint-use-prompt-regexp) nil) (set (make-local-variable 'comint-inhibit-carriage-motion) t) (set (make-local-variable 'comint-input-sender) 'slime-mrepl-input-sender) (set (make-local-variable 'comint-output-filter-functions) nil) (set (make-local-variable 'slime-mrepl-expect-sexp) t) ;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input) (set-syntax-table lisp-mode-syntax-table) ) (slime-define-keys slime-mrepl-mode-map ((kbd "RET") 'slime-mrepl-return) ([return] 'slime-mrepl-return) ;;((kbd "TAB") 'slime-indent-and-complete-symbol) ((kbd "C-c C-b") 'slime-interrupt) ((kbd "C-c C-c") 'slime-interrupt)) (defun slime-mrepl-process% () (get-buffer-process (current-buffer))) ;stupid (defun slime-mrepl-mark () (process-mark (slime-mrepl-process%))) (defun slime-mrepl-insert (string) (comint-output-filter (slime-mrepl-process%) string)) (slime-define-channel-type listener) (slime-define-channel-method listener :prompt (package prompt) (with-current-buffer (slime-channel-get self 'buffer) (slime-mrepl-prompt package prompt))) (defun slime-mrepl-prompt (package prompt) (setf slime-buffer-package package) (slime-mrepl-insert (format "%s%s> " (cl-case (current-column) (0 "") (t "\n")) prompt)) (slime-mrepl-recenter)) (defun slime-mrepl-recenter () (when (get-buffer-window) (recenter -1))) (slime-define-channel-method listener :write-result (result) (with-current-buffer (slime-channel-get self 'buffer) (goto-char (point-max)) (slime-mrepl-insert result))) (slime-define-channel-method listener :evaluation-aborted () (with-current-buffer (slime-channel-get self 'buffer) (goto-char (point-max)) (slime-mrepl-insert "; Evaluation aborted\n"))) (slime-define-channel-method listener :write-string (string) (slime-mrepl-write-string self string)) (defun slime-mrepl-write-string (self string) (with-current-buffer (slime-channel-get self 'buffer) (goto-char (slime-mrepl-mark)) (slime-mrepl-insert string))) (slime-define-channel-method listener :set-read-mode (mode) (with-current-buffer (slime-channel-get self 'buffer) (cl-ecase mode (:read (setq slime-mrepl-expect-sexp nil) (message "[Listener is waiting for input]")) (:eval (setq slime-mrepl-expect-sexp t))))) (defun slime-mrepl-return (&optional end-of-input) (interactive "P") (slime-check-connected) (goto-char (point-max)) (cond ((and slime-mrepl-expect-sexp (or (slime-input-complete-p (slime-mrepl-mark) (point)) end-of-input)) (comint-send-input)) ((not slime-mrepl-expect-sexp) (unless end-of-input (insert "\n")) (comint-send-input t)) (t (insert "\n") (inferior-slime-indent-line) (message "[input not complete]"))) (slime-mrepl-recenter)) (defun slime-mrepl-input-sender (proc string) (slime-mrepl-send-string (substring-no-properties string))) (defun slime-mrepl-send-string (string &optional command-string) (slime-mrepl-send `(:process ,string))) (defun slime-mrepl-send (msg) "Send MSG to the remote channel." (slime-send-to-remote-channel slime-mrepl-remote-channel msg)) (defun slime-new-mrepl () "Create a new listener window." (interactive) (let ((channel (slime-make-channel slime-listener-channel-methods))) (slime-eval-async `(swank-mrepl:create-mrepl ,(slime-channel.id channel)) (slime-rcurry (lambda (result channel) (cl-destructuring-bind (remote thread-id package prompt) result (pop-to-buffer (generate-new-buffer (slime-buffer-name :mrepl))) (slime-mrepl-mode) (setq slime-current-thread thread-id) (setq slime-buffer-connection (slime-connection)) (set (make-local-variable 'slime-mrepl-remote-channel) remote) (slime-channel-put channel 'buffer (current-buffer)) (slime-channel-send channel `(:prompt ,package ,prompt)))) channel)))) (defun slime-mrepl () (let ((conn (slime-connection))) (cl-find-if (lambda (x) (with-current-buffer x (and (eq major-mode 'slime-mrepl-mode) (eq (slime-current-connection) conn)))) (buffer-list)))) (def-slime-selector-method ?m "First mrepl-buffer" (or (slime-mrepl) (error "No mrepl buffer (%s)" (slime-connection-name)))) (provide 'slime-mrepl) slime-2.20/contrib/slime-package-fu.el000066400000000000000000000316651315100173500176510ustar00rootroot00000000000000(require 'slime) (require 'slime-c-p-c) (require 'slime-parse) (defvar slime-package-fu-init-undo-stack nil) (define-slime-contrib slime-package-fu "Exporting/Unexporting symbols at point." (:authors "Tobias C. Rittweiler ") (:license "GPL") (:swank-dependencies swank-package-fu) (:on-load (push `(progn (define-key slime-mode-map "\C-cx" ',(lookup-key slime-mode-map "\C-cx"))) slime-package-fu-init-undo-stack) (define-key slime-mode-map "\C-cx" 'slime-export-symbol-at-point)) (:on-unload (while slime-c-p-c-init-undo-stack (eval (pop slime-c-p-c-init-undo-stack))))) (defvar slime-package-file-candidates (mapcar #'file-name-nondirectory '("package.lisp" "packages.lisp" "pkgdcl.lisp" "defpackage.lisp"))) (defvar slime-export-symbol-representation-function #'(lambda (n) (format "#:%s" n))) (defvar slime-export-symbol-representation-auto t "Determine automatically which style is used for symbols, #: or : If it's mixed or no symbols are exported so far, use `slime-export-symbol-representation-function'.") (defvar slime-export-save-file nil "Save the package file after each automatic modification") (defvar slime-defpackage-regexp "^(\\(cl:\\|common-lisp:\\)?defpackage\\>[ \t']*") (defun slime-find-package-definition-rpc (package) (slime-eval `(swank:find-definition-for-thing (swank::guess-package ,package)))) (defun slime-find-package-definition-regexp (package) (save-excursion (save-match-data (goto-char (point-min)) (cl-block nil (while (re-search-forward slime-defpackage-regexp nil t) (when (slime-package-equal package (slime-sexp-at-point)) (backward-sexp) (cl-return (make-slime-file-location (buffer-file-name) (1- (point)))))))))) (defun slime-package-equal (designator1 designator2) ;; First try to be lucky and compare the strings themselves (for the ;; case when one of the designated packages isn't loaded in the ;; image.) Then try to do it properly using the inferior Lisp which ;; will also resolve nicknames for us &c. (or (cl-equalp (slime-cl-symbol-name designator1) (slime-cl-symbol-name designator2)) (slime-eval `(swank:package= ,designator1 ,designator2)))) (defun slime-export-symbol (symbol package) "Unexport `symbol' from `package' in the Lisp image." (slime-eval `(swank:export-symbol-for-emacs ,symbol ,package))) (defun slime-unexport-symbol (symbol package) "Export `symbol' from `package' in the Lisp image." (slime-eval `(swank:unexport-symbol-for-emacs ,symbol ,package))) (defun slime-find-possible-package-file (buffer-file-name) (cl-labels ((file-name-subdirectory (dirname) (expand-file-name (concat (file-name-as-directory (slime-to-lisp-filename dirname)) (file-name-as-directory "..")))) (try (dirname) (cl-dolist (package-file-name slime-package-file-candidates) (let ((f (slime-to-lisp-filename (concat dirname package-file-name)))) (when (file-readable-p f) (cl-return f)))))) (when buffer-file-name (let ((buffer-cwd (file-name-directory buffer-file-name))) (or (try buffer-cwd) (try (file-name-subdirectory buffer-cwd)) (try (file-name-subdirectory (file-name-subdirectory buffer-cwd)))))))) (defun slime-goto-package-source-definition (package) "Tries to find the DEFPACKAGE form of `package'. If found, places the cursor at the start of the DEFPACKAGE form." (cl-labels ((try (location) (when (slime-location-p location) (slime-goto-source-location location) t))) (or (try (slime-find-package-definition-rpc package)) (try (slime-find-package-definition-regexp package)) (try (let ((package-file (slime-find-possible-package-file (buffer-file-name)))) (when package-file (with-current-buffer (find-file-noselect package-file t) (slime-find-package-definition-regexp package))))) (error "Couldn't find source definition of package: %s" package)))) (defun slime-at-expression-p (pattern) (when (ignore-errors ;; at a list? (= (point) (progn (down-list 1) (backward-up-list 1) (point)))) (save-excursion (down-list 1) (slime-in-expression-p pattern)))) (defun slime-goto-next-export-clause () ;; Assumes we're inside the beginning of a DEFPACKAGE form. (let ((point)) (save-excursion (cl-block nil (while (ignore-errors (slime-forward-sexp) t) (skip-chars-forward " \n\t") (when (slime-at-expression-p '(:export *)) (setq point (point)) (cl-return))))) (if point (goto-char point) (error "No next (:export ...) clause found")))) (defun slime-search-exports-in-defpackage (symbol-name) "Look if `symbol-name' is mentioned in one of the :EXPORT clauses." ;; Assumes we're inside the beginning of a DEFPACKAGE form. (cl-labels ((target-symbol-p (symbol) (string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$" (regexp-quote symbol-name)) symbol))) (save-excursion (cl-block nil (while (ignore-errors (slime-goto-next-export-clause) t) (let ((clause-end (save-excursion (forward-sexp) (point)))) (save-excursion (while (search-forward symbol-name clause-end t) (when (target-symbol-p (slime-symbol-at-point)) (cl-return (if (slime-inside-string-p) ;; Include the following " (1+ (point)) (point)))))))))))) (defun slime-export-symbols () "Return a list of symbols inside :export clause of a defpackage." ;; Assumes we're at the beginning of :export (cl-labels ((read-sexp () (ignore-errors (forward-comment (point-max)) (buffer-substring-no-properties (point) (progn (forward-sexp) (point)))))) (save-excursion (cl-loop for sexp = (read-sexp) while sexp collect sexp)))) (defun slime-defpackage-exports () "Return a list of symbols inside :export clause of a defpackage." ;; Assumes we're inside the beginning of a DEFPACKAGE form. (cl-labels ((normalize-name (name) (if (string-prefix-p "\"" name) (read name) (replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)" "" name)))) (save-excursion (mapcar #'normalize-name (cl-loop while (ignore-errors (slime-goto-next-export-clause) t) do (down-list) (forward-sexp) append (slime-export-symbols) do (up-list) (backward-sexp)))))) (defun slime-symbol-exported-p (name symbols) (cl-member name symbols :test 'cl-equalp)) (defun slime-frob-defpackage-form (current-package do-what symbols) "Adds/removes `symbol' from the DEFPACKAGE form of `current-package' depending on the value of `do-what' which can either be `:export', or `:unexport'. Returns t if the symbol was added/removed. Nil if the symbol was already exported/unexported." (save-excursion (slime-goto-package-source-definition current-package) (down-list 1) ; enter DEFPACKAGE form (forward-sexp) ; skip DEFPACKAGE symbol ;; Don't or will fail if (:export ...) is immediately following ;; (forward-sexp) ; skip package name (let ((exported-symbols (slime-defpackage-exports)) (symbols (if (consp symbols) symbols (list symbols))) (number-of-actions 0)) (cl-ecase do-what (:export (slime-add-export) (dolist (symbol symbols) (let ((symbol-name (slime-cl-symbol-name symbol))) (unless (slime-symbol-exported-p symbol-name exported-symbols) (cl-incf number-of-actions) (slime-insert-export symbol-name))))) (:unexport (dolist (symbol symbols) (let ((symbol-name (slime-cl-symbol-name symbol))) (when (slime-symbol-exported-p symbol-name exported-symbols) (slime-remove-export symbol-name) (cl-incf number-of-actions)))))) (when slime-export-save-file (save-buffer)) number-of-actions))) (defun slime-add-export () (let (point) (save-excursion (while (ignore-errors (slime-goto-next-export-clause) t) (setq point (point)))) (cond (point (goto-char point) (down-list) (slime-end-of-list)) (t (slime-end-of-list) (unless (looking-back "^\\s-*") (newline-and-indent)) (insert "(:export ") (save-excursion (insert ")")))))) (defun slime-determine-symbol-style () ;; Assumes we're inside :export (save-excursion (slime-beginning-of-list) (slime-forward-sexp) (let ((symbols (slime-export-symbols))) (cond ((null symbols) slime-export-symbol-representation-function) ((cl-every (lambda (x) (string-match "^:" x)) symbols) (lambda (n) (format ":%s" n))) ((cl-every (lambda (x) (string-match "^#:" x)) symbols) (lambda (n) (format "#:%s" n))) ((cl-every (lambda (x) (string-prefix-p "\"" x)) symbols) (lambda (n) (prin1-to-string (upcase (substring-no-properties n))))) (t slime-export-symbol-representation-function))))) (defun slime-format-symbol-for-defpackage (symbol-name) (funcall (if slime-export-symbol-representation-auto (slime-determine-symbol-style) slime-export-symbol-representation-function) symbol-name)) (defun slime-insert-export (symbol-name) ;; Assumes we're at the inside :export after the last symbol (let ((symbol-name (slime-format-symbol-for-defpackage symbol-name))) (unless (looking-back "^\\s-*") (newline-and-indent)) (insert symbol-name))) (defun slime-remove-export (symbol-name) ;; Assumes we're inside the beginning of a DEFPACKAGE form. (let ((point)) (while (setq point (slime-search-exports-in-defpackage symbol-name)) (save-excursion (goto-char point) (backward-sexp) (delete-region (point) point) (beginning-of-line) (when (looking-at "^\\s-*$") (join-line) (delete-trailing-whitespace (point) (line-end-position))))))) (defun slime-export-symbol-at-point () "Add the symbol at point to the defpackage source definition belonging to the current buffer-package. With prefix-arg, remove the symbol again. Additionally performs an EXPORT/UNEXPORT of the symbol in the Lisp image if possible." (interactive) (let ((package (slime-current-package)) (symbol (slime-symbol-at-point))) (unless symbol (error "No symbol at point.")) (cond (current-prefix-arg (if (cl-plusp (slime-frob-defpackage-form package :unexport symbol)) (message "Symbol `%s' no longer exported form `%s'" symbol package) (message "Symbol `%s' is not exported from `%s'" symbol package)) (slime-unexport-symbol symbol package)) (t (if (cl-plusp (slime-frob-defpackage-form package :export symbol)) (message "Symbol `%s' now exported from `%s'" symbol package) (message "Symbol `%s' already exported from `%s'" symbol package)) (slime-export-symbol symbol package))))) (defun slime-export-class (name) "Export acessors, constructors, etc. associated with a structure or a class" (interactive (list (slime-read-from-minibuffer "Export structure named: " (slime-symbol-at-point)))) (let* ((package (slime-current-package)) (symbols (slime-eval `(swank:export-structure ,name ,package)))) (message "%s symbols exported from `%s'" (slime-frob-defpackage-form package :export symbols) package))) (defalias 'slime-export-structure 'slime-export-class) (provide 'slime-package-fu) ;; Local Variables: ;; indent-tabs-mode: nil ;; End: slime-2.20/contrib/slime-parse.el000066400000000000000000000350031315100173500167460ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (define-slime-contrib slime-parse "Utility contrib containg functions to parse forms in a buffer." (:authors "Matthias Koeppe " "Tobias C. Rittweiler ") (:license "GPL")) (defun slime-parse-form-until (limit form-suffix) "Parses form from point to `limit'." ;; For performance reasons, this function does not use recursion. (let ((todo (list (point))) ; stack of positions (sexps) ; stack of expressions (cursexp) (curpos) (depth 1)) ; This function must be called from the ; start of the sexp to be parsed. (while (and (setq curpos (pop todo)) (progn (goto-char curpos) ;; (Here we also move over suppressed ;; reader-conditionalized code! Important so CL-side ;; of autodoc won't see that garbage.) (ignore-errors (slime-forward-cruft)) (< (point) limit))) (setq cursexp (pop sexps)) (cond ;; End of an sexp? ((or (looking-at "\\s)") (eolp)) (cl-decf depth) (push (nreverse cursexp) (car sexps))) ;; Start of a new sexp? ((looking-at "\\s'*\\s(") (let ((subpt (match-end 0))) (ignore-errors (forward-sexp) ;; (In case of error, we're at an incomplete sexp, and ;; nothing's left todo after it.) (push (point) todo)) (push cursexp sexps) (push subpt todo) ; to descend into new sexp (push nil sexps) (cl-incf depth))) ;; In mid of an sexp.. (t (let ((pt1 (point)) (pt2 (condition-case e (progn (forward-sexp) (point)) (scan-error (cl-fourth e))))) ; end of sexp (push (buffer-substring-no-properties pt1 pt2) cursexp) (push pt2 todo) (push cursexp sexps))))) (when sexps (setf (car sexps) (cl-nreconc form-suffix (car sexps))) (while (> depth 1) (push (nreverse (pop sexps)) (car sexps)) (cl-decf depth)) (nreverse (car sexps))))) (defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped) "Returns t if the character that `get-char-fn' yields has characer syntax of `syntax'. If `unescaped' is true, it's ensured that the character is not escaped." (let ((char (funcall get-char-fn (point))) (char-before (funcall get-char-fn (1- (point))))) (if (and char (eq (char-syntax char) (aref syntax 0))) (if unescaped (or (null char-before) (not (eq (char-syntax char-before) ?\\))) t) nil))) (defconst slime-cursor-marker 'swank::%cursor-marker%) (defun slime-parse-form-upto-point (&optional max-levels) (save-restriction ;; Don't parse more than 500 lines before point, so we don't spend ;; too much time. NB. Make sure to go to beginning of line, and ;; not possibly anywhere inside comments or strings. (narrow-to-region (line-beginning-position -500) (point-max)) (save-excursion (let ((suffix (list slime-cursor-marker))) (cond ((slime-compare-char-syntax #'char-after "(" t) ;; We're at the start of some expression, so make sure ;; that SWANK::%CURSOR-MARKER% will come after that ;; expression. If the expression is not balanced, make ;; still sure that the marker does *not* come directly ;; after the preceding expression. (or (ignore-errors (forward-sexp) t) (push "" suffix))) ((or (bolp) (slime-compare-char-syntax #'char-before " " t)) ;; We're after some expression, so we have to make sure ;; that %CURSOR-MARKER% does *not* come directly after ;; that expression. (push "" suffix)) ((slime-compare-char-syntax #'char-before "(" t) ;; We're directly after an opening parenthesis, so we ;; have to make sure that something comes before ;; %CURSOR-MARKER%. (push "" suffix)) (t ;; We're at a symbol, so make sure we get the whole symbol. (slime-end-of-symbol))) (let ((pt (point))) (ignore-errors (up-list (if max-levels (- max-levels) -5))) (ignore-errors (down-list)) (slime-parse-form-until pt suffix)))))) (require 'bytecomp) (mapc (lambda (sym) (cond ((fboundp sym) (unless (byte-code-function-p (symbol-function sym)) (byte-compile sym))) (t (error "%S is not fbound" sym)))) '(slime-parse-form-upto-point slime-parse-form-until slime-compare-char-syntax)) ;;;; Test cases (defun slime-extract-context () "Parse the context for the symbol at point. Nil is returned if there's no symbol at point. Otherwise we detect the following cases (the . shows the point position): (defun n.ame (...) ...) -> (:defun name) (defun (setf n.ame) (...) ...) -> (:defun (setf name)) (defmethod n.ame (...) ...) -> (:defmethod name (...)) (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name) (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name) (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name) (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name)) (defmacro n.ame (...) ...) -> (:defmacro name) (defsetf n.ame (...) ...) -> (:defsetf name) (define-setf-expander n.ame (...) ...) -> (:define-setf-expander name) (define-modify-macro n.ame (...) ...) -> (:define-modify-macro name) (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name) (defvar n.ame (...) ...) -> (:defvar name) (defparameter n.ame ...) -> (:defparameter name) (defconstant n.ame ...) -> (:defconstant name) (defclass n.ame ...) -> (:defclass name) (defstruct n.ame ...) -> (:defstruct name) (defpackage n.ame ...) -> (:defpackage name) For other contexts we return the symbol at point." (let ((name (slime-symbol-at-point))) (if name (let ((symbol (read name))) (or (progn ;;ignore-errors (slime-parse-context symbol)) symbol))))) (defun slime-parse-context (name) (save-excursion (cond ((slime-in-expression-p '(defun *)) `(:defun ,name)) ((slime-in-expression-p '(defmacro *)) `(:defmacro ,name)) ((slime-in-expression-p '(defgeneric *)) `(:defgeneric ,name)) ((slime-in-expression-p '(setf *)) ;;a setf-definition, but which? (backward-up-list 1) (slime-parse-context `(setf ,name))) ((slime-in-expression-p '(defmethod *)) (unless (looking-at "\\s ") (forward-sexp 1)) ; skip over the methodname (let (qualifiers arglist) (cl-loop for e = (read (current-buffer)) until (listp e) do (push e qualifiers) finally (setq arglist e)) `(:defmethod ,name ,@qualifiers ,(slime-arglist-specializers arglist)))) ((and (symbolp name) (slime-in-expression-p `(,name))) ;; looks like a regular call (let ((toplevel (ignore-errors (slime-parse-toplevel-form)))) (cond ((slime-in-expression-p `(setf (*))) ;a setf-call (if toplevel `(:call ,toplevel (setf ,name)) `(setf ,name))) ((not toplevel) name) ((slime-in-expression-p `(labels ((*)))) `(:labels ,toplevel ,name)) ((slime-in-expression-p `(flet ((*)))) `(:flet ,toplevel ,name)) (t `(:call ,toplevel ,name))))) ((slime-in-expression-p '(define-compiler-macro *)) `(:define-compiler-macro ,name)) ((slime-in-expression-p '(define-modify-macro *)) `(:define-modify-macro ,name)) ((slime-in-expression-p '(define-setf-expander *)) `(:define-setf-expander ,name)) ((slime-in-expression-p '(defsetf *)) `(:defsetf ,name)) ((slime-in-expression-p '(defvar *)) `(:defvar ,name)) ((slime-in-expression-p '(defparameter *)) `(:defparameter ,name)) ((slime-in-expression-p '(defconstant *)) `(:defconstant ,name)) ((slime-in-expression-p '(defclass *)) `(:defclass ,name)) ((slime-in-expression-p '(defpackage *)) `(:defpackage ,name)) ((slime-in-expression-p '(defstruct *)) `(:defstruct ,(if (consp name) (car name) name))) (t name)))) (defun slime-in-expression-p (pattern) "A helper function to determine the current context. The pattern can have the form: pattern ::= () ;matches always | (*) ;matches inside a list | ( ) ;matches if the first element in ; the current list is and ; if matches. | (()) ;matches if we are in a nested list." (save-excursion (let ((path (reverse (slime-pattern-path pattern)))) (cl-loop for p in path always (ignore-errors (cl-etypecase p (symbol (slime-beginning-of-list) (eq (read (current-buffer)) p)) (number (backward-up-list p) t))))))) (defun slime-pattern-path (pattern) ;; Compute the path to the * in the pattern to make matching ;; easier. The path is a list of symbols and numbers. A number ;; means "(down-list )" and a symbol "(look-at )") (if (null pattern) '() (cl-etypecase (car pattern) ((member *) '()) (symbol (cons (car pattern) (slime-pattern-path (cdr pattern)))) (cons (cons 1 (slime-pattern-path (car pattern))))))) (defun slime-beginning-of-list (&optional up) "Move backward to the beginning of the current expression. Point is placed before the first expression in the list." (backward-up-list (or up 1)) (down-list 1) (skip-syntax-forward " ")) (defun slime-end-of-list (&optional up) (backward-up-list (or up 1)) (forward-list 1) (down-list -1)) (defun slime-parse-toplevel-form () (ignore-errors ; (foo) (save-excursion (goto-char (car (slime-region-for-defun-at-point))) (down-list 1) (forward-sexp 1) (slime-parse-context (read (current-buffer)))))) (defun slime-arglist-specializers (arglist) (cond ((or (null arglist) (member (cl-first arglist) '(&optional &key &rest &aux))) (list)) ((consp (cl-first arglist)) (cons (cl-second (cl-first arglist)) (slime-arglist-specializers (cl-rest arglist)))) (t (cons 't (slime-arglist-specializers (cl-rest arglist)))))) (defun slime-definition-at-point (&optional only-functional) "Return object corresponding to the definition at point." (let ((toplevel (slime-parse-toplevel-form))) (if (or (symbolp toplevel) (and only-functional (not (member (car toplevel) '(:defun :defgeneric :defmethod :defmacro :define-compiler-macro))))) (error "Not in a definition") (slime-dcase toplevel (((:defun :defgeneric) symbol) (format "#'%s" symbol)) (((:defmacro :define-modify-macro) symbol) (format "(macro-function '%s)" symbol)) ((:define-compiler-macro symbol) (format "(compiler-macro-function '%s)" symbol)) ((:defmethod symbol &rest args) (declare (ignore args)) (format "#'%s" symbol)) (((:defparameter :defvar :defconstant) symbol) (format "'%s" symbol)) (((:defclass :defstruct) symbol) (format "(find-class '%s)" symbol)) ((:defpackage symbol) (format "(or (find-package '%s) (error \"Package %s not found\"))" symbol symbol)) (t (error "Not in a definition")))))) (defsubst slime-current-parser-state () ;; `syntax-ppss' does not save match data as it invokes ;; `beginning-of-defun' implicitly which does not save match ;; data. This issue has been reported to the Emacs maintainer on ;; Feb27. (syntax-ppss)) (defun slime-inside-string-p () (nth 3 (slime-current-parser-state))) (defun slime-inside-comment-p () (nth 4 (slime-current-parser-state))) (defun slime-inside-string-or-comment-p () (let ((state (slime-current-parser-state))) (or (nth 3 state) (nth 4 state)))) ;;; The following two functions can be handy when inspecting ;;; source-location while debugging `M-.'. ;;; (defun slime-current-tlf-number () "Return the current toplevel number." (interactive) (let ((original-pos (car (slime-region-for-defun-at-point))) (n 0)) (save-excursion ;; We use this and no repeated `beginning-of-defun's to get ;; reader conditionals right. (goto-char (point-min)) (while (progn (slime-forward-sexp) (< (point) original-pos)) (cl-incf n))) n)) ;;; This is similiar to `slime-enclosing-form-paths' in the ;;; `slime-parse' contrib except that this does not do any duck-tape ;;; parsing, and gets reader conditionals right. (defun slime-current-form-path () "Returns the path from the beginning of the current toplevel form to the atom at point, or nil if we're in front of a tlf." (interactive) (let ((source-path nil)) (save-excursion ;; Moving forward to get reader conditionals right. (cl-loop for inner-pos = (point) for outer-pos = (cl-nth-value 1 (slime-current-parser-state)) while outer-pos do (goto-char outer-pos) (unless (eq (char-before) ?#) ; when at #(...) continue. (forward-char) (let ((n 0)) (while (progn (slime-forward-sexp) (< (point) inner-pos)) (cl-incf n)) (push n source-path) (goto-char outer-pos))))) source-path)) (provide 'slime-parse) slime-2.20/contrib/slime-presentation-streams.el000066400000000000000000000012011315100173500220140ustar00rootroot00000000000000(eval-and-compile (require 'slime)) (define-slime-contrib slime-presentation-streams "Streams that allow attaching object identities to portions of output." (:authors "Alan Ruttenberg " "Matthias Koeppe " "Helmut Eller ") (:license "GPL") (:on-load (add-hook 'slime-connected-hook 'slime-presentation-streams-on-connected)) (:swank-dependencies swank-presentation-streams)) (defun slime-presentation-streams-on-connected () (slime-eval `(swank:init-presentation-streams))) (provide 'slime-presentation-streams) slime-2.20/contrib/slime-presentations.el000066400000000000000000001152111315100173500205320ustar00rootroot00000000000000(require 'slime) (require 'bridge) (require 'cl-lib) (eval-when-compile (require 'cl)) (define-slime-contrib slime-presentations "Imitate LispM presentations." (:authors "Alan Ruttenberg " "Matthias Koeppe ") (:license "GPL") (:slime-dependencies slime-repl) (:swank-dependencies swank-presentations) (:on-load (add-hook 'slime-repl-mode-hook (lambda () ;; Respect the syntax text properties of presentation. (set (make-local-variable 'parse-sexp-lookup-properties) t) (add-hook 'after-change-functions 'slime-after-change-function 'append t))) (add-hook 'slime-event-hooks 'slime-dispatch-presentation-event) (setq slime-write-string-function 'slime-presentation-write) (add-hook 'slime-connected-hook 'slime-presentations-on-connected) (add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed) (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input) (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open) (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations) (add-hook 'slime-edit-definition-hooks 'slime-edit-presentation) (setq sldb-insert-frame-variable-value-function 'slime-presentation-sldb-insert-frame-variable-value) (slime-presentation-init-keymaps) (slime-presentation-add-easy-menu))) ;; To get presentations in the inspector as well, add this to your ;; init file. ;; ;; (eval-after-load 'slime-presentations ;; '(setq slime-inspector-insert-ispec-function ;; 'slime-presentation-inspector-insert-ispec)) ;; (defface slime-repl-output-mouseover-face '((t (:box (:line-width 1 :color "black" :style released-button) :inherit slime-repl-inputed-output-face))) "Face for Lisp output in the SLIME REPL, when the mouse hovers over it" :group 'slime-repl) (defface slime-repl-inputed-output-face '((((class color) (background light)) (:foreground "Red")) (((class color) (background dark)) (:foreground "Red")) (t (:slant italic))) "Face for the result of an evaluation in the SLIME REPL." :group 'slime-repl) ;; FIXME: This conditional is not right - just used because the code ;; here does not work in XEmacs. (when (boundp 'text-property-default-nonsticky) (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky :test 'equal) (pushnew '(slime-repl-result-face . t) text-property-default-nonsticky :test 'equal)) (make-variable-buffer-local (defvar slime-presentation-start-to-point (make-hash-table))) (defun slime-mark-presentation-start (id &optional target) "Mark the beginning of a presentation with the given ID. TARGET can be nil (regular process output) or :repl-result." (setf (gethash id slime-presentation-start-to-point) ;; We use markers because text can also be inserted before this presentation. ;; (Output arrives while we are writing presentations within REPL results.) (copy-marker (slime-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)))) (cl-defstruct slime-presentation text id) (defvar slime-presentation-syntax-table (let ((table (copy-syntax-table lisp-mode-syntax-table))) ;; We give < and > parenthesis syntax, so that #< ... > is treated ;; as a balanced expression. This allows to use C-M-k, C-M-SPC, ;; etc. to deal with a whole presentation. (For Lisp mode, this ;; is not desirable, since we do not wish to get a mismatched ;; paren highlighted everytime we type < or >.) (modify-syntax-entry ?< "(>" table) (modify-syntax-entry ?> ")<" table) table) "Syntax table for presentations.") (defun slime-add-presentation-properties (start end id result-p) "Make the text between START and END a presentation with ID. RESULT-P decides whether a face for a return value or output text is used." (let* ((text (buffer-substring-no-properties start end)) (presentation (make-slime-presentation :text text :id id))) (let ((inhibit-modification-hooks t)) (add-text-properties start end `(modification-hooks (slime-after-change-function) insert-in-front-hooks (slime-after-change-function) insert-behind-hooks (slime-after-change-function) syntax-table ,slime-presentation-syntax-table rear-nonsticky t)) ;; Use the presentation as the key of a text property (case (- end start) (0) (1 (add-text-properties start end `(slime-repl-presentation ,presentation ,presentation :start-and-end))) (t (add-text-properties start (1+ start) `(slime-repl-presentation ,presentation ,presentation :start)) (when (> (- end start) 2) (add-text-properties (1+ start) (1- end) `(,presentation :interior))) (add-text-properties (1- end) end `(slime-repl-presentation ,presentation ,presentation :end)))) ;; Also put an overlay for the face and the mouse-face. This enables ;; highlighting of nested presentations. However, overlays get lost ;; when we copy a presentation; their removal is also not undoable. ;; In these cases the mouse-face text properties need to take over --- ;; but they do not give nested highlighting. (slime-ensure-presentation-overlay start end presentation)))) (defvar slime-presentation-map (make-sparse-keymap)) (defun slime-ensure-presentation-overlay (start end presentation) (unless (cl-find presentation (overlays-at start) :key (lambda (overlay) (overlay-get overlay 'slime-repl-presentation))) (let ((overlay (make-overlay start end (current-buffer) t nil))) (overlay-put overlay 'slime-repl-presentation presentation) (overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face) (overlay-put overlay 'help-echo (if (eq major-mode 'slime-repl-mode) "mouse-2: copy to input; mouse-3: menu" "mouse-2: inspect; mouse-3: menu")) (overlay-put overlay 'face 'slime-repl-inputed-output-face) (overlay-put overlay 'keymap slime-presentation-map)))) (defun slime-remove-presentation-properties (from to presentation) (let ((inhibit-read-only t)) (remove-text-properties from to `(,presentation t syntax-table t rear-nonsticky t)) (when (eq (get-text-property from 'slime-repl-presentation) presentation) (remove-text-properties from (1+ from) `(slime-repl-presentation t))) (when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation) (remove-text-properties (1- to) to `(slime-repl-presentation t))) (dolist (overlay (overlays-at from)) (when (eq (overlay-get overlay 'slime-repl-presentation) presentation) (delete-overlay overlay))))) (defun slime-insert-presentation (string output-id &optional rectangle) "Insert STRING in current buffer and mark it as a presentation corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line strings to line up below the current point." (cl-labels ((insert-it () (if rectangle (slime-insert-indented string) (insert string)))) (let ((start (point))) (insert-it) (slime-add-presentation-properties start (point) output-id t)))) (defun slime-presentation-whole-p (presentation start end &optional object) (let ((object (or object (current-buffer)))) (string= (etypecase object (buffer (with-current-buffer object (buffer-substring-no-properties start end))) (string (substring-no-properties object start end))) (slime-presentation-text presentation)))) (defun slime-presentations-around-point (point &optional object) (let ((object (or object (current-buffer)))) (loop for (key value . rest) on (text-properties-at point object) by 'cddr when (slime-presentation-p key) collect key))) (defun slime-presentation-start-p (tag) (memq tag '(:start :start-and-end))) (defun slime-presentation-stop-p (tag) (memq tag '(:end :start-and-end))) (cl-defun slime-presentation-start (point presentation &optional (object (current-buffer))) "Find start of `presentation' at `point' in `object'. Return buffer index and whether a start-tag was found." (let* ((this-presentation (get-text-property point presentation object))) (while (not (slime-presentation-start-p this-presentation)) (let ((change-point (previous-single-property-change point presentation object (point-min)))) (unless change-point (return-from slime-presentation-start (values (etypecase object (buffer (with-current-buffer object 1)) (string 0)) nil))) (setq this-presentation (get-text-property change-point presentation object)) (unless this-presentation (return-from slime-presentation-start (values point nil))) (setq point change-point))) (values point t))) (cl-defun slime-presentation-end (point presentation &optional (object (current-buffer))) "Find end of presentation at `point' in `object'. Return buffer index (after last character of the presentation) and whether an end-tag was found." (let* ((this-presentation (get-text-property point presentation object))) (while (not (slime-presentation-stop-p this-presentation)) (let ((change-point (next-single-property-change point presentation object))) (unless change-point (return-from slime-presentation-end (values (etypecase object (buffer (with-current-buffer object (point-max))) (string (length object))) nil))) (setq point change-point) (setq this-presentation (get-text-property point presentation object)))) (if this-presentation (let ((after-end (next-single-property-change point presentation object))) (if (not after-end) (values (etypecase object (buffer (with-current-buffer object (point-max))) (string (length object))) t) (values after-end t))) (values point nil)))) (cl-defun slime-presentation-bounds (point presentation &optional (object (current-buffer))) "Return start index and end index of `presentation' around `point' in `object', and whether the presentation is complete." (multiple-value-bind (start good-start) (slime-presentation-start point presentation object) (multiple-value-bind (end good-end) (slime-presentation-end point presentation object) (values start end (and good-start good-end (slime-presentation-whole-p presentation start end object)))))) (defun slime-presentation-around-point (point &optional object) "Return presentation, start index, end index, and whether the presentation is complete." (let ((object (or object (current-buffer))) (innermost-presentation nil) (innermost-start 0) (innermost-end most-positive-fixnum)) (dolist (presentation (slime-presentations-around-point point object)) (multiple-value-bind (start end whole-p) (slime-presentation-bounds point presentation object) (when whole-p (when (< (- end start) (- innermost-end innermost-start)) (setq innermost-start start innermost-end end innermost-presentation presentation))))) (values innermost-presentation innermost-start innermost-end))) (defun slime-presentation-around-or-before-point (point &optional object) (let ((object (or object (current-buffer)))) (multiple-value-bind (presentation start end whole-p) (slime-presentation-around-point point object) (if (or presentation (= point (point-min))) (values presentation start end whole-p) (slime-presentation-around-point (1- point) object))))) (defun slime-presentation-around-or-before-point-or-error (point) (multiple-value-bind (presentation start end whole-p) (slime-presentation-around-or-before-point point) (unless presentation (error "No presentation at point")) (values presentation start end whole-p))) (cl-defun slime-for-each-presentation-in-region (from to function &optional (object (current-buffer))) "Call `function' with arguments `presentation', `start', `end', `whole-p' for every presentation in the region `from'--`to' in the string or buffer `object'." (cl-labels ((handle-presentation (presentation point) (multiple-value-bind (start end whole-p) (slime-presentation-bounds point presentation object) (funcall function presentation start end whole-p)))) ;; Handle presentations active at `from'. (dolist (presentation (slime-presentations-around-point from object)) (handle-presentation presentation from)) ;; Use the `slime-repl-presentation' property to search for new presentations. (let ((point from)) (while (< point to) (setq point (next-single-property-change point 'slime-repl-presentation object to)) (let* ((presentation (get-text-property point 'slime-repl-presentation object)) (status (get-text-property point presentation object))) (when (slime-presentation-start-p status) (handle-presentation presentation point))))))) ;; XEmacs compatibility hack, from message by Stephen J. Turnbull on ;; xemacs-beta@xemacs.org of 18 Mar 2002 (unless (boundp 'undo-in-progress) (defvar undo-in-progress nil "Placeholder defvar for XEmacs compatibility from SLIME.") (defadvice undo-more (around slime activate) (let ((undo-in-progress t)) ad-do-it))) (defun slime-after-change-function (start end &rest ignore) "Check all presentations within and adjacent to the change. When a presentation has been altered, change it to plain text." (let ((inhibit-modification-hooks t)) (let ((real-start (max 1 (1- start))) (real-end (min (1+ (buffer-size)) (1+ end))) (any-change nil)) ;; positions around the change (slime-for-each-presentation-in-region real-start real-end (lambda (presentation from to whole-p) (cond (whole-p (slime-ensure-presentation-overlay from to presentation)) ((not undo-in-progress) (slime-remove-presentation-properties from to presentation) (setq any-change t))))) (when any-change (undo-boundary))))) (defun slime-presentation-around-click (event) "Return the presentation around the position of the mouse-click EVENT. If there is no presentation, signal an error. Also return the start position, end position, and buffer of the presentation." (when (and (featurep 'xemacs) (not (button-press-event-p event))) (error "Command must be bound to a button-press-event")) (let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) (window (if (featurep 'xemacs) (event-window event) (caadr event)))) (with-current-buffer (window-buffer window) (multiple-value-bind (presentation start end) (slime-presentation-around-point point) (unless presentation (error "No presentation at click")) (values presentation start end (current-buffer)))))) (defun slime-check-presentation (from to buffer presentation) (unless (slime-eval `(cl:nth-value 1 (swank:lookup-presented-object ',(slime-presentation-id presentation)))) (with-current-buffer buffer (slime-remove-presentation-properties from to presentation)))) (defun slime-copy-or-inspect-presentation-at-mouse (event) (interactive "e") ; no "@" -- we don't want to select the clicked-at window (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) (slime-check-presentation start end buffer presentation) (if (with-current-buffer buffer (eq major-mode 'slime-repl-mode)) (slime-copy-presentation-at-mouse-to-repl event) (slime-inspect-presentation-at-mouse event)))) (defun slime-inspect-presentation (presentation start end buffer) (let ((reset-p (with-current-buffer buffer (not (eq major-mode 'slime-inspector-mode))))) (slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p) 'slime-open-inspector))) (defun slime-inspect-presentation-at-mouse (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) (slime-inspect-presentation presentation start end buffer))) (defun slime-inspect-presentation-at-point (point) (interactive "d") (multiple-value-bind (presentation start end) (slime-presentation-around-or-before-point-or-error point) (slime-inspect-presentation presentation start end (current-buffer)))) (defun slime-M-.-presentation (presentation start end buffer &optional where) (let* ((id (slime-presentation-id presentation)) (presentation-string (format "Presentation %s" id)) (location (slime-eval `(swank:find-definition-for-thing (swank:lookup-presented-object ',(slime-presentation-id presentation)))))) (unless (eq (car location) :error) (slime-edit-definition-cont (and location (list (make-slime-xref :dspec `(,presentation-string) :location location))) presentation-string where)))) (defun slime-M-.-presentation-at-mouse (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) (slime-M-.-presentation presentation start end buffer))) (defun slime-M-.-presentation-at-point (point) (interactive "d") (multiple-value-bind (presentation start end) (slime-presentation-around-or-before-point-or-error point) (slime-M-.-presentation presentation start end (current-buffer)))) (defun slime-edit-presentation (name &optional where) (if (or current-prefix-arg (not (equal (slime-symbol-at-point) name))) nil ; NAME came from user explicitly, so decline. (multiple-value-bind (presentation start end whole-p) (slime-presentation-around-or-before-point (point)) (when presentation (slime-M-.-presentation presentation start end (current-buffer) where))))) (defun slime-copy-presentation-to-repl (presentation start end buffer) (let ((text (with-current-buffer buffer ;; we use the buffer-substring rather than the ;; presentation text to capture any overlays (buffer-substring start end))) (id (slime-presentation-id presentation))) (unless (integerp id) (setq id (slime-eval `(swank:lookup-and-save-presented-object-or-lose ',id)))) (unless (eql major-mode 'slime-repl-mode) (slime-switch-to-output-buffer)) (cl-flet ((do-insertion () (unless (looking-back "\\s-" (- (point) 1)) (insert " ")) (slime-insert-presentation text id) (unless (or (eolp) (looking-at "\\s-")) (insert " ")))) (if (>= (point) slime-repl-prompt-start-mark) (do-insertion) (save-excursion (goto-char (point-max)) (do-insertion)))))) (defun slime-copy-presentation-at-mouse-to-repl (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) (slime-copy-presentation-to-repl presentation start end buffer))) (defun slime-copy-presentation-at-point-to-repl (point) (interactive "d") (multiple-value-bind (presentation start end) (slime-presentation-around-or-before-point-or-error point) (slime-copy-presentation-to-repl presentation start end (current-buffer)))) (defun slime-copy-presentation-at-mouse-to-point (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) (let ((presentation-text (with-current-buffer buffer (buffer-substring start end)))) (when (not (string-match "\\s-" (buffer-substring (1- (point)) (point)))) (insert " ")) (insert presentation-text) (slime-after-change-function (point) (point)) (when (and (not (eolp)) (not (looking-at "\\s-"))) (insert " "))))) (defun slime-copy-presentation-to-kill-ring (presentation start end buffer) (let ((presentation-text (with-current-buffer buffer (buffer-substring start end)))) (kill-new presentation-text) (message "Saved presentation \"%s\" to kill ring" presentation-text))) (defun slime-copy-presentation-at-mouse-to-kill-ring (event) (interactive "e") (multiple-value-bind (presentation start end buffer) (slime-presentation-around-click event) (slime-copy-presentation-to-kill-ring presentation start end buffer))) (defun slime-copy-presentation-at-point-to-kill-ring (point) (interactive "d") (multiple-value-bind (presentation start end) (slime-presentation-around-or-before-point-or-error point) (slime-copy-presentation-to-kill-ring presentation start end (current-buffer)))) (defun slime-describe-presentation (presentation) (slime-eval-describe `(swank::describe-to-string (swank:lookup-presented-object ',(slime-presentation-id presentation))))) (defun slime-describe-presentation-at-mouse (event) (interactive "@e") (multiple-value-bind (presentation) (slime-presentation-around-click event) (slime-describe-presentation presentation))) (defun slime-describe-presentation-at-point (point) (interactive "d") (multiple-value-bind (presentation) (slime-presentation-around-or-before-point-or-error point) (slime-describe-presentation presentation))) (defun slime-pretty-print-presentation (presentation) (slime-eval-describe `(swank::swank-pprint (cl:list (swank:lookup-presented-object ',(slime-presentation-id presentation)))))) (defun slime-pretty-print-presentation-at-mouse (event) (interactive "@e") (multiple-value-bind (presentation) (slime-presentation-around-click event) (slime-pretty-print-presentation presentation))) (defun slime-pretty-print-presentation-at-point (point) (interactive "d") (multiple-value-bind (presentation) (slime-presentation-around-or-before-point-or-error point) (slime-pretty-print-presentation presentation))) (defun slime-mark-presentation (point) (interactive "d") (multiple-value-bind (presentation start end) (slime-presentation-around-or-before-point-or-error point) (goto-char start) (push-mark end nil t))) (defun slime-previous-presentation (&optional arg) "Move point to the beginning of the first presentation before point. With ARG, do this that many times. A negative argument means move forward instead." (interactive "p") (unless arg (setq arg 1)) (slime-next-presentation (- arg))) (defun slime-next-presentation (&optional arg) "Move point to the beginning of the next presentation after point. With ARG, do this that many times. A negative argument means move backward instead." (interactive "p") (unless arg (setq arg 1)) (cond ((plusp arg) (dotimes (i arg) ;; First skip outside the current surrounding presentation (if any) (multiple-value-bind (presentation start end) (slime-presentation-around-point (point)) (when presentation (goto-char end))) (let ((p (next-single-property-change (point) 'slime-repl-presentation))) (unless p (error "No next presentation")) (multiple-value-bind (presentation start end) (slime-presentation-around-or-before-point-or-error p) (goto-char start))))) ((minusp arg) (dotimes (i (- arg)) ;; First skip outside the current surrounding presentation (if any) (multiple-value-bind (presentation start end) (slime-presentation-around-point (point)) (when presentation (goto-char start))) (let ((p (previous-single-property-change (point) 'slime-repl-presentation))) (unless p (error "No previous presentation")) (multiple-value-bind (presentation start end) (slime-presentation-around-or-before-point-or-error p) (goto-char start))))))) (define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse) (define-key slime-presentation-map [mouse-3] 'slime-presentation-menu) (when (featurep 'xemacs) (define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse) (define-key slime-presentation-map [button3] 'slime-presentation-menu)) ;; protocol for handling up a menu. ;; 1. Send lisp message asking for menu choices for this object. ;; Get back list of strings. ;; 2. Let used choose ;; 3. Call back to execute menu choice, passing nth and string of choice (defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda) "Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'." (let* ((what (slime-presentation-id presentation)) (choices (with-current-buffer buffer (slime-eval `(swank::menu-choices-for-presentation-id ',what))))) (cl-labels ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name (let ((sym (cl-gensym))) (setf (gethash sym choice-to-lambda) f) sym))) (etypecase choices (list `(,(format "Presentation %s" (truncate-string-to-width (slime-presentation-text presentation) 30 nil nil t)) ("" ("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse)) ("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse)) ("Describe" . ,(savel 'slime-describe-presentation-at-mouse)) ("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse)) ("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl)) ("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring)) ,@(unless buffer-read-only `(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point)))) ,@(let ((nchoice 0)) (mapcar (lambda (choice) (incf nchoice) (cons choice (savel `(lambda () (interactive) (slime-eval '(swank::execute-menu-choice-for-presentation-id ',what ,nchoice ,(nth (1- nchoice) choices))))))) choices))))) (symbol ; not-present (with-current-buffer buffer (slime-remove-presentation-properties from to presentation)) (sit-for 0) ; allow redisplay `("Object no longer recorded" ("sorry" . ,(if (featurep 'xemacs) nil '(nil))))))))) (defun slime-presentation-menu (event) (interactive "e") (let* ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event)))) (window (if (featurep 'xemacs) (event-window event) (caadr event))) (buffer (window-buffer window)) (choice-to-lambda (make-hash-table))) (multiple-value-bind (presentation from to) (with-current-buffer buffer (slime-presentation-around-point point)) (unless presentation (error "No presentation at event position")) (let ((menu (slime-menu-choices-for-presentation presentation buffer from to choice-to-lambda))) (let ((choice (x-popup-menu event menu))) (when choice (call-interactively (gethash choice choice-to-lambda)))))))) (defun slime-presentation-expression (presentation) "Return a string that contains a CL s-expression accessing the presented object." (let ((id (slime-presentation-id presentation))) (etypecase id (number ;; Make sure it works even if *read-base* is not 10. (format "(swank:lookup-presented-object-or-lose %d.)" id)) (list ;; for frame variables and inspector parts (format "(swank:lookup-presented-object-or-lose '%s)" id))))) (defun slime-buffer-substring-with-reified-output (start end) (let ((str-props (buffer-substring start end)) (str-no-props (buffer-substring-no-properties start end))) (slime-reify-old-output str-props str-no-props))) (defun slime-reify-old-output (str-props str-no-props) (let ((pos (slime-property-position 'slime-repl-presentation str-props))) (if (null pos) str-no-props (multiple-value-bind (presentation start-pos end-pos whole-p) (slime-presentation-around-point pos str-props) (if (not presentation) str-no-props (concat (substring str-no-props 0 pos) ;; Eval in the reader so that we play nice with quote. ;; -luke (19/May/2005) "#." (slime-presentation-expression presentation) (slime-reify-old-output (substring str-props end-pos) (substring str-no-props end-pos)))))))) (defun slime-repl-grab-old-output (replace) "Resend the old REPL output at point. If replace it non-nil the current input is replaced with the old output; otherwise the new input is appended." (multiple-value-bind (presentation beg end) (slime-presentation-around-or-before-point (point)) (slime-check-presentation beg end (current-buffer) presentation) (let ((old-output (buffer-substring beg end))) ;;keep properties ;; Append the old input or replace the current input (cond (replace (goto-char slime-repl-input-start-mark)) (t (goto-char (point-max)) (unless (eq (char-before) ?\ ) (insert " ")))) (delete-region (point) (point-max)) (let ((inhibit-read-only t)) (insert old-output))))) ;;; Presentation-related key bindings, non-context menu (defvar slime-presentation-command-map nil "Keymap for presentation-related commands. Bound to a prefix key.") (defvar slime-presentation-bindings '((?i slime-inspect-presentation-at-point) (?d slime-describe-presentation-at-point) (?w slime-copy-presentation-at-point-to-kill-ring) (?r slime-copy-presentation-at-point-to-repl) (?p slime-previous-presentation) (?n slime-next-presentation) (?\ slime-mark-presentation))) (defun slime-presentation-init-keymaps () (slime-init-keymap 'slime-presentation-command-map nil t slime-presentation-bindings) (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations) ;; C-c C-v is the prefix for the presentation-command map. (define-key slime-prefix-map "\C-v" slime-presentation-command-map)) (defun slime-presentation-around-or-before-point-p () (multiple-value-bind (presentation beg end) (slime-presentation-around-or-before-point (point)) presentation)) (defvar slime-presentation-easy-menu (let ((P '(slime-presentation-around-or-before-point-p))) `("Presentations" [ "Find Definition" slime-M-.-presentation-at-point ,P ] [ "Inspect" slime-inspect-presentation-at-point ,P ] [ "Describe" slime-describe-presentation-at-point ,P ] [ "Pretty-print" slime-pretty-print-presentation-at-point ,P ] [ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ] [ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ] [ "Mark" slime-mark-presentation ,P ] "--" [ "Previous presentation" slime-previous-presentation ] [ "Next presentation" slime-next-presentation ] "--" [ "Clear all presentations" slime-clear-presentations ]))) (defun slime-presentation-add-easy-menu () (easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu) (easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu) (easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu) (easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu) (easy-menu-add slime-presentation-easy-menu 'slime-mode-map) (easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map) (easy-menu-add slime-presentation-easy-menu 'sldb-mode-map) (easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map)) ;;; hook functions (hard to isolate stuff) (defun slime-dispatch-presentation-event (event) (slime-dcase event ((:presentation-start id &optional target) (slime-mark-presentation-start id target) t) ((:presentation-end id &optional target) (slime-mark-presentation-end id target) t) (t nil))) (defun slime-presentation-write-result (string) (with-current-buffer (slime-output-buffer) (let ((marker (slime-output-target-marker :repl-result)) (saved-point (point-marker))) (goto-char marker) (slime-propertize-region `(face slime-repl-result-face rear-nonsticky (face)) (insert string)) ;; Move the input-start marker after the REPL result. (set-marker marker (point)) (set-marker slime-output-end (point)) ;; Restore point before insertion but only it if was farther ;; than `marker'. Omitting this breaks REPL test ;; `repl-type-ahead'. (when (> saved-point (point)) (goto-char saved-point))) (slime-repl-show-maximum-output))) (defun slime-presentation-write (string &optional target) (case target ((nil) ; Regular process output (slime-repl-emit string)) (:repl-result (slime-presentation-write-result string)) (t (slime-emit-to-target string target)))) (defun slime-presentation-current-input (&optional until-point-p) "Return the current input as string. The input is the region from after the last prompt to the end of buffer. Presentations of old results are expanded into code." (slime-buffer-substring-with-reified-output slime-repl-input-start-mark (if until-point-p (point) (point-max)))) (defun slime-presentation-on-return-pressed (end-of-input) (when (and (car (slime-presentation-around-or-before-point (point))) (< (point) slime-repl-input-start-mark)) (slime-repl-grab-old-output end-of-input) (slime-repl-recenter-if-needed) t)) (defun slime-presentation-bridge-insert (process output) (slime-output-filter process (or output ""))) (defun slime-presentation-on-stream-open (stream) (install-bridge) (setq bridge-insert-function #'slime-presentation-bridge-insert) (setq bridge-destination-insert nil) (setq bridge-source-insert nil) (setq bridge-handlers (list* '("<" . slime-mark-presentation-start-handler) '(">" . slime-mark-presentation-end-handler) bridge-handlers))) (defun slime-clear-presentations () "Forget all objects associated to SLIME presentations. This allows the garbage collector to remove these objects even on Common Lisp implementations without weak hash tables." (interactive) (slime-eval-async `(swank:clear-repl-results)) (unless (eql major-mode 'slime-repl-mode) (slime-switch-to-output-buffer)) (slime-for-each-presentation-in-region 1 (1+ (buffer-size)) (lambda (presentation from to whole-p) (slime-remove-presentation-properties from to presentation)))) (defun slime-presentation-inspector-insert-ispec (ispec) (if (stringp ispec) (insert ispec) (slime-dcase ispec ((:value string id) (slime-propertize-region (list 'slime-part-number id 'mouse-face 'highlight 'face 'slime-inspector-value-face) (slime-insert-presentation string `(:inspected-part ,id) t))) ((:label string) (insert (slime-inspector-fontify label string))) ((:action string id) (slime-insert-propertized (list 'slime-action-number id 'mouse-face 'highlight 'face 'slime-inspector-action-face) string))))) (defun slime-presentation-sldb-insert-frame-variable-value (value frame index) (slime-insert-presentation (sldb-in-face local-value value) `(:frame-var ,slime-current-thread ,(car frame) ,index) t)) (defun slime-presentations-on-connected () (slime-eval-async `(swank:init-presentations))) (provide 'slime-presentations) slime-2.20/contrib/slime-quicklisp.el000066400000000000000000000032411315100173500176370ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) ;;; bits of the following taken from slime-asdf.el (define-slime-contrib slime-quicklisp "Quicklisp support." (:authors "Matthew Kennedy ") (:license "GPL") (:slime-dependencies slime-repl) (:swank-dependencies swank-quicklisp)) ;;; Utilities (defgroup slime-quicklisp nil "Quicklisp support for Slime." :prefix "slime-quicklisp-" :group 'slime) (defvar slime-quicklisp-system-history nil "History list for Quicklisp system names.") (defun slime-read-quicklisp-system-name (&optional prompt default-value) "Read a Quick system name from the minibuffer, prompting with PROMPT." (let* ((completion-ignore-case nil) (prompt (or prompt "Quicklisp system")) (quicklisp-system-names (slime-eval `(swank:list-quicklisp-systems))) (prompt (concat prompt (if default-value (format " (default `%s'): " default-value) ": ")))) (completing-read prompt (slime-bogus-completion-alist quicklisp-system-names) nil nil nil 'slime-quicklisp-system-history default-value))) (defun slime-quicklisp-quickload (system) "Load a Quicklisp system." (slime-save-some-lisp-buffers) (slime-display-output-buffer) (slime-repl-shortcut-eval-async `(ql:quickload ,system))) ;;; REPL shortcuts (defslime-repl-shortcut slime-repl-quicklisp-quickload ("quicklisp-quickload" "ql") (:handler (lambda () (interactive) (slime-quicklisp-quickload (slime-read-quicklisp-system-name)))) (:one-liner "Load a system known to Quicklisp.")) (provide 'slime-quicklisp) slime-2.20/contrib/slime-references.el000066400000000000000000000125271315100173500177630ustar00rootroot00000000000000(require 'slime) (require 'advice) (require 'slime-compiler-notes-tree) ; FIXME: actually only uses the tree bits, so that should be a library. (define-slime-contrib slime-references "Clickable references to documentation (SBCL only)." (:authors "Christophe Rhodes " "Luke Gorrie " "Tobias C. Rittweiler ") (:license "GPL") (:on-load (ad-enable-advice 'slime-note.message 'after 'slime-note.message+references) (ad-activate 'slime-note.message) (setq slime-tree-printer 'slime-tree-print-with-references) (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)) (:on-unload (ad-disable-advice 'slime-note.message 'after 'slime-note.message+references) (ad-deactivate 'slime-note.message) (setq slime-tree-printer 'slime-tree-default-printer) (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))) (defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/" "*The base URL of the SBCL manual, for documentation lookup." :type 'string :group 'slime-mode) (defface sldb-reference-face (list (list t '(:underline t))) "Face for references." :group 'slime-debugger) ;;;;; SBCL-style references (defvar slime-references-local-keymap (let ((map (make-sparse-keymap "local keymap for slime references"))) (define-key map [mouse-2] 'slime-lookup-reference-at-mouse) (define-key map [return] 'slime-lookup-reference-at-point) map)) (defun slime-reference-properties (reference) "Return the properties for a reference. Only add clickability to properties we actually know how to lookup." (cl-destructuring-bind (where type what) reference (if (or (and (eq where :sbcl) (eq type :node)) (and (eq where :ansi-cl) (memq type '(:function :special-operator :macro :type :system-class :section :glossary :issue)))) `(slime-reference ,reference font-lock-face sldb-reference-face follow-link t mouse-face highlight help-echo "mouse-2: visit documentation." keymap ,slime-references-local-keymap)))) (defun slime-insert-reference (reference) "Insert documentation reference from a condition. See SWANK-BACKEND:CONDITION-REFERENCES for the datatype." (cl-destructuring-bind (where type what) reference (insert "\n" (slime-format-reference-source where) ", ") (slime-insert-propertized (slime-reference-properties reference) (slime-format-reference-node what)) (insert (format " [%s]" type)))) (defun slime-insert-references (references) (when references (insert "\nSee also:") (slime-with-rigid-indentation 2 (mapc #'slime-insert-reference references)))) (defun slime-format-reference-source (where) (cl-case where (:amop "The Art of the Metaobject Protocol") (:ansi-cl "Common Lisp Hyperspec") (:sbcl "SBCL Manual") (t (format "%S" where)))) (defun slime-format-reference-node (what) (if (listp what) (mapconcat #'prin1-to-string what ".") what)) (defun slime-lookup-reference-at-point () "Browse the documentation reference at point." (interactive) (let ((refs (get-text-property (point) 'slime-reference))) (if (null refs) (error "No references at point") (cl-destructuring-bind (where type what) refs (cl-case where (:ansi-cl (cl-case type (:section (browse-url (funcall common-lisp-hyperspec-section-fun what))) (:glossary (browse-url (funcall common-lisp-hyperspec-glossary-function what))) (:issue (browse-url (funcall 'common-lisp-issuex what))) (t (hyperspec-lookup what)))) (t (let ((url (format "%s#%s" slime-sbcl-manual-root (subst-char-in-string ?\ ?\- what)))) (browse-url url)))))))) (defun slime-lookup-reference-at-mouse (event) "Invoke the action pointed at by the mouse." (interactive "e") (cl-destructuring-bind (mouse-1 (w pos . _) . _) event (save-excursion (goto-char pos) (slime-lookup-reference-at-point)))) ;;;;; Hook into *SLIME COMPILATION* (defun slime-note.references (note) (plist-get note :references)) ;;; FIXME: `compilation-mode' will swallow the `mouse-face' ;;; etc. properties. (defadvice slime-note.message (after slime-note.message+references) (setq ad-return-value (concat ad-return-value (with-temp-buffer (slime-insert-references (slime-note.references (ad-get-arg 0))) (buffer-string))))) ;;;;; Hook into slime-compiler-notes-tree (defun slime-tree-print-with-references (tree) ;; for SBCL-style references (slime-tree-default-printer tree) (let ((note (plist-get (slime-tree.plist tree) 'note))) (when note (let ((references (slime-note.references note))) (when references (terpri (current-buffer)) (slime-insert-references references)))))) ;;;;; Hook into SLDB (defun sldb-maybe-insert-references (extra) (slime-dcase extra ((:references references) (slime-insert-references references) t) (t nil))) (provide 'slime-references) slime-2.20/contrib/slime-repl.el000066400000000000000000002056501315100173500166050ustar00rootroot00000000000000;;; slime-repl.el --- ;; ;; Original Author: Helmut Eller ;; Contributors: too many to mention ;; License: GNU GPL (same license as Emacs) ;; ;;; Description: ;; ;; ;;; Installation: ;; ;; Call slime-setup and include 'slime-repl as argument: ;; ;; (slime-setup '(slime-repl [others conribs ...])) ;; (require 'slime) (require 'slime-parse) (require 'cl-lib) (eval-when-compile (require 'cl)) ; slime-def-connection-var, which ; expands to defsetf not in cl-lib (define-slime-contrib slime-repl "Read-Eval-Print Loop written in Emacs Lisp. This contrib implements a Lisp Listener along with some niceties like a persistent history and various \"shortcut\" commands. Nothing here depends on comint.el; I/O is multiplexed over SLIME's socket. This used to be the default REPL for SLIME, but it was hard to maintain." (:authors "too many to mention") (:license "GPL") (:on-load (slime-repl-add-hooks) (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package)) (:on-unload (slime-repl-remove-hooks)) (:swank-dependencies swank-repl)) ;;;;; 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-auto-right-margin nil "When T we bind CL:*PRINT-RIGHT-MARGIN* to the width of the current repl's (as per slime-output-buffer) window." :type '(boolean) :group 'slime-repl) (defface slime-repl-prompt-face '((t (:inherit font-lock-keyword-face))) "Face for the prompt in the SLIME REPL." :group 'slime-repl) (defface slime-repl-output-face '((t (:inherit font-lock-string-face))) "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) (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) ;; 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)) ;;;; 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) (setq slime-buffer-package (slime-lisp-package 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) (slime-move-point (point-max)) (slime-mark-output-start) (slime-mark-input-start) (slime-repl-insert-prompt)) (defun slime-repl-insert-banner () (when (zerop (buffer-size)) (let ((welcome (concat "; SLIME " slime-version))) (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))) (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))) (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 coding-system) (let ((stream (open-network-stream "*lisp-output-stream*" (slime-with-connection-buffer () (current-buffer)) (car (process-contact (slime-connection))) port)) (emacs-coding-system (car (cl-find coding-system slime-net-valid-coding-systems :key #'cl-third)))) (slime-set-query-on-exit-flag stream) (set-process-filter stream 'slime-output-filter) (set-process-coding-system stream emacs-coding-system emacs-coding-system) (let ((secret (slime-secret))) (when 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)) (switch-to-buffer (slime-output-buffer)) (delete-other-windows) (sit-for 0) (slime-repl-send-string "(swank:io-speed-test 4000 1)") (let ((proc (slime-inferior-process))) (when proc (display-buffer (process-buffer proc) t) (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)) (t (slime-emit-to-target string target)))) (defvar slime-repl-popup-on-output nil "Display the output buffer when some output is written. This is set to nil after displaying the buffer.") (defmacro slime-save-marker (marker &rest body) (declare (debug (sexp &rest form))) (let ((pos (cl-gensym "pos"))) `(let ((,pos (marker-position ,marker))) (prog1 (progn . ,body) (set-marker ,marker ,pos))))) (put 'slime-save-marker 'lisp-indent-function 1) (defun slime-repl-emit (string) ;; insert the string STRING in the output buffer (with-current-buffer (slime-output-buffer) (save-excursion (goto-char slime-output-end) (slime-save-marker slime-output-start (slime-propertize-region '(face slime-repl-output-face slime-repl-output t rear-nonsticky (face)) (let ((inhibit-read-only t)) (insert-before-markers string) (when (and (= (point) slime-repl-prompt-start-mark) (not (bolp))) (insert-before-markers "\n") (set-marker slime-output-end (1- (point)))))))) (when slime-repl-popup-on-output (setq slime-repl-popup-on-output nil) (display-buffer (current-buffer))) (slime-repl-show-maximum-output))) (defun slime-repl-emit-result (string &optional bol) ;; insert STRING and mark it as evaluation result (with-current-buffer (slime-output-buffer) (save-excursion (goto-char slime-repl-input-start-mark) (slime-save-marker slime-output-start (goto-char slime-repl-input-start-mark) (when (and bol (not (bolp))) (insert-before-markers-and-inherit "\n")) (slime-save-marker slime-output-end (slime-propertize-region `(face slime-repl-result-face rear-nonsticky (face)) (insert-before-markers string))) (set-marker slime-output-end (point)))) (slime-repl-show-maximum-output))) (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-to-target (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 () "Select the output buffer, when possible in an existing window. Hint: You can use `display-buffer-reuse-frames' and `special-display-buffer-names' to customize the frame in which the buffer should appear." (interactive) (pop-to-buffer (slime-output-buffer)) (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 point-max ;; ;; input-start is a right inserting marker, because ;; we want it to stay behind when the user inserts text. ;; ;; We maintain the following invariant: ;; ;; output-start <= output-end <= input-start. ;; ;; 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 insert at that point, we must move the right markers. We should ;; also not leave (window-)point in the middle of the new output. The ;; idiom we use is a combination to slime-save-marker, ;; insert-before-markers, and manually updating window-point ;; afterwards. ;; ;; A "synchronous" evaluation request proceeds as follows: the user ;; inserts some text between input-start and point-max and then hits ;; return. We send that region 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. See `slime-repl-insert-prompt'. ;; ;; 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). ;; ;; 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. ;; ;; FIXME: slime-lisp-package should be local in a REPL buffer (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-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-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)) (set markname (make-marker)) (set-marker (symbol-value markname) (point)))) ;;;;; REPL mode setup (defvar slime-repl-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map lisp-mode-map) map)) (slime-define-keys slime-prefix-map ("\C-z" 'slime-switch-to-output-buffer) ("\M-p" 'slime-repl-set-package)) (slime-define-keys slime-mode-map ("\C-c~" 'slime-sync-package-and-default-directory) ("\C-c\C-y" 'slime-call-defun) ("\C-c\C-j" 'slime-eval-last-expression-in-repl)) (slime-define-keys slime-connection-list-mode-map ((kbd "RET") 'slime-goto-connection) ([return] 'slime-goto-connection)) (slime-define-keys slime-repl-mode-map ("\C-m" 'slime-repl-return) ([return] 'slime-repl-return) ("\C-j" 'slime-repl-newline-and-indent) ("\C-\M-m" 'slime-repl-closing-return) ([(control return)] 'slime-repl-closing-return) ("\M-p" 'slime-repl-previous-input) ((kbd "C-") 'slime-repl-backward-input) ("\M-n" 'slime-repl-next-input) ((kbd "C-") 'slime-repl-forward-input) ("\M-r" 'slime-repl-previous-matching-input) ("\M-s" 'slime-repl-next-matching-input) ("\C-c\C-c" 'slime-interrupt) (" " 'slime-space) ((string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut) ("\C-c\C-o" 'slime-repl-clear-output) ("\C-c\M-o" '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-z" 'slime-nop) ("\C-cI" 'slime-repl-inspect)) (slime-define-keys slime-inspector-mode-map ((kbd "M-RET") 'slime-inspector-copy-down-to-repl)) (slime-define-keys sldb-mode-map ("\C-y" 'sldb-insert-frame-call-to-repl) ((kbd "M-RET") 'sldb-copy-down-to-repl)) (def-slime-selector-method ?r "SLIME Read-Eval-Print-Loop." (slime-output-buffer)) (define-minor-mode slime-repl-map-mode "Minor mode which makes slime-repl-mode-map available. \\{slime-repl-mode-map}" nil nil slime-repl-mode-map) (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) (slime-editing-mode 1) (slime-repl-map-mode 1) (lisp-mode-variables t) (set (make-local-variable 'lisp-indent-function) 'common-lisp-indent-function) (slime-setup-completion) (set (make-local-variable 'tab-always-indent) 'complete) (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) (when slime-repl-history-file (slime-repl-safe-load-history) (add-hook 'kill-buffer-hook 'slime-repl-safe-save-merged-history 'append t)) (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories) ;; 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-mode-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) (current-buffer)) (defun slime-repl-mode-beginning-of-defun (&optional arg) (if (and arg (< arg 0)) (slime-repl-mode-end-of-defun (- arg)) (dotimes (i (or arg 1)) (slime-repl-previous-prompt)))) (defun slime-repl-mode-end-of-defun (&optional arg) (if (and arg (< arg 0)) (slime-repl-mode-beginning-of-defun (- arg)) (dotimes (i (or arg 1)) (slime-repl-next-prompt)))) (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 () ((if slime-repl-auto-right-margin `(swank-repl:listener-eval ,string :window-width ,(with-current-buffer (slime-output-buffer) (window-width))) `(swank-repl:listener-eval ,string)) (slime-lisp-package)) ((:ok result) (slime-repl-insert-result result)) ((:abort condition) (slime-repl-show-abort condition)))) (defun slime-repl-insert-result (result) (with-current-buffer (slime-output-buffer) (save-excursion (when result (slime-dcase result ((:values &rest strings) (cond ((null strings) (slime-repl-emit-result "; No value\n" t)) (t (dolist (s strings) (slime-repl-emit-result s t))))))) (slime-repl-insert-prompt)) (slime-repl-show-maximum-output))) (defun slime-repl-show-abort (condition) (with-current-buffer (slime-output-buffer) (save-excursion (slime-save-marker slime-output-start (slime-save-marker slime-output-end (goto-char slime-output-end) (insert-before-markers (format "; Evaluation aborted on %s.\n" condition)) (slime-repl-insert-prompt)))) (slime-repl-show-maximum-output))) (defvar slime-repl-suppress-prompt nil "Supresses Slime REPL prompt when bound to T.") (defun slime-repl-insert-prompt () "Insert the prompt (before markers!). Set point after the prompt. Return the position of the prompt beginning. If `slime-repl-suppress-prompt' is true, does nothing and returns nil." (goto-char slime-repl-input-start-mark) (unless slime-repl-suppress-prompt (slime-save-marker slime-output-start (slime-save-marker slime-output-end (unless (bolp) (insert-before-markers "\n")) (let ((prompt-start (point)) (prompt (format "%s> " (slime-lisp-package-prompt-string)))) (slime-propertize-region '(face slime-repl-prompt-face read-only t slime-repl-prompt t rear-nonsticky t front-sticky (read-only) inhibit-line-move-field-capture t field output) (insert-before-markers prompt)) (set-marker slime-repl-prompt-start-mark prompt-start) (setq buffer-undo-list nil) prompt-start))))) (defun slime-repl-show-maximum-output () "Put the end of the buffer at the bottom of the window." (when (eobp) (let ((win (if (eq (window-buffer) (current-buffer)) (selected-window) (get-buffer-window (current-buffer) t)))) (when win (with-selected-window win (set-window-point win (point-max)) (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 until-point-p (point) (point-max))))) (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-input-start-mark (point) (current-buffer))) (defun slime-mark-output-start () (set-marker slime-output-start (point)) (set-marker slime-output-end (point))) (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-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 () (<= slime-repl-input-start-mark (point))) (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) ;; FIXME: this looks very strange (defun slime-repl-end-of-defun () "Move to next of defun." (interactive) ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN. (if (and (not (= (point) (point-max))) (slime-repl-in-input-area-p)) (goto-char (point-max)) (end-of-defun)) t) (defun slime-repl-previous-prompt () "Move backward to the previous prompt." (interactive) (slime-repl-find-prompt t)) (defun slime-repl-next-prompt () "Move forward to the next prompt." (interactive) (slime-repl-find-prompt)) (defun slime-repl-find-prompt (&optional backward) (let ((origin (point)) (prop 'slime-repl-prompt)) (while (progn (slime-search-property-change prop backward) (not (or (slime-end-of-proprange-p prop) (bobp) (eobp))))) (unless (slime-end-of-proprange-p prop) (goto-char origin)))) (defun slime-search-property-change (prop &optional backward) (cond (backward (goto-char (or (previous-single-char-property-change (point) prop) (point-min)))) (t (goto-char (or (next-single-char-property-change (point) prop) (point-max)))))) (defun slime-end-of-proprange-p (property) (and (get-char-property (max 1 (1- (point))) property) (not (get-char-property (point) property)))) (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 only 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) (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 end-of-input)) ((slime-input-complete-p slime-repl-input-start-mark (point-max)) (slime-repl-send-input t)) (t (slime-repl-newline-and-indent) (message "[input not complete]")))) (defun slime-repl-recenter-if-needed () "Make sure that (point) is visible." (unless (pos-visible-in-window-p (point-max)) (save-excursion (goto-char (point-max)) (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." (unless (slime-repl-in-input-area-p) (error "No input at point.")) (goto-char (point-max)) (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-modification-hooks 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 'face 'slime-repl-input-face))) (let ((input (slime-repl-current-input))) (goto-char (point-max)) (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 (point-max)) (unless (eq (char-before) ?\ ) (insert " ")))) (delete-region (point) (point-max)) (save-excursion (insert old-input) (when (equal (char-before) ?\n) (delete-char -1))) (forward-char offset)))) (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 all text from the prompt." (interactive) (delete-region slime-repl-input-start-mark (point-max))) (defun slime-eval-last-expression-in-repl (prefix) "Evaluates last expression in the Slime REPL. Switches REPL to current package of the source buffer for the duration. If used with a prefix argument (C-u), doesn't switch back afterwards." (interactive "P") (let ((expr (slime-last-expression)) (buffer-name (buffer-name (current-buffer))) (new-package (slime-current-package)) (old-package (slime-lisp-package)) (slime-repl-suppress-prompt t) (yank-back nil)) (with-current-buffer (slime-output-buffer) (unless (eq (current-buffer) (window-buffer)) (pop-to-buffer (current-buffer) t)) (goto-char (point-max)) ;; Kill pending input in the REPL (when (< (marker-position slime-repl-input-start-mark) (point)) (kill-region slime-repl-input-start-mark (point)) (setq yank-back t)) (unwind-protect (progn (insert-before-markers (format "\n;;; from %s\n" buffer-name)) (when new-package (slime-repl-set-package new-package)) (let ((slime-repl-suppress-prompt nil)) (slime-repl-insert-prompt)) (insert expr) (slime-repl-return)) (unless (or prefix (equal (slime-lisp-package) old-package)) ;; Switch back. (slime-repl-set-package old-package) (let ((slime-repl-suppress-prompt nil)) (slime-repl-insert-prompt)))) ;; Put pending input back. (when yank-back (yank))))) (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) (let ((inhibit-field-text-motion t)) (line-beginning-position)))) (defun slime-clear-repl-variables () (interactive) (slime-eval-async `(swank-repl:clear-repl-variables))) (defvar slime-repl-clear-buffer-hook) (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-repl-variables) (defun slime-repl-clear-buffer () "Delete the output generated by the Lisp process." (interactive) (let ((inhibit-read-only t)) (delete-region (point-min) slime-repl-prompt-start-mark) (delete-region slime-output-start slime-output-end) (when (< (point) slime-repl-input-start-mark) (goto-char slime-repl-input-start-mark)) (recenter t)) (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 (when (>= (point) slime-repl-input-start-mark) (goto-char slime-repl-input-start-mark)) (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-repl-set-package (package) "Set the package of the REPL buffer to PACKAGE." (interactive (list (let* ((p (slime-current-package)) (p (and p (slime-pretty-package-name p))) (p (and (not (equal p (slime-lisp-package))) p))) (slime-read-package-name "Package: " p)))) (with-current-buffer (slime-output-buffer) (let ((previouse-point (- (point) slime-repl-input-start-mark)) (previous-prompt (slime-lisp-package-prompt-string))) (destructuring-bind (name prompt-string) (slime-repl-shortcut-eval `(swank:set-package ,package)) (setf (slime-lisp-package) name) (setf slime-buffer-package name) (unless (equal previous-prompt prompt-string) (setf (slime-lisp-package-prompt-string) prompt-string) (slime-repl-insert-prompt)) (when (plusp previouse-point) (goto-char (+ previouse-point slime-repl-input-start-mark))))))) ;;;;; History (defcustom slime-repl-wrap-history nil "*T to wrap history around when the end is reached." :type 'boolean :group 'slime-repl) (defcustom slime-repl-history-remove-duplicates nil "*When T all duplicates are removed except the last one." :type 'boolean :group 'slime-repl) (defcustom slime-repl-history-trim-whitespaces nil "*When T strip all whitespaces from the beginning and end." :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." (when slime-repl-history-trim-whitespaces (setq string (slime-trim-whitespace string))) (unless (equal string "") (when slime-repl-history-remove-duplicates (setq slime-repl-input-history (remove string slime-repl-input-history))) (unless (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) "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." (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 "") (slime-repl-current-input))) (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")))) ;;(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 &optional exclude-string) "Return the position of the history item matching REGEXP. Return -1 resp. the length of the history if no item matches. If EXCLUDE-STRING is specified then it's excluded from the search." ;; 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 for history-item = (nth pos history) if (and (string-match regexp history-item) (not (equal history-item exclude-string))) 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))) (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))) (defun slime-repl-forward-input () "Cycle forwards through input history." (interactive) (slime-repl-history-replace 'forward (slime-repl-history-pattern))) (defun slime-repl-backward-input () "Cycle backwards through input history." (interactive) (slime-repl-history-replace 'backward (slime-repl-history-pattern))) (defun slime-repl-previous-matching-input (regexp) (interactive (list (slime-read-from-minibuffer "Previous element matching (regexp): "))) (slime-repl-terminate-history-search) (slime-repl-history-replace 'backward regexp)) (defun slime-repl-next-matching-input (regexp) (interactive (list (slime-read-from-minibuffer "Next 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 (goto-char (max slime-repl-input-start-mark (point))) (let ((str (slime-repl-current-input t))) (cond ((string-match "^[ \t\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-read-history nil t) slime-repl-input-history))) (setq slime-repl-input-history (cl-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 (cl-remove-if test new-hist) (cl-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 (cl-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 (defvar slime-repl-read-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-m" 'slime-repl-return) (define-key map [return] 'slime-repl-return) (define-key map (kbd "TAB") 'self-insert-command) (define-key map "\C-c\C-b" 'slime-repl-read-break) (define-key map "\C-c\C-c" 'slime-repl-read-break) (define-key map [remap slime-indent-and-complete-symbol] 'ignore) (define-key map [remap slime-handle-repl-shortcut] 'self-insert-command) map)) (define-minor-mode slime-repl-read-mode "Mode to read input from Emacs \\{slime-repl-read-mode-map}" nil "[read]") (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-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 (cl-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.") (defvar slime-within-repl-shortcut-handler-p nil "Bound to T if we're in a REPL shortcut handler invoked from the REPL.") (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)))) (with-struct (slime-repl-shortcut. handler) shortcut (let ((slime-within-repl-shortcut-handler-p t)) (call-interactively handler)))))) (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) (cl-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 plist specifying the handler doing the actual work of the shortcut \(`:handler'\), and a help text \(`:one-liner'\)." `(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 (cl-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-repl-shortcut-eval (sexp &optional package) "This function should be used by REPL shortcut handlers instead of `slime-eval' to evaluate their final expansion. (This expansion will be added to the REPL's history.)" (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo? (slime-repl-add-to-input-history (prin1-to-string sexp))) (slime-eval sexp package)) (defun slime-repl-shortcut-eval-async (sexp &optional cont package) "This function should be used by REPL shortcut handlers instead of `slime-eval-async' to evaluate their final expansion. (This expansion will be added to the REPL's history.)" (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo? (slime-repl-add-to-input-history (prin1-to-string sexp))) (slime-eval-async sexp cont package)) (defun slime-list-repl-short-cuts () (interactive) (slime-with-popup-buffer ((slime-buffer-name :repl-help)) (let ((table (cl-sort (cl-copy-list slime-repl-shortcut-table) #'string< :key (lambda (x) (car (slime-repl-shortcut.names x)))))) (save-excursion (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) ")")) (when (slime-repl-shortcut.one-liner shortcut) (insert "\n " (slime-repl-shortcut.one-liner shortcut))) (insert "\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))) (defun slime-kill-all-buffers () "Kill all the SLIME-related buffers." (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)))) (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 the current connection.")) (defslime-repl-shortcut slime-repl-disconnect-all ("disconnect-all") (:handler 'slime-disconnect-all) (: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 (lambda () (interactive) ;; `slime-quit-lisp' determines the connection to quit ;; on behalf of the REPL's `slime-buffer-connection'. (let ((repl-buffer (slime-output-buffer))) (slime-quit-lisp) (kill-buffer repl-buffer)))) (: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-repl-shortcut-eval-async `(swank:compile-file-if-needed ,(slime-to-lisp-filename filename) t) #'slime-compilation-finished))) (: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-redirect-inferior-output (&optional noerror) "Redirect output of the inferior-process to the REPL buffer." (interactive) (let ((proc (slime-inferior-process))) (cond (proc (let ((filter (slime-rcurry #'slime-inferior-output-filter (slime-current-connection)))) (set-process-filter proc filter))) (noerror) (t (error "No inferior lisp process"))))) (defun slime-inferior-output-filter (proc string conn) (cond ((eq (process-status conn) 'closed) (message "Connection closed. Removing inferior output filter.") (message "Lost output: %S" string) (set-process-filter proc nil)) (t (slime-output-filter conn string)))) (defun slime-redirect-trace-output () "Redirect the trace output to a separate Emacs buffer." (interactive) (let ((buffer (get-buffer-create (slime-buffer-name :trace)))) (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-repl: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-call-defun () "Insert a call to the toplevel form defined around point into the REPL." (interactive) (cl-labels ((insert-call (name &key (function t) defclass) (let* ((setf (and function (consp name) (= (length name) 2) (eql (car name) 'setf))) (symbol (if setf (cadr name) name)) (qualified-symbol-name (slime-qualify-cl-symbol-name symbol)) (symbol-name (slime-cl-symbol-name qualified-symbol-name)) (symbol-package (slime-cl-symbol-package qualified-symbol-name)) (call (if (cl-equalp (slime-lisp-package) symbol-package) symbol-name qualified-symbol-name))) (slime-switch-to-output-buffer) (goto-char slime-repl-input-start-mark) (insert (if function "(" " ")) (when setf (insert "setf (")) (if defclass (insert "make-instance '")) (insert call) (cond (setf (insert " ") (save-excursion (insert ") )"))) (function (insert " ") (save-excursion (insert ")")))) (unless function (goto-char slime-repl-input-start-mark))))) (let ((toplevel (slime-parse-toplevel-form))) (if (symbolp toplevel) (error "Not in a function definition") (slime-dcase toplevel (((:defun :defgeneric :defmacro :define-compiler-macro) symbol) (insert-call symbol)) ((:defmethod symbol &rest args) (declare (ignore args)) (insert-call symbol)) (((:defparameter :defvar :defconstant) symbol) (insert-call symbol :function nil)) (((:defclass) symbol) (insert-call symbol :defclass t)) (t (error "Not in a function definition"))))))) (defun slime-repl-copy-down-to-repl (slimefun &rest args) (slime-eval-async `(swank-repl:listener-save-value ',slimefun ,@args) #'(lambda (_ignored) (with-current-buffer (slime-repl) (slime-eval-async '(swank-repl:listener-get-value) #'(lambda (_ignored) (slime-repl-insert-prompt))))))) (defun slime-inspector-copy-down-to-repl (number) "Evaluate the inspector 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-copy-down-to-repl 'swank:inspector-nth-part number)) (defun sldb-copy-down-to-repl (frame-id var-id) "Evaluate the frame var at point via the REPL (to set `*')." (interactive (list (sldb-frame-number-at-point) (sldb-var-number-at-point))) (slime-repl-copy-down-to-repl 'swank/backend:frame-var-value frame-id var-id)) (defun sldb-insert-frame-call-to-repl () "Insert a call to a frame at point." (interactive) (let ((call (slime-eval `(swank/backend::frame-call ,(sldb-frame-number-at-point))))) (slime-switch-to-output-buffer) (if (>= (point) slime-repl-prompt-start-mark) (insert call) (save-excursion (goto-char (point-max)) (insert call)))) (slime-repl)) (defun slime-set-default-directory (directory) "Make DIRECTORY become Lisp's current directory." (interactive (list (read-directory-name "Directory: " nil nil t))) (let ((dir (expand-file-name directory))) (message "default-directory: %s" (slime-from-lisp-filename (slime-repl-shortcut-eval `(swank:set-default-directory ,(slime-to-lisp-filename dir))))) (with-current-buffer (slime-output-buffer) (setq default-directory dir)))) (defun slime-sync-package-and-default-directory () "Set Lisp's package and directory to the values in current buffer." (interactive) (let* ((package (slime-current-package)) (exists-p (or (null package) (slime-eval `(cl:packagep (swank::guess-package ,package))))) (directory default-directory)) (when (and package exists-p) (slime-repl-set-package package)) (slime-set-default-directory directory) ;; Sync *inferior-lisp* dir (let* ((proc (slime-process)) (buffer (and proc (process-buffer proc)))) (when (buffer-live-p buffer) (with-current-buffer buffer (setq default-directory directory)))) (message "package: %s%s directory: %s" (with-current-buffer (slime-output-buffer) (slime-lisp-package)) (if exists-p "" (format " (package %s doesn't exist)" package)) directory))) (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-repl-inside-string-or-comment-p () (save-restriction (when (and (boundp 'slime-repl-input-start-mark) slime-repl-input-start-mark (>= (point) slime-repl-input-start-mark)) (narrow-to-region slime-repl-input-start-mark (point))) (slime-inside-string-or-comment-p))) (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 ]))) (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-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 t))) (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)))))) (defun slime-repl-choose-coding-system () (let ((candidates (slime-connection-coding-systems))) (or (cl-find (symbol-name (car default-process-coding-system)) candidates :test (lambda (s1 s2) (if (fboundp 'coding-system-equal) (coding-system-equal (intern s1) (intern s2))))) (car candidates) (error "Can't find suitable coding-system")))) (defun slime-repl-connected-hook-function () (destructuring-bind (package prompt) (let ((slime-current-thread t) (cs (slime-repl-choose-coding-system))) (slime-eval `(swank-repl:create-repl nil :coding-system ,cs))) (setf (slime-lisp-package) package) (setf (slime-lisp-package-prompt-string) prompt)) (slime-hide-inferior-lisp-buffer) (slime-init-output-buffer (slime-connection))) (defun slime-repl-event-hook-function (event) (slime-dcase event ((:write-string output &optional target) (slime-write-string output target) t) ((:read-string thread tag) (assert thread) (slime-repl-read-string thread tag) t) ((:read-aborted thread tag) (slime-repl-abort-read thread tag) t) ((:open-dedicated-output-stream port coding-system) (slime-open-stream-to-lisp port coding-system) t) ((:new-package package prompt-string) (setf (slime-lisp-package) package) (setf (slime-lisp-package-prompt-string) prompt-string) (let ((buffer (slime-connection-output-buffer))) (when (buffer-live-p buffer) (with-current-buffer buffer (setq slime-buffer-package package)))) t) (t nil))) (defun slime-change-repl-to-default-connection () "Change current REPL to the REPL of the default connection. If the current buffer is not a REPL, don't do anything." (when (equal major-mode 'slime-repl-mode) (let ((slime-buffer-connection slime-default-connection)) (pop-to-buffer-same-window (slime-connection-output-buffer))))) (defun slime-repl-find-buffer-package () (or (slime-search-buffer-package) (slime-lisp-package))) (defun slime-repl-add-hooks () (add-hook 'slime-event-hooks 'slime-repl-event-hook-function) (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function) (add-hook 'slime-cycle-connections-hook 'slime-change-repl-to-default-connection)) (defun slime-repl-remove-hooks () (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function) (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function) (remove-hook 'slime-cycle-connections-hook 'slime-change-repl-to-default-connection)) (defun slime-repl-sexp-at-point () "Returns the current sexp at point (or NIL if none is found) while ignoring the repl prompt text." (if (<= slime-repl-input-start-mark (point)) (save-restriction (narrow-to-region slime-repl-input-start-mark (point-max)) (slime-sexp-at-point)) (slime-sexp-at-point))) (defun slime-repl-inspect (string) (interactive (list (slime-read-from-minibuffer "Inspect value (evaluated): " (slime-repl-sexp-at-point)))) (slime-inspect string)) (require 'bytecomp) ;; (mapc (lambda (sym) ;; (cond ((fboundp sym) ;; (unless (byte-code-function-p (symbol-function sym)) ;; (byte-compile sym))) ;; (t (error "%S is not fbound" sym)))) ;; '(slime-repl-event-hook-function ;; slime-write-string ;; slime-repl-write-string ;; slime-repl-emit ;; slime-repl-show-maximum-output)) (provide 'slime-repl) slime-2.20/contrib/slime-sbcl-exts.el000066400000000000000000000023421315100173500175400ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (define-slime-contrib slime-sbcl-exts "Misc extensions for SBCL" (:authors "Tobias C. Rittweiler ") (:license "GPL") (:slime-dependencies slime-references) (:swank-dependencies swank-sbcl-exts)) (defun slime-sbcl-bug-at-point () (save-excursion (save-match-data (unless (looking-at "#[0-9]\\{6\\}") (search-backward-regexp "#\\<" (line-beginning-position) t)) (when (looking-at "#[0-9]\\{6\\}") (buffer-substring-no-properties (match-beginning 0) (match-end 0)))))) (defun slime-read-sbcl-bug (prompt &optional query) "Either read a sbcl bug or choose the one at point. The user is prompted if a prefix argument is in effect, if there is no symbol at point, or if QUERY is non-nil." (let ((bug (slime-sbcl-bug-at-point))) (cond ((or current-prefix-arg query (not bug)) (slime-read-from-minibuffer prompt bug)) (t bug)))) (defun slime-visit-sbcl-bug (bug) "Visit the Launchpad site that describes `bug' (#nnnnnn)." (interactive (list (slime-read-sbcl-bug "Bug number (#nnnnnn): "))) (browse-url (format "http://bugs.launchpad.net/sbcl/+bug/%s" (substring bug 1)))) (provide 'slime-sbcl-exts) slime-2.20/contrib/slime-scheme.el000066400000000000000000000023721315100173500171030ustar00rootroot00000000000000;;; slime-scheme.el --- Support Scheme programs running under Common Lisp ;; ;; Authors: Matthias Koeppe ;; ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation: ;; ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "") ;; (add-hook 'slime-load-hook (lambda () (require 'slime-scheme))) ;; (eval-and-compile (require 'slime)) (defun slime-scheme-mode-hook () (slime-mode 1)) (defun slime-scheme-indentation-update (symbol indent packages) ;; Does the symbol have an indentation value that we set? (when (equal (get symbol 'scheme-indent-function) (get symbol 'slime-scheme-indent)) (put symbol 'slime-scheme-indent indent) (put symbol 'scheme-indent-function indent))) ;;; Initialization (defun slime-scheme-init () (add-hook 'scheme-mode-hook 'slime-scheme-mode-hook) (add-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update) (add-to-list 'slime-lisp-modes 'scheme-mode)) (defun slime-scheme-unload () (remove-hook 'scheme-mode-hook 'slime-scheme-mode-hook) (remove-hook 'slime-indentation-update-hooks 'slime-scheme-indentation-update) (setq slime-lisp-modes (remove 'scheme-mode slime-lisp-modes))) (provide 'slime-scheme) slime-2.20/contrib/slime-scratch.el000066400000000000000000000024241315100173500172640ustar00rootroot00000000000000;;; slime-scratch.el (require 'slime) (require 'cl-lib) (define-slime-contrib slime-scratch "Imitate Emacs' *scratch* buffer" (:authors "Helmut Eller ") (:license "GPL") (:on-load (def-slime-selector-method ?s "*slime-scratch* buffer." (slime-scratch-buffer)))) ;;; Code (defvar slime-scratch-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map lisp-mode-map) map)) (defun slime-scratch () (interactive) (slime-switch-to-scratch-buffer)) (defun slime-switch-to-scratch-buffer () (set-buffer (slime-scratch-buffer)) (unless (eq (current-buffer) (window-buffer)) (pop-to-buffer (current-buffer) t))) (defvar slime-scratch-file nil) (defun slime-scratch-buffer () "Return the scratch buffer, create it if necessary." (or (get-buffer (slime-buffer-name :scratch)) (with-current-buffer (if slime-scratch-file (find-file slime-scratch-file) (get-buffer-create (slime-buffer-name :scratch))) (rename-buffer (slime-buffer-name :scratch)) (lisp-mode) (use-local-map slime-scratch-mode-map) (slime-mode t) (current-buffer)))) (slime-define-keys slime-scratch-mode-map ("\C-j" 'slime-eval-print-last-expression)) (provide 'slime-scratch) slime-2.20/contrib/slime-snapshot.el000066400000000000000000000022011315100173500174650ustar00rootroot00000000000000(eval-and-compile (require 'slime)) (define-slime-contrib slime-snapshot "Save&restore memory images without disconnecting" (:authors "Helmut Eller ") (:license "GPL v3") (:swank-dependencies swank-snapshot)) (defun slime-snapshot (filename &optional background) "Save a memory image to the file FILENAME." (interactive (list (read-file-name "Image file: ") current-prefix-arg)) (let ((file (expand-file-name filename))) (when (and (file-exists-p file) (not (yes-or-no-p (format "File exists %s. Overwrite it? " filename)))) (signal 'quit nil)) (slime-eval-with-transcript `(,(if background 'swank-snapshot:background-save-snapshot 'swank-snapshot:save-snapshot) ,file)))) (defun slime-restore (filename) "Restore a memory image stored in file FILENAME." (interactive (list (read-file-name "Image file: "))) ;; bypass event dispatcher because we don't expect a reply. FIXME. (slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot ,(expand-file-name filename)) nil t nil) (slime-connection))) (provide 'slime-snapshot) slime-2.20/contrib/slime-sprof.el000066400000000000000000000167161315100173500167770ustar00rootroot00000000000000(require 'slime) (require 'cl-lib) (eval-when-compile (require 'cl)) ; lexical-let* (define-slime-contrib slime-sprof "Integration with SBCL's sb-sprof." (:authors "Juho Snellman" "Stas Boukarev") (:license "MIT") (:swank-dependencies swank-sprof) (:on-load (let ((C '(and (slime-connected-p) (equal (slime-lisp-implementation-type) "SBCL")))) (setf (cdr (last (assoc "Profiling" slime-easy-menu))) `("--" [ "Start sb-sprof" slime-sprof-start ,C ] [ "Stop sb-sprof" slime-sprof-stop ,C ] [ "Report sb-sprof" slime-sprof-report ,C ]))))) (defvar slime-sprof-exclude-swank nil "*Display swank functions in the report.") (define-derived-mode slime-sprof-browser-mode fundamental-mode "slprof" "Mode for browsing profiler data\ \\\ \\{slime-sprof-browser-mode-map}" :syntax-table lisp-mode-syntax-table (setq buffer-read-only t)) (set-keymap-parent slime-sprof-browser-mode-map slime-parent-map) (slime-define-keys slime-sprof-browser-mode-map ("h" 'describe-mode) ("d" 'slime-sprof-browser-disassemble-function) ("g" 'slime-sprof-browser-go-to) ("v" 'slime-sprof-browser-view-source) ("s" 'slime-sprof-toggle-swank-exclusion) ((kbd "RET") 'slime-sprof-browser-toggle)) ;; Start / stop profiling (cl-defun slime-sprof-start (&optional (mode :cpu)) (interactive) (slime-eval `(swank:swank-sprof-start :mode ,mode))) (defun slime-sprof-start-alloc () (interactive) (slime-sprof-start :alloc)) (defun slime-sprof-start-time () (interactive) (slime-sprof-start :time)) (defun slime-sprof-stop () (interactive) (slime-eval `(swank:swank-sprof-stop))) ;; Reporting (defun slime-sprof-format (graph) (with-current-buffer (slime-buffer-name :sprof) (let ((inhibit-read-only t)) (erase-buffer) (insert (format "%4s %-54s %6s %6s %6s\n" "Rank" "Name" "Self%" "Cumul%" "Total%")) (dolist (data graph) (slime-sprof-browser-insert-line data 54)))) (forward-line 2)) (cl-defun slime-sprof-update (&optional (exclude-swank slime-sprof-exclude-swank)) (slime-eval-async `(swank:swank-sprof-get-call-graph :exclude-swank ,exclude-swank) 'slime-sprof-format)) (defalias 'slime-sprof-browser 'slime-sprof-report) (defun slime-sprof-report () (interactive) (slime-with-popup-buffer ((slime-buffer-name :sprof) :connection t :select t :mode 'slime-sprof-browser-mode) (slime-sprof-update))) (defun slime-sprof-toggle-swank-exclusion () (interactive) (setq slime-sprof-exclude-swank (not slime-sprof-exclude-swank)) (slime-sprof-update)) (defun slime-sprof-browser-insert-line (data name-length) (cl-destructuring-bind (index name self cumul total) data (if index (insert (format "%-4d " index)) (insert " ")) (slime-insert-propertized (slime-sprof-browser-name-properties) (format (format "%%-%ds " name-length) (slime-sprof-abbreviate-name name name-length))) (insert (format "%6.2f " self)) (when cumul (insert (format "%6.2f " cumul)) (when total (insert (format "%6.2f" total)))) (when index (slime-sprof-browser-add-line-text-properties `(profile-index ,index expanded nil))) (insert "\n"))) (defun slime-sprof-abbreviate-name (name max-length) (cl-subseq name 0 (min (length name) max-length))) ;; Expanding / collapsing (defun slime-sprof-browser-toggle () (interactive) (let ((index (get-text-property (point) 'profile-index))) (when index (save-excursion (if (slime-sprof-browser-line-expanded-p) (slime-sprof-browser-collapse) (slime-sprof-browser-expand)))))) (defun slime-sprof-browser-collapse () (let ((inhibit-read-only t)) (slime-sprof-browser-add-line-text-properties '(expanded nil)) (forward-line) (cl-loop until (or (eobp) (get-text-property (point) 'profile-index)) do (delete-region (point-at-bol) (point-at-eol)) (unless (eobp) (delete-char 1))))) (defun slime-sprof-browser-expand () (lexical-let* ((buffer (current-buffer)) (point (point)) (index (get-text-property point 'profile-index))) (slime-eval-async `(swank:swank-sprof-expand-node ,index) (lambda (data) (with-current-buffer buffer (save-excursion (destructuring-bind (&key callers calls) data (slime-sprof-browser-add-expansion callers "Callers" 0) (slime-sprof-browser-add-expansion calls "Calls" 0)))))))) (defun slime-sprof-browser-add-expansion (data type nesting) (when data (let ((inhibit-read-only t)) (slime-sprof-browser-add-line-text-properties '(expanded t)) (end-of-line) (insert (format "\n %s" type)) (dolist (node data) (cl-destructuring-bind (index name cumul) node (insert (format (format "\n%%%ds" (+ 7 (* 2 nesting))) "")) (slime-insert-propertized (slime-sprof-browser-name-properties) (let ((len (- 59 (* 2 nesting)))) (format (format "%%-%ds " len) (slime-sprof-abbreviate-name name len)))) (slime-sprof-browser-add-line-text-properties `(profile-sub-index ,index)) (insert (format "%6.2f" cumul))))))) (defun slime-sprof-browser-line-expanded-p () (get-text-property (point) 'expanded)) (defun slime-sprof-browser-add-line-text-properties (properties) (add-text-properties (point-at-bol) (point-at-eol) properties)) (defun slime-sprof-browser-name-properties () '(face sldb-restart-number-face)) ;; "Go to function" (defun slime-sprof-browser-go-to () (interactive) (let ((sub-index (get-text-property (point) 'profile-sub-index))) (when sub-index (let ((pos (text-property-any (point-min) (point-max) 'profile-index sub-index))) (when pos (goto-char pos)))))) ;; Disassembly (defun slime-sprof-browser-disassemble-function () (interactive) (let ((index (or (get-text-property (point) 'profile-index) (get-text-property (point) 'profile-sub-index)))) (when index (slime-eval-describe `(swank:swank-sprof-disassemble ,index))))) ;; View source (defun slime-sprof-browser-view-source () (interactive) (let ((index (or (get-text-property (point) 'profile-index) (get-text-property (point) 'profile-sub-index)))) (when index (slime-eval-async `(swank:swank-sprof-source-location ,index) (lambda (source-location) (slime-dcase source-location ((:error message) (message "%s" message) (ding)) (t (slime-show-source-location source-location)))))))) (provide 'slime-sprof) slime-2.20/contrib/slime-trace-dialog.el000066400000000000000000001045721315100173500201770ustar00rootroot00000000000000;;; -*- coding: utf-8; lexical-binding: t -*- ;;; ;;; slime-trace-dialog.el -- a navigable dialog of inspectable trace entries ;;; ;;; TODO: implement better wrap interface for sbcl method, labels and such ;;; TODO: backtrace printing is very slow ;;; (require 'slime) (require 'slime-parse) (require 'slime-repl) (require 'cl-lib) (define-slime-contrib slime-trace-dialog "Provide an interfactive trace dialog buffer for managing and inspecting details of traced functions. Invoke this dialog with C-c T." (:authors "João Távora ") (:license "GPL") (:swank-dependencies swank-trace-dialog) (:on-load (add-hook 'slime-mode-hook 'slime-trace-dialog-enable) (add-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable)) (:on-unload (remove-hook 'slime-mode-hook 'slime-trace-dialog-enable) (remove-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable))) ;;;; Variables ;;; (defvar slime-trace-dialog-flash t "Non-nil means flash the updated region of the SLIME Trace Dialog. ") (defvar slime-trace-dialog--specs-overlay nil) (defvar slime-trace-dialog--progress-overlay nil) (defvar slime-trace-dialog--tree-overlay nil) (defvar slime-trace-dialog--collapse-chars (cons "-" "+")) ;;;; Local trace entry model (defvar slime-trace-dialog--traces nil) (cl-defstruct (slime-trace-dialog--trace (:constructor slime-trace-dialog--make-trace)) id parent spec args retlist depth beg end collapse-button-marker summary-beg children-end collapsed-p) (defun slime-trace-dialog--find-trace (id) (gethash id slime-trace-dialog--traces)) ;;;; Modes and mode maps ;;; (defvar slime-trace-dialog-mode-map (let ((map (make-sparse-keymap)) (remaps '((slime-inspector-operate-on-point . nil) (slime-inspector-operate-on-click . nil) (slime-inspector-reinspect . slime-trace-dialog-fetch-status) (slime-inspector-next-inspectable-object . slime-trace-dialog-next-button) (slime-inspector-previous-inspectable-object . slime-trace-dialog-prev-button)))) (set-keymap-parent map slime-inspector-mode-map) (cl-loop for (old . new) in remaps do (substitute-key-definition old new map)) (set-keymap-parent map slime-parent-map) (define-key map (kbd "G") 'slime-trace-dialog-fetch-traces) (define-key map (kbd "C-k") 'slime-trace-dialog-clear-fetched-traces) (define-key map (kbd "g") 'slime-trace-dialog-fetch-status) (define-key map (kbd "M-RET") 'slime-trace-dialog-copy-down-to-repl) (define-key map (kbd "q") 'quit-window) map)) (define-derived-mode slime-trace-dialog-mode fundamental-mode "SLIME Trace Dialog" "Mode for controlling SLIME's Trace Dialog" (set-syntax-table lisp-mode-syntax-table) (read-only-mode 1) (add-to-list (make-local-variable 'slime-trace-dialog-after-toggle-hook) 'slime-trace-dialog-fetch-status)) (define-derived-mode slime-trace-dialog--detail-mode slime-inspector-mode "SLIME Trace Detail" "Mode for viewing a particular trace from SLIME's Trace Dialog") (setq slime-trace-dialog--detail-mode-map (let ((map (make-sparse-keymap)) (remaps '((slime-inspector-next-inspectable-object . slime-trace-dialog-next-button) (slime-inspector-previous-inspectable-object . slime-trace-dialog-prev-button)))) (set-keymap-parent map slime-trace-dialog-mode-map) (cl-loop for (old . new) in remaps do (substitute-key-definition old new map)) map)) (defvar slime-trace-dialog-minor-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c T") 'slime-trace-dialog) (define-key map (kbd "C-c M-t") 'slime-trace-dialog-toggle-trace) map)) (define-minor-mode slime-trace-dialog-minor-mode "Add keybindings for accessing SLIME's Trace Dialog.") (defun slime-trace-dialog-enable () (slime-trace-dialog-minor-mode 1)) (easy-menu-define slime-trace-dialog--menubar (list slime-trace-dialog-minor-mode-map slime-trace-dialog-mode-map) "A menu for accessing some features of SLIME's Trace Dialog" (let* ((in-dialog '(eq major-mode 'slime-trace-dialog-mode)) (dialog-live `(and ,in-dialog (memq slime-buffer-connection slime-net-processes))) (connected '(slime-connected-p))) `("Trace" ["Toggle trace" slime-trace-dialog-toggle-trace ,connected] ["Trace complex spec" slime-trace-dialog-toggle-complex-trace ,connected] ["Open Trace dialog" slime-trace-dialog (and ,connected (not ,in-dialog))] "--" [ "Refresh traces and progress" slime-trace-dialog-fetch-status ,dialog-live] [ "Fetch next batch" slime-trace-dialog-fetch-traces ,dialog-live] [ "Clear all fetched traces" slime-trace-dialog-clear-fetched-traces ,dialog-live] [ "Toggle details" slime-trace-dialog-hide-details-mode ,in-dialog] [ "Toggle autofollow" slime-trace-dialog-autofollow-mode ,in-dialog]))) (define-minor-mode slime-trace-dialog-hide-details-mode "Hide details in `slime-trace-dialog-mode'" nil " Brief" :group 'slime-trace-dialog (unless (derived-mode-p 'slime-trace-dialog-mode) (error "Not a SLIME Trace Dialog buffer")) (slime-trace-dialog--set-hide-details-mode)) (define-minor-mode slime-trace-dialog-autofollow-mode "Automatically open buffers with trace details from `slime-trace-dialog-mode'" nil " Autofollow" :group 'slime-trace-dialog (unless (derived-mode-p 'slime-trace-dialog-mode) (error "Not a SLIME Trace Dialog buffer"))) ;;;; Helper functions ;;; (defun slime-trace-dialog--call-refreshing (buffer overlay dont-erase recover-point-p fn) (with-current-buffer buffer (let ((inhibit-point-motion-hooks t) (inhibit-read-only t) (saved (point))) (save-restriction (when overlay (narrow-to-region (overlay-start overlay) (overlay-end overlay))) (unwind-protect (if dont-erase (goto-char (point-max)) (delete-region (point-min) (point-max))) (funcall fn) (when recover-point-p (goto-char saved))) (when slime-trace-dialog-flash (slime-flash-region (point-min) (point-max))))) buffer)) (cl-defmacro slime-trace-dialog--refresh ((&key overlay dont-erase recover-point-p buffer) &rest body) (declare (indent 1) (debug (sexp &rest form))) `(slime-trace-dialog--call-refreshing ,(or buffer `(current-buffer)) ,overlay ,dont-erase ,recover-point-p #'(lambda () ,@body))) (defmacro slime-trace-dialog--insert-and-overlay (string overlay) `(save-restriction (let ((inhibit-read-only t)) (narrow-to-region (point) (point)) (insert ,string "\n") (set (make-local-variable ',overlay) (let ((overlay (make-overlay (point-min) (point-max) (current-buffer) nil t))) (move-overlay overlay (overlay-start overlay) (1- (overlay-end overlay))) ;; (overlay-put overlay 'face '(:background "darkslategrey")) overlay))))) (defun slime-trace-dialog--buffer-name () (format "*traces for %s*" (slime-connection-name slime-default-connection))) (defun slime-trace-dialog--live-dialog (&optional buffer-or-name) (let ((buffer-or-name (or buffer-or-name (slime-trace-dialog--buffer-name)))) (and (buffer-live-p (get-buffer buffer-or-name)) (with-current-buffer buffer-or-name (memq slime-buffer-connection slime-net-processes)) buffer-or-name))) (defun slime-trace-dialog--ensure-buffer () (let ((name (slime-trace-dialog--buffer-name))) (or (slime-trace-dialog--live-dialog name) (with-current-buffer (get-buffer-create name) (let ((inhibit-read-only t)) (erase-buffer)) (slime-trace-dialog-mode) (save-excursion (buffer-disable-undo) (slime-trace-dialog--insert-and-overlay "[waiting for the traced specs to be available]" slime-trace-dialog--specs-overlay) (slime-trace-dialog--insert-and-overlay "[waiting for some info on trace download progress ]" slime-trace-dialog--progress-overlay) (slime-trace-dialog--insert-and-overlay "[waiting for the actual traces to be available]" slime-trace-dialog--tree-overlay) (current-buffer)) (setq slime-buffer-connection slime-default-connection) (current-buffer))))) (defun slime-trace-dialog--make-autofollow-fn (id) (let ((requested nil)) #'(lambda (_before after) (let ((inhibit-point-motion-hooks t) (id-after (get-text-property after 'slime-trace-dialog--id))) (when (and (= after (point)) slime-trace-dialog-autofollow-mode id-after (= id-after id) (not requested)) (setq requested t) (slime-eval-async `(swank-trace-dialog:report-trace-detail ,id-after) #'(lambda (detail) (setq requested nil) (when detail (let ((inhibit-point-motion-hooks t)) (slime-trace-dialog--open-detail detail 'no-pop)))))))))) (defun slime-trace-dialog--set-collapsed (collapsed-p trace button) (save-excursion (setf (slime-trace-dialog--trace-collapsed-p trace) collapsed-p) (slime-trace-dialog--go-replace-char-at button (if collapsed-p (cdr slime-trace-dialog--collapse-chars) (car slime-trace-dialog--collapse-chars))) (slime-trace-dialog--hide-unhide (slime-trace-dialog--trace-summary-beg trace) (slime-trace-dialog--trace-end trace) (if collapsed-p 1 -1)) (slime-trace-dialog--hide-unhide (slime-trace-dialog--trace-end trace) (slime-trace-dialog--trace-children-end trace) (if collapsed-p 1 -1)))) (defun slime-trace-dialog--hide-unhide (start-pos end-pos delta) (cl-loop with inhibit-read-only = t for pos = start-pos then next for next = (next-single-property-change pos 'slime-trace-dialog--hidden-level nil end-pos) for hidden-level = (+ (or (get-text-property pos 'slime-trace-dialog--hidden-level) 0) delta) do (add-text-properties pos next (list 'slime-trace-dialog--hidden-level hidden-level 'invisible (cl-plusp hidden-level))) while (< next end-pos))) (defun slime-trace-dialog--set-hide-details-mode () (cl-loop for trace being the hash-values of slime-trace-dialog--traces do (slime-trace-dialog--hide-unhide (slime-trace-dialog--trace-summary-beg trace) (slime-trace-dialog--trace-end trace) (if slime-trace-dialog-hide-details-mode 1 -1)))) (defun slime-trace-dialog--format-part (part-id part-text trace-id type) (slime-trace-dialog--button (format "%s" part-text) #'(lambda (_button) (slime-eval-async `(swank-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type) #'slime-open-inspector)) 'mouse-face 'highlight 'slime-trace-dialog--part-id part-id 'slime-trace-dialog--type type 'face 'slime-inspector-value-face)) (defun slime-trace-dialog--format-trace-entry (id external) (slime-trace-dialog--button (format "%s" external) #'(lambda (_button) (slime-eval-async `(swank::inspect-object (swank-trace-dialog::find-trace ,id)) #'slime-open-inspector)) 'face 'slime-inspector-value-face)) (defun slime-trace-dialog--format (fmt-string &rest args) (let* ((string (apply #'format fmt-string args)) (indent (make-string (max 2 (- 50 (length string))) ? ))) (format "%s%s" string indent))) (defun slime-trace-dialog--button (title lambda &rest props) (let ((string (format "%s" title))) (apply #'make-text-button string nil 'action #'(lambda (button) (funcall lambda button)) 'mouse-face 'highlight 'face 'slime-inspector-action-face props) string)) (defun slime-trace-dialog--call-maintaining-properties (pos fn) (save-excursion (goto-char pos) (let* ((saved-props (text-properties-at pos)) (saved-point (point)) (inhibit-read-only t) (inhibit-point-motion-hooks t)) (funcall fn) (add-text-properties saved-point (point) saved-props) (if (markerp pos) (set-marker pos saved-point))))) (cl-defmacro slime-trace-dialog--maintaining-properties (pos &body body) (declare (indent 1)) `(slime-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body))) (defun slime-trace-dialog--go-replace-char-at (pos char) (slime-trace-dialog--maintaining-properties pos (delete-char 1) (insert char))) ;;;; Handlers for the *trace-dialog* and *trace-detail* buffers ;;; (defun slime-trace-dialog--open-specs (traced-specs) (cl-labels ((make-report-spec-fn (&optional form) #'(lambda (_button) (slime-eval-async `(cl:progn ,form (swank-trace-dialog:report-specs)) #'(lambda (results) (slime-trace-dialog--open-specs results)))))) (slime-trace-dialog--refresh (:overlay slime-trace-dialog--specs-overlay :recover-point-p t) (insert (slime-trace-dialog--format "Traced specs (%s)" (length traced-specs)) (slime-trace-dialog--button "[refresh]" (make-report-spec-fn)) "\n" (make-string 50 ? ) (slime-trace-dialog--button "[untrace all]" (make-report-spec-fn `(swank-trace-dialog:dialog-untrace-all))) "\n\n") (cl-loop for spec in traced-specs do (insert " " (slime-trace-dialog--button "[untrace]" (make-report-spec-fn `(swank-trace-dialog:dialog-untrace ',spec))) (format " %s" spec) "\n"))))) (defvar slime-trace-dialog--fetch-key nil) (defvar slime-trace-dialog--stop-fetching nil) (defun slime-trace-dialog--update-progress (total &optional show-stop-p remaining-p) ;; `remaining-p' indicates `total' is the number of remaining traces. (slime-trace-dialog--refresh (:overlay slime-trace-dialog--progress-overlay :recover-point-p t) (let* ((done (hash-table-count slime-trace-dialog--traces)) (total (if remaining-p (+ done total) total))) (insert (slime-trace-dialog--format "Trace collection status (%d/%s)" done (or total "0")) (slime-trace-dialog--button "[refresh]" #'(lambda (_button) (slime-trace-dialog-fetch-progress)))) (when (and total (cl-plusp (- total done))) (insert "\n" (make-string 50 ? ) (slime-trace-dialog--button "[fetch next batch]" #'(lambda (_button) (slime-trace-dialog-fetch-traces nil))) "\n" (make-string 50 ? ) (slime-trace-dialog--button "[fetch all]" #'(lambda (_button) (slime-trace-dialog-fetch-traces t))))) (when total (insert "\n" (make-string 50 ? ) (slime-trace-dialog--button "[clear]" #'(lambda (_button) (slime-trace-dialog-clear-fetched-traces))))) (when show-stop-p (insert "\n" (make-string 50 ? ) (slime-trace-dialog--button "[stop]" #'(lambda (_button) (setq slime-trace-dialog--stop-fetching t))))) (insert "\n\n")))) (defun slime-trace-dialog--open-detail (trace-tuple &optional no-pop) (slime-with-popup-buffer ("*trace-detail*" :select (not no-pop) :mode 'slime-trace-dialog--detail-mode) (cl-destructuring-bind (id _parent-id _spec args retlist backtrace external) trace-tuple (let ((headline (slime-trace-dialog--format-trace-entry id external))) (setq headline (format "%s\n%s\n" headline (make-string (length headline) ?-))) (insert headline)) (cl-loop for (type objects label) in `((:arg ,args "Called with args:") (:retval ,retlist "Returned values:")) do (insert (format "\n%s\n" label)) (insert (cl-loop for object in objects for i from 0 concat (format " %s: %s\n" i (slime-trace-dialog--format-part (cl-first object) (cl-second object) id type))))) (when backtrace (insert "\nBacktrace:\n" (cl-loop for (i spec) in backtrace concat (format " %s: %s\n" i spec))))))) ;;;; Rendering traces ;;; (defun slime-trace-dialog--draw-tree-lines (start offset direction) (save-excursion (let ((inhibit-point-motion-hooks t)) (goto-char start) (cl-loop with replace-set = (if (eq direction 'down) '(? ) '(? ?`)) for line-beginning = (line-beginning-position (if (eq direction 'down) 2 0)) for pos = (+ line-beginning offset) while (and (< (point-min) line-beginning) (< line-beginning (point-max)) (memq (char-after pos) replace-set)) do (slime-trace-dialog--go-replace-char-at pos "|") (goto-char pos))))) (defun slime-trace-dialog--make-indent (depth suffix) (concat (make-string (* 3 (max 0 (1- depth))) ? ) (if (cl-plusp depth) suffix))) (defun slime-trace-dialog--make-collapse-button (trace) (slime-trace-dialog--button (if (slime-trace-dialog--trace-collapsed-p trace) (cdr slime-trace-dialog--collapse-chars) (car slime-trace-dialog--collapse-chars)) #'(lambda (button) (slime-trace-dialog--set-collapsed (not (slime-trace-dialog--trace-collapsed-p trace)) trace button)))) (defun slime-trace-dialog--insert-trace (trace) (let* ((id (slime-trace-dialog--trace-id trace)) (parent (slime-trace-dialog--trace-parent trace)) (has-children-p (slime-trace-dialog--trace-children-end trace)) (indent-spec (slime-trace-dialog--make-indent (slime-trace-dialog--trace-depth trace) "`--")) (indent-summary (slime-trace-dialog--make-indent (slime-trace-dialog--trace-depth trace) " ")) (autofollow-fn (slime-trace-dialog--make-autofollow-fn id)) (id-string (slime-trace-dialog--button (format "%4s" id) #'(lambda (_button) (slime-eval-async `(swank-trace-dialog:report-trace-detail ,id) #'slime-trace-dialog--open-detail)))) (spec (slime-trace-dialog--trace-spec trace)) (summary (cl-loop for (type objects marker) in `((:arg ,(slime-trace-dialog--trace-args trace) " > ") (:retval ,(slime-trace-dialog--trace-retlist trace) " < ")) concat (cl-loop for object in objects concat " " concat indent-summary concat marker concat (slime-trace-dialog--format-part (cl-first object) (cl-second object) id type) concat "\n")))) (puthash id trace slime-trace-dialog--traces) ;; insert and propertize the text ;; (setf (slime-trace-dialog--trace-beg trace) (point-marker)) (insert id-string " ") (insert indent-spec) (if has-children-p (insert (slime-trace-dialog--make-collapse-button trace)) (setf (slime-trace-dialog--trace-collapse-button-marker trace) (point-marker)) (insert "-")) (insert (format " %s\n" spec)) (setf (slime-trace-dialog--trace-summary-beg trace) (point-marker)) (insert summary) (setf (slime-trace-dialog--trace-end trace) (point-marker)) (set-marker-insertion-type (slime-trace-dialog--trace-beg trace) t) (add-text-properties (slime-trace-dialog--trace-beg trace) (slime-trace-dialog--trace-end trace) (list 'slime-trace-dialog--id id 'point-entered autofollow-fn 'point-left autofollow-fn)) ;; respect brief mode and collapsed state ;; (cl-loop for condition in (list slime-trace-dialog-hide-details-mode (slime-trace-dialog--trace-collapsed-p trace)) when condition do (slime-trace-dialog--hide-unhide (slime-trace-dialog--trace-summary-beg trace) (slime-trace-dialog--trace-end trace) 1)) (cl-loop for tr = trace then parent for parent = (slime-trace-dialog--trace-parent tr) while parent when (slime-trace-dialog--trace-collapsed-p parent) do (slime-trace-dialog--hide-unhide (slime-trace-dialog--trace-beg trace) (slime-trace-dialog--trace-end trace) (+ 1 (or (get-text-property (slime-trace-dialog--trace-beg parent) 'slime-trace-dialog--hidden-level) 0))) (cl-return)) ;; maybe add the collapse-button to the parent in case it didn't ;; have one already ;; (when (and parent (slime-trace-dialog--trace-collapse-button-marker parent)) (slime-trace-dialog--maintaining-properties (slime-trace-dialog--trace-collapse-button-marker parent) (delete-char 1) (insert (slime-trace-dialog--make-collapse-button parent)) (setf (slime-trace-dialog--trace-collapse-button-marker parent) nil))) ;; draw the tree lines ;; (when parent (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) (+ 2 (length indent-spec)) 'up)) (when has-children-p (slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace) (+ 5 (length indent-spec)) 'down)) ;; set the "children-end" slot ;; (unless (slime-trace-dialog--trace-children-end trace) (cl-loop for parent = trace then (slime-trace-dialog--trace-parent parent) while parent do (setf (slime-trace-dialog--trace-children-end parent) (slime-trace-dialog--trace-end trace)))))) (defun slime-trace-dialog--render-trace (trace) ;; Render the trace entry in the appropriate place. ;; ;; A trace becomes a few lines of slightly propertized text in the ;; buffer, inserted by `slime-trace-dialog--insert-trace', bound by ;; point markers that we use here. ;; ;; The new trace might be replacing an existing one, or otherwise ;; must be placed under its existing parent which might or might not ;; be the last entry inserted. ;; (let ((existing (slime-trace-dialog--find-trace (slime-trace-dialog--trace-id trace))) (parent (slime-trace-dialog--trace-parent trace))) (cond (existing ;; Other traces might already reference `existing' and with ;; need to maintain that eqness. Best way to do that is ;; destructively modify `existing' with the new retlist... ;; (setf (slime-trace-dialog--trace-retlist existing) (slime-trace-dialog--trace-retlist trace)) ;; Now, before deleting and re-inserting `existing' at an ;; arbitrary point in the tree, note that it's ;; "children-end" marker is already non-nil, and informs us ;; about its parenthood status. We want to 1. leave it ;; alone if it's already a parent, or 2. set it to nil if ;; it's a leaf, thus forcing the needed update of the ;; parents' "children-end" marker. ;; (when (= (slime-trace-dialog--trace-children-end existing) (slime-trace-dialog--trace-end existing)) (setf (slime-trace-dialog--trace-children-end existing) nil)) (delete-region (slime-trace-dialog--trace-beg existing) (slime-trace-dialog--trace-end existing)) (goto-char (slime-trace-dialog--trace-end existing)) ;; Remember to set `trace' to be `existing' ;; (setq trace existing)) (parent (goto-char (1+ (slime-trace-dialog--trace-children-end parent)))) (;; top level trace t (goto-char (point-max)))) (goto-char (line-beginning-position)) (slime-trace-dialog--insert-trace trace))) (defun slime-trace-dialog--update-tree (tuples) (save-excursion (slime-trace-dialog--refresh (:overlay slime-trace-dialog--tree-overlay :dont-erase t) (cl-loop for tuple in tuples for parent = (slime-trace-dialog--find-trace (cl-second tuple)) for trace = (slime-trace-dialog--make-trace :id (cl-first tuple) :parent parent :spec (cl-third tuple) :args (cl-fourth tuple) :retlist (cl-fifth tuple) :depth (if parent (1+ (slime-trace-dialog--trace-depth parent)) 0)) do (slime-trace-dialog--render-trace trace))))) (defun slime-trace-dialog--clear-local-tree () (set (make-local-variable 'slime-trace-dialog--fetch-key) (cl-gensym "slime-trace-dialog-fetch-key-")) (set (make-local-variable 'slime-trace-dialog--traces) (make-hash-table)) (slime-trace-dialog--refresh (:overlay slime-trace-dialog--tree-overlay)) (slime-trace-dialog--update-progress nil)) (defun slime-trace-dialog--on-new-results (results &optional recurse) (cl-destructuring-bind (tuples remaining reply-key) results (cond ((and slime-trace-dialog--fetch-key (string= (symbol-name slime-trace-dialog--fetch-key) (symbol-name reply-key))) (slime-trace-dialog--update-tree tuples) (slime-trace-dialog--update-progress remaining (and recurse (cl-plusp remaining)) t) (when (and recurse (not (prog1 slime-trace-dialog--stop-fetching (setq slime-trace-dialog--stop-fetching nil))) (cl-plusp remaining)) (slime-eval-async `(swank-trace-dialog:report-partial-tree ',reply-key) #'(lambda (results) (slime-trace-dialog--on-new-results results recurse)))))))) ;;;; Interactive functions ;;; (defun slime-trace-dialog-fetch-specs () "Refresh just list of traced specs." (interactive) (slime-eval-async `(swank-trace-dialog:report-specs) #'slime-trace-dialog--open-specs)) (defun slime-trace-dialog-fetch-progress () (interactive) (slime-eval-async '(swank-trace-dialog:report-total) #'(lambda (total) (slime-trace-dialog--update-progress total)))) (defun slime-trace-dialog-fetch-status () "Refresh just the status part of the SLIME Trace Dialog" (interactive) (slime-trace-dialog-fetch-specs) (slime-trace-dialog-fetch-progress)) (defun slime-trace-dialog-clear-fetched-traces (&optional interactive) "Clear local and remote traces collected so far" (interactive "p") (when (or (not interactive) (y-or-n-p "Clear all collected and fetched traces?")) (slime-eval-async '(swank-trace-dialog:clear-trace-tree) #'(lambda (_ignored) (slime-trace-dialog--clear-local-tree))))) (defun slime-trace-dialog-fetch-traces (&optional recurse) (interactive "P") (setq slime-trace-dialog--stop-fetching nil) (slime-eval-async `(swank-trace-dialog:report-partial-tree ',slime-trace-dialog--fetch-key) #'(lambda (results) (slime-trace-dialog--on-new-results results recurse)))) (defun slime-trace-dialog-next-button (&optional goback) (interactive) (let ((finder (if goback #'previous-single-property-change #'next-single-property-change))) (cl-loop for pos = (funcall finder (point) 'action) while pos do (goto-char pos) until (get-text-property pos 'action)))) (defun slime-trace-dialog-prev-button () (interactive) (slime-trace-dialog-next-button 'goback)) (defvar slime-trace-dialog-after-toggle-hook nil "Hooks run after toggling a dialog-trace") (defun slime-trace-dialog-toggle-trace (&optional using-context-p) "Toggle the dialog-trace of the spec at point. When USING-CONTEXT-P, attempt to decipher lambdas. methods and other complicated function specs." (interactive "P") ;; Notice the use of "spec strings" here as opposed to the ;; proper cons specs we use on the swank side. ;; ;; Notice the conditional use of `slime-trace-query' found in ;; swank-fancy-trace.el ;; (let* ((spec-string (if using-context-p (slime-extract-context) (slime-symbol-at-point))) (spec-string (if (fboundp 'slime-trace-query) (slime-trace-query spec-string) spec-string))) (message "%s" (slime-eval `(swank-trace-dialog:dialog-toggle-trace (swank::from-string ,spec-string)))) (run-hooks 'slime-trace-dialog-after-toggle-hook))) (defun slime-trace-dialog--update-existing-dialog () (let ((existing (slime-trace-dialog--live-dialog))) (when existing (with-current-buffer existing (slime-trace-dialog-fetch-status))))) (add-hook 'slime-trace-dialog-after-toggle-hook 'slime-trace-dialog--update-existing-dialog) (defun slime-trace-dialog-toggle-complex-trace () "Toggle the dialog-trace of the complex spec at point. See `slime-trace-dialog-toggle-trace'." (interactive) (slime-trace-dialog-toggle-trace t)) (defun slime-trace-dialog (&optional clear-and-fetch) "Show trace dialog and refresh trace collection status. With optional CLEAR-AND-FETCH prefix arg, clear the current tree and fetch a first batch of traces." (interactive "P") (with-current-buffer (pop-to-buffer (slime-trace-dialog--ensure-buffer)) (slime-trace-dialog-fetch-status) (when (or clear-and-fetch (null slime-trace-dialog--fetch-key)) (slime-trace-dialog--clear-local-tree)) (when clear-and-fetch (slime-trace-dialog-fetch-traces nil)))) (defun slime-trace-dialog-copy-down-to-repl (id part-id type) "Eval the Trace Dialog entry under point in the REPL (to set *)" (interactive (cl-loop for prop in '(slime-trace-dialog--id slime-trace-dialog--part-id slime-trace-dialog--type) collect (get-text-property (point) prop))) (unless (and id part-id type) (error "No trace part at point %s" (point))) (slime-repl-send-string (format "%s" `(nth-value 0 (swank-trace-dialog::find-trace-part ,id ,part-id ,type)))) (slime-repl)) (provide 'slime-trace-dialog) slime-2.20/contrib/slime-tramp.el000066400000000000000000000104301315100173500167540ustar00rootroot00000000000000(require 'slime) (require 'tramp) (eval-when-compile (require 'cl)) ; lexical-let (define-slime-contrib slime-tramp "Filename translations for tramp" (:authors "Marco Baringer ") (:license "GPL") (:on-load (setq slime-to-lisp-filename-function #'slime-tramp-to-lisp-filename) (setq slime-from-lisp-filename-function #'slime-tramp-from-lisp-filename))) (defcustom slime-filename-translations nil "Assoc list of hostnames and filename translation functions. Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). HOSTNAME-REGEXP is a regexp which is applied to the connection's slime-machine-instance. If HOSTNAME-REGEXP maches then the corresponding TO-LISP and FROM-LISP functions will be used to translate emacs filenames and lisp filenames. TO-LISP will be passed the filename of an emacs buffer and must return a string which the underlying lisp understandas as a pathname. FROM-LISP will be passed a pathname as returned by the underlying lisp and must return something that emacs will understand as a filename (this string will be passed to find-file). This list will be traversed in order, so multiple matching regexps are possible. Example: Assuming you run emacs locally and connect to slime running on the machine 'soren' and you can connect with the username 'animaliter': (push (list \"^soren$\" (lambda (emacs-filename) (subseq emacs-filename (length \"/ssh:animaliter@soren:\"))) (lambda (lisp-filename) (concat \"/ssh:animaliter@soren:\" lisp-filename))) slime-filename-translations) See also `slime-create-filename-translator'." :type '(repeat (list :tag "Host description" (regexp :tag "Hostname regexp") (function :tag "To lisp function") (function :tag "From lisp function"))) :group 'slime-lisp) (defun slime-find-filename-translators (hostname) (cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname)) slime-filename-translations))) (t (list #'identity #'identity)))) (defun slime-make-tramp-file-name (username remote-host lisp-filename) "Old (with multi-hops) tramp compatability function" (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))) (cl-defun slime-create-filename-translator (&key machine-instance remote-host username) "Creates a three element list suitable for push'ing onto slime-filename-translations which uses Tramp to load files on hostname using username. MACHINE-INSTANCE is a required parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME defaults to (user-login-name). MACHINE-INSTANCE is the value returned by slime-machine-instance, which is just the value returned by cl:machine-instance on the remote lisp. REMOTE-HOST is the fully qualified domain name (or just the IP) of the remote machine. USERNAME is the username we should login with. The functions created here expect your tramp-default-method or tramp-default-method-alist to be setup correctly." (lexical-let ((remote-host (or remote-host machine-instance)) (username (or username (user-login-name)))) (list (concat "^" machine-instance "$") (lambda (emacs-filename) (tramp-file-name-localname (tramp-dissect-file-name emacs-filename))) `(lambda (lisp-filename) (slime-make-tramp-file-name ,username ,remote-host lisp-filename))))) (defun slime-tramp-to-lisp-filename (filename) (funcall (if (slime-connected-p) (first (slime-find-filename-translators (slime-machine-instance))) 'identity) (expand-file-name filename))) (defun slime-tramp-from-lisp-filename (filename) (funcall (second (slime-find-filename-translators (slime-machine-instance))) filename)) (provide 'slime-tramp) slime-2.20/contrib/slime-typeout-frame.el000066400000000000000000000062051315100173500204370ustar00rootroot00000000000000(require 'slime) (require 'slime-autodoc) (require 'cl-lib) (defvar slime-typeout-frame-unbind-stack ()) (define-slime-contrib slime-typeout-frame "Display messages in a dedicated frame." (:authors "Luke Gorrie ") (:license "GPL") (:on-load (unless (slime-typeout-tty-only-p) (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame) (add-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc) (cl-loop for (var value) in '((slime-message-function slime-typeout-message) (slime-background-message-function slime-typeout-message)) do (slime-typeout-frame-init-var var value)))) (:on-unload (remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame) (remove-hook 'slime-autodoc-mode-hook 'slime-typeout-wrap-autodoc) (cl-loop for (var value) in slime-typeout-frame-unbind-stack do (cond ((eq var 'slime-unbound) (makunbound var)) (t (set var value)))) (setq slime-typeout-frame-unbind-stack nil))) (defun slime-typeout-frame-init-var (var value) (push (list var (if (boundp var) (symbol-value var) 'slime-unbound)) slime-typeout-frame-unbind-stack) (set var value)) (defun slime-typeout-tty-only-p () (cond ((featurep 'xemacs) (null (remove 'tty (mapcar #'device-type (console-device-list))))) (t (not (window-system))))) ;;;; Typeout frame ;; When a "typeout frame" exists it is used to display certain ;; messages instead of the echo area or pop-up windows. (defvar slime-typeout-window nil "The current typeout window.") (defvar slime-typeout-frame-properties '((height . 10) (minibuffer . nil)) "The typeout frame properties (passed to `make-frame').") (defun slime-typeout-buffer () (with-current-buffer (get-buffer-create (slime-buffer-name :typeout)) (setq buffer-read-only t) (current-buffer))) (defun slime-typeout-active-p () (and slime-typeout-window (window-live-p slime-typeout-window))) (defun slime-typeout-message-aux (format-string &rest format-args) (slime-ensure-typeout-frame) (with-current-buffer (slime-typeout-buffer) (let ((inhibit-read-only t) (msg (apply #'format format-string format-args))) (unless (string= msg "") (erase-buffer) (insert msg))))) (defun slime-typeout-message (format-string &rest format-args) (apply #'slime-typeout-message-aux format-string format-args)) (defun slime-make-typeout-frame () "Create a frame for displaying messages (e.g. arglists)." (interactive) (let ((frame (make-frame slime-typeout-frame-properties))) (save-selected-window (select-window (frame-selected-window frame)) (switch-to-buffer (slime-typeout-buffer)) (setq slime-typeout-window (selected-window))))) (defun slime-ensure-typeout-frame () "Create the typeout frame unless it already exists." (interactive) (if (slime-typeout-active-p) (save-selected-window (select-window slime-typeout-window) (switch-to-buffer (slime-typeout-buffer))) (slime-make-typeout-frame))) (defun slime-typeout-wrap-autodoc () (setq eldoc-message-function 'slime-typeout-message-aux)) (provide 'slime-typeout-frame) slime-2.20/contrib/slime-xref-browser.el000066400000000000000000000074441315100173500202710ustar00rootroot00000000000000(eval-and-compile (require 'slime)) (define-slime-contrib slime-xref-browser "Xref browsing with tree-widget" (:authors "Rui Patrocnio ") (:license "GPL")) ;;;; classes browser (defun slime-expand-class-node (widget) (or (widget-get widget :args) (let ((name (widget-get widget :tag))) (cl-loop for kid in (slime-eval `(swank:mop :subclasses ,name)) collect `(tree-widget :tag ,kid :expander slime-expand-class-node :has-children t))))) (defun slime-browse-classes (name) "Read the name of a class and show its subclasses." (interactive (list (slime-read-symbol-name "Class Name: "))) (slime-call-with-browser-setup (slime-buffer-name :browser) (slime-current-package) "Class Browser" (lambda () (widget-create 'tree-widget :tag name :expander 'slime-expand-class-node :has-echildren t)))) (defvar slime-browser-map nil "Keymap for tree widget browsers") (require 'tree-widget) (unless slime-browser-map (setq slime-browser-map (make-sparse-keymap)) (set-keymap-parent slime-browser-map widget-keymap) (define-key slime-browser-map "q" 'bury-buffer)) (defun slime-call-with-browser-setup (buffer package title fn) (switch-to-buffer buffer) (kill-all-local-variables) (setq slime-buffer-package package) (let ((inhibit-read-only t)) (erase-buffer)) (widget-insert title "\n\n") (save-excursion (funcall fn)) (lisp-mode-variables t) (slime-mode t) (use-local-map slime-browser-map) (widget-setup)) ;;;; Xref browser (defun slime-fetch-browsable-xrefs (type name) "Return a list ((LABEL DSPEC)). LABEL is just a string for display purposes. DSPEC can be used to expand the node." (let ((xrefs '())) (cl-loop for (_file . specs) in (slime-eval `(swank:xref ,type ,name)) do (cl-loop for (dspec . _location) in specs do (let ((exp (ignore-errors (read (downcase dspec))))) (cond ((and (consp exp) (eq 'flet (car exp))) ;; we can't expand FLET references so they're useless ) ((and (consp exp) (eq 'method (car exp))) ;; this isn't quite right, but good enough for now (push (list dspec (string (cl-second exp))) xrefs)) (t (push (list dspec dspec) xrefs)))))) xrefs)) (defun slime-expand-xrefs (widget) (or (widget-get widget :args) (let* ((type (widget-get widget :xref-type)) (dspec (widget-get widget :xref-dspec)) (xrefs (slime-fetch-browsable-xrefs type dspec))) (cl-loop for (label dspec) in xrefs collect `(tree-widget :tag ,label :xref-type ,type :xref-dspec ,dspec :expander slime-expand-xrefs :has-children t))))) (defun slime-browse-xrefs (name type) "Show the xref graph of a function in a tree widget." (interactive (list (slime-read-from-minibuffer "Name: " (slime-symbol-at-point)) (read (completing-read "Type: " (slime-bogus-completion-alist '(":callers" ":callees" ":calls")) nil t ":")))) (slime-call-with-browser-setup (slime-buffer-name :xref) (slime-current-package) "Xref Browser" (lambda () (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name :expander 'slime-expand-xrefs :has-echildren t)))) (provide 'slime-xref-browser) slime-2.20/contrib/swank-arglists.lisp000066400000000000000000002052641315100173500200550ustar00rootroot00000000000000;;; swank-arglists.lisp --- arglist related code ?? ;; ;; Authors: Matthias Koeppe ;; Tobias C. Rittweiler ;; and others ;; ;; License: Public Domain ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-c-p-c)) ;;;; Utilities (defun compose (&rest functions) "Compose FUNCTIONS right-associatively, returning a function" #'(lambda (x) (reduce #'funcall functions :initial-value x :from-end t))) (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)))) (declaim (inline memq)) (defun memq (item list) (member item list :test #'eq)) (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)) (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) (member symbol '(declare declaim)))) (defun function-exists-p (form) (and (valid-function-name-p form) (fboundp form) t)) (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)))))) (defun arglist-available-p (arglist) (not (eql arglist :not-available))) (defmacro with-available-arglist ((var &rest more-vars) form &body body) `(multiple-value-bind (,var ,@more-vars) ,form (if (eql ,var :not-available) :not-available (progn ,@body)))) ;;;; Arglist Definition (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) ...)) ;;; ;; This is a wrapper object around anything that came from Slime and ;; could not reliably be read. (defstruct (arglist-dummy (:conc-name #:arglist-dummy.) (:constructor make-arglist-dummy (string-representation))) string-representation) (defun empty-arg-p (dummy) (and (arglist-dummy-p dummy) (zerop (length (arglist-dummy.string-representation dummy))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter +lambda-list-keywords+ '(&provided &required &optional &rest &key &any))) (defmacro do-decoded-arglist (decoded-arglist &body clauses) (assert (loop for clause in clauses thereis (member (car clause) +lambda-list-keywords+))) (flet ((parse-clauses (clauses) (let* ((size (length +lambda-list-keywords+)) (initial (make-hash-table :test #'eq :size size)) (main (make-hash-table :test #'eq :size size)) (final (make-hash-table :test #'eq :size size))) (loop for clause in clauses for lambda-list-keyword = (first clause) for clause-parameter = (second clause) do (case clause-parameter (:initially (setf (gethash lambda-list-keyword initial) clause)) (:finally (setf (gethash lambda-list-keyword final) clause)) (t (setf (gethash lambda-list-keyword main) clause))) finally (return (values initial main final))))) (generate-main-clause (clause arglist) (dcase clause ((&provided (&optional arg) . body) (let ((gensym (gensym "PROVIDED-ARG+"))) `(dolist (,gensym (arglist.provided-args ,arglist)) (declare (ignorable ,gensym)) (let (,@(when arg `((,arg ,gensym)))) ,@body)))) ((&required (&optional arg) . body) (let ((gensym (gensym "REQUIRED-ARG+"))) `(dolist (,gensym (arglist.required-args ,arglist)) (declare (ignorable ,gensym)) (let (,@(when arg `((,arg ,gensym)))) ,@body)))) ((&optional (&optional arg init) . body) (let ((optarg (gensym "OPTIONAL-ARG+"))) `(dolist (,optarg (arglist.optional-args ,arglist)) (declare (ignorable ,optarg)) (let (,@(when arg `((,arg (optional-arg.arg-name ,optarg)))) ,@(when init `((,init (optional-arg.default-arg ,optarg))))) ,@body)))) ((&key (&optional keyword arg init) . body) (let ((keyarg (gensym "KEY-ARG+"))) `(dolist (,keyarg (arglist.keyword-args ,arglist)) (declare (ignorable ,keyarg)) (let (,@(when keyword `((,keyword (keyword-arg.keyword ,keyarg)))) ,@(when arg `((,arg (keyword-arg.arg-name ,keyarg)))) ,@(when init `((,init (keyword-arg.default-arg ,keyarg))))) ,@body)))) ((&rest (&optional arg body-p) . body) `(when (arglist.rest ,arglist) (let (,@(when arg `((,arg (arglist.rest ,arglist)))) ,@(when body-p `((,body-p (arglist.body-p ,arglist))))) ,@body))) ((&any (&optional arg) . body) (let ((gensym (gensym "REQUIRED-ARG+"))) `(dolist (,gensym (arglist.any-args ,arglist)) (declare (ignorable ,gensym)) (let (,@(when arg `((,arg ,gensym)))) ,@body))))))) (let ((arglist (gensym "DECODED-ARGLIST+"))) (multiple-value-bind (initially-clauses main-clauses finally-clauses) (parse-clauses clauses) `(let ((,arglist ,decoded-arglist)) (block do-decoded-arglist ,@(loop for keyword in '(&provided &required &optional &rest &key &any) append (cddr (gethash keyword initially-clauses)) collect (let ((clause (gethash keyword main-clauses))) (when clause (generate-main-clause clause arglist))) append (cddr (gethash keyword finally-clauses))))))))) ;;;; Arglist Printing (defun undummy (x) (if (typep x 'arglist-dummy) (arglist-dummy.string-representation x) (prin1-to-string x))) (defun print-decoded-arglist (arglist &key operator provided-args highlight) (let ((first-space-after-operator (and operator t))) (macrolet ((space () ;; Kludge: When OPERATOR is not given, we don't want to ;; print a space for the first argument. `(if (not operator) (setq operator t) (progn (write-char #\space) (if first-space-after-operator (setq first-space-after-operator nil) (pprint-newline :fill))))) (with-highlighting ((&key index) &body body) `(if (eql ,index (car highlight)) (progn (princ "===> ") ,@body (princ " <===")) (progn ,@body))) (print-arglist-recursively (argl &key index) `(if (eql ,index (car highlight)) (print-decoded-arglist ,argl :highlight (cdr highlight)) (print-decoded-arglist ,argl)))) (let ((index 0)) (pprint-logical-block (nil nil :prefix "(" :suffix ")") (when operator (print-arg operator) (pprint-indent :current 1)) ; 1 due to possibly added space (do-decoded-arglist (remove-given-args arglist provided-args) (&provided (arg) (space) (print-arg arg :literal-strings t) (incf index)) (&required (arg) (space) (if (arglist-p arg) (print-arglist-recursively arg :index index) (with-highlighting (:index index) (print-arg arg))) (incf index)) (&optional :initially (when (arglist.optional-args arglist) (space) (princ '&optional))) (&optional (arg init-value) (space) (if (arglist-p arg) (print-arglist-recursively arg :index index) (with-highlighting (:index index) (if (null init-value) (print-arg arg) (format t "~:@<~A ~A~@:>" (undummy arg) (undummy init-value))))) (incf index)) (&key :initially (when (arglist.key-p arglist) (space) (princ '&key))) (&key (keyword arg init) (space) (if (arglist-p arg) (pprint-logical-block (nil nil :prefix "(" :suffix ")") (prin1 keyword) (space) (print-arglist-recursively arg :index keyword)) (with-highlighting (:index keyword) (cond ((and init (keywordp keyword)) (format t "~:@<~A ~A~@:>" keyword (undummy init))) (init (format t "~:@<(~A ..) ~A~@:>" (undummy keyword) (undummy init))) ((not (keywordp keyword)) (format t "~:@<(~S ..)~@:>" keyword)) (t (princ keyword)))))) (&key :finally (when (arglist.allow-other-keys-p arglist) (space) (princ '&allow-other-keys))) (&any :initially (when (arglist.any-p arglist) (space) (princ '&any))) (&any (arg) (space) (print-arg arg)) (&rest (args bodyp) (space) (princ (if bodyp '&body '&rest)) (space) (if (arglist-p args) (print-arglist-recursively args :index index) (with-highlighting (:index index) (print-arg args)))) ;; FIXME: add &UNKNOWN-JUNK? )))))) (defun print-arg (arg &key literal-strings) (let ((arg (if (arglist-dummy-p arg) (arglist-dummy.string-representation arg) arg))) (if (or (and literal-strings (stringp arg)) (keywordp arg)) (prin1 arg) (princ arg)))) (defun print-decoded-arglist-as-template (decoded-arglist &key (prefix "(") (suffix ")")) (let ((first-p t)) (flet ((space () (unless first-p (write-char #\space)) (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-dummy (princ (arglist-dummy.string-representation arg))) (arglist (print-decoded-arglist-as-template arg))) (pprint-newline :fill))) (pprint-logical-block (nil nil :prefix prefix :suffix suffix) (do-decoded-arglist decoded-arglist (&provided ()) ; do nothing; provided args are in the buffer already. (&required (arg) (space) (print-arg-or-pattern arg)) (&optional (arg) (space) (princ "[") (print-arg-or-pattern arg) (princ "]")) (&key (keyword arg) (space) (prin1 (if (keywordp keyword) keyword `',keyword)) (space) (print-arg-or-pattern arg) (pprint-newline :linear)) (&any (arg) (space) (print-arg-or-pattern arg)) (&rest (args) (when (or (not (arglist.keyword-args decoded-arglist)) (arglist.allow-other-keys-p decoded-arglist)) (space) (format t "~A..." args)))))))) (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))) (defvar *arglist-show-packages* t) (defmacro with-arglist-io-syntax (&body body) (let ((package (gensym))) `(let ((,package *package*)) (with-standard-io-syntax (let ((*package* (if *arglist-show-packages* *package* ,package))) (with-bindings *arglist-pprint-bindings* ,@body)))))) (defun decoded-arglist-to-string (decoded-arglist &key operator highlight print-right-margin) (with-output-to-string (*standard-output*) (with-arglist-io-syntax (let ((*print-right-margin* print-right-margin)) (print-decoded-arglist decoded-arglist :operator operator :highlight highlight))))) (defun decoded-arglist-to-template-string (decoded-arglist &key (prefix "(") (suffix ")")) (with-output-to-string (*standard-output*) (with-arglist-io-syntax (print-decoded-arglist-as-template decoded-arglist :prefix prefix :suffix suffix)))) ;;;; Arglist Decoding / Encoding (defun decode-required-arg (arg) "ARG can be a symbol or a destructuring pattern." (etypecase arg (symbol arg) (arglist-dummy 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) (defun canonicalize-default-arg (form) (if (equalp ''nil form) nil form)) (defun make-keyword-arg (keyword arg-name default-arg) (%make-keyword-arg :keyword keyword :arg-name arg-name :default-arg (canonicalize-default-arg default-arg))) (defun decode-keyword-arg (arg) "Decode a keyword item of formal argument list. Return three values: keyword, argument name, default arg." (flet ((intern-as-keyword (arg) (intern (etypecase arg (symbol (symbol-name arg)) (arglist-dummy (arglist-dummy.string-representation arg))) keyword-package))) (cond ((or (symbolp arg) (arglist-dummy-p arg)) (make-keyword-arg (intern-as-keyword arg) 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-as-keyword (car arg)) (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)))) ;;; FIXME suppliedp? (defstruct (optional-arg (:conc-name optional-arg.) (:constructor %make-optional-arg)) arg-name default-arg) (defun make-optional-arg (arg-name default-arg) (%make-optional-arg :arg-name arg-name :default-arg (canonicalize-default-arg 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)) (arglist-dummy (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." (etypecase arglist ((eql :not-available) (return-from decode-arglist :not-available)) (list)) (loop with mode = nil with result = (make-arglist) for arg = (if (consp arglist) (pop arglist) (progn (prog1 arglist (setf mode '&rest arglist nil)))) do (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)) ((memq arg '(&optional &rest &body &aux)) (setq mode arg)) ((memq 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)) ((memq 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)))))) until (null arglist) finally (nreversef (arglist.required-args result)) finally (nreversef (arglist.optional-args result)) finally (nreversef (arglist.keyword-args result)) finally (nreversef (arglist.aux-args result)) finally (nreversef (arglist.any-args result)) finally (nreversef (arglist.known-junk result)) finally (nreversef (arglist.unknown-junk result)) finally (assert (or (and (not (arglist.key-p result)) (not (arglist.any-p result))) (exactly-one-p (arglist.key-p result) (arglist.any-p result)))) finally (return 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))) ;;;; Arglist Enrichment (defun arglist-keywords (lambda-list) "Return the list of keywords in ARGLIST. As a secondary value, return whether &allow-other-keys appears." (let ((decoded-arglist (decode-arglist lambda-list))) (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))))) (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.")) ;;; We make sure that symbol-from-KEYWORD-using keywords come before ;;; symbol-from-arbitrary-package-using keywords. And we sort the ;;; latter according to how their home-packages relate to *PACKAGE*. ;;; ;;; Rationale is to show those key parameters first which make most ;;; sense in the current context. And in particular: to put ;;; implementation-internal stuff last. ;;; ;;; This matters tremendeously on Allegro in combination with ;;; AllegroCache as that does some evil tinkering with initargs, ;;; obfuscating the arglist of MAKE-INSTANCE. ;;; (defmethod extra-keywords :around (op &rest args) (declare (ignorable op args)) (multiple-value-bind (keywords aok enrichments) (call-next-method) (values (sort-extra-keywords keywords) aok enrichments))) (defun make-package-comparator (reference-packages) "Returns a two-argument test function which compares packages according to their used-by relation with REFERENCE-PACKAGES. Packages will be sorted first which appear first in the PACKAGE-USE-LIST of the reference packages." (let ((package-use-table (make-hash-table :test 'eq))) ;; Walk the package dependency graph breadth-fist, and fill ;; PACKAGE-USE-TABLE accordingly. (loop with queue = (copy-list reference-packages) with bfn = 0 ; Breadth-First Number for p = (pop queue) unless (gethash p package-use-table) do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn))) and do (setf queue (nconc queue (copy-list (package-use-list p)))) while queue) #'(lambda (p1 p2) (let ((bfn1 (gethash p1 package-use-table)) (bfn2 (gethash p2 package-use-table))) (cond ((and bfn1 bfn2) (<= bfn1 bfn2)) (bfn1 bfn1) (bfn2 nil) ; p2 is used, p1 not (t (string<= (package-name p1) (package-name p2)))))))) (defun sort-extra-keywords (kwds) (stable-sort kwds (make-package-comparator (list keyword-package *package*)) :key (compose #'symbol-package #'keyword-arg.keyword))) (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." (with-available-arglist (arglist) (arglist-from-form (ensure-list operator)) (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 (ignore-errors (swank-mop:finalize-inheritance class))) 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) (and (swank-mop:slot-definition-initfunction 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) (ignore-errors (applicable-methods-keywords #'initialize-instance (list (swank-mop:class-prototype class)))) (multiple-value-bind (shared-initialize-keywords si-aokp) (ignore-errors (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) (ignore-errors (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)))))))) (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) (with-available-arglist (decoded-arglist) (decode-arglist (arglist operator-form)) (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) (memq (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)) (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'multiple-value-call)) argument-forms) (compute-enriched-decoded-arglist 'apply argument-forms)) (defun delete-given-args (decoded-arglist args) "Delete given ARGS from DECODED-ARGLIST." (macrolet ((pop-or-return (list) `(if (null ,list) (return-from do-decoded-arglist) (pop ,list)))) (do-decoded-arglist decoded-arglist (&provided () (assert (eq (pop-or-return args) (pop (arglist.provided-args decoded-arglist))))) (&required () (pop-or-return args) (pop (arglist.required-args decoded-arglist))) (&optional () (pop-or-return args) (pop (arglist.optional-args decoded-arglist))) (&key (keyword) ;; N.b. we consider a keyword to be given only when the keyword ;; _and_ a value has been given for it. (loop for (key value) on args by #'cddr when (and (eq keyword key) value) do (setf (arglist.keyword-args decoded-arglist) (remove keyword (arglist.keyword-args decoded-arglist) :key #'keyword-arg.keyword)))))) decoded-arglist) (defun remove-given-args (decoded-arglist args) ;; FIXME: We actually needa deep copy here. (delete-given-args (copy-arglist decoded-arglist) args)) ;;;; Arglist Retrieval (defun arglist-from-form (form) (if (null form) :not-available (arglist-dispatch (car form) (cdr form)))) (export 'arglist-dispatch) (defgeneric arglist-dispatch (operator arguments) ;; Default method (:method (operator arguments) (unless (and (symbolp operator) (valid-operator-symbol-p operator)) (return-from arglist-dispatch :not-available)) (multiple-value-bind (decoded-arglist determining-args) (compute-enriched-decoded-arglist operator arguments) (with-available-arglist (arglist) decoded-arglist ;; replace some formal args by determining actual args (setf arglist (delete-given-args arglist determining-args)) (setf (arglist.provided-args arglist) determining-args) arglist)))) (defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments) (match (cons operator arguments) (('defmethod (#'function-exists-p gf-name) . rest) (let ((gf (fdefinition gf-name))) (when (typep gf 'generic-function) (with-available-arglist (arglist) (decode-arglist (arglist gf)) (let ((qualifiers (loop for x in rest until (or (listp x) (empty-arg-p x)) collect x))) (return-from arglist-dispatch (make-arglist :provided-args (cons gf-name qualifiers) :required-args (list arglist) :rest "body" :body-p t))))))) (_)) ; Fall through (call-next-method)) (defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments) (match (cons operator arguments) (('define-compiler-macro (#'function-exists-p gf-name) . _) (let ((gf (fdefinition gf-name))) (with-available-arglist (arglist) (decode-arglist (arglist gf)) (return-from arglist-dispatch (make-arglist :provided-args (list gf-name) :required-args (list arglist) :rest "body" :body-p t))))) (_)) ; Fall through (call-next-method)) (defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments) (declare (ignore arguments)) (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) (make-arglist :required-args (list (make-arglist :any-p t :any-args eval-when-args)) :rest '#:body :body-p t))) (defmethod arglist-dispatch ((operator (eql 'declare)) arguments) (let* ((declaration (cons operator (last arguments))) (typedecl-arglist (arglist-for-type-declaration declaration))) (if (arglist-available-p typedecl-arglist) typedecl-arglist (match declaration (('declare ((#'consp typespec) . decl-args)) (with-available-arglist (typespec-arglist) (decoded-arglist-for-type-specifier typespec) (make-arglist :required-args (list (make-arglist :required-args (list typespec-arglist) :rest '#:variables))))) (('declare (decl-identifier . decl-args)) (decoded-arglist-for-declaration decl-identifier decl-args)) (_ (make-arglist :rest '#:declaration-specifiers)))))) (defmethod arglist-dispatch ((operator (eql 'declaim)) arguments) (arglist-dispatch 'declare arguments)) (defun arglist-for-type-declaration (declaration) (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name) (with-available-arglist (typespec-arglist) (decoded-arglist-for-type-specifier typespec) (make-arglist :required-args (list (make-arglist :provided-args (list identifier) :required-args (list typespec-arglist) :rest rest-var-name)))))) (match declaration (('declare ('type (#'consp typespec) . decl-args)) (%arglist-for-type-declaration 'type typespec '#:variables)) (('declare ('ftype (#'consp typespec) . decl-args)) (%arglist-for-type-declaration 'ftype typespec '#:function-names)) (('declare ((#'consp typespec) . decl-args)) (with-available-arglist (typespec-arglist) (decoded-arglist-for-type-specifier typespec) (make-arglist :required-args (list (make-arglist :required-args (list typespec-arglist) :rest '#:variables))))) (_ :not-available)))) (defun decoded-arglist-for-declaration (decl-identifier decl-args) (declare (ignore decl-args)) (with-available-arglist (arglist) (decode-arglist (declaration-arglist decl-identifier)) (setf (arglist.provided-args arglist) (list decl-identifier)) (make-arglist :required-args (list arglist)))) (defun decoded-arglist-for-type-specifier (type-specifier) (etypecase type-specifier (arglist-dummy :not-available) (cons (decoded-arglist-for-type-specifier (car type-specifier))) (symbol (with-available-arglist (arglist) (decode-arglist (type-specifier-arglist type-specifier)) (setf (arglist.provided-args arglist) (list type-specifier)) arglist)))) ;;; Slimefuns ;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at ;;; user's point in Emacs. A RAW-FORM looks like ;;; ;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SWANK::%CURSOR-MARKER%)) ;;; ;;; The expression before the cursor marker is the expression where ;;; user's cursor points at. An explicit marker is necessary to ;;; disambiguate between ;;; ;;; ("IF" ("PRED") ;;; ("F" "X" "Y" %CURSOR-MARKER%)) ;;; ;;; and ;;; ("IF" ("PRED") ;;; ("F" "X" "Y") %CURSOR-MARKER%) ;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes ;;; user's point, the following should be sent ("FOO" ("BAR" "" ;;; %CURSOR-MARKER%)). Only the forms up to point should be ;;; considered. (defslimefun autodoc (raw-form &key print-right-margin) "Return a list of two elements. First, a string representing the arglist for the deepest subform in RAW-FORM that does have an arglist. The highlighted parameter is wrapped in ===> X <===. Second, a boolean value telling whether the returned string can be cached." (handler-bind ((serious-condition #'(lambda (c) (unless (debug-on-swank-error) (let ((*print-right-margin* print-right-margin)) (return-from autodoc (format nil "Arglist Error: \"~A\"" c))))))) (with-buffer-syntax () (multiple-value-bind (form arglist obj-at-cursor form-path) (find-subform-with-arglist (parse-raw-form raw-form)) (cond ((boundp-and-interesting obj-at-cursor) (list (print-variable-to-string obj-at-cursor) nil)) (t (list (with-available-arglist (arglist) arglist (decoded-arglist-to-string arglist :print-right-margin print-right-margin :operator (car form) :highlight (form-path-to-arglist-path form-path form arglist))) t))))))) (defun boundp-and-interesting (symbol) (and symbol (symbolp symbol) (boundp symbol) (not (memq symbol '(cl:t cl:nil))) (not (keywordp symbol)))) (defun print-variable-to-string (symbol) "Return a short description of VARIABLE-NAME, or NIL." (let ((*print-pretty* t) (*print-level* 4) (*print-length* 10) (*print-lines* 1) (*print-readably* nil) (value (symbol-value symbol))) (call/truncated-output-to-string 75 (lambda (s) (without-printing-errors (:object value :stream s) (format s "~A ~A~S" symbol *echo-area-prefix* value)))))) (defslimefun complete-form (raw-form) "Read FORM-STRING in the current buffer package, then complete it by adding a template for the missing arguments." ;; We do not catch errors here because COMPLETE-FORM is an ;; interactive command, not automatically run in the background like ;; ARGLIST-FOR-ECHO-AREA. (with-buffer-syntax () (multiple-value-bind (arglist provided-args) (find-immediately-containing-arglist (parse-raw-form raw-form)) (with-available-arglist (arglist) arglist (decoded-arglist-to-template-string (delete-given-args arglist (remove-if #'empty-arg-p provided-args :from-end t :count 1)) :prefix "" :suffix ""))))) (defslimefun completions-for-keyword (keyword-string raw-form) "Return a list of possible completions for KEYWORD-STRING relative to the context provided by RAW-FORM." (with-buffer-syntax () (let ((arglist (find-immediately-containing-arglist (parse-raw-form raw-form)))) (when (arglist-available-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 (make-compound-prefix-matcher #\-))) (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))))))) (defparameter +cursor-marker+ '%cursor-marker%) (defun find-subform-with-arglist (form) "Returns four values: The appropriate subform of `form' which is closest to the +CURSOR-MARKER+ and whose operator is valid and has an arglist. The +CURSOR-MARKER+ is removed from that subform. Second value is the arglist. Local function and macro definitions appearing in `form' into account. Third value is the object in front of +CURSOR-MARKER+. Fourth value is a form path to that object." (labels ((yield-success (form local-ops) (multiple-value-bind (form obj-at-cursor form-path) (extract-cursor-marker form) (values form (let ((entry (assoc (car form) local-ops :test #'op=))) (if entry (decode-arglist (cdr entry)) (arglist-from-form form))) obj-at-cursor form-path))) (yield-failure () (values nil :not-available)) (operator-p (operator local-ops) (or (and (symbolp operator) (valid-operator-symbol-p operator)) (assoc operator local-ops :test #'op=))) (op= (op1 op2) (cond ((and (symbolp op1) (symbolp op2)) (eq op1 op2)) ((and (arglist-dummy-p op1) (arglist-dummy-p op2)) (string= (arglist-dummy.string-representation op1) (arglist-dummy.string-representation op2))))) (grovel-form (form local-ops) "Descend FORM top-down, always taking the rightest branch, until +CURSOR-MARKER+." (assert (listp form)) (destructuring-bind (operator . args) form ;; N.b. the user's cursor is at the rightmost, deepest ;; subform right before +CURSOR-MARKER+. (let ((last-subform (car (last form))) (new-ops)) (cond ((eq last-subform +cursor-marker+) (if (operator-p operator local-ops) (yield-success form local-ops) (yield-failure))) ((not (operator-p operator local-ops)) (grovel-form last-subform local-ops)) ;; Make sure to pick up the arglists of local ;; function/macro definitions. ((setq new-ops (extract-local-op-arglists operator args)) (multiple-value-or (grovel-form last-subform (nconc new-ops local-ops)) (yield-success form local-ops))) ;; Some typespecs clash with function names, so we make ;; sure to bail out early. ((member operator '(cl:declare cl:declaim)) (yield-success form local-ops)) ;; Mostly uninteresting, hence skip. ((memq operator '(cl:quote cl:function)) (yield-failure)) (t (multiple-value-or (grovel-form last-subform local-ops) (yield-success form local-ops)))))))) (if (null form) (yield-failure) (grovel-form form '())))) (defun extract-cursor-marker (form) "Returns three values: normalized `form' without +CURSOR-MARKER+, the object in front of +CURSOR-MARKER+, and a form path to that object." (labels ((grovel (form last path) (let ((result-form)) (loop for (car . cdr) on form do (cond ((eql car +cursor-marker+) (decf (first path)) (return-from grovel (values (nreconc result-form cdr) last (nreverse path)))) ((consp car) (multiple-value-bind (new-car new-last new-path) (grovel car last (cons 0 path)) (when new-path ; CAR contained cursor-marker? (return-from grovel (values (nreconc (cons new-car result-form) cdr) new-last new-path)))))) (push car result-form) (setq last car) (incf (first path)) finally (return-from grovel (values (nreverse result-form) nil nil)))))) (grovel form nil (list 0)))) (defgeneric extract-local-op-arglists (operator args) (:documentation "If the form `(OPERATOR ,@ARGS) is a local operator binding form, return a list of pairs (OP . ARGLIST) for each locally bound op.") (:method (operator args) (declare (ignore operator args)) nil) ;; FLET (:method ((operator (eql 'cl:flet)) args) (let ((defs (first args)) (body (rest args))) (cond ((null body) nil) ; `(flet ((foo (x) |' ((atom defs) nil) ; `(flet ,foo (|' (t (%collect-op/argl-alist defs))))) ;; LABELS (:method ((operator (eql 'cl:labels)) args) ;; Notice that we only have information to "look backward" and ;; show arglists of previously occuring local functions. (destructuring-bind (defs . body) args (unless (or (atom defs) (null body)) ; `(labels ,foo (|' (let ((current-def (car (last defs)))) (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|' ((not (null body)) (extract-local-op-arglists 'cl:flet args)) (t (let ((def.body (cddr current-def))) (when def.body (%collect-op/argl-alist defs))))))))) ;; MACROLET (:method ((operator (eql 'cl:macrolet)) args) (extract-local-op-arglists 'cl:labels args))) (defun %collect-op/argl-alist (defs) (setq defs (remove-if-not #'(lambda (x) ;; Well-formed FLET/LABELS def? (and (consp x) (second x))) defs)) (loop for (name arglist . nil) in defs collect (cons name arglist))) (defun find-immediately-containing-arglist (form) "Returns the arglist of the subform _immediately_ containing +CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may be in a nested arglist \(e.g. `(WITH-OPEN-FILE ('\), and the arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be returned in that case." (flet ((try (form-path form arglist) (let* ((arglist-path (form-path-to-arglist-path form-path form arglist)) (argl (apply #'arglist-ref arglist arglist-path)) (args (apply #'provided-arguments-ref (cdr form) arglist arglist-path))) (when (and (arglist-p argl) (listp args)) (values argl args))))) (multiple-value-bind (form arglist obj form-path) (find-subform-with-arglist form) (declare (ignore obj)) (with-available-arglist (arglist) arglist ;; First try the form the cursor is in (in case of a normal ;; form), then try the surrounding form (in case of a nested ;; macro form). (multiple-value-or (try form-path form arglist) (try (butlast form-path) form arglist) :not-available))))) (defun form-path-to-arglist-path (form-path form arglist) "Convert a form path to an arglist path consisting of arglist indices." (labels ((convert (path args arglist) (if (null path) nil (let* ((idx (car path)) (idx* (arglist-index idx args arglist)) (arglist* (and idx* (arglist-ref arglist idx*))) (args* (and idx* (provided-arguments-ref args arglist idx*)))) ;; The FORM-PATH may be more detailed than ARGLIST; ;; consider (defun foo (x y) ...), a form path may ;; point into the function's lambda-list, but the ;; arglist of DEFUN won't contain as much information. ;; So we only recurse if possible. (cond ((null idx*) nil) ((arglist-p arglist*) (cons idx* (convert (cdr path) args* arglist*))) (t (list idx*))))))) (convert ;; FORM contains irrelevant operator. Adjust FORM-PATH. (cond ((null form-path) nil) ((equal form-path '(0)) nil) (t (destructuring-bind (car . cdr) form-path (cons (1- car) cdr)))) (cdr form) arglist))) (defun arglist-index (provided-argument-index provided-arguments arglist) "Return the arglist index into `arglist' for the parameter belonging to the argument (NTH `provided-argument-index' `provided-arguments')." (let ((positional-args# (positional-args-number arglist)) (arg-index provided-argument-index)) (with-struct (arglist. key-p rest) arglist (cond ((< arg-index positional-args#) ; required + optional arg-index) ((and (not key-p) (not rest)) ; more provided than allowed nil) ((not key-p) ; rest + body (assert (arglist.rest arglist)) positional-args#) (t ; key ;; Find last provided &key parameter (let* ((argument (nth arg-index provided-arguments)) (provided-keys (subseq provided-arguments positional-args#))) (loop for (key value) on provided-keys by #'cddr when (eq value argument) return (match key (('quote symbol) symbol) (_ key))))))))) (defun arglist-ref (arglist &rest indices) "Returns the parameter in ARGLIST along the INDICIES path. Numbers represent positional parameters (required, optional), keywords represent key parameters." (flet ((ref-positional-arg (arglist index) (check-type index (integer 0 *)) (with-struct (arglist. provided-args required-args optional-args rest) arglist (loop for args in (list provided-args required-args (mapcar #'optional-arg.arg-name optional-args)) for args# = (length args) if (< index args#) return (nth index args) else do (decf index args#) finally (return (or rest nil))))) (ref-keyword-arg (arglist keyword) ;; keyword argument may be any symbol, ;; not only from the KEYWORD package. (let ((keyword (match keyword (('quote symbol) symbol) (_ keyword)))) (do-decoded-arglist arglist (&key (kw arg) (when (eq kw keyword) (return-from ref-keyword-arg arg))))) nil)) (dolist (index indices) (assert (arglist-p arglist)) (setq arglist (if (numberp index) (ref-positional-arg arglist index) (ref-keyword-arg arglist index)))) arglist)) (defun provided-arguments-ref (provided-args arglist &rest indices) "Returns the argument in PROVIDED-ARGUMENT along the INDICES path relative to ARGLIST." (check-type arglist arglist) (flet ((ref (provided-args arglist index) (if (numberp index) (nth index provided-args) (let ((provided-keys (subseq provided-args (positional-args-number arglist)))) (loop for (key value) on provided-keys when (eq key index) return value))))) (dolist (idx indices) (setq provided-args (ref provided-args arglist idx)) (setq arglist (arglist-ref arglist idx))) provided-args)) (defun positional-args-number (arglist) (+ (length (arglist.provided-args arglist)) (length (arglist.required-args arglist)) (length (arglist.optional-args arglist)))) (defun parse-raw-form (raw-form) "Parse a RAW-FORM into a Lisp form. I.e. substitute strings by symbols if already interned. For strings not already interned, use ARGLIST-DUMMY." (unless (null raw-form) (loop for element in raw-form collect (etypecase element (string (read-conversatively element)) (list (parse-raw-form element)) (symbol (prog1 element ;; Comes after list, so ELEMENT can't be NIL. (assert (eq element +cursor-marker+)))))))) (defun read-conversatively (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), an object of type 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)) (length (length string)) (type (cond ((zerop length) nil) ((eql (aref string 0) #\') :quoted-symbol) ((search "#'" string :end2 (min length 2)) :sharpquoted-symbol) ((char= (char string 0) (char string (1- length)) #\") :string) (t :symbol)))) (multiple-value-bind (symbol found?) (case type (:symbol (parse-symbol string)) (:quoted-symbol (parse-symbol (subseq string 1))) (:sharpquoted-symbol (parse-symbol (subseq string 2))) (:string (values string t)) (t (values string nil))) (if found? (ecase type (:symbol symbol) (:quoted-symbol `(quote ,symbol)) (:sharpquoted-symbol `(function ,symbol)) (:string (if (> length 1) (subseq string 1 (1- length)) string))) (make-arglist-dummy string))))) (defun test-print-arglist () (flet ((test (arglist &rest strings) (let* ((*package* (find-package :swank)) (actual (decoded-arglist-to-string (decode-arglist arglist) :print-right-margin 1000))) (unless (loop for string in strings thereis (string= actual string)) (warn "Test failed: ~S => ~S~% Expected: ~A" arglist actual (if (cdr strings) (format nil "One of: ~{~S~^, ~}" strings) (format nil "~S" (first strings)))))))) (test '(function cons) "(function cons)") (test '(quote cons) "(quote cons)") (test '(&key (function #'+)) "(&key (function #'+))" "(&key (function (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 ..)))") (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)))"))) (defun test-arglist-ref () (macrolet ((soft-assert (form) `(unless ,form (warn "Assertion failed: ~S~%" ',form)))) (let ((sample (decode-arglist '(x &key ((:k (y z))))))) (soft-assert (eq (arglist-ref sample 0) 'x)) (soft-assert (eq (arglist-ref sample :k 0) 'y)) (soft-assert (eq (arglist-ref sample :k 1) 'z)) (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0) 'a)) (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0) 'b)) (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1) 'c))))) (test-print-arglist) (test-arglist-ref) (provide :swank-arglists) slime-2.20/contrib/swank-asdf.lisp000066400000000000000000000513221315100173500171340ustar00rootroot00000000000000;;; swank-asdf.lisp -- ASDF support ;; ;; Authors: Daniel Barlow ;; Marco Baringer ;; Edi Weitz ;; Francois-Rene Rideau ;; and others ;; License: Public Domain ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; The best way to load ASDF is from an init file of an ;;; implementation. If ASDF is not loaded at the time swank-asdf is ;;; loaded, it will be tried first with (require "asdf"), if that ;;; doesn't help and *asdf-path* is set, it will be loaded from that ;;; file. ;;; To set *asdf-path* put the following into ~/.swank.lisp: ;;; (defparameter swank::*asdf-path* #p"/path/to/asdf/asdf.lisp") (defvar *asdf-path* nil "Path to asdf.lisp file, to be loaded in case (require \"asdf\") fails.")) (eval-when (:compile-toplevel :load-toplevel :execute) (unless (member :asdf *features*) (ignore-errors (funcall 'require "asdf")))) (eval-when (:compile-toplevel :load-toplevel :execute) (unless (member :asdf *features*) (handler-bind ((warning #'muffle-warning)) (when *asdf-path* (load *asdf-path* :if-does-not-exist nil))))) ;; If still not found, error out. (eval-when (:compile-toplevel :load-toplevel :execute) (unless (member :asdf *features*) (error "Could not load ASDF. Please update your implementation or install a recent release of ASDF and in your ~~/.swank.lisp specify: (defparameter swank::*asdf-path* #p\"/path/containing/asdf/asdf.lisp\")"))) ;;; If ASDF is too old, punt. ;; As of January 2014, Quicklisp has been providing 2.26 for a year ;; (and previously had 2.014.6 for over a year), whereas ;; all SLIME-supported implementations provide ASDF3 (i.e. 2.27 or later) ;; except LispWorks (stuck with 2.019) and SCL (which hasn't been released ;; in years and doesn't provide ASDF at all, but is fully supported by ASDF). ;; If your implementation doesn't provide ASDF, or provides an old one, ;; install an upgrade yourself and configure *asdf-path*. ;; It's just not worth the hassle supporting something ;; that doesn't even have COERCE-PATHNAME. ;; ;; NB: this version check is duplicated in swank-loader.lisp so that we don't ;; try to load this contrib when ASDF is too old since that will abort the SLIME ;; connection. #-asdf3 (eval-when (:compile-toplevel :load-toplevel :execute) (unless (or #+asdf3 t #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "2.14.6")) (error "Your ASDF is too old. ~ The oldest version supported by swank-asdf is 2.014.6."))) ;;; Import functionality from ASDF that isn't available in all ASDF versions. ;;; Please do NOT depend on any of the below as reference: ;;; they are sometimes stripped down versions, for compatibility only. ;;; Indeed, they are supposed to work on *OLDER*, not *NEWER* versions of ASDF. ;;; ;;; The way I got these is usually by looking at the current definition, ;;; using git blame in one screen to locate which commit last modified it, ;;; and git log in another to determine which release that made it in. ;;; It is OK for some of the below definitions to be or become obsolete, ;;; as long as it will make do with versions older than the tagged version: ;;; if ASDF is more recent, its more recent version will win. ;;; ;;; If your software is hacking ASDF, use its internals. ;;; If you want ASDF utilities in user software, please use ASDF-UTILS. (defun asdf-at-least (version) (asdf:version-satisfies (asdf:asdf-version) version)) (defmacro asdefs (version &rest defs) (flet ((defun* (version name aname rest) `(progn (defun ,name ,@rest) (declaim (notinline ,name)) (when (asdf-at-least ,version) (setf (fdefinition ',name) (fdefinition ',aname))))) (defmethod* (version aname rest) `(unless (asdf-at-least ,version) (defmethod ,aname ,@rest))) (defvar* (name aname rest) `(progn (define-symbol-macro ,name ,aname) (defvar ,aname ,@rest)))) `(progn ,@(loop :for (def name . args) :in defs :for aname = (intern (string name) :asdf) :collect (ecase def ((defun) (defun* version name aname args)) ((defmethod) (defmethod* version aname args)) ((defvar) (defvar* name aname args))))))) (asdefs "2.15" (defvar *wild* #-cormanlisp :wild #+cormanlisp "*") (defun collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory))) (defun register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (collect-asds-in-directory directory collect) (collect-sub*directories-asd-files directory :exclude exclude :collect collect)))) (asdefs "2.16" (defun load-sysdef (name pathname) (declare (ignore name)) (let ((package (asdf::make-temporary-package))) (unwind-protect (let ((*package* package) (*default-pathname-defaults* (asdf::pathname-directory-pathname (translate-logical-pathname pathname)))) (asdf::asdf-message "~&; Loading system definition from ~A into ~A~%" ; pathname package) (load pathname)) (delete-package package)))) (defun directory* (pathname-spec &rest keys &key &allow-other-keys) (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) #+clozure '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" '#:sb-impl) '(:resolve-symlinks nil))))))) (asdefs "2.17" (defun collect-sub*directories-asd-files (directory &key (exclude asdf::*default-source-registry-exclusions*) collect) (asdf::collect-sub*directories directory (constantly t) (lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) (lambda (dir) (collect-asds-in-directory dir collect)))) (defun system-source-directory (system-designator) (asdf::pathname-directory-pathname (asdf::system-source-file system-designator))) (defun filter-logical-directory-results (directory entries merger) (if (typep directory 'logical-pathname) (loop for f in entries when (if (typep f 'logical-pathname) f (let ((u (ignore-errors (funcall merger f)))) (and u (equal (ignore-errors (truename u)) (truename f)) u))) collect it) entries)) (defun directory-asd-files (directory) (directory-files directory asdf::*wild-asd*))) (asdefs "2.19" (defun subdirectories (directory) (let* ((directory (asdf::ensure-directory-pathname directory)) #-(or abcl cormanlisp xcl) (wild (asdf::merge-pathnames* #-(or abcl allegro cmu lispworks sbcl scl xcl) asdf::*wild-directory* #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp xcl) (ignore-errors (directory* wild . #.(or #+clozure '(:directories t :files nil) #+mcl '(:directories t)))) #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory)) #+(or abcl allegro cmu lispworks sbcl scl xcl) (dirs (loop for x in dirs for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) #+(or cmu sbcl scl) (asdf::directory-pathname-p x) #+lispworks (lw:file-directory-p x) when d collect #+(or abcl allegro xcl) d #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) ;; because allegro 8.x returns NIL for #p"FOO:" '(:absolute)))) (lambda (d) (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) (and (consp dir) (consp (cdr dir)) (make-pathname :defaults directory :name nil :type nil :version nil :directory (append prefix (make-pathname-component-logical (last dir)))))))))))) (asdefs "2.21" (defun component-loaded-p (c) (and (gethash 'load-op (asdf::component-operation-times (asdf::find-component c nil))) t)) (defun normalize-pathname-directory-component (directory) (cond #-(or cmu sbcl scl) ((stringp directory) `(:absolute ,directory) directory) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) (t (error "Unrecognized pathname directory component ~S" directory)))) (defun make-pathname-component-logical (x) (typecase x ((eql :unspecific) nil) #+clisp (string (string-upcase x)) #+clisp (cons (mapcar 'make-pathname-component-logical x)) (t x))) (defun make-pathname-logical (pathname host) (make-pathname :host host :directory (make-pathname-component-logical (pathname-directory pathname)) :name (make-pathname-component-logical (pathname-name pathname)) :type (make-pathname-component-logical (pathname-type pathname)) :version (make-pathname-component-logical (pathname-version pathname))))) (asdefs "2.22" (defun directory-files (directory &optional (pattern asdf::*wild-file*)) (let ((dir (pathname directory))) (when (typep dir 'logical-pathname) (when (wild-pathname-p dir) (error "Invalid wild pattern in logical directory ~S" directory)) (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) (setf pattern (make-pathname-logical pattern (pathname-host dir)))) (let ((entries (ignore-errors (directory* (asdf::merge-pathnames* pattern dir))))) (filter-logical-directory-results directory entries (lambda (f) (make-pathname :defaults dir :name (make-pathname-component-logical (pathname-name f)) :type (make-pathname-component-logical (pathname-type f)) :version (make-pathname-component-logical (pathname-version f))))))))) (asdefs "2.26.149" (defmethod component-relative-pathname ((system asdf:system)) (asdf::coerce-pathname (and (slot-boundp system 'asdf::relative-pathname) (slot-value system 'asdf::relative-pathname)) :type :directory :defaults (system-source-directory system))) (defun load-asd (pathname &key name &allow-other-keys) (asdf::load-sysdef (or name (string-downcase (pathname-name pathname))) pathname))) ;;; Taken from ASDF 1.628 (defmacro while-collecting ((&rest collectors) &body body) `(asdf::while-collecting ,collectors ,@body)) ;;; Now for SLIME-specific stuff (defun asdf-operation (operation) (or (asdf::find-symbol* operation :asdf) (error "Couldn't find ASDF operation ~S" operation))) (defun map-system-components (fn system) (map-component-subcomponents fn (asdf:find-system system))) (defun map-component-subcomponents (fn component) (when component (funcall fn component) (when (typep component 'asdf:module) (dolist (c (asdf:module-components component)) (map-component-subcomponents fn c))))) ;;; Maintaining a pathname to component table (defvar *pathname-component* (make-hash-table :test 'equal)) (defun clear-pathname-component-table () (clrhash *pathname-component*)) (defun register-system-pathnames (system) (map-system-components 'register-component-pathname system)) (defun recompute-pathname-component-table () (clear-pathname-component-table) (asdf::map-systems 'register-system-pathnames)) (defun pathname-component (x) (gethash (pathname x) *pathname-component*)) (defmethod asdf:component-pathname :around ((component asdf:component)) (let ((p (call-next-method))) (when (pathnamep p) (setf (gethash p *pathname-component*) component)) p)) (defun register-component-pathname (component) (asdf:component-pathname component)) (recompute-pathname-component-table) ;;; This is a crude hack, see ASDF's LP #481187. (defslimefun who-depends-on (system) (flet ((system-dependencies (op system) (mapcar (lambda (dep) (asdf::coerce-name (if (consp dep) (second dep) dep))) (cdr (assoc op (asdf:component-depends-on op system)))))) (let ((system-name (asdf::coerce-name system)) (result)) (asdf::map-systems (lambda (system) (when (member system-name (system-dependencies 'asdf:load-op system) :test #'string=) (push (asdf:component-name system) result)))) result))) (defmethod xref-doit ((type (eql :depends-on)) thing) (when (typep thing '(or string symbol)) (loop for dependency in (who-depends-on thing) for asd-file = (asdf:system-definition-pathname dependency) when asd-file collect (list dependency (swank/backend:make-location `(:file ,(namestring asd-file)) `(:position 1) `(:snippet ,(format nil "(defsystem :~A" dependency) :align t)))))) (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords) "Compile and load SYSTEM using ASDF. Record compiler notes signalled as `compiler-condition's." (collect-notes (lambda () (apply #'operate-on-system system-name operation keywords)))) (defun operate-on-system (system-name operation-name &rest keyword-args) "Perform OPERATION-NAME on SYSTEM-NAME using ASDF. The KEYWORD-ARGS are passed on to the operation. Example: \(operate-on-system \"cl-ppcre\" 'compile-op :force t)" (handler-case (with-compilation-hooks () (apply #'asdf:operate (asdf-operation operation-name) system-name keyword-args) t) ((or asdf:compile-error #+asdf3 asdf/lisp-build:compile-file-error) () nil))) (defun unique-string-list (&rest lists) (sort (delete-duplicates (apply #'append lists) :test #'string=) #'string<)) (defslimefun list-all-systems-in-central-registry () "Returns a list of all systems in ASDF's central registry AND in its source-registry. (legacy name)" (unique-string-list (mapcar #'pathname-name (while-collecting (c) (loop for dir in asdf:*central-registry* for defaults = (eval dir) when defaults do (collect-asds-in-directory defaults #'c)) (asdf:ensure-source-registry) (if (or #+asdf3 t #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15")) (loop :for k :being :the :hash-keys :of asdf::*source-registry* :do (c k)) #-asdf3 (dolist (entry (asdf::flatten-source-registry)) (destructuring-bind (directory &key recurse exclude) entry (register-asd-directory directory :recurse recurse :exclude exclude :collect #'c)))))))) (defslimefun list-all-systems-known-to-asdf () "Returns a list of all systems ASDF knows already." (while-collecting (c) (asdf::map-systems (lambda (system) (c (asdf:component-name system)))))) (defslimefun list-asdf-systems () "Returns the systems in ASDF's central registry and those which ASDF already knows." (unique-string-list (list-all-systems-known-to-asdf) (list-all-systems-in-central-registry))) (defun asdf-component-source-files (component) (while-collecting (c) (labels ((f (x) (typecase x (asdf:source-file (c (asdf:component-pathname x))) (asdf:module (map () #'f (asdf:module-components x)))))) (f component)))) (defun asdf-component-output-files (component) (while-collecting (c) (labels ((f (x) (typecase x (asdf:source-file (map () #'c (asdf:output-files (make-instance 'asdf:compile-op) x))) (asdf:module (map () #'f (asdf:module-components x)))))) (f component)))) (defslimefun asdf-system-files (name) (let* ((system (asdf:find-system name)) (files (mapcar #'namestring (cons (asdf:system-definition-pathname system) (asdf-component-source-files system)))) (main-file (find name files :test #'equalp :key #'pathname-name :start 1))) (if main-file (cons main-file (remove main-file files :test #'equal :count 1)) files))) (defslimefun asdf-system-loaded-p (name) (component-loaded-p name)) (defslimefun asdf-system-directory (name) (namestring (asdf:system-source-directory name))) (defun pathname-system (pathname) (let ((component (pathname-component pathname))) (when component (asdf:component-name (asdf:component-system component))))) (defslimefun asdf-determine-system (file buffer-package-name) (or (and file (pathname-system file)) (and file (progn ;; If not found, let's rebuild the table first (recompute-pathname-component-table) (pathname-system file))) ;; If we couldn't find an already defined system, ;; try finding a system that's named like BUFFER-PACKAGE-NAME. (loop with package = (guess-buffer-package buffer-package-name) for name in (package-names package) for system = (asdf:find-system (asdf::coerce-name name) nil) when (and system (or (not file) (pathname-system file))) return (asdf:component-name system)))) (defslimefun delete-system-fasls (name) (let ((removed-count (loop for file in (asdf-component-output-files (asdf:find-system name)) when (probe-file file) count it and do (delete-file file)))) (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count))) (defvar *recompile-system* nil) (defmethod asdf:operation-done-p :around ((operation asdf:compile-op) component) (unless (eql *recompile-system* (asdf:component-system component)) (call-next-method))) (defslimefun reload-system (name) (let ((*recompile-system* (asdf:find-system name))) (operate-on-system-for-emacs name 'asdf:load-op))) ;; Doing list-all-systems-in-central-registry might be quite slow ;; since it accesses a file-system, so run it once at the background ;; to initialize caches. (when (eql *communication-style* :spawn) (spawn (lambda () (ignore-errors (list-all-systems-in-central-registry))) :name "init-asdf-fs-caches")) ;;; Hook for compile-file-for-emacs (defun try-compile-file-with-asdf (pathname load-p &rest options) (declare (ignore options)) (let ((component (pathname-component pathname))) (when component ;;(format t "~&Compiling ASDF component ~S~%" component) (let ((op (make-instance 'asdf:compile-op))) (with-compilation-hooks () (asdf:perform op component)) (when load-p (asdf:perform (make-instance 'asdf:load-op) component)) (values t t nil (first (asdf:output-files op component))))))) (defun try-compile-asd-file (pathname load-p &rest options) (declare (ignore load-p options)) (when (equalp (pathname-type pathname) "asd") (load-asd pathname) (values t t nil pathname))) (pushnew 'try-compile-asd-file *compile-file-for-emacs-hook*) ;;; (pushnew 'try-compile-file-with-asdf *compile-file-for-emacs-hook*) (provide :swank-asdf) slime-2.20/contrib/swank-c-p-c.lisp000066400000000000000000000276571315100173500171340ustar00rootroot00000000000000;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion ;; ;; Author: Luke Gorrie ;; Edi Weitz ;; Matthias Koeppe ;; Tobias C. Rittweiler ;; and others ;; ;; License: Public Domain ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-util)) (defslimefun completions (string default-package-name) "Return a list of completions for a symbol designator STRING. The result is the list (COMPLETION-SET COMPLETED-PREFIX), where COMPLETION-SET is the list of all matching completions, and COMPLETED-PREFIX is the best (partial) completion of the input string. Simple compound matching is supported on a per-hyphen basis: (completions \"m-v-\" \"COMMON-LISP\") ==> ((\"multiple-value-bind\" \"multiple-value-call\" \"multiple-value-list\" \"multiple-value-prog1\" \"multiple-value-setq\" \"multiple-values-limit\") \"multiple-value\") \(For more advanced compound matching, see FUZZY-COMPLETIONS.) If STRING is package qualified the result list will also be qualified. If string is non-qualified the result strings are also not qualified and are considered relative to DEFAULT-PACKAGE-NAME. The way symbols are matched depends on the symbol designator's format. The cases are as follows: FOO - Symbols with matching prefix and accessible in the buffer package. PKG:FOO - Symbols with matching prefix and external in package PKG. PKG::FOO - Symbols with matching prefix and accessible in package PKG. " (multiple-value-bind (name package-name package internal-p) (parse-completion-arguments string default-package-name) (let* ((symbol-set (symbol-completion-set name package-name package internal-p (make-compound-prefix-matcher #\-))) (package-set (package-completion-set name package-name package internal-p (make-compound-prefix-matcher '(#\. #\-)))) (completion-set (format-completion-set (nconc symbol-set package-set) internal-p package-name))) (when completion-set (list completion-set (longest-compound-prefix completion-set)))))) ;;;;; Find completion set (defun symbol-completion-set (name package-name package internal-p matchp) "Return the set of completion-candidates as strings." (mapcar (completion-output-symbol-converter name) (and package (mapcar #'symbol-name (find-matching-symbols name package (and (not internal-p) package-name) matchp))))) (defun package-completion-set (name package-name package internal-p matchp) (declare (ignore package internal-p)) (mapcar (completion-output-package-converter name) (and (not package-name) (find-matching-packages name matchp)))) (defun find-matching-symbols (string package external test) "Return a list of symbols in PACKAGE matching STRING. TEST is called with two strings. If EXTERNAL is true, only external symbols are returned." (let ((completions '()) (converter (completion-output-symbol-converter string))) (flet ((symbol-matches-p (symbol) (and (or (not external) (symbol-external-p symbol package)) (funcall test string (funcall converter (symbol-name symbol)))))) (do-symbols* (symbol package) (when (symbol-matches-p symbol) (push symbol completions)))) completions)) (defun find-matching-symbols-in-list (string list test) "Return a list of symbols in LIST matching STRING. TEST is called with two strings." (let ((completions '()) (converter (completion-output-symbol-converter string))) (flet ((symbol-matches-p (symbol) (funcall test string (funcall converter (symbol-name symbol))))) (dolist (symbol list) (when (symbol-matches-p symbol) (push symbol completions)))) (remove-duplicates completions))) (defun find-matching-packages (name matcher) "Return a list of package names matching NAME with MATCHER. MATCHER is a two-argument predicate." (let ((converter (completion-output-package-converter name))) (remove-if-not (lambda (x) (funcall matcher name (funcall converter x))) (mapcar (lambda (pkgname) (concatenate 'string pkgname ":")) (loop for package in (list-all-packages) nconcing (package-names package)))))) ;; PARSE-COMPLETION-ARGUMENTS return table: ;; ;; user behaviour | NAME | PACKAGE-NAME | PACKAGE ;; ----------------+--------+--------------+----------------------------------- ;; asdf [tab] | "asdf" | NIL | # ;; | | | or *BUFFER-PACKAGE* ;; asdf: [tab] | "" | "asdf" | # ;; | | | ;; asdf:foo [tab] | "foo" | "asdf" | # ;; | | | ;; as:fo [tab] | "fo" | "as" | NIL ;; | | | ;; : [tab] | "" | "" | # ;; | | | ;; :foo [tab] | "foo" | "" | # ;; (defun parse-completion-arguments (string default-package-name) "Parse STRING as a symbol designator. Return these values: SYMBOL-NAME PACKAGE-NAME, or nil if the designator does not include an explicit package. PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; if PACKAGE is non-NIL but a package cannot be found under that name, return NIL.) INTERNAL-P, if the symbol is qualified with `::'." (multiple-value-bind (name package-name internal-p) (tokenize-symbol string) (flet ((default-package () (or (guess-package default-package-name) *buffer-package*))) (let ((package (cond ((not package-name) (default-package)) ((equal package-name "") (guess-package (symbol-name :keyword))) ((find-locally-nicknamed-package package-name (default-package))) (t (guess-package package-name))))) (values name package-name package internal-p))))) (defun completion-output-case-converter (input &optional with-escaping-p) "Return a function to convert strings for the completion output. INPUT is used to guess the preferred case." (ecase (readtable-case *readtable*) (:upcase (cond ((or with-escaping-p (and (plusp (length input)) (not (some #'lower-case-p input)))) #'identity) (t #'string-downcase))) (:invert (lambda (output) (multiple-value-bind (lower upper) (determine-case output) (cond ((and lower upper) output) (lower (string-upcase output)) (upper (string-downcase output)) (t output))))) (:downcase (cond ((or with-escaping-p (and (zerop (length input)) (not (some #'upper-case-p input)))) #'identity) (t #'string-upcase))) (:preserve #'identity))) (defun completion-output-package-converter (input) "Return a function to convert strings for the completion output. INPUT is used to guess the preferred case." (completion-output-case-converter input)) (defun completion-output-symbol-converter (input) "Return a function to convert strings for the completion output. INPUT is used to guess the preferred case. Escape symbols when needed." (let ((case-converter (completion-output-case-converter input)) (case-converter-with-escaping (completion-output-case-converter input t))) (lambda (str) (if (or (multiple-value-bind (lowercase uppercase) (determine-case str) ;; In these readtable cases, symbols with letters from ;; the wrong case need escaping (case (readtable-case *readtable*) (:upcase lowercase) (:downcase uppercase) (t nil))) (some (lambda (el) (or (member el '(#\: #\Space #\Newline #\Tab)) (multiple-value-bind (macrofun nonterminating) (get-macro-character el) (and macrofun (not nonterminating))))) str)) (concatenate 'string "|" (funcall case-converter-with-escaping str) "|") (funcall case-converter str))))) (defun determine-case (string) "Return two booleans LOWER and UPPER indicating whether STRING contains lower or upper case characters." (values (some #'lower-case-p string) (some #'upper-case-p string))) ;;;;; Compound-prefix matching (defun make-compound-prefix-matcher (delimiter &key (test #'char=)) "Returns a matching function that takes a `prefix' and a `target' string and which returns T if `prefix' is a compound-prefix of `target', and otherwise NIL. Viewing each of `prefix' and `target' as a series of substrings delimited by DELIMITER, if each substring of `prefix' is a prefix of the corresponding substring in `target' then we call `prefix' a compound-prefix of `target'. DELIMITER may be a character, or a list of characters." (let ((delimiters (etypecase delimiter (character (list delimiter)) (cons (assert (every #'characterp delimiter)) delimiter)))) (lambda (prefix target) (declare (type simple-string prefix target)) (loop with tpos = 0 for ch across prefix always (and (< tpos (length target)) (let ((delimiter (car (member ch delimiters :test test)))) (if delimiter (setf tpos (position delimiter target :start tpos)) (funcall test ch (aref target tpos))))) do (incf tpos))))) ;;;;; Extending the input string by completion (defun longest-compound-prefix (completions &optional (delimiter #\-)) "Return the longest compound _prefix_ for all COMPLETIONS." (flet ((tokenizer (string) (tokenize-completion string delimiter))) (untokenize-completion (loop for token-list in (transpose-lists (mapcar #'tokenizer completions)) if (notevery #'string= token-list (rest token-list)) ;; Note that we possibly collect the "" here as well, so that ;; UNTOKENIZE-COMPLETION will append a delimiter for us. collect (longest-common-prefix token-list) and do (loop-finish) else collect (first token-list)) delimiter))) (defun tokenize-completion (string delimiter) "Return all substrings of STRING delimited by DELIMITER." (loop with end for start = 0 then (1+ end) until (> start (length string)) do (setq end (or (position delimiter string :start start) (length string))) collect (subseq string start end))) (defun untokenize-completion (tokens &optional (delimiter #\-)) (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens)) (defun transpose-lists (lists) "Turn a list-of-lists on its side. If the rows are of unequal length, truncate uniformly to the shortest. For example: \(transpose-lists '((ONE TWO THREE) (1 2))) => ((ONE 1) (TWO 2))" (cond ((null lists) '()) ((some #'null lists) '()) (t (cons (mapcar #'car lists) (transpose-lists (mapcar #'cdr lists)))))) ;;;; Completion for character names (defslimefun completions-for-character (prefix) (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal)) (completion-set (character-completion-set prefix matcher)) (completions (sort completion-set #'string<))) (list completions (longest-compound-prefix completions #\_)))) (provide :swank-c-p-c) slime-2.20/contrib/swank-clipboard.lisp000066400000000000000000000041701315100173500201550ustar00rootroot00000000000000;;; swank-clipboard.lisp --- Object clipboard ;; ;; Written by Helmut Eller in 2008. ;; License: Public Domain (defpackage :swank-clipboard (:use :cl) (:import-from :swank :defslimefun :with-buffer-syntax :dcase) (:export :add :delete-entry :entries :entry-to-ref :ref)) (in-package :swank-clipboard) (defstruct clipboard entries (counter 0)) (defvar *clipboard* (make-clipboard)) (defslimefun add (datum) (let ((value (dcase datum ((:string string package) (with-buffer-syntax (package) (eval (read-from-string string)))) ((:inspector part) (swank:inspector-nth-part part)) ((:sldb frame var) (swank/backend:frame-var-value frame var))))) (clipboard-add value) (format nil "Added: ~a" (entry-to-string (1- (length (clipboard-entries *clipboard*))))))) (defslimefun entries () (loop for (ref . value) in (clipboard-entries *clipboard*) collect `(,ref . ,(to-line value)))) (defslimefun delete-entry (entry) (let ((msg (format nil "Deleted: ~a" (entry-to-string entry)))) (clipboard-delete-entry entry) msg)) (defslimefun entry-to-ref (entry) (destructuring-bind (ref . value) (clipboard-entry entry) (list ref (to-line value 5)))) (defun clipboard-add (value) (setf (clipboard-entries *clipboard*) (append (clipboard-entries *clipboard*) (list (cons (incf (clipboard-counter *clipboard*)) value))))) (defun clipboard-ref (ref) (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car))) (cond (tail (cdr (car tail))) (t (error "Invalid clipboard ref: ~s" ref))))) (defun clipboard-entry (entry) (elt (clipboard-entries *clipboard*) entry)) (defun clipboard-delete-entry (index) (let* ((list (clipboard-entries *clipboard*)) (tail (nthcdr index list))) (setf (clipboard-entries *clipboard*) (append (ldiff list tail) (cdr tail))))) (defun entry-to-string (entry) (destructuring-bind (ref . value) (clipboard-entry entry) (format nil "#@~d(~a)" ref (to-line value)))) (defun to-line (object &optional (width 75)) (with-output-to-string (*standard-output*) (write object :right-margin width :lines 1))) (provide :swank-clipboard) slime-2.20/contrib/swank-fancy-inspector.lisp000066400000000000000000001246511315100173500213310ustar00rootroot00000000000000;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects ;; ;; Author: Marco Baringer and others ;; License: Public Domain ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-util)) (defmethod emacs-inspect ((symbol symbol)) (let ((package (symbol-package symbol))) (multiple-value-bind (_symbol status) (and package (find-symbol (string symbol) package)) (declare (ignore _symbol)) (append (label-value-line "Its name is" (symbol-name symbol)) ;; ;; Value (cond ((boundp symbol) (append (label-value-line (if (constantp symbol) "It is a constant of value" "It is a global variable bound to") (symbol-value symbol) :newline nil) ;; unbinding constants might be not a good idea, but ;; implementations usually provide a restart. `(" " (:action "[unbind]" ,(lambda () (makunbound symbol)))) '((:newline)))) (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 "[unbind]" ,(lambda () (fmakunbound symbol)))) `((:newline))) `("It has no function value." (:newline))) (docstring-ispec "Function documentation" symbol 'function) (when (compiler-macro-function symbol) (append (label-value-line "It also names the compiler macro" (compiler-macro-function symbol) :newline nil) `(" " (:action "[remove]" ,(lambda () (setf (compiler-macro-function symbol) nil))) (:newline)))) (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]" ,(lambda () (export symbol package))))) " " (:action "[unintern]" ,(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))) (inspect-type-specifier symbol))))) #-sbcl (defun inspect-type-specifier (symbol) (declare (ignore symbol))) #+sbcl (defun inspect-type-specifier (symbol) (let* ((kind (sb-int:info :type :kind symbol)) (fun (case kind (:defined (or (sb-int:info :type :expander symbol) t)) (:primitive (or #.(if (swank/sbcl::sbcl-version>= 1 3 1) '(let ((x (sb-int:info :type :expander symbol))) (if (consp x) (car x) x)) '(sb-int:info :type :translator symbol)) t))))) (when fun (append (list (format nil "It names a ~@[primitive~* ~]type-specifier." (eq kind :primitive)) '(:newline)) (docstring-ispec "Type-specifier documentation" symbol 'type) (unless (eq t fun) (let ((arglist (arglist fun))) (append `("Type-specifier lambda-list: " ;; Could use ~:s, but inspector-princ does a bit more, ;; and not all NILs in the arglist should be printed that way. ,(if arglist (inspector-princ arglist) "()") (:newline)) (multiple-value-bind (expansion ok) (handler-case (sb-ext:typexpand-1 symbol) (error () (values nil nil))) (when ok (list "Type-specifier expansion: " (princ-to-string expansion))))))))))) (defun docstring-ispec (label object kind) "Return a inspector spec if OBJECT has a docstring 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)))))) (unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) (defmethod emacs-inspect ((f function)) (inspect-function f))) (defun inspect-function (f) (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))) #-sbcl (t (swank-mop:class-name spec)) #+sbcl (t ;; SBCL has extended specializers (let ((gf (sb-mop:method-generic-function method))) (cond (gf (sb-pcl:unparse-specializer-using-class gf spec)) ((typep spec 'class) (class-name spec)) (t 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 emacs-inspect ((object standard-object)) (let ((class (class-of object))) `("Class: " (:value ,class) (:newline) ,@(all-slots-for-inspector object)))) (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))) ((typep s1 'class) (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)))) (defstruct (inspector-checklist (:conc-name checklist.) (:constructor %make-checklist (buttons))) (buttons nil :type (or null simple-vector)) (count 0)) (defun make-checklist (n) (%make-checklist (make-array n :initial-element nil))) (defun reinitialize-checklist (checklist) ;; Along this counter the buttons are created, so we have to ;; initialize it to 0 everytime the inspector page is redisplayed. (setf (checklist.count checklist) 0) checklist) (defun make-checklist-button (checklist) (let ((buttons (checklist.buttons checklist)) (i (checklist.count checklist))) (incf (checklist.count checklist)) `(:action ,(if (svref buttons i) "[X]" "[ ]") ,#'(lambda () (setf (svref buttons i) (not (svref buttons i)))) :refreshp t))) (defmacro do-checklist ((idx checklist) &body body) "Iterate over all set buttons in CHECKLIST." (let ((buttons (gensym "buttons"))) `(let ((,buttons (checklist.buttons ,checklist))) (dotimes (,idx (length ,buttons)) (when (svref ,buttons ,idx) ,@body))))) (defun box (thing) (cons :box thing)) (defun ref (box) (assert (eq (car box) :box)) (cdr box)) (defun (setf ref) (value box) (assert (eq (car box) :box)) (setf (cdr box) value)) (defvar *inspector-slots-default-order* :alphabetically "Accepted values: :alphabetically and :unsorted") (defvar *inspector-slots-default-grouping* :all "Accepted values: :inheritance and :all") (defgeneric all-slots-for-inspector (object)) (defmethod all-slots-for-inspector ((object standard-object)) (let* ((class (class-of object)) (direct-slots (swank-mop:class-direct-slots class)) (effective-slots (swank-mop:class-slots class)) (longest-slot-name-length (loop for slot :in effective-slots maximize (length (symbol-name (swank-mop:slot-definition-name slot))))) (checklist (reinitialize-checklist (ensure-istate-metadata object :checklist (make-checklist (length effective-slots))))) (grouping-kind ;; We box the value so we can re-set it. (ensure-istate-metadata object :grouping-kind (box *inspector-slots-default-grouping*))) (sort-order (ensure-istate-metadata object :sort-order (box *inspector-slots-default-order*))) (sort-predicate (ecase (ref sort-order) (:alphabetically #'string<) (:unsorted (constantly nil)))) (sorted-slots (sort (copy-seq effective-slots) sort-predicate :key #'swank-mop:slot-definition-name)) (effective-slots (ecase (ref grouping-kind) (:all sorted-slots) (:inheritance (stable-sort-by-inheritance sorted-slots class sort-predicate))))) `("--------------------" (:newline) " Group slots by inheritance " (:action ,(ecase (ref grouping-kind) (:all "[ ]") (:inheritance "[X]")) ,(lambda () ;; We have to do this as the order of slots will ;; be sorted differently. (fill (checklist.buttons checklist) nil) (setf (ref grouping-kind) (ecase (ref grouping-kind) (:all :inheritance) (:inheritance :all)))) :refreshp t) (:newline) " Sort slots alphabetically " (:action ,(ecase (ref sort-order) (:unsorted "[ ]") (:alphabetically "[X]")) ,(lambda () (fill (checklist.buttons checklist) nil) (setf (ref sort-order) (ecase (ref sort-order) (:unsorted :alphabetically) (:alphabetically :unsorted)))) :refreshp t) (:newline) ,@ (case (ref grouping-kind) (:all `((:newline) "All Slots:" (:newline) ,@(make-slot-listing checklist object class effective-slots direct-slots longest-slot-name-length))) (:inheritance (list-all-slots-by-inheritance checklist object class effective-slots direct-slots longest-slot-name-length))) (:newline) (:action "[set value]" ,(lambda () (do-checklist (idx checklist) (query-and-set-slot class object (nth idx effective-slots)))) :refreshp t) " " (:action "[make unbound]" ,(lambda () (do-checklist (idx checklist) (swank-mop:slot-makunbound-using-class class object (nth idx effective-slots)))) :refreshp t) (:newline)))) (defun list-all-slots-by-inheritance (checklist object class effective-slots direct-slots longest-slot-name-length) (flet ((slot-home-class (slot) (slot-home-class-using-class slot class))) (let ((current-slots '())) (append (loop for slot in effective-slots for previous-home-class = (slot-home-class slot) then home-class for home-class = previous-home-class then (slot-home-class slot) if (eq home-class previous-home-class) do (push slot current-slots) else collect '(:newline) and collect (format nil "~A:" (class-name previous-home-class)) and collect '(:newline) and append (make-slot-listing checklist object class (nreverse current-slots) direct-slots longest-slot-name-length) and do (setf current-slots (list slot))) (and current-slots `((:newline) ,(format nil "~A:" (class-name (slot-home-class-using-class (car current-slots) class))) (:newline) ,@(make-slot-listing checklist object class (nreverse current-slots) direct-slots longest-slot-name-length))))))) (defun make-slot-listing (checklist object class effective-slots direct-slots longest-slot-name-length) (flet ((padding-for (slot-name) (make-string (- longest-slot-name-length (length slot-name)) :initial-element #\Space))) (loop for effective-slot :in effective-slots 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)) collect (make-checklist-button checklist) collect " " collect `(:value ,(if direct-slot (list direct-slot effective-slot) effective-slot) ,slot-name) collect (padding-for slot-name) collect " = " collect (slot-value-for-inspector class object effective-slot) collect '(:newline)))) (defgeneric slot-value-for-inspector (class object slot) (:method (class object slot) (let ((boundp (swank-mop:slot-boundp-using-class class object slot))) (if boundp `(:value ,(swank-mop:slot-value-using-class class object slot)) "#")))) (defun slot-home-class-using-class (slot class) (let ((slot-name (swank-mop:slot-definition-name slot))) (loop for class in (reverse (swank-mop:class-precedence-list class)) thereis (and (member slot-name (swank-mop:class-direct-slots class) :key #'swank-mop:slot-definition-name :test #'eq) class)))) (defun stable-sort-by-inheritance (slots class predicate) (stable-sort slots predicate :key #'(lambda (s) (class-name (slot-home-class-using-class s class))))) (defun query-and-set-slot (class object slot) (let* ((slot-name (swank-mop:slot-definition-name slot)) (value-string (read-from-minibuffer-in-emacs (format nil "Set slot ~S to (evaluated) : " slot-name)))) (when (and value-string (not (string= value-string ""))) (with-simple-restart (abort "Abort setting slot ~S" slot-name) (setf (swank-mop:slot-value-using-class class object slot) (eval (read-from-string value-string))))))) (defmethod emacs-inspect ((gf standard-generic-function)) (flet ((lv (label value) (label-value-line label value))) (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)))) (defmethod emacs-inspect ((method standard-method)) `(,@(if (swank-mop:method-generic-function 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))))) '("Method without a generic function")) (: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))) (defun specializer-direct-methods (class) (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))))))) (defmethod emacs-inspect ((class standard-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))))) `("# " (:action "[finalize]" ,(lambda () (swank-mop:finalize-inheritance class))))) (: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))))) '("#")) (:newline) ,@(when (swank-mop:specializer-direct-methods class) `("It is used as a direct specializer in the following methods:" (:newline) ,@(loop for method in (specializer-direct-methods class) 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)) '"#") (:newline) ,@(all-slots-for-inspector class))) (defmethod emacs-inspect ((slot swank-mop:standard-slot-definition)) `("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)) "#") (:newline) "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline) ,@(all-slots-for-inspector slot))) ;; 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 EMACS-INSPECT. ;; 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 (see SYMBOL-CLASSIFICATION-STRING)" (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))) (values (concatenate 'string name (make-string (+ padding distance) :initial-element #\Space)) (symbol-classification-string symbol))))) `("" ; 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 #\-) " " (symbol-classification-string '#:foo)) (: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)) (+default-classification+ :misc)) (flet ((normalize-classifications (classifications) (cond ((null classifications) `(,+default-classification+)) ;; Convert an :FBOUNDP in CLASSIFICATIONS to ;; :FUNCTION if possible. ((and (member :fboundp classifications) (not (member :macro classifications)) (not (member :special-operator classifications))) (substitute :function :fboundp classifications)) (t (remove :fboundp classifications))))) (loop for symbol in symbols do (loop for classification in (normalize-classifications (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 ;; Sort alphabetically, except ;; +DEFAULT-CLASSIFICATION+ which ;; sort to the end. (lambda (a b) (cond ((eql a +default-classification+) nil) ((eql b +default-classification+) t) (t (string< a b))))))) (loop for classification in classifications for symbols = (gethash classification table) appending`(,(symbol-name classification) (:newline) ,(make-string 64 :initial-element #\-) (:newline) ,@(mapcan (lambda (symbol) `((:value ,symbol ,(symbol-name symbol)) (:newline))) ;; restore alphabetic order. (nreverse symbols)) (:newline)))))) (defmethod emacs-inspect ((%container %package-symbols-container)) (with-struct (%container. title description symbols grouping-kind) %container `(,title (:newline) (:newline) ,@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)))) (defun 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)))) (defmethod emacs-inspect ((package package)) (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) (inherited-symbols '()) (inherited-symbols-length 0) (external-symbols '()) (external-symbols-length 0)) (do-symbols* (sym package) (let ((status (symbol-status sym package))) (when (eq status :inherited) (push sym inherited-symbols) (incf inherited-symbols-length) (go :continue)) (push sym present-symbols) (incf present-symbols-length) (cond ((eq status :internal) (push sym internal-symbols) (incf internal-symbols-length)) (t (push sym external-symbols) (incf external-symbols-length)))) :continue) (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<)) ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18. (setf present-symbols (sort present-symbols #'string<) internal-symbols (sort internal-symbols #'string<) external-symbols (sort external-symbols #'string<) inherited-symbols (sort inherited-symbols #'string<)) `("" ;; 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) ,(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 "inherited" inherited-symbols inherited-symbols-length :title (format nil "All inherited symbols of package \"~A\"" package-name) :description '("A symbol is considered inherited in a package if it" (:newline) "was made accessible via USE-PACKAGE." (:newline))) (:newline) ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) :title (format nil "All shadowed symbols of package \"~A\"" package-name) :description nil)))) (defmethod emacs-inspect ((pathname pathname)) `(,(if (wild-pathname-p pathname) "A wild pathname." "A pathname.") (:newline) ,@(label-value-line* ("Namestring" (namestring pathname)) ("Host" (pathname-host pathname)) ("Device" (pathname-device pathname)) ("Directory" (pathname-directory pathname)) ("Name" (pathname-name pathname)) ("Type" (pathname-type pathname)) ("Version" (pathname-version pathname))) ,@ (unless (or (wild-pathname-p pathname) (not (probe-file pathname))) (label-value-line "Truename" (truename pathname))))) (defmethod emacs-inspect ((pathname logical-pathname)) (append (label-value-line* ("Namestring" (namestring pathname)) ("Physical pathname: " (translate-logical-pathname pathname))) `("Host: " (:value ,(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 emacs-inspect ((n 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)) (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 (if dst (+ zone 1) zone)))))) (defmethod emacs-inspect ((i integer)) (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 emacs-inspect ((c complex)) (label-value-line* ("Real part" (realpart c)) ("Imaginary part" (imagpart c)))) (defmethod emacs-inspect ((r ratio)) (label-value-line* ("Numerator" (numerator r)) ("Denominator" (denominator r)) ("As float" (float r)))) (defmethod emacs-inspect ((f float)) (cond ((float-nan-p f) ;; try NaN first because the next tests may perform operations ;; that are undefined for NaNs. (list "Not a Number.")) ((not (float-infinity-p f)) (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))))) ((> f 0) (list "Positive infinity.")) ((< f 0) (list "Negative infinity.")))) (defun make-pathname-ispec (pathname position) `("Pathname: " (:value ,pathname) (:newline) " " ,@(when position `((:action "[visit file and show current position]" ,(lambda () (ed-in-emacs `(,pathname :position ,position :bytep t))) :refreshp nil) (:newline))))) (defun make-file-stream-ispec (stream) ;; SBCL's socket stream are file-stream but are not associated to ;; any pathname. (let ((pathname (ignore-errors (pathname stream)))) (when pathname (make-pathname-ispec pathname (and (open-stream-p stream) (file-position stream)))))) (defmethod emacs-inspect ((stream file-stream)) (multiple-value-bind (content) (call-next-method) (append (make-file-stream-ispec stream) content))) (defmethod emacs-inspect ((condition stream-error)) (multiple-value-bind (content) (call-next-method) (let ((stream (stream-error-stream condition))) (append (when (typep stream 'file-stream) (make-file-stream-ispec stream)) content)))) (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))) (provide :swank-fancy-inspector) slime-2.20/contrib/swank-fuzzy.lisp000066400000000000000000001016201315100173500174030ustar00rootroot00000000000000;;; swank-fuzzy.lisp --- fuzzy symbol completion ;; ;; Authors: Brian Downing ;; Tobias C. Rittweiler ;; and others ;; ;; License: Public Domain ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-util) (swank-require :swank-c-p-c)) (defvar *fuzzy-duplicate-symbol-filter* :nearest-package "Specifies how fuzzy-matching handles \"duplicate\" symbols. Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom function. See Fuzzy Completion in the manual for details.") (export '*fuzzy-duplicate-symbol-filter*) ;;; For nomenclature of the fuzzy completion section, please read ;;; through the following docstring. (defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec) "Returns a list of two values: An (optionally limited to LIMIT best results) list of fuzzy completions for a symbol designator STRING. The list will be sorted by score, most likely match first. A flag that indicates whether or not TIME-LIMIT-IN-MSEC has been exhausted during computation. If that parameter's value is NIL or 0, no time limit is assumed. The main result is a list of completion objects, where a completion object is: (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING) where a CHUNK is a description of a matched substring: (OFFSET SUBSTRING) and FLAGS is short string describing properties of the symbol (see SYMBOL-CLASSIFICATION-STRING). E.g., completing \"mvb\" in a package that uses COMMON-LISP would return something like: ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\")) (:FBOUNDP :MACRO)) ...) If STRING is package qualified the result list will also be qualified. If string is non-qualified the result strings are also not qualified and are considered relative to DEFAULT-PACKAGE-NAME. Which symbols are candidates for matching depends on the symbol designator's format. The cases are as follows: FOO - Symbols accessible in the buffer package. PKG:FOO - Symbols external in package PKG. PKG::FOO - Symbols accessible in package PKG." ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC ;; to denote an infinite time limit. Internally, we only use NIL for ;; that purpose, to be able to distinguish between "no time limit ;; alltogether" and "current time limit already exhausted." So we've ;; got to canonicalize its value at first: (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec))) (time-limit (if no-time-limit-p nil time-limit-in-msec))) (multiple-value-bind (completion-set interrupted-p) (fuzzy-completion-set string default-package-name :limit limit :time-limit-in-msec time-limit) ;; We may send this as elisp [] arrays to spare a coerce here, ;; but then the network serialization were slower by handling arrays. ;; Instead we limit the number of completions that is transferred ;; (the limit is set from Emacs.) (list (coerce completion-set 'list) interrupted-p)))) ;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion ;;; object that will be sent back to Emacs, as described above. (defstruct (fuzzy-matching (:conc-name fuzzy-matching.) (:predicate fuzzy-matching-p) (:constructor make-fuzzy-matching (symbol package-name score package-chunks symbol-chunks &key (symbol-p t)))) symbol ; The symbol that has been found to match. symbol-p ; To deffirentiate between completeing ; package: and package:nil package-name ; The name of the package where SYMBOL was found in. ; (This is not necessarily the same as the home-package ; of SYMBOL, because the SYMBOL can be internal to ; lots of packages; also think of package nicknames.) score ; The higher the better SYMBOL is a match. package-chunks ; Chunks pertaining to the package identifier of SYMBOL. symbol-chunks) ; Chunks pertaining to SYMBOL's name. (defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string) (multiple-value-bind (_ user-package-name __ input-internal-p) (parse-completion-arguments user-input-string nil) (declare (ignore _ __)) (with-struct (fuzzy-matching. score symbol package-name package-chunks symbol-chunks symbol-p) fuzzy-matching (let (symbol-name real-package-name internal-p) (cond (symbol-p ; symbol fuzzy matching? (setf symbol-name (symbol-name symbol)) (setf internal-p input-internal-p) (setf real-package-name (cond ((keywordp symbol) "") ((not user-package-name) nil) (t package-name)))) (t ; package fuzzy matching? (setf symbol-name "") (setf real-package-name package-name) ;; If no explicit package name was given by the user ;; (e.g. input was "asdf"), we want to append only ;; one colon ":" to the package names. (setf internal-p (if user-package-name input-internal-p nil)))) (values symbol-name real-package-name (if user-package-name internal-p nil) (completion-output-symbol-converter user-input-string) (completion-output-package-converter user-input-string)))))) (defun fuzzy-format-matching (fuzzy-matching user-input-string) "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING." (multiple-value-bind (symbol-name package-name internal-p symbol-converter package-converter) (%fuzzy-extract-matching-info fuzzy-matching user-input-string) (setq symbol-name (and symbol-name (funcall symbol-converter symbol-name))) (setq package-name (and package-name (funcall package-converter package-name))) (let ((result (untokenize-symbol package-name internal-p symbol-name))) ;; We return the length of the possibly added prefix as second value. (values result (search symbol-name result))))) (defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string) "Converts a result from the fuzzy completion core into something that emacs is expecting. Converts symbols to strings, fixes case issues, and adds information (as a string) describing if the symbol is bound, fbound, a class, a macro, a generic-function, a special-operator, or a package." (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks symbol-p) fuzzy-matching (multiple-value-bind (name added-length) (fuzzy-format-matching fuzzy-matching user-input-string) (list name (format nil "~,2f" score) (append package-chunks (mapcar (lambda (chunk) ;; Fix up chunk positions to account for possible ;; added package identifier. (let ((offset (first chunk)) (string (second chunk))) (list (+ added-length offset) string))) symbol-chunks)) (if symbol-p (symbol-classification-string symbol) "-------p"))))) (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec) "Returns two values: an array of completion objects, sorted by their score, that is how well they are a match for STRING according to the fuzzy completion algorithm. If LIMIT is set, only the top LIMIT results will be returned. Additionally, a flag is returned that indicates whether or not TIME-LIMIT-IN-MSEC was exhausted." (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum)))) (multiple-value-bind (matchings interrupted-p) (fuzzy-generate-matchings string default-package-name time-limit-in-msec) (when (and limit (> limit 0) (< limit (length matchings))) (if (array-has-fill-pointer-p matchings) (setf (fill-pointer matchings) limit) (setf matchings (make-array limit :displaced-to matchings)))) (map-into matchings #'(lambda (m) (fuzzy-convert-matching-for-emacs m string)) matchings) (values matchings interrupted-p))) (defun fuzzy-generate-matchings (string default-package-name time-limit-in-msec) "Does all the hard work for FUZZY-COMPLETION-SET. If TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." (multiple-value-bind (parsed-symbol-name parsed-package-name package internal-p) (parse-completion-arguments string default-package-name) (flet ((fix-up (matchings parent-package-matching) ;; The components of each matching in MATCHINGS have been computed ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. (let* ((p parent-package-matching) (p.name (fuzzy-matching.package-name p)) (p.score (fuzzy-matching.score p)) (p.chunks (fuzzy-matching.package-chunks p))) (map-into matchings (lambda (m) (let ((m.score (fuzzy-matching.score m))) (setf (fuzzy-matching.package-name m) p.name) (setf (fuzzy-matching.package-chunks m) p.chunks) (setf (fuzzy-matching.score m) (if (equal parsed-symbol-name "") ;; Make package matchings be sorted before all ;; the relative symbol matchings while preserving ;; over all orderness. (/ p.score 100) (+ p.score m.score))) m)) matchings))) (find-symbols (designator package time-limit &optional filter) (fuzzy-find-matching-symbols designator package :time-limit-in-msec time-limit :external-only (not internal-p) :filter (or filter #'identity))) (find-packages (designator time-limit) (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit)) (maybe-find-local-package (name) (or (find-locally-nicknamed-package name *buffer-package*) (find-package name)))) (let ((time-limit time-limit-in-msec) (symbols) (packages) (results) (dedup-table (make-hash-table :test #'equal))) (cond ((not parsed-package-name) ; E.g. STRING = "asd" ;; We don't know if user is searching for a package or a symbol ;; within his current package. So we try to find either. (setf (values packages time-limit) (find-packages parsed-symbol-name time-limit)) (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) (t ; E.g. STRING = "asd:" or "asd:foo" ;; Find fuzzy matchings of the denoted package identifier part. ;; After that, find matchings for the denoted symbol identifier ;; relative to all the packages found. (multiple-value-bind (symbol-packages rest-time-limit) (find-packages parsed-package-name time-limit-in-msec) ;; We want to traverse the found packages in the order of ;; their score, since those with higher score presumably ;; represent better choices. (This is important because some ;; packages may never be looked at if time limit exhausts ;; during traversal.) (setf symbol-packages (sort symbol-packages #'fuzzy-matching-greaterp)) (loop for package-matching across symbol-packages for package = (maybe-find-local-package (fuzzy-matching.package-name package-matching)) while (or (not time-limit) (> rest-time-limit 0)) do (multiple-value-bind (matchings remaining-time) ;; The duplication filter removes all those symbols ;; which are present in more than one package ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER* (find-symbols parsed-symbol-name package rest-time-limit (%make-duplicate-symbols-filter package-matching symbol-packages dedup-table)) (setf matchings (fix-up matchings package-matching)) (setf symbols (concatenate 'vector symbols matchings)) (setf rest-time-limit remaining-time) (let ((guessed-sort-duration (%guess-sort-duration (length symbols)))) (when (and rest-time-limit (<= rest-time-limit guessed-sort-duration)) (decf rest-time-limit guessed-sort-duration) (loop-finish)))) finally (setf time-limit rest-time-limit) (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:" (setf packages symbol-packages)))))) ;; Sort by score; thing with equal score, sort alphabetically. ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all ;; possible completions are to be returned.) (setf results (concatenate 'vector symbols packages)) (setf results (sort results #'fuzzy-matching-greaterp)) (values results (and time-limit (<= time-limit 0))))))) (defun %guess-sort-duration (length) ;; These numbers are pretty much arbitrary, except that they're ;; vaguely correct on my machine with SBCL. Yes, this is an ugly ;; kludge, but it's better than before (where this didn't exist at ;; all, which essentially meant, that this was taken to be 0.) (if (zerop length) 0 (let ((comparasions (* 3.8 (* length (log length 2))))) (* 1000 (* comparasions (expt 10 -7)))))) ; msecs (defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table) ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*. (case *fuzzy-duplicate-symbol-filter* (:home-package ;; Return a filter function that takes a symbol, and which returns T ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents ;; the home-package of the symbol passed. (let ((packages (mapcar #'(lambda (m) (find-package (fuzzy-matching.package-name m))) (remove current-package-matching (coerce fuzzy-package-matchings 'list))))) #'(lambda (symbol) (not (member (symbol-package symbol) packages))))) (:nearest-package ;; Keep only the first occurence of the symbol. #'(lambda (symbol) (unless (gethash (symbol-name symbol) dedup-table) (setf (gethash (symbol-name symbol) dedup-table) t)))) (:all ;; No filter #'identity) (t (typecase *fuzzy-duplicate-symbol-filter* (function ;; Custom filter (funcall *fuzzy-duplicate-symbol-filter* (fuzzy-matching.package-name current-package-matching) (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings) dedup-table)) (t ;; Bad filter value (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s" *fuzzy-duplicate-symbol-filter*) #'identity))))) (defun fuzzy-matching-greaterp (m1 m2) "Returns T if fuzzy-matching M1 should be sorted before M2. Basically just the scores of the two matchings are compared, and the match with higher score wins. For the case that the score is equal, the one which comes alphabetically first wins." (declare (type fuzzy-matching m1 m2)) (let ((score1 (fuzzy-matching.score m1)) (score2 (fuzzy-matching.score m2))) (cond ((> score1 score2) t) ((< score1 score2) nil) ; total order (t (let ((name1 (symbol-name (fuzzy-matching.symbol m1))) (name2 (symbol-name (fuzzy-matching.symbol m2)))) (string< name1 name2)))))) (declaim (ftype (function () (integer 0)) get-real-time-msecs)) (defun get-real-time-in-msecs () (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) (values (floor (get-internal-real-time) units-per-msec)))) (defun fuzzy-find-matching-symbols (string package &key (filter #'identity) external-only time-limit-in-msec) "Returns two values: a vector of fuzzy matchings for matching symbols in PACKAGE, using the fuzzy completion algorithm, and the remaining time limit. Only those symbols are considered of which FILTER does return T. If EXTERNAL-ONLY is true, only external symbols are considered. A TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or negative, perform a NOP." (let ((time-limit-p (and time-limit-in-msec t)) (time-limit (or time-limit-in-msec 0)) (rtime-at-start (get-real-time-in-msecs)) (package-name (package-name package)) (count 0)) (declare (type boolean time-limit-p)) (declare (type integer time-limit rtime-at-start)) (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) (flet ((recompute-remaining-time (old-remaining-time) (cond ((not time-limit-p) ;; propagate NIL back as infinite time limit (values nil nil)) ((> count 0) ; ease up on getting internal time like crazy (setf count (mod (1+ count) 128)) (values nil old-remaining-time)) (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)) (remaining (- time-limit elapsed-time))) (values (<= remaining 0) remaining))))) (perform-fuzzy-match (string symbol-name) (let* ((converter (completion-output-symbol-converter string)) (converted-symbol-name (funcall converter symbol-name))) (compute-highest-scoring-completion string converted-symbol-name)))) (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) (rest-time-limit time-limit)) (do-symbols* (symbol package) (multiple-value-bind (exhausted? remaining-time) (recompute-remaining-time rest-time-limit) (setf rest-time-limit remaining-time) (cond (exhausted? (return)) ((not (and (or (not external-only) (symbol-external-p symbol package)) (funcall filter symbol)))) ((string= "" string) ; "" matches always (vector-push-extend (make-fuzzy-matching symbol package-name 0.0 '() '()) completions)) (t (multiple-value-bind (match-result score) (perform-fuzzy-match string (symbol-name symbol)) (when match-result (vector-push-extend (make-fuzzy-matching symbol package-name score '() match-result) completions))))))) (values completions rest-time-limit))))) (defun fuzzy-find-matching-packages (name &key time-limit-in-msec) "Returns a vector of fuzzy matchings for each package that is similiar to NAME, and the remaining time limit. Cf. FUZZY-FIND-MATCHING-SYMBOLS." (let ((time-limit-p (and time-limit-in-msec t)) (time-limit (or time-limit-in-msec 0)) (rtime-at-start (get-real-time-in-msecs)) (converter (completion-output-package-converter name)) (completions (make-array 32 :adjustable t :fill-pointer 0))) (declare (type boolean time-limit-p)) (declare (type integer time-limit rtime-at-start)) (declare (type function converter)) (flet ((match-package (names) (loop with max-pkg-name = "" with max-result = nil with max-score = 0 for package-name in names for converted-name = (funcall converter package-name) do (multiple-value-bind (result score) (compute-highest-scoring-completion name converted-name) (when (and result (> score max-score)) (setf max-pkg-name package-name) (setf max-result result) (setf max-score score))) finally (when max-result (vector-push-extend (make-fuzzy-matching nil max-pkg-name max-score max-result '() :symbol-p nil) completions))))) (cond ((and time-limit-p (<= time-limit 0)) (values #() time-limit)) (t (loop for (nick) in (package-local-nicknames *buffer-package*) do (match-package (list nick))) (loop for package in (list-all-packages) do ;; Find best-matching package-nickname: (match-package (package-names package)) finally (return (values completions (and time-limit-p (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))) (- time-limit elapsed-time))))))))))) (defslimefun fuzzy-completion-selected (original-string completion) "This function is called by Slime when a fuzzy completion is selected by the user. It is for future expansion to make testing, say, a machine learning algorithm for completion scoring easier. ORIGINAL-STRING is the string the user completed from, and COMPLETION is the completion object (see docstring for SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the user selected." (declare (ignore original-string completion)) nil) ;;;;; Fuzzy completion core (defparameter *fuzzy-recursion-soft-limit* 30 "This is a soft limit for recursion in RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, completing a string such as \"ZZZZZZ\" with a symbol named \"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to find all the ways it can match. Most natural language searches and symbols do not have this problem -- this is only here as a safeguard.") (declaim (fixnum *fuzzy-recursion-soft-limit*)) (defvar *all-chunks* '()) (declaim (type list *all-chunks*)) (defun compute-highest-scoring-completion (short full) "Finds the highest scoring way to complete the abbreviation SHORT onto the string FULL, using CHAR= as a equality function for letters. Returns two values: The first being the completion chunks of the highest scorer, and the second being the score." (let* ((scored-results (mapcar #'(lambda (result) (cons (score-completion result short full) result)) (compute-most-completions short full))) (winner (first (sort scored-results #'> :key #'first)))) (values (rest winner) (first winner)))) (defun compute-most-completions (short full) "Finds most possible ways to complete FULL with the letters in SHORT. Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns a list of (&rest CHUNKS), where each CHUNKS is a description of how a completion matches." (let ((*all-chunks* nil)) (recursively-compute-most-completions short full 0 0 nil nil nil t) *all-chunks*)) (defun recursively-compute-most-completions (short full short-index initial-full-index chunks current-chunk current-chunk-pos recurse-p) "Recursively (if RECURSE-P is true) find /most/ possible ways to fuzzily map the letters in SHORT onto FULL, using CHAR= to determine if two letters match. A chunk is a list of elements that have matched consecutively. When consecutive matches stop, it is coerced into a string, paired with the starting position of the chunk, and pushed onto CHUNKS. Whenever a letter matches, if RECURSE-P is true, RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position one index ahead, to find other possibly higher scoring possibilities. If there are less than *FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently, this call will also recurse. Once a word has been completely matched, the chunks are pushed onto the special variable *ALL-CHUNKS* and the function returns." (declare (optimize speed) (type fixnum short-index initial-full-index) (type list current-chunk) (simple-string short full)) (flet ((short-cur () "Returns the next letter from the abbreviation, or NIL if all have been used." (if (= short-index (length short)) nil (aref short short-index))) (add-to-chunk (char pos) "Adds the CHAR at POS in FULL to the current chunk, marking the start position if it is empty." (unless current-chunk (setf current-chunk-pos pos)) (push char current-chunk)) (collect-chunk () "Collects the current chunk to CHUNKS and prepares for a new chunk." (when current-chunk (let ((current-chunk-as-string (nreverse (make-array (length current-chunk) :element-type 'character :initial-contents current-chunk)))) (push (list current-chunk-pos current-chunk-as-string) chunks) (setf current-chunk nil current-chunk-pos nil))))) ;; If there's an outstanding chunk coming in collect it. Since ;; we're recursively called on skipping an input character, the ;; chunk can't possibly continue on. (when current-chunk (collect-chunk)) (do ((pos initial-full-index (1+ pos))) ((= pos (length full))) (let ((cur-char (aref full pos))) (if (and (short-cur) (char= cur-char (short-cur))) (progn (when recurse-p ;; Try other possibilities, limiting insanely deep ;; recursion somewhat. (recursively-compute-most-completions short full short-index (1+ pos) chunks current-chunk current-chunk-pos (not (> (length *all-chunks*) *fuzzy-recursion-soft-limit*)))) (incf short-index) (add-to-chunk cur-char pos)) (collect-chunk)))) (collect-chunk) ;; If we've exhausted the short characters we have a match. (if (short-cur) nil (let ((rev-chunks (reverse chunks))) (push rev-chunks *all-chunks*) rev-chunks)))) ;;;;; Fuzzy completion scoring (defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<" "Letters that are likely to be at the beginning of a symbol. Letters found after one of these prefixes will be scored as if they were at the beginning of ths symbol.") (defvar *fuzzy-completion-symbol-suffixes* "*+->" "Letters that are likely to be at the end of a symbol. Letters found before one of these suffixes will be scored as if they were at the end of the symbol.") (defvar *fuzzy-completion-word-separators* "-/." "Letters that separate different words in symbols. Letters after one of these symbols will be scores more highly than other letters.") (defun score-completion (completion short full) "Scores the completion chunks COMPLETION as a completion from the abbreviation SHORT to the full string FULL. COMPLETION is a list like: ((0 \"mul\") (9 \"v\") (15 \"b\")) Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\", would indicate that it completed as such (completed letters capitalized): MULtiple-Value-Bind Letters are given scores based on their position in the string. Letters at the beginning of a string or after a prefix letter at the beginning of a string are scored highest. Letters after a word separator such as #\- are scored next highest. Letters at the end of a string or before a suffix letter at the end of a string are scored medium, and letters anywhere else are scored low. If a letter is directly after another matched letter, and its intrinsic value in that position is less than a percentage of the previous letter's value, it will use that percentage instead. Finally, a small scaling factor is applied to favor shorter matches, all other things being equal." (labels ((at-beginning-p (pos) (= pos 0)) (after-prefix-p (pos) (and (= pos 1) (find (aref full 0) *fuzzy-completion-symbol-prefixes*))) (word-separator-p (pos) (find (aref full pos) *fuzzy-completion-word-separators*)) (after-word-separator-p (pos) (find (aref full (1- pos)) *fuzzy-completion-word-separators*)) (at-end-p (pos) (= pos (1- (length full)))) (before-suffix-p (pos) (and (= pos (- (length full) 2)) (find (aref full (1- (length full))) *fuzzy-completion-symbol-suffixes*))) (score-or-percentage-of-previous (base-score pos chunk-pos) (if (zerop chunk-pos) base-score (max base-score (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85) (expt 1.2 chunk-pos))))) (score-char (pos chunk-pos) (score-or-percentage-of-previous (cond ((at-beginning-p pos) 10) ((after-prefix-p pos) 10) ((word-separator-p pos) 1) ((after-word-separator-p pos) 8) ((at-end-p pos) 6) ((before-suffix-p pos) 6) (t 1)) pos chunk-pos)) (score-chunk (chunk) (loop for chunk-pos below (length (second chunk)) for pos from (first chunk) summing (score-char pos chunk-pos)))) (let* ((chunk-scores (mapcar #'score-chunk completion)) (length-score (/ 10.0 (1+ (- (length full) (length short)))))) (values (+ (reduce #'+ chunk-scores) length-score) (list (mapcar #'list chunk-scores completion) length-score))))) (defun highlight-completion (completion full) "Given a chunk definition COMPLETION and the string FULL, HIGHLIGHT-COMPLETION will create a string that demonstrates where the completion matched in the string. Matches will be capitalized, while the rest of the string will be lower-case." (let ((highlit (nstring-downcase (copy-seq full)))) (dolist (chunk completion) (setf highlit (nstring-upcase highlit :start (first chunk) :end (+ (first chunk) (length (second chunk)))))) highlit)) (defun format-fuzzy-completion-set (winners) "Given a list of completion objects such as on returned by FUZZY-COMPLETION-SET, format the list into user-readable output for interactive debugging purpose." (let ((max-len (loop for winner in winners maximizing (length (first winner))))) (loop for (sym score result) in winners do (format t "~&~VA score ~8,2F ~A" max-len (highlight-completion result sym) score result)))) (provide :swank-fuzzy) slime-2.20/contrib/swank-goo.goo000066400000000000000000000746671315100173500166410ustar00rootroot00000000000000;;;; swank-goo.goo --- Swank server for GOO ;;; ;;; Copyright (C) 2005 Helmut Eller ;;; ;;; This file is licensed under the terms of the GNU General Public ;;; License as distributed with Emacs (press C-h C-c to view it). ;;;; Installation ;; ;; 1. Add something like this to your .emacs: ;; ;; (setq slime-lisp-implementations ;; '((goo ("g2c") :init goo-slime-init))) ;; ;; (defun goo-slime-init (file _) ;; (format "%S\n%S\n" ;; `(set goo/system:*module-search-path* ;; (cat '(".../slime/contrib/") ;; goo/system:*module-search-path*)) ;; `(swank-goo:start-swank ,file))) ;; ;; 2. Start everything with M-- M-x slime goo ;; ;;;; Code (use goo) (use goo/boot) (use goo/x) (use goo/io/port) (use goo/io/write) (use goo/eval) (use goo/system) (use goo/conditions) (use goo/fun) (use goo/loc) (use goo/chr) (use eval/module) (use eval/ast) (use eval/g2c) ;;;; server setup (df create-server (port-number) (setup-server port-number announce-port)) (df start-swank (port-file) (setup-server 0 (fun (s) (write-port-file (%local-port s) port-file)))) (df setup-server (port-number announce) (let ((s (create-socket port-number))) (fin (seq (announce s) (let ((c (accept s))) ;;(post "connection: %s" c) (fin (serve-requests c) (%close (@fd c))))) (post "closing socket: %s" s) (%close s)))) (df announce-port (socket) (post "Listening on port: %d\n" (%local-port socket))) (df write-port-file (port-number filename) (with-port (file (open filename)) (msg file "%d\n" port-number))) (dc ()) (dc ()) (dp @socket ( => )) (dp @in ( => )) (dp @out ( => )) (dv emacs-connection|(t? ) #f) (df serve-requests (socket) (dlet ((emacs-connection (new @socket socket @out (new @socket socket) @in (new @socket socket)))) (dlet ((out (@out emacs-connection)) (in (@in emacs-connection))) (while #t (simple-restart "SLIME top-level" (fun () (process-next-event socket))))))) (d. (t= 'nil)) (d. t #t) (d. cons pair) (dv tag-counter| 0) (df process-next-event (port) (dispatch-event (decode-message port) port)) (df dispatch-event (event port) ;; (post "%=\n" event) (match event ((:emacs-rex ,form ,package ,_thread-id ,id) (eval-for-emacs form package port id)) ((:read-string ,_) (def tag (incf tag-counter)) (encode-message `(:read-string ,_ ,tag) port) (rep loop () (match (decode-message port) ((:emacs-return-string ,_ ,rtag ,str) (assert (= tag rtag) "Unexpected reply tag: %d" rtag) str) ((,@evt) (try-recover (fun () (dispatch-event evt port)) (fun () (encode-message `(:read-aborted ,_ ,tag) port))) (loop))))) ((:emacs-return-string ,_ ,rtag ,str) (error "Unexpected event: %=" event)) ((,@_) (encode-message event port)))) (dc ()) (dp @module ( => )) (dp @id ( => )) (dp @port ( => )) (dp @prev ( => (t? ))) ;; should be ddv (dv eval-context|(t? ) #f) (df buffer-module () (@module eval-context)) (df eval-for-emacs (form| package|(t+ ) port id|) (try-recover (fun () (try debugger-hook (dlet ((eval-context (new @module (find-buffer-module package) @id id @port port @prev eval-context))) (def result (eval (frob-form-for-eval form) 'swank-goo)) (force-out out) (dispatch-event `(:return (:ok ,result) ,id) port)))) (fun () (dispatch-event `(:return (:abort) ,id) port)))) (dm find-buffer-module (name| => ) (or (elt-or (all-modules) (as-sym name) #f) (find-buffer-module 'nil))) (dm find-buffer-module (name| => ) default-module) (dv default-module| (runtime-module 'goo/user)) (d. slimefuns (fab 100)) (ds defslimefun (,name ,args ,@body) `(set (elt slimefuns ',name) (df ,(cat-sym 'swank@ name) ,args ,@body))) (df slimefun (name) (or (elt-or slimefuns name #f) (error "Undefined slimefun: %=" name))) ;; rewrite (swank:foo ...) to ((slimefun 'foo) ...) (df frob-form-for-eval (form) (match form ((,op ,@args) (match (map as-sym (split (sym-name op) #\:)) ((swank ,name) `((slimefun ',name) ,@args)))))) ;;;; debugger (dc ()) (dp @level ( => )) (dp @top-frame ( => )) (dp @restarts ( => )) (dp @condition ( => )) (dp @eval-context ( => (t? ))) (dv sldb-context|(t? ) #f) (df debugger-hook (c| resume) (let ((tf (find-top-frame 'debugger-hook 2)) (rs (compute-restarts c)) (l (if sldb-context (1+ (@level sldb-context)) 1))) (cond ((> l 10) (emergency-abort c)) (#t (dlet ((sldb-context (new @level l @top-frame tf @restarts rs @condition c @eval-context eval-context))) (let ((bt (compute-backtrace tf 0 10))) (force-out out) (dispatch-event `(:debug 0 ,l ,@(debugger-info c rs bt eval-context)) (@port eval-context)) (sldb-loop l (@port eval-context)))))))) (df emergency-abort (c) (post "Maximum debug level reached aborting...\n") (post "%s\n" (describe-condition c)) (do-stack-frames (fun (f args) (msg out " %= %=\n" f args))) (invoke-handler-interactively (find-restart ) in out)) (df sldb-loop (level port) (fin (while #t (dispatch-event `(:debug-activate 0 ,level) port) (simple-restart (msg-to-str "Return to SLDB level %s" level) (fun () (process-next-event port)))) (dispatch-event `(:debug-return 0 ,level nil) port))) (defslimefun backtrace (start| end|(t+ )) (backtrace-for-emacs (compute-backtrace (@top-frame sldb-context) start (if (isa? end ) end #f)))) (defslimefun throw-to-toplevel () (invoke-handler-interactively (find-restart ) in out)) (defslimefun invoke-nth-restart-for-emacs (sldb-level| n|) (when (= (@level sldb-context) sldb-level) (invoke-handler-interactively (elt (@restarts sldb-context) n) in out))) (defslimefun debugger-info-for-emacs (start end) (debugger-info (@condition sldb-context) (@restarts sldb-context) (compute-backtrace (@top-frame sldb-context) start (if (isa? end ) end #f)))) (defslimefun frame-locals-and-catch-tags (frame-idx) (def frame (nth-frame frame-idx)) (list (map-keyed (fun (i name) (lst ':name (sym-name name) ':id 0 ':value (safe-write-to-string (frame-var-value frame i)))) (frame-var-names frame)) '())) (defslimefun inspect-frame-var (frame-idx var-idx) (reset-inspector) (inspect-object (frame-var-value (nth-frame frame-idx) var-idx))) (defslimefun inspect-current-condition () (reset-inspector) (inspect-object (@condition sldb-context))) (defslimefun frame-source-location (frame-idx) (match (nth-frame frame-idx) ((,f ,@_) (or (emacs-src-loc f) `(:error ,(msg-to-str "No src-loc available for: %s" f)))))) (defslimefun eval-string-in-frame (string frame-idx) (def frame (nth-frame frame-idx)) (let ((names (frame-var-names frame)) (values (frame-var-values frame))) (write-to-string (app (eval `(fun ,names ,(read-from-string string)) (module-name (buffer-module))) values)))) (df debugger-info (condition restarts backtrace eval-context) (lst `(,(try-or (fun () (describe-condition condition)) "<...>") ,(cat " [class: " (class-name-str condition) "]") ()) (restarts-for-emacs restarts) (backtrace-for-emacs backtrace) (pending-continuations eval-context))) (df backtrace-for-emacs (backtrace) (map (fun (f) (match f ((,idx (,f ,@args)) (lst idx (cat (if (fun-name f) (sym-name (fun-name f)) (safe-write-to-string f)) (safe-write-to-string args)))))) backtrace)) (df restarts-for-emacs (restarts) (map (fun (x) `(,(sym-name (class-name (%handler-condition-type x))) ,(describe-restart x))) restarts)) (df describe-restart (restart) (describe-handler (%handler-info restart) (%handler-condition-type restart))) (df compute-restarts (condition) (packing (%do-handlers-of-type (fun (c) (pack c))))) (df find-restart (type) (esc ret (%do-handlers-of-type type ret) #f)) (df pending-continuations (context|(t? )) (if context (pair (@id context) (pending-continuations (@prev context))) '())) (df find-top-frame (fname| offset|) (esc ret (let ((top-seen? #f)) (do-stack-frames (fun (f args) (cond (top-seen? (cond ((== offset 0) (ret (pair f args))) (#t (decf offset)))) ((== (fun-name f) fname) (set top-seen? #t)))))))) (df compute-backtrace (top-frame start| end) (packing (esc break (do-user-frames (fun (idx f args) (when (and end (<= end idx)) (break #f)) (when (<= start idx) (pack (lst idx (pair f args))))) top-frame)))) (df nth-frame (n|) (esc ret (do-user-frames (fun (idx f args) (when (= idx n) (ret (pair f args)))) (@top-frame sldb-context)))) (df frame-var-value (frame var-idx) (match frame ((,f ,@args) (def sig (fun-sig f)) (def arity (sig-arity sig)) (def nary? (sig-nary? sig)) (cond ((< var-idx arity) (elt args var-idx)) (nary? (sub* args arity)))))) (df frame-var-names (frame) (match frame ((,f ,@_) (fun-info-names (fun-info f))))) (df frame-var-values (frame) (map (curry frame-var-value frame) (keys (frame-var-names frame)))) (df do-user-frames (f| top-frame) (let ((idx -1) (top-seen? #f)) (do-stack-frames (fun (ffun args) (cond (top-seen? (incf idx) (f idx ffun (rev args))) ((= (pair ffun args) top-frame) (set top-seen? #t))))))) ;;;; Write some classes a little less verbose ;; (dm recurring-write (port| x d| recur|) ;; (msg port "#{%s &%s}" (class-name-str x) ;; (num-to-str-base (address-of x) 16))) (dm recurring-write (port| x| d| recur|) (msg port "#{%s %s}" (class-name-str x) (module-name x))) (dm recurring-write (port| x| d| recur|) (msg port "#{%s %s}" (class-name-str x) (binding-name x))) (dm recurring-write (port| x| d| recur|) (msg port "#{%s %s}" (class-name-str x) (len x))) (dm recurring-write (port| x| d| recur|) (msg port "#{%s}" (class-name-str x))) (dm recurring-write (port| x| d| recur|) (msg port "#{%s}" (class-name-str x))) (dm recurring-write (port| x| d| recur|) (msg port "#{%s %s:%=}" (class-name-str x) (src-loc-file x) (src-loc-line x))) ;;;; Inspector (dc ()) (dp! @object ( => )) (dp! @parts ( => ) (new )) (dp! @stack ( => ) '()) (dv inspector #f) (defslimefun init-inspector (form|) (reset-inspector) (inspect-object (str-eval form (buffer-module)))) (defslimefun quit-inspector () (reset-inspector) 'nil) (defslimefun inspect-nth-part (n|) (inspect-object (elt (@parts inspector) n))) (defslimefun inspector-pop () (cond ((<= 2 (len (@stack inspector))) (popf (@stack inspector)) (inspect-object (popf (@stack inspector)))) (#t 'nil))) (df reset-inspector () (set inspector (new ))) (df inspect-object (o) (set (@object inspector) o) (set (@parts inspector) (new )) (pushf (@stack inspector) o) (lst ':title (safe-write-to-string o) ; ':type (class-name-str o) ':content (inspector-content `("class: " (:value ,(class-of o)) "\n" ,@(inspect o))))) (df inspector-content (content) (map (fun (part) (case-by part isa? (() part) (() (match part ((:value ,o ,@str) `(:value ,@(if (nul? str) (lst (safe-write-to-string o)) str) ,(assign-index o))))) (#t (error "Bad inspector content: %=" part)))) content)) (df assign-index (o) (pushf (@parts inspector) o) (1- (len (@parts inspector)))) (dg inspect (o)) ;; a list of dangerous functions (d. getter-blacklist (lst fun-code fun-env class-row)) (dm inspect (o) (join (map (fun (p) (let ((getter (prop-getter p))) `(,(sym-name (fun-name getter)) ": " ,(cond ((mem? getter-blacklist getter) "<...>") ((not (prop-bound? o getter)) "") (#t (try-or (fun () `(:value ,(getter o))) "<...>")))))) (class-props (class-of o))) '("\n"))) (dm inspect (o|) (join (packing (do-keyed (fun (pos val) (pack `(,(num-to-str pos) ": " (:value ,val)))) o)) '("\n"))) (dm inspect (o|) (join (packing (do-keyed (fun (key val) (pack `((:value ,key) "\t: " (:value ,val)))) o)) '("\n"))) ;; inspecting the env of closures is broken ;; (dm inspect (o|) ;; (cat (sup o) ;; '("\n") ;; (if (%fun-env? o) ;; (inspect (packing (for ((i (below (%fun-env-len o)))) ;; (pack (%fun-env-elt o i))))) ;; '()))) ;; ;; (df %fun-env? (f| => ) #eb{ FUNENV($f) != $#f }) ;; (df %fun-env-len (f| => ) #ei{ ((ENV)FUNENV ($f))->size }) ;; (df %fun-env-elt (f| i| => ) #eg{ FUNENVGET($f, @i) }) ;;;; init (defslimefun connection-info () `(:pid ,(process-id) :style nil :lisp-implementation (:type "GOO" :name "goo" :version ,(%lookup '*goo-version* 'eval/main)) :machine (:instance "" :type "" :version "") :features () :package (:name "goo/user" :prompt "goo/user"))) (defslimefun quit-lisp () #ei{ exit (0),0 }) (defslimefun set-default-directory (dir|) #ei{ chdir(@dir) } dir) ;;;; eval (defslimefun ping () "PONG") (defslimefun create-repl (_) (let ((name (sym-name (module-name (buffer-module))))) `(,name ,name))) (defslimefun listener-eval (string) (clear-input in) `(:values ,(write-to-string (str-eval string (buffer-module))))) (defslimefun interactive-eval (string) (cat "=> " (write-to-string (str-eval string (buffer-module))))) (df str-eval (s| m|) (eval (read-from-string s) (module-name m))) (df clear-input (in|) (while (ready? in) (get in))) (dc ()) (defslimefun simple-break () (simple-restart "Continue from break" (fun () (sig (new condition-message "Interrupt from Emacs")))) 'nil) (defslimefun clear-repl-results () 'nil) ;;;; compile (defslimefun compile-string-for-emacs (string buffer position directory) (def start (current-time)) (def r (g2c-eval (read-from-string string) (module-target-environment (buffer-module)))) (lst (write-to-string r) (/ (as (- (current-time) start)) 1000000.0))) (defslimefun compiler-notes-for-emacs () 'nil) (defslimefun filename-to-modulename (filename| => (t+ )) (try-or (fun () (sym-name (filename-to-modulename filename))) 'nil)) (df filename-to-modulename (filename| => ) (def paths (map pathname-to-components (map simplify-filename (pick file-exists? *module-search-path*)))) (def filename (pathname-to-components filename)) (def moddir (rep parent ((modpath filename)) (cond ((any? (curry = modpath) paths) modpath) (#t (parent (components-parent-directory modpath)))))) (def modfile (components-to-pathname (sub* filename (len moddir)))) (as-sym (sub modfile 0 (- (len modfile) (len *goo-extension*))))) ;;;; Load (defslimefun load-file (filename) (let ((file (cond ((= (sub (rev filename) 0 4) "oog.") filename) (#t (cat filename ".goo"))))) (safe-write-to-string (load-file file (filename-to-modulename file))))) ;;;; background activities (defslimefun operator-arglist (op _) (try-or (fun () (let ((value (str-eval op (buffer-module)))) (if (isa? value ) (write-to-string value) 'nil))) 'nil)) ;;;; M-. (defslimefun find-definitions-for-emacs (name|) (match (parse-symbol name) ((,sym ,modname) (def env (module-target-environment (runtime-module modname))) (def b (find-binding sym env)) (cond (b (find-binding-definitions b)) (#t 'nil))))) (df parse-symbol (name| => ) (if (mem? name #\:) (match (split name #\:) ((,module ,name) (lst (as-sym name) (as-sym module)))) (lst (as-sym name) (module-name (buffer-module))))) (df find-binding-definitions (b|) (def value (case (binding-kind b) (('runtime) (loc-val (binding-locative b))) (('global) (let ((box (binding-global-box b))) (and box (global-box-value box)))) (('macro) (binding-info b)) (#t (error "unknown binding kind %=" (binding-kind b))))) (map (fun (o) (def loc (emacs-src-loc o)) `(,(write-to-string (dspec o)) ,(or loc `(:error "no src-loc available")))) (defining-objects value))) (dm defining-objects (o => ) '()) (dm defining-objects (o| => ) (lst o)) (dm defining-objects (o| => ) (pair o (fun-mets o))) (dm emacs-src-loc (o|) (def loc (fun-src-loc o)) (and loc `(:location (:file ,(simplify-filename (find-goo-file-in-path (module-name-to-relpath (src-loc-file loc)) *module-search-path*))) (:line ,(src-loc-line loc)) ()))) (dm dspec (f|) (cond ((fun-name f) `(,(if (isa? f ) 'dg 'dm) ,(fun-name f) ,@(dspec-arglist f))) (#t f))) (df dspec-arglist (f|) (map2 (fun (name class) (cond ((= class ) name) ((isa? class ) `(,name ,(class-name class))) (#t `(,name ,class)))) (fun-info-names (fun-info f)) (sig-specs (fun-sig f)))) (defslimefun buffer-first-change (filename) 'nil) ;;;; apropos (defslimefun apropos-list-for-emacs (pattern only-external? case-sensitive? package) (def matches (fab 100)) (do-all-bindings (fun (b) (when (finds (binding-name-str b) pattern) (set (elt matches (cat-sym (binding-name b) (module-name (binding-module b)))) b)))) (set matches (sort-by (packing-as (for ((b matches)) (pack b))) (fun (x y) (< (binding-name x) (binding-name y))))) (map (fun (b) `(:designator ,(cat (sym-name (module-name (binding-module b))) ":" (binding-name-str b) "\tkind: " (sym-name (binding-kind b))))) (as matches))) (df do-all-bindings (f|) (for ((module (%module-loader-modules (runtime-module-loader)))) (do f (environment-bindings (module-target-environment module))))) (dm < (s1| s2| => ) (let ((l1 (len s1)) (l2 (len s2))) (rep loop ((i 0)) (cond ((= i l1) (~= l1 l2)) ((= i l2) #f) ((< (elt s1 i) (elt s2 i)) #t) ((= (elt s1 i) (elt s2 i)) (loop (1+ i))) (#t #f))))) (df %binding-info (name| module|) (binding-info (find-binding name (module-target-environment (runtime-module module))))) ;;;; completion (defslimefun simple-completions (pattern| package) (def matches (lst)) (for ((b (environment-bindings (module-target-environment (buffer-module))))) (when (prefix? (binding-name-str b) pattern) (pushf matches b))) (def strings (map binding-name-str matches)) `(,strings ,(cond ((nul? strings) pattern) (#t (fold+ common-prefix strings))))) (df common-prefix (s1| s2|) (let ((limit (min (len s1) (len s2)))) (rep loop ((i 0)) (cond ((or (= i limit) (~= (elt s1 i) (elt s2 i))) (sub s1 0 i)) (#t (loop (1+ i))))))) (defslimefun list-all-package-names (_|...) (map sym-name (keys (all-modules)))) (df all-modules () (%module-loader-modules (runtime-module-loader))) ;;;; Macroexpand (defslimefun swank-macroexpand-1 (str|) (write-to-string (%ast-macro-expand (read-from-string str) (module-target-environment (buffer-module)) #f))) ;;;; streams (dc ()) (dp @socket ( => )) (dp! @buf-len ( => ) 0) (dp @buf ( => ) (new )) (dp! @timestamp ( => ) 0) (dm recurring-write (port| x| d| recur|) (msg port "#{%s buf-len: %s}" (class-name-str x) (@buf-len x))) (dm put (p| c|) (add! (@buf p) c) (incf (@buf-len p)) (maybe-flush p (= c #\newline))) (dm puts (p| s|) (add! (@buf p) s) (incf (@buf-len p) (len s)) (maybe-flush p (mem? s #\newline))) (df maybe-flush (p| newline?|) (and (or (> (@buf-len p) 4000) newline?) (> (- (current-time) (@timestamp p)) 100000) (force-out p))) (dm force-out (p|) (unless (zero? (@buf-len p)) (dispatch-event `(:write-string ,(%buf-to-str (@buf p))) (@socket p)) (set (@buf-len p) 0) (zap! (@buf p))) (set (@timestamp p) (current-time))) (df %buf-to-str (buf|) (packing-as (for ((i buf)) (cond ((isa? i ) (for ((c i)) (pack c))) (#t (pack i)))))) (dc ()) (dp @socket ( => )) (dp! @idx ( => ) 0) (dp! @buf ( => ) "") (df receive-input (p|) (dispatch-event `(:read-string ,0) (@socket p))) (dm get (p| => ) (cond ((< (@idx p) (len (@buf p))) (def c (elt (@buf p) (@idx p))) (incf (@idx p)) c) (#t (def input (receive-input p)) (cond ((zero? (len input)) (eof-object)) (#t (set (@buf p) input) (set (@idx p) 0) (get p)))))) (dm ready? (p| => ) (< (@idx p) (len (@buf p)))) (dm peek (p| => ) (let ((c (get p))) (unless (eof-object? c) (decf (@idx p))) c)) ;;;; Message encoding (df decode-message (port|) (read-from-string (get-block port (read-message-length port)))) (df read-message-length (port) (or (str-to-num (cat "#x" (get-block port 6))) (error "can't parse message length"))) (df encode-message (message port) (let ((string (dlet ((*max-print-length* 1000000) (*max-print-depth* 1000000)) (write-to-string message)))) (puts port (encode-message-length (len string))) (puts port string) (force-out port))) (df encode-message-length (n) (loc ((hex (byte) (if (< byte #x10) (cat "0" (num-to-str-base byte 16)) (num-to-str-base byte 16))) (byte (i) (hex (& (>> n (* i 8)) 255)))) (cat (byte 2) (byte 1) (byte 0)))) ;;;; semi general utilities ;; Return the name of O's class as string. (df class-name-str (o => ) (sym-name (class-name (class-of o)))) (df binding-name-str (b| => ) (sym-name (binding-name b))) (df as-sym (str|) (as str)) ;; Replace '//' in the middle of a filename with with a '/' (df simplify-filename (str| => ) (match (pathname-to-components str) ((,hd ,@tl) (components-to-pathname (cons hd (del-vals tl 'root)))))) ;; Execute BODY and only if BODY exits abnormally execute RECOVER. (df try-recover (body recover) (let ((ok #f)) (fin (let ((val (body))) (set ok #t) val) (unless ok (recover))))) ;; like CL's IGNORE-ERRORS but return VALUE in case of an error. (df try-or (body| value) (esc ret (try (fun (condition resume) (ret value)) (body)))) (df simple-restart (type msg body) (esc restart (try ((type type) (description msg)) (fun (c r) (restart #f)) (body)))) (df safe-write-to-string (o) (esc ret (try (fun (c r) (ret (cat "#"))) (write-to-string o)))) ;; Read a string of length COUNT. (df get-block (port| count| => ) (packing-as (for ((i (below count))) (let ((c (get port))) (cond ((eof-object? c) (error "Premature EOF (read %d of %d)" i count)) (#t (pack c))))))) ;;;; import some internal bindings (df %lookup (name| module|) (loc-val (binding-locative (find-binding name (module-target-environment (runtime-module module)))))) (d. %handler-info (%lookup 'handler-info 'goo/conditions)) (d. %handler-condition-type (%lookup 'handler-condition-type 'goo/conditions)) (d. %do-handlers-of-type (%lookup 'do-handlers-of-type 'goo/conditions)) (d. %module-loader-modules (%lookup 'module-loader-modules 'eval/module)) (d. %ast-macro-expand (%lookup 'ast-macro-expand 'eval/ast)) ;;;; low level socket stuff ;;; this shouldn't be here #{ #include #include #include #include #include #include #include /* convert a goo number to a C long */ static long g2i (P o) { return untag (o); } static int set_reuse_address (int socket, int value) { return setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, &value, sizeof value); } static int bind_socket (int socket, int port) { struct sockaddr_in addr; addr.sin_family = AF_INET; addr.sin_port = htons (port); addr.sin_addr.s_addr = htonl (INADDR_ANY); return bind (socket, (struct sockaddr *)&addr, sizeof addr); } static int local_port (int socket) { struct sockaddr_in addr; socklen_t len = sizeof addr; int code = getsockname (socket, (struct sockaddr *)&addr, &len); return (code == -1) ? -1 : ntohs (addr.sin_port); } static int c_accept (int socket) { struct sockaddr_in addr; socklen_t len = sizeof addr; return accept (socket, (struct sockaddr *)&addr, &len); } static P tup3 (P e0, P e1, P e2) { P tup = YPPtfab ((P)3, YPfalse); YPtelt_setter (e0, tup, (P)0); YPtelt_setter (e1, tup, (P)1); YPtelt_setter (e2, tup, (P)2); return tup; } static P current_time (void) { struct timeval timeval; int code = gettimeofday (&timeval, NULL); if (code == 0) { return tup3 (YPib ((P)(timeval.tv_sec >> 24)), YPib ((P)(timeval.tv_sec & 0xffffff)), YPib ((P)(timeval.tv_usec))); } else return YPib ((P)errno); } } ;; Return the current time in microsecs (df current-time (=> ) (def t #eg{ current_time () }) (cond ((isa? t ) (error "%s" (strerror t))) (#t (+ (* (+ (<< (1st t) 24) (2nd t)) 1000000) (3rd t))))) (dm strerror (e| => ) #es{ strerror (g2i ($e)) }) (dm strerror (e|(t= #f) => ) #es{ strerror (errno) }) (df checkr (value|) (cond ((~== value -1) value) (#t (error "%s" (strerror #f))))) (df create-socket (port| => ) (let ((socket (checkr #ei{ socket (PF_INET, SOCK_STREAM, 0) }))) (checkr #ei{ set_reuse_address (g2i ($socket), 1) }) (checkr #ei{ bind_socket (g2i ($socket), g2i ($port)) }) (checkr #ei{ listen (g2i ($socket), 1)}) socket)) (df %local-port (fd|) (checkr #ei{ local_port (g2i ($fd)) })) (df %close (fd|) (checkr #ei{ close (g2i ($fd)) })) (dc ( )) (dp @fd ( => )) (dp @in ( => )) (dp @out ( => )) (dm recurring-write (port| x| d| recur|) (msg port "#{%s fd: %s}" (class-name-str x) (@fd x))) (dm get (port| => ) (get (@in port))) (dm puts (port| s|) (puts (@out port) s)) (dm force-out (port|) (force-out (@out port))) (dm fdopen (fd| type|(t= ) => ) (new @fd fd @in (new port-handle (%fdopen fd "r")) @out (new port-handle (%fdopen fd "w")))) (df %fdopen (fd| mode| => ) (def addr #ei{ fdopen (g2i ($fd), @mode) }) (when (zero? addr) (error "fdopen failed: %s" (strerror #f))) (%lb (%iu addr))) (df accept (socket| => ) (fdopen (checkr #ei{ c_accept (g2i ($socket)) }) )) (export start-swank create-server) ;;; swank-goo.goo ends hereslime-2.20/contrib/swank-hyperdoc.lisp000066400000000000000000000013741315100173500200360ustar00rootroot00000000000000(in-package :swank) (defslimefun hyperdoc (string) (let ((hyperdoc-package (find-package :hyperdoc))) (when hyperdoc-package (multiple-value-bind (symbol foundp symbol-name package) (parse-symbol string *buffer-package*) (declare (ignore symbol)) (when foundp (funcall (find-symbol (string :lookup) hyperdoc-package) (package-name (if (member package (cons *buffer-package* (package-use-list *buffer-package*))) *buffer-package* package)) symbol-name)))))) (provide :swank-hyperdoc) slime-2.20/contrib/swank-ikarus.ss000066400000000000000000000046451315100173500172010ustar00rootroot00000000000000;; swank-larceny.scm --- Swank server for Ikarus ;; ;; License: Public Domain ;; Author: Helmut Eller ;; ;; In a shell execute: ;; ikarus swank-ikarus.ss ;; and then `M-x slime-connect' in Emacs. ;; (library (swank os) (export getpid make-server-socket accept local-port close-socket) (import (rnrs) (only (ikarus foreign) make-c-callout dlsym dlopen pointer-set-c-long! pointer-ref-c-unsigned-short malloc free pointer-size) (rename (only (ikarus ipc) tcp-server-socket accept-connection close-tcp-server-socket) (tcp-server-socket make-server-socket) (close-tcp-server-socket close-socket)) (only (ikarus) struct-type-descriptor struct-type-field-names struct-field-accessor) ) (define libc (dlopen)) (define (cfun name return-type arg-types) ((make-c-callout return-type arg-types) (dlsym libc name))) (define getpid (cfun "getpid" 'signed-int '())) (define (accept socket codec) (let-values (((in out) (accept-connection socket))) (values (transcoded-port in (make-transcoder codec)) (transcoded-port out (make-transcoder codec))))) (define (socket-fd socket) (let ((rtd (struct-type-descriptor socket))) (do ((i 0 (+ i 1)) (names (struct-type-field-names rtd) (cdr names))) ((eq? (car names) 'fd) ((struct-field-accessor rtd i) socket))))) (define sockaddr_in/size 16) (define sockaddr_in/sin_family 0) (define sockaddr_in/sin_port 2) (define sockaddr_in/sin_addr 4) (define (local-port socket) (let* ((fd (socket-fd socket)) (addr (malloc sockaddr_in/size)) (size (malloc (pointer-size)))) (pointer-set-c-long! size 0 sockaddr_in/size) (let ((code (getsockname fd addr size)) (port (ntohs (pointer-ref-c-unsigned-short addr sockaddr_in/sin_port)))) (free addr) (free size) (cond ((= code -1) (error "getsockname failed")) (#t port))))) (define getsockname (cfun "getsockname" 'signed-int '(signed-int pointer pointer))) (define ntohs (cfun "ntohs" 'unsigned-short '(unsigned-short))) ) (library (swank sys) (export implementation-name eval-in-interaction-environment) (import (rnrs) (rnrs eval) (only (ikarus) interaction-environment)) (define (implementation-name) "ikarus") (define (eval-in-interaction-environment form) (eval form (interaction-environment))) ) (import (only (ikarus) load)) (load "swank-r6rs.scm") (import (swank)) (start-server #f) slime-2.20/contrib/swank-indentation.lisp000066400000000000000000000133251315100173500205340ustar00rootroot00000000000000(in-package :swank) (defvar *application-hints-tables* '() "A list of hash tables mapping symbols to indentation hints (lists of symbols and numbers as per cl-indent.el). Applications can add hash tables to the list to change the auto indentation slime sends to emacs.") (defun has-application-indentation-hint-p (symbol) (let ((default (load-time-value (gensym)))) (dolist (table *application-hints-tables*) (let ((indentation (gethash symbol table default))) (unless (eq default indentation) (return-from has-application-indentation-hint-p (values indentation t)))))) (values nil nil)) (defun application-indentation-hint (symbol) (let ((indentation (has-application-indentation-hint-p symbol))) (labels ((walk (indentation-spec) (etypecase indentation-spec (null nil) (number indentation-spec) (symbol (string-downcase indentation-spec)) (cons (cons (walk (car indentation-spec)) (walk (cdr indentation-spec))))))) (walk indentation)))) ;;; override swank version of this function (defun symbol-indentation (symbol) "Return a form describing the indentation of SYMBOL. The form is to be used as the `common-lisp-indent-function' property in Emacs." (cond ((has-application-indentation-hint-p symbol) (application-indentation-hint symbol)) ((and (macro-function symbol) (not (known-to-emacs-p symbol))) (let ((arglist (arglist symbol))) (etypecase arglist ((member :not-available) nil) (list (macro-indentation arglist))))) (t nil))) ;;; More complex version. (defun macro-indentation (arglist) (labels ((frob (list &optional base) (if (every (lambda (x) (member x '(nil "&rest") :test #'equal)) list) ;; If there was nothing interesting, don't return anything. nil ;; Otherwise substitute leading NIL's with 4 or 1. (let ((ok t)) (substitute-if (if base 4 1) (lambda (x) (if (and ok (not x)) t (setf ok nil))) list)))) (walk (list level &optional firstp) (when (consp list) (let ((head (car list))) (if (consp head) (let ((indent (frob (walk head (+ level 1) t)))) (cons (list* "&whole" (if (zerop level) 4 1) indent) (walk (cdr list) level))) (case head ;; &BODY is &BODY, this is clear. (&body '("&body")) ;; &KEY is tricksy. If it's at the base level, we want ;; to indent them normally: ;; ;; (foo bar quux ;; :quux t ;; :zot nil) ;; ;; If it's at a destructuring level, we want indent of 1: ;; ;; (with-foo (var arg ;; :foo t ;; :quux nil) ;; ...) (&key (if (zerop level) '("&rest" nil) '("&rest" 1))) ;; &REST is tricksy. If it's at the front of ;; destructuring, we want to indent by 1, otherwise ;; normally: ;; ;; (foo (bar quux ;; zot) ;; ...) ;; ;; but ;; ;; (foo bar quux ;; zot) (&rest (if (and (plusp level) firstp) '("&rest" 1) '("&rest" nil))) ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there ;; at all. ((&whole &environment) (walk (cddr list) level firstp)) ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker ;; itself is not counted. (&optional (walk (cdr list) level)) ;; Indent normally, walk the tail -- but ;; unknown lambda-list keywords terminate the walk. (otherwise (unless (member head lambda-list-keywords) (cons nil (walk (cdr list) level)))))))))) (frob (walk arglist 0 t) t))) #+nil (progn (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body") (macro-indentation '(bar quux (&rest slots) &body body)))) (assert (equal nil (macro-indentation '(a b c &rest more)))) (assert (equal '(4 4 4 "&body") (macro-indentation '(a b c &body more)))) (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body") (macro-indentation '((name zot &key foo bar) &body body)))) (assert (equal nil (macro-indentation '(x y &key z))))) (provide :swank-indentation) slime-2.20/contrib/swank-jolt.k000066400000000000000000001002631315100173500164510ustar00rootroot00000000000000;;; swank-jolt.k --- Swank server for Jolt -*- goo -*- ;; ;; Copyright (C) 2008 Helmut Eller ;; ;; This file is licensed under the terms of the GNU General Public ;; License as distributed with Emacs (press C-h C-c for details). ;;; Commentary: ;; ;; Jolt/Coke is a Lisp-like language wich operates at the semantic level of ;; C, i.e. most objects are machine words and memory pointers. The ;; standard boot files define an interface to Id Smalltalk. So we can ;; also pretend to do OOP, but we must be careful to pass properly ;; tagged pointers to Smalltalk. ;; ;; This file only implements a minimum of SLIME's functionality. We ;; install a handler with atexit(3) to invoke the debugger. This way ;; we can stop Jolt from terminating the process on every error. ;; Unfortunately, the backtrace doesn't contain much information and ;; we also have no error message (other than the exit code). Jolt ;; usually prints some message to stdout before calling exit, so you ;; have to look in the *inferior-lisp* buffer for hints. We do ;; nothing (yet) to recover from SIGSEGV. ;;; Installation ;; ;; 1. Download and build cola. See . ;; I used the svn version: ;; svn co http://piumarta.com/svn2/idst/trunk idst ;; 2. Add something like this to your .emacs: ;; ;; (add-to-list 'slime-lisp-implementations ;; '(jolt (".../idst/function/jolt-burg/main" ;; "boot.k" ".../swank-jolt.k" "-") ; note the "-" ;; :init jolt-slime-init ;; :init-function slime-redirect-inferior-output) ;; (defun jolt-slime-init (file _) (format "%S\n" `(start-swank ,file))) ;; (defun jolt () (interactive) (slime 'jolt)) ;; ;; 3. Use `M-x jolt' to start it. ;; ;;; Code ;; In this file I use 2-3 letters for often used names, like DF or ;; VEC, even if those names are abbreviations. I think that after a ;; little getting used to, this style is just as readable as the more ;; traditional DEFUN and VECTOR. Shorter names make it easier to ;; write terse code, in particular 1-line definitions. ;; `df' is like `defun' in a traditional lisp (syntax df (lambda (form compiler) (printf "df %s ...\n" [[[form second] asString] _stringValue]) `(define ,[form second] (lambda ,@[form copyFrom: '2])))) ;; (! args ...) is the same as [args ...] but easier to edit. (syntax ! (lambda (form compiler) (cond ((== [form size] '3) (if [[form third] isSymbol] `(send ',[form third] ,[form second]) [compiler errorSyntax: [form third]])) ((and [[form size] > '3] (== [[form size] \\ '2] '0)) (let ((args [OrderedCollection new]) (keys [OrderedCollection new]) (i '2) (len [form size])) (while (< i len) (let ((key [form at: i])) (if (or [key isKeyword] (and (== i '2) [key isSymbol])) ; for [X + Y] [keys addLast: [key asString]] [compiler errorSyntax: key])) [args addLast: [form at: [i + '1]]] (set i [i + '2])) `(send ',[[keys concatenated] asSymbol] ,[form second] ,@args))) (1 [compiler errorArgumentCount: form])))) (define Integer (import "Integer")) (define Symbol (import "Symbol")) ;; aka. _selector (define StaticBlockClosure (import "StaticBlockClosure")) (define BlockClosure (import "BlockClosure")) (define SequenceableCollection (import "SequenceableCollection")) (define _vtable (import "_vtable")) (define ByteArray (import "ByteArray")) (define CodeGenerator (import "CodeGenerator")) (define TheGlobalEnvironment (import "TheGlobalEnvironment")) (df error (msg) (! Object error: msg)) (df print-to-string (obj) (let ((len '200) (stream (! WriteStream on: (! String new: len)))) (! stream print: obj) (! stream contents))) (df assertion-failed (exp) (error (! '"Assertion failed: " , (print-to-string exp)))) (syntax assert (lambda (form) `(if (not ,(! form second)) (assertion-failed ',(! form second))))) (df isa? (obj type) (! obj isKindOf: type)) (df equal (o1 o2) (! o1 = o2)) (define nil 0) (define false 0) (define true (! Object notNil)) (df bool? (obj) (or (== obj false) (== obj true))) (df int? (obj) (isa? obj Integer)) ;; In this file the convention X>Y is used for operations that convert ;; X-to-Y. And _ means "machine word". So _>int is the operator that ;; converts a machine word to an Integer. (df _>int (word) (! Integer value_: word)) (df int>_ (i) (! i _integerValue)) ;; Fixnum operators. Manual tagging/untagging would probably be more ;; efficent than invoking methods. (df fix? (obj) (& obj 1)) (df _>fix (n) (! SmallInteger value_: n)) (df fix>_ (i) (! i _integerValue)) (df fx+ (fx1 fx2) (! fx1 + fx2)) (df fx* (fx1 fx2) (! fx1 * fx2)) (df fx1+ (fx) (! fx + '1)) (df fx1- (fx) (! fx - '1)) (df str? (obj) (isa? obj String)) (df >str (o) (! o asString)) (df str>_ (s) (! s _stringValue)) (df _>str (s) (! String value_: s)) (df sym? (obj) (isa? obj Symbol)) (df seq? (obj) (isa? obj SequenceableCollection)) (df array? (obj) (isa? obj Array)) (df len (obj) (! obj size)) (df len_ (obj) (! (! obj size) _integerValue)) (df ref (obj idx) (! obj at: idx)) (df set-ref (obj idx elt) (! obj at: idx put: elt)) (df first (obj) (! obj first)) (df second (obj) (! obj second)) (df puts (string stream) (! stream nextPutAll: string)) (define _GC_base (dlsym "GC_base")) ;; Is ADDR a pointer to a heap allocated object? The Boehm GC nows ;; such things. This is useful for debugging, because we can quite ;; safely (i.e. without provoking SIGSEGV) access such addresses. (df valid-pointer? (addr) (let ((ptr (& addr (~ 1)))) (and (_GC_base ptr) (_GC_base (long@ ptr -1))))) ;; Print OBJ as a Lisp printer would do. (df prin1 (obj stream) (cond ((fix? obj) (! stream print: obj)) ((== obj nil) (puts '"nil" stream)) ((== obj false) (puts '"#f" stream)) ((== obj true) (puts '"#t" stream)) ((not (valid-pointer? obj)) (begin (puts '"#int obj) stream) (puts '">" stream))) ((int? obj) (! stream print: obj)) ((sym? obj) (puts (>str obj) stream)) ((isa? obj StaticBlockClosure) (begin (puts '"#" stream))) ((and (str? obj) (len obj)) (! obj printEscapedOn: stream delimited: (ref '"\"" '0))) ((and (array? obj) (len obj)) (begin (puts '"(" stream) (let ((max (- (len_ obj) 1))) (for (i 0 1 max) (prin1 (ref obj (_>fix i)) stream) (if (!= i max) (puts '" " stream)))) (puts '")" stream))) ((and (isa? obj OrderedCollection) (len obj)) (begin (puts '"#[" stream) (let ((max (- (len_ obj) 1))) (for (i 0 1 max) (prin1 (ref obj (_>fix i)) stream) (if (!= i max) (puts '" " stream)))) (puts '"]" stream))) (true (begin (puts '"#<" stream) (puts (! obj debugName) stream) (puts '">" stream)))) obj) (df print (obj) (prin1 obj StdOut) (puts '"\n" StdOut)) (df prin1-to-string (obj) (let ((len '100) (stream (! WriteStream on: (! String new: len)))) (prin1 obj stream) (! stream contents))) ;;(df %vable-tally (_vtable) (long@ _vtable)) (df cr () (printf "\n")) (df print-object-selectors (obj) (let ((vtable (! obj _vtable)) (tally (long@ vtable 0)) (bindings (long@ vtable 1))) (for (i 1 1 tally) (print (long@ (long@ bindings i))) (cr)))) (df print-object-slots (obj) (let ((size (! obj _sizeof)) (end (+ obj size))) (while (< obj end) (print (long@ obj)) (cr) (incr obj 4)))) (df intern (string) (! Symbol intern: string)) ;; Jolt doesn't seem to have an equivalent for gensym, but it's damn ;; hard to write macros without it. So here we adopt the conventions ;; that symbols which look like ".[0-9]+" are reserved for gensym and ;; shouldn't be used for "user visible variables". (define gensym-counter 0) (df gensym () (set gensym-counter (+ gensym-counter 1)) (intern (! '"." , (>str (_>fix gensym-counter))))) ;; Surprisingly, SequenceableCollection doesn't have a indexOf method. ;; So we even need to implement such mundane things. (df index-of (seq elt) (let ((max (len seq)) (i '0)) (while (! i < max) (if (equal (ref seq i) elt) (return i) (set i (! i + '1)))) nil)) (df find-dot (array) (index-of array '.)) ;; What followes is the implementation of the pattern matching macro MIF. ;; The syntax is (mif (PATTERN EXP) THEN ELSE). ;; The THEN-branch is executed if PATTERN matches the value produced by EXP. ;; ELSE gets only executed if the match failes. ;; A pattern can be ;; 1) a symbol, which matches all values, but also binds the variable to the ;; value ;; 2) (quote LITERAL), matches if the value is `equal' to LITERAL. ;; 3) (PS ...) matches sequences, if the elements match PS. ;; 4) (P1 ... Pn . Ptail) matches if P1 ... Pn match the respective elements ;; at indices 1..n and if Ptail matches the rest ;; of the sequence ;; Examples: ;; (mif (x 10) x 'else) => 10 ;; (mif ('a 'a) 'then 'else) => then ;; (mif ('a 'b) 'then 'else) => else ;; (mif ((a b) '(1 2)) b 'else) => 2 ;; (mif ((a . b) '(1 2)) b 'else) => '(2) ;; (mif ((. x) '(1 2)) x 'else) => '(1 2) (define mif% 0) ;; defer (df mif%array (compiler pattern i value then fail) ;;(print `(mif%array ,pattern ,i ,value)) (cond ((== i (len_ pattern)) then) ((== (ref pattern (_>fix i)) '.) (begin (if (!= (- (len_ pattern) 2) i) (begin (print pattern) (! compiler error: (! '"dot in strange position: " , (>str (_>fix i)))))) (mif% compiler (ref pattern (_>fix (+ i 1))) `(! ,value copyFrom: ',(_>fix i)) then fail))) (true (mif% compiler (ref pattern (_>fix i)) `(ref ,value ',(_>fix i)) (mif%array compiler pattern (+ i 1) value then fail) fail)))) (df mif% (compiler pattern value then fail) ;;(print `(mif% ,pattern ,value ,then)) (cond ((== pattern '_) then) ((== pattern '.) (! compiler errorSyntax: pattern)) ((sym? pattern) `(let ((,pattern ,value)) ,then)) ((seq? pattern) (cond ((== (len_ pattern) 0) `(if (== (len_ ,value) 0) ,then (goto ,fail))) ((== (first pattern) 'quote) (begin (if (not (== (len_ pattern) 2)) (! compiler errorSyntax: pattern)) `(if (equal ,value ,pattern) ,then (goto ,fail)))) (true (let ((tmp (gensym)) (tmp2 (gensym)) (pos (find-dot pattern))) `(let ((,tmp2 ,value) (,tmp ,tmp2)) (if (and (seq? ,tmp) ,(if (find-dot pattern) `(>= (len ,tmp) ',(_>fix (- (len_ pattern) 2))) `(== (len ,tmp) ',(len pattern)))) ,(mif%array compiler pattern 0 tmp then fail) (goto ,fail))))))) (true (! compiler errorSyntax: pattern)))) (syntax mif (lambda (node compiler) ;;(print `(mif ,node)) (if (not (or (== (len_ node) 4) (== (len_ node) 3))) (! compiler errorArgumentCount: node)) (if (not (and (array? (ref node '1)) (== (len_ (ref node '1)) 2))) (! compiler errorSyntax: (ref node '1))) (let ((pattern (first (ref node '1))) (value (second (ref node '1))) (then (ref node '2)) (else (if (== (len_ node) 4) (ref node '3) `(error "mif failed"))) (destination (gensym)) (fail (! compiler newLabel)) (success (! compiler newLabel))) `(let ((,destination 0)) ,(mif% compiler pattern value `(begin (set ,destination ,then) (goto ,success)) fail) (label ,fail) (set ,destination ,else) (label ,success) ,destination)))) ;; (define *catch-stack* nil) ;; (df bar (o) (mif ('a o) 'yes 'no)) (assert (== (bar 'a) 'yes)) (assert (== (bar 'b) 'no)) (df foo (o) (mif (('a) o) 'yes 'no)) (assert (== (foo '(a)) 'yes)) (assert (== (foo '(b)) 'no)) (df baz (o) (mif (('a 'b) o) 'yes 'no)) (assert (== (baz '(a b)) 'yes)) (assert (== (baz '(a c)) 'no)) (assert (== (baz '(b c)) 'no)) (assert (== (baz 'a) 'no)) (df mifvar (o) (mif (y o) y 'no)) (assert (== (mifvar 'foo) 'foo)) (df mifvec (o) (mif ((y) o) y 'no)) (assert (== (mifvec '(a)) 'a)) (assert (== (mifvec 'x) 'no)) (df mifvec2 (o) (mif (('a y) o) y 'no)) (assert (== (mifvec2 '(a b)) 'b)) (assert (== (mifvec2 '(b c)) 'no)) (assert (== (mif ((x) '(a)) x 'no) 'a)) (assert (== (mif ((x . y) '(a b)) x 'no) 'a)) (assert (== (mif ((x y . z) '(a b)) y 'no) 'b)) (assert (equal (mif ((x . y) '(a b)) y 'no) '(b))) (assert (equal (mif ((. x) '(a b)) x 'no) '(a b))) (assert (equal (mif (((. x)) '((a b))) x 'no) '(a b))) (assert (equal (mif (((. x) . y) '((a b) c)) y 'no) '(c))) (assert (== (mif (() '()) 'yes 'no) 'yes)) (assert (== (mif (() '(a)) 'yes 'no) 'no)) ;; Now that we have a somewhat convenient pattern matcher we can write ;; a more convenient macro defining macro: (syntax defmacro (lambda (node compiler) (mif (('defmacro name (. args) . body) node) (begin (printf "defmacro %s ...\n" (str>_ (>str name))) `(syntax ,name (lambda (node compiler) (mif ((',name ,@args) node) (begin ,@body) (! compiler errorSyntax: node))))) (! compiler errorSyntax: node)))) ;; and an even more convenient pattern matcher: (defmacro mcase (value . clauses) (let ((tmp (gensym))) `(let ((,tmp ,value)) ,(mif (() clauses) `(begin (print ,tmp) (error "mcase failed")) (mif (((pattern . body) . more) clauses) `(mif (,pattern ,tmp) (begin ,@(mif (() body) '(0) body)) (mcase ,tmp ,@more)) (! compiler errorSyntax: clauses)))))) ;; and some traditional macros (defmacro when (test . body) `(if ,test (begin ,@body))) (defmacro unless (test . body) `(if ,test 0 (begin ,@body))) (defmacro or (. args) ; the built in OR returns 1 on success. (mcase args (() 0) ((e) e) ((e1 . more) (let ((tmp (gensym))) `(let ((,tmp ,e1)) (if ,tmp ,tmp (or ,@more))))))) (defmacro dotimes_ ((var n) . body) (let ((tmp (gensym))) `(let ((,tmp ,n) (,var 0)) (while (< ,var ,tmp) ,@body (set ,var (+ ,var 1)))))) (defmacro dotimes ((var n) . body) (let ((tmp (gensym))) `(let ((,tmp ,n) (,var '0)) (while (< ,var ,tmp) ,@body (set ,var (fx1+ ,var)))))) ;; DOVEC is like the traditional DOLIST but works on "vectors" ;; i.e. sequences which can be indexed efficently. (defmacro dovec ((var seq) . body) (let ((i (gensym)) (max (gensym)) (tmp (gensym))) `(let ((,i 0) (,tmp ,seq) (,max (len_ ,tmp))) (while (< ,i ,max) (let ((,var (! ,tmp at: (_>fix ,i)))) ,@body (set ,i (+ ,i 1))))))) ;; "Packing" is what Lispers usually call "collecting". ;; The Lisp idiom (let ((result '())) .. (push x result) .. (nreverse result)) ;; translates to (packing (result) .. (pack x result)) (defmacro packing ((var) . body) `(let ((,var (! OrderedCollection new))) ,@body (! ,var asArray))) (df pack (elt packer) (! packer addLast: elt)) (assert (equal (packing (p) (dotimes_ (i 2) (pack (_>fix i) p))) '(0 1))) (assert (equal (packing (p) (dovec (e '(2 3)) (pack e p))) '(2 3))) (assert (equal (packing (p) (let ((a '(2 3))) (dotimes (i (len a)) (pack (ref a i) p)))) '(2 3))) ;; MAPCAR (more or less) (df map (fun col) (packing (r) (dovec (e col) (pack (fun e) r)))) ;; VEC allocates and initializes a new array. ;; The macro translates (vec x y z) to `(,x ,y ,z). (defmacro vec (. args) `(quasiquote (,@(map (lambda (arg) `(,'unquote ,arg)) args)))) (assert (equal (vec '0 '1) '(0 1))) (assert (equal (vec) '())) (assert (== (len (vec 0 1 2 3 4)) '5)) ;; Concatenate. (defmacro cat (. args) `(! (vec '"" ,@args) concatenated)) (assert (equal (cat '"a" '"b" '"c") '"abc")) ;; Take a vector of bytes and copy the bytes to a continuous ;; block of memory (df assemble_ (col) (! (! ByteArray withAll: col) _bytes)) ;; Jolt doesn't seem to have catch/throw or something equivalent. ;; Here I use a pair of assembly routines as substitue. ;; (catch% FUN) calls FUN with the current stack pointer. ;; (throw% VALUE K) unwinds the stack to K and then returns VALUE. ;; catch% is a bit like call/cc. ;; ;; [Would setjmp/longjmp work from Jolt? or does setjmp require ;; C-compiler magic?] ;; [I figure Smalltalk has a way to do non-local-exits but, I don't know ;; how to use that in Jolt.] ;; (define catch% (assemble_ '(0x55 ; push %ebp 0x89 0xe5 ; mov %esp,%ebp 0x54 ; push %esp 0x8b 0x45 0x08 ; mov 0x8(%ebp),%eax 0xff 0xd0 ; call *%eax 0xc9 ; leave 0xc3 ; ret ))) (define throw% (assemble_ `(,@'() 0x8b 0x44 0x24 0x04 ; mov 0x4(%esp),%eax 0x8b 0x6c 0x24 0x08 ; mov 0x8(%esp),%ebp 0xc9 ; leave 0xc3 ; ret ))) (df bar (i k) (if (== i 0) (throw% 100 k) (begin (printf "bar %d\n" i) (bar (- i 1) k)))) (df foo (k) (printf "foo.1\n") (printf "foo.2 %d\n" (bar 10 k))) ;; Our way to produce closures: we compile a new little function which ;; hardcodes the addresses of the code resp. the data-vector. The ;; nice thing is that such closures can be used called C function ;; pointers. It's probably slow to invoke the compiler for such ;; things, so use with care. (df make-closure (addr state) (int>_ (! `(lambda (a b c d) (,(_>int addr) ,(_>int state) a b c d)) eval))) ;; Return a closure which calls FUN with ARGS and the arguments ;; that the closure was called with. ;; Example: ((curry printf "%d\n") 10) (defmacro curry (fun . args) `(make-closure (lambda (state a b c d) ((ref state '0) ,@(packing (sv) (dotimes (i (len args)) (pack `(ref state ',(fx1+ i)) sv))) a b c d)) (vec ,fun ,@args))) (df parse-closure-arglist (vars) (let ((pos (or (index-of vars '|) (return nil))) (cvars (! vars copyFrom: '0 to: (fx1- pos))) (lvars (! vars copyFrom: (fx1+ pos)))) (vec cvars lvars))) ;; Create a closure, to-be-closed-over variables must enumerated ;; explicitly. ;; Example: ((let ((x 1)) (closure (x | y) (+ x y))) 3) => 4. ;; The variables before the "|" are captured by the closure. (defmacro closure ((. vars) . body) (mif ((cvars lvars) (parse-closure-arglist vars)) `(curry (lambda (,@cvars ,@lvars) ,@body) ,@cvars) (! compiler errorSyntax: vars))) ;; The analog for Smalltalkish "blocks". (defmacro block ((. vars) . body) (mif ((cvars lvars) (parse-closure-arglist vars)) `(! StaticBlockClosure function_: (curry (lambda (,@cvars _closure _self ,@lvars) ,@body) ,@cvars) arity_: ,(len lvars)) (! compiler errorSyntax: vars))) (define %mkstemp (dlsym "mkstemp")) (df make-temp-file () (let ((name (! '"/tmp/jolt-tmp.XXXXXX" copy)) (fd (%mkstemp (! name _stringValue)))) (if (== fd -1) (error "mkstemp failed")) `(,fd ,name))) (define %unlink (dlsym "unlink")) (df unlink (filename) (%unlink (! filename _stringValue))) (define write (dlsym "write")) (df write-bytes (addr count fd) (let ((written (write fd addr count))) (if (!= written count) (begin (printf "write failed %p %d %d => %d" addr count fd written) (error '"write failed"))))) (define system (dlsym "system")) (define main (dlsym "main")) ;; Starting at address ADDR, disassemble COUNT bytes. ;; This is implemented by writing the memory region to a file ;; and call ndisasm on it. (df disas (addr count) (let ((fd+name (make-temp-file))) (write-bytes addr count (first fd+name)) (let ((cmd (str>_ (cat '"ndisasm -u -o " (>str (_>fix addr)) '" " (second fd+name))))) (printf "Running: %s\n" cmd) (system cmd)) (unlink (second fd+name)))) (df rep () (let ((result (! (! CokeScanner read: StdIn) eval))) (puts '"=> " StdOut) (print result) (puts '"\n" StdOut))) ;; Perhaps we could use setcontext/getcontext to return from signal ;; handlers (or not). (define +ucontext-size+ 350) (define _getcontext (dlsym "getcontext")) (define _setcontext (dlsym "setcontext")) (df getcontext () (let ((context (malloc 350))) (_getcontext context) context)) (define on_exit (dlsym "on_exit")) ; "atexit" doesn't work. why? (define *top-level-restart* 0) (define *top-level-context* 0) (define *debugger-hook* 0) ;; Jolt's error handling strategy is charmingly simple: call exit. ;; We invoke the SLIME debugger from an exit handler. ;; (The handler is registered with atexit, that's a libc function.) (df exit-handler (reason arg) (printf "exit-handler 0x%x\n" reason) ;;(backtrace) (on_exit exit-handler nil) (when *debugger-hook* (*debugger-hook* `(exit ,reason))) (cond (*top-level-context* (_setcontext *top-level-context*)) (*top-level-restart* (throw% reason *top-level-restart*)))) (df repl () (set *top-level-context* (getcontext)) (while (not (! (! StdIn readStream) atEnd)) (printf "top-level\n") (catch% (lambda (k) (set *top-level-restart* k) (printf "repl\n") (while 1 (rep))))) (printf "EOF\n")) ;; (repl) ;;; Socket code. (How boring. Duh, should have used netcat instead.) (define strerror (dlsym "strerror")) (df check-os-code (value) (if (== value -1) (error (_>str (strerror (fix>_ (! OS errno))))) value)) ;; For now just hard-code constants which usually reside in header ;; files (just like a Forth guy would do). (define PF_INET 2) (define SOCK_STREAM 1) (define SOL_SOCKET 1) (define SO_REUSEADDR 2) (define socket (dlsym "socket")) (define setsockopt (dlsym "setsockopt")) (df set-reuse-address (sock value) (let ((word-size 4) (val (! Object _balloc: (_>fix word-size)))) (set-int@ val value) (check-os-code (setsockopt sock SOL_SOCKET SO_REUSEADDR val word-size)))) (define sockaddr_in/size 16) (define sockaddr_in/sin_family 0) (define sockaddr_in/sin_port 2) (define sockaddr_in/sin_addr 4) (define INADDR_ANY 0) (define AF_INET 2) (define htons (dlsym "htons")) (define bind (dlsym "bind")) (df bind-socket (sock port) (let ((addr (! OS _balloc: (_>fix sockaddr_in/size)))) (set-short@ (+ addr sockaddr_in/sin_family) AF_INET) (set-short@ (+ addr sockaddr_in/sin_port) (htons port)) (set-int@ (+ addr sockaddr_in/sin_addr) INADDR_ANY) (check-os-code (bind sock addr sockaddr_in/size)))) (define listen (dlsym "listen")) (df create-socket (port) (let ((sock (check-os-code (socket PF_INET SOCK_STREAM 0)))) (set-reuse-address sock 1) (bind-socket sock port) (check-os-code (listen sock 1)) sock)) (define accept% (dlsym "accept")) (df accept (sock) (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))) (len (! OS _balloc: 4))) (set-int@ len sockaddr_in/size) (check-os-code (accept% sock addr len)))) (define getsockname (dlsym "getsockname")) (define ntohs (dlsym "ntohs")) (df local-port (sock) (let ((addr (! OS _balloc: (_>fix sockaddr_in/size))) (len (! OS _balloc: 4))) (set-int@ len sockaddr_in/size) (check-os-code (getsockname sock addr len)) (ntohs (short@ (+ addr sockaddr_in/sin_port))))) (define close (dlsym "close")) (define _read (dlsym "read")) ;; Now, after 2/3 of the file we can begin with the actual Swank ;; server. (df read-string (fd count) (let ((buffer (! String new: count)) (buffer_ (str>_ buffer)) (count_ (int>_ count)) (start 0)) (while (> (- count_ start) 0) (let ((rcount (check-os-code (_read fd (+ buffer_ start) (- count_ start))))) (set start (+ start rcount)))) buffer)) ;; Read and parse a message from the wire. (df read-packet (fd) (let ((header (read-string fd '6)) (length (! Integer fromString: header base: '16)) (payload (read-string fd length))) (! CokeScanner read: payload))) ;; Print a messag to the wire. (df send-to-emacs (event fd) (let ((stream (! WriteStream on: (! String new: '100)))) (! stream position: '6) (prin1 event stream) (let ((len (! stream position))) (! stream position: '0) (! (fx+ len '-6) printOn: stream base: '16 width: '6) (write-bytes (str>_ (! stream collection)) (int>_ len) fd)))) (df add-quotes (form) (mcase form ((fun . args) `(,fun ,@(packing (s) (dovec (e args) (pack `(quote ,e) s))))))) (define sldb 0) ;defer (df eval-for-emacs (form id fd abort) (let ((old-hook *debugger-hook*)) (mcase (catch% (closure (form fd | k) (set *debugger-hook* (curry sldb fd k)) `(ok ,(int>_ (! (add-quotes form) eval))))) (('ok value) (set *debugger-hook* old-hook) (send-to-emacs `(:return (:ok ,value) ,id) fd) 'ok) (arg (set *debugger-hook* old-hook) (send-to-emacs `(:return (:abort) ,id) fd) (throw% arg abort))))) (df process-events (fd) (on_exit exit-handler nil) (let ((done nil)) (while (not done) (mcase (read-packet fd) ((':emacs-rex form package thread id) (mcase (catch% (closure (form id fd | abort) (eval-for-emacs form id fd abort))) ('ok) ;;('abort nil) ('top-level) (other ;;(return other) ; compiler breaks with return (set done 1)))))))) (df next-frame (fp) (let ((next (get-caller-fp fp))) (if (and (!= next fp) (<= next %top-level-fp)) next nil))) (df nth-frame (n top) (let ((fp top) (i 0)) (while fp (if (== i n) (return fp)) (set fp (next-frame fp)) (set i (+ i 1))) nil)) (define Dl_info/size 16) (define Dl_info/dli_fname 0) (define Dl_info/dli_sname 8) (df get-dl-sym-name (addr) (let ((info (! OS _balloc: (_>fix Dl_info/size)))) (when (== (dladdr addr info) 0) (return nil)) (let ((sname (long@ (+ info Dl_info/dli_sname)) ) (fname (long@ (+ info Dl_info/dli_fname)))) (cond ((and sname fname) (cat (_>str sname) '" in " (_>str fname))) (sname (_>str fname)) (fname (cat '" " (_>str fname))) (true nil))))) ;;(get-dl-sym-name printf) (df guess-function-name (ip) (let ((fname (get-function-name ip))) (if fname (_>str fname) (get-dl-sym-name ip)))) (df backtrace>el (top_ from_ to_) (let ((fp (nth-frame from_ top_)) (i from_)) (packing (bt) (while (and fp (< i to_)) (let ((ip (get-frame-ip fp))) (pack (vec (_>int i) (cat (or (guess-function-name ip) '"(no-name)") '" " ;;(>str (_>int ip)) )) bt)) (set i (+ i 1)) (set fp (next-frame fp)))))) (df debugger-info (fp msg) (vec `(,(prin1-to-string msg) " [type ...]" ()) '(("quit" "Return to top level")) (backtrace>el fp 0 20) '())) (define *top-frame* 0) (define *sldb-quit* 0) (df debugger-loop (fd args abort) (let ((fp (get-current-fp))) (set *top-frame* fp) (send-to-emacs `(:debug 0 1 ,@(debugger-info fp args)) fd) (while 1 (mcase (read-packet fd) ((':emacs-rex form package thread id) (mcase (catch% (closure (form id fd | k) (set *sldb-quit* k) (eval-for-emacs form id fd k) 'ok)) ('ok nil) (other (send-to-emacs `(:return (:abort) ,id) fd) (throw% other abort)))))))) (df sldb (fd abort args) (let ((old-top-frame *top-frame*) (old-sldb-quit *sldb-quit*)) (mcase (catch% (curry debugger-loop fd args)) (value (set *top-frame* old-top-frame) (set *sldb-quit* old-sldb-quit) (send-to-emacs `(:debug-return 0 1 nil) fd) (throw% value abort))))) (df swank:backtrace (start end) (backtrace>el *top-frame* (int>_ start) (int>_ end))) (df sldb-quit () (assert *sldb-quit*) (throw% 'top-level *sldb-quit*)) (df swank:invoke-nth-restart-for-emacs (...) (sldb-quit)) (df swank:throw-to-toplevel (...) (sldb-quit)) (df setup-server (port announce) (let ((sock (create-socket port))) (announce sock) (let ((client (accept sock))) (process-events client) (close client)) (printf "Closing socket: %d %d\n" sock (local-port sock)) (close sock))) (df announce-port (sock) (printf "Listening on port: %d\n" (local-port sock))) (df create-server (port) (setup-server port announce-port)) (df write-port-file (filename sock) (let ((f (! File create: filename))) (! f write: (print-to-string (_>int (local-port sock)))) (! f close))) (df start-swank (port-file) (setup-server 0 (curry write-port-file (_>str port-file)))) (define getpid (dlsym "getpid")) (df swank:connection-info () `(,@'() :pid ,(_>int (getpid)) :style nil :lisp-implementation (,@'() :type "Coke" :name "jolt" :version ,(! CodeGenerator versionString)) :machine (:instance "" :type ,(! OS architecture) :version "") :features () :package (:name "jolt" :prompt "jolt"))) (df swank:listener-eval (string) (let ((result (! (! CokeScanner read: string) eval))) `(:values ,(prin1-to-string (if (or (fix? result) (and (valid-pointer? result) (int? result))) (int>_ result) result)) ,(prin1-to-string result)))) (df swank:interactive-eval (string) (let ((result (! (! CokeScanner read: string) eval))) (cat '"=> " (prin1-to-string (if (or (fix? result) (and (valid-pointer? result) (int? result))) (int>_ result) result)) '", " (prin1-to-string result)))) (df swank:operator-arglist () nil) (df swank:buffer-first-change () nil) (df swank:create-repl (_) '("jolt" "jolt")) (df min (x y) (if (<= x y) x y)) (df common-prefix2 (e1 e2) (let ((i '0) (max (min (len e1) (len e2)))) (while (and (< i max) (== (ref e1 i) (ref e2 i))) (set i (fx1+ i))) (! e1 copyFrom: '0 to: (fx1- i)))) (df common-prefix (seq) (mcase seq (() nil) (_ (let ((prefix (ref seq '0))) (dovec (e seq) (set prefix (common-prefix2 prefix e))) prefix)))) (df swank:simple-completions (prefix _package) (let ((matches (packing (s) (dovec (e (! TheGlobalEnvironment keys)) (let ((name (>str e))) (when (! name beginsWith: prefix) (pack name s))))))) (vec matches (or (common-prefix matches) prefix)))) ;; swank-jolt.k ends here slime-2.20/contrib/swank-kawa.scm000066400000000000000000002563671315100173500167750ustar00rootroot00000000000000;;;; swank-kawa.scm --- Swank server for Kawa ;;; ;;; Copyright (C) 2007 Helmut Eller ;;; ;;; This file is licensed under the terms of the GNU General Public ;;; License as distributed with Emacs (press C-h C-c for details). ;;;; Installation ;; ;; 1. You need Kawa (version 2.x) and a JVM with debugger support. ;; ;; 2. Compile this file and create swank-kawa.jar with: ;; java -cp kawa.jar:$JAVA_HOME/lib/tools.jar \ ;; -Xss2M kawa.repl --r7rs -d classes -C swank-kawa.scm && ;; jar cf swank-kawa.jar -C classes . ;; ;; 3. Add something like this to your .emacs: #| ;; Kawa, Swank, and the debugger classes (tools.jar) must be in the ;; classpath. You also need to start the debug agent. (setq slime-lisp-implementations '((kawa ("java" ;; needed jar files "-cp" "kawa-2.0.1.jar:swank-kawa.jar:/opt/jdk1.8.0/lib/tools.jar" ;; channel for debugger "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n" ;; depending on JVM, compiler may need more stack "-Xss2M" ;; kawa without GUI "kawa.repl" "-s") :init kawa-slime-init))) (defun kawa-slime-init (file _) (setq slime-protocol-version 'ignore) (format "%S\n" `(begin (import (swank-kawa)) (start-swank ,file) ;; Optionally add source paths of your code so ;; that M-. works better: ;;(set! swank-java-source-path ;; (append ;; '(,(expand-file-name "~/lisp/slime/contrib/") ;; "/scratch/kawa") ;; swank-java-source-path)) ))) ;; Optionally define a command to start it. (defun kawa () (interactive) (slime 'kawa)) |# ;; 4. Start everything with M-- M-x slime kawa ;; ;; ;;; Code: (define-library (swank macros) (export df fun seq set fin esc ! !! !s @ @s when unless while dotimes dolist for packing with pushf == assert mif mcase mlet mlet* typecase ignore-errors ferror ) (import (scheme base) (only (kawa base) syntax quasisyntax syntax-case define-syntax-case identifier? invoke invoke-static field static-field instance? try-finally try-catch primitive-throw format reverse! as )) (begin " (" (define (ferror fstring #!rest args) (let ((err ( (as (apply format fstring args))))) (primitive-throw err))) (define (rewrite-lambda-list args) (syntax-case args () (() #`()) ((rest x ...) (eq? #'rest #!rest) args) ((optional x ...) (eq? #'optional #!optional) args) ((var args ...) (identifier? #'var) #`(var #,@(rewrite-lambda-list #'(args ...)))) (((var type) args ...) (identifier? #'var) #`((var :: type) #,@(rewrite-lambda-list #'(args ...)))))) (define-syntax df (lambda (stx) (syntax-case stx (=>) ((df name (args ... => return-type) body ...) #`(define (name #,@(rewrite-lambda-list #'(args ...))) :: return-type (seq body ...))) ((df name (args ...) body ...) #`(define (name #,@(rewrite-lambda-list #'(args ...))) (seq body ...)))))) (define-syntax fun (lambda (stx) (syntax-case stx (=>) ((fun (args ... => return-type) body ...) #`(lambda #,(rewrite-lambda-list #'(args ...)) :: return-type (seq body ...))) ((fun (args ...) body ...) #`(lambda #,(rewrite-lambda-list #'(args ...)) (seq body ...)))))) (define-syntax fin (syntax-rules () ((fin body handler ...) (try-finally body (seq handler ...))))) (define-syntax seq (syntax-rules () ((seq) (begin #!void)) ((seq body ...) (begin body ...)))) (define-syntax esc (syntax-rules () ((esc abort body ...) (let* ((key ()) (abort (lambda (val) (throw key val)))) (catch key (lambda () body ...) (lambda (key val) val)))))) (define-syntax ! (syntax-rules () ((! name obj args ...) (invoke obj 'name args ...)))) (define-syntax !! (syntax-rules () ((!! name1 name2 obj args ...) (! name1 (! name2 obj args ...))))) (define-syntax !s (syntax-rules () ((! class name args ...) (invoke-static class 'name args ...)))) (define-syntax @ (syntax-rules () ((@ name obj) (field obj 'name)))) (define-syntax @s (syntax-rules (quote) ((@s class name) (static-field class (quote name))))) (define-syntax while (syntax-rules () ((while exp body ...) (do () ((not exp)) body ...)))) (define-syntax dotimes (syntax-rules () ((dotimes (i n result) body ...) (let ((max :: n)) (do ((i :: 0 (as (+ i 1)))) ((= i max) result) body ...))) ((dotimes (i n) body ...) (dotimes (i n #f) body ...)))) (define-syntax dolist (syntax-rules () ((dolist (e list) body ... ) (for ((e list)) body ...)))) (define-syntax for (syntax-rules () ((for ((var iterable)) body ...) (let ((iter (! iterator iterable))) (while (! has-next iter) ((lambda (var) body ...) (! next iter))))))) (define-syntax packing (syntax-rules () ((packing (var) body ...) (let ((var :: '())) (let ((var (lambda (v) (set! var (cons v var))))) body ...) (reverse! var))))) ;;(define-syntax loop ;; (syntax-rules (for = then collect until) ;; ((loop for var = init then step until test collect exp) ;; (packing (pack) ;; (do ((var init step)) ;; (test) ;; (pack exp)))) ;; ((loop while test collect exp) ;; (packing (pack) (while test (pack exp)))))) (define-syntax with (syntax-rules () ((with (vars ... (f args ...)) body ...) (f args ... (lambda (vars ...) body ...))))) (define-syntax pushf (syntax-rules () ((pushf value var) (set! var (cons value var))))) (define-syntax == (syntax-rules () ((== x y) (eq? x y)))) (define-syntax set (syntax-rules () ((set x y) (let ((tmp y)) (set! x tmp) tmp)) ((set x y more ...) (begin (set! x y) (set more ...))))) (define-syntax assert (syntax-rules () ((assert test) (seq (when (not test) (error "Assertion failed" 'test)) 'ok)) ((assert test fstring args ...) (seq (when (not test) (error "Assertion failed" 'test (format #f fstring args ...))) 'ok)))) (define-syntax mif (syntax-rules (quote unquote _) ((mif ('x value) then else) (if (equal? 'x value) then else)) ((mif (,x value) then else) (if (eq? x value) then else)) ((mif (() value) then else) (if (eq? value '()) then else)) #| This variant produces no lambdas but breaks the compiler ((mif ((p . ps) value) then else) (let ((tmp value) (fail? :: 0) (result #!null)) (if (instance? tmp ) (let ((tmp :: tmp)) (mif (p (! get-car tmp)) (mif (ps (! get-cdr tmp)) (set! result then) (set! fail? -1)) (set! fail? -1))) (set! fail? -1)) (if (= fail? 0) result else))) |# ((mif ((p . ps) value) then else) (let ((fail (lambda () else)) (tmp value)) (if (instance? tmp ) (let ((tmp :: tmp)) (mif (p (! get-car tmp)) (mif (ps (! get-cdr tmp)) then (fail)) (fail))) (fail)))) ((mif (_ value) then else) then) ((mif (var value) then else) (let ((var value)) then)) ((mif (pattern value) then) (mif (pattern value) then (values))))) (define-syntax mcase (syntax-rules () ((mcase exp (pattern body ...) more ...) (let ((tmp exp)) (mif (pattern tmp) (begin body ...) (mcase tmp more ...)))) ((mcase exp) (ferror "mcase failed ~s\n~a" 'exp exp)))) (define-syntax mlet (syntax-rules () ((mlet (pattern value) body ...) (let ((tmp value)) (mif (pattern tmp) (begin body ...) (error "mlet failed" tmp)))))) (define-syntax mlet* (syntax-rules () ((mlet* () body ...) (begin body ...)) ((mlet* ((pattern value) ms ...) body ...) (mlet (pattern value) (mlet* (ms ...) body ...))))) (define-syntax typecase% (syntax-rules (eql or satisfies) ((typecase% var (#t body ...) more ...) (seq body ...)) ((typecase% var ((eql value) body ...) more ...) (cond ((eqv? var 'value) body ...) (else (typecase% var more ...)))) ((typecase% var ((satisfies predicate) body ...) more ...) (cond ((predicate var) body ...) (else (typecase% var more ...)))) ((typecase% var ((or type) body ...) more ...) (typecase% var (type body ...) more ...)) ((typecase% var ((or type ...) body ...) more ...) (let ((f (lambda (var) body ...))) (typecase% var (type (f var)) ... (#t (typecase% var more ...))))) ((typecase% var (type body ...) more ...) (cond ((instance? var type) (let ((var :: type (as type var))) body ...)) (else (typecase% var more ...)))) ((typecase% var) (error "typecase% failed" var (! getClass (as var)))))) (define-syntax typecase (lambda (stx) (syntax-case stx () ((_ exp more ...) (identifier? (syntax exp)) #`(typecase% exp more ...)) ((_ exp more ...) #`(let ((tmp exp)) (typecase% tmp more ...)))))) (define-syntax ignore-errors (syntax-rules () ((ignore-errors body ...) (try-catch (seq body ...) (v #f) (v #f))))) )) (define-library (swank-kawa) (export start-swank create-swank-server swank-java-source-path break) (import (scheme base) (scheme file) (scheme repl) (scheme read) (scheme write) (scheme eval) (scheme process-context) (swank macros) (only (kawa base) define-alias define-variable define-simple-class this invoke-special instance? as primitive-throw try-finally try-catch synchronized call-with-input-string call-with-output-string force-output format make-process command-parse runnable scheme-implementation-version reverse! ) (rnrs hashtables) (only (gnu kawa slib syntaxutils) expand) (only (kawa regex) regex-match)) (begin " (" ;;(define-syntax dc ;; (syntax-rules () ;; ((dc name () %% (props ...) prop more ...) ;; (dc name () %% (props ... (prop )) more ...)) ;; ;;((dc name () %% (props ...) (prop type) more ...) ;; ;; (dc name () %% (props ... (prop type)) more ...)) ;; ((dc name () %% ((prop type) ...)) ;; (define-simple-class name () ;; ((*init* (prop :: type) ...) ;; (set (field (this) 'prop) prop) ...) ;; (prop :type type) ...)) ;; ((dc name () props ...) ;; (dc name () %% () props ...)))) ;;;; Aliases (define-alias java.net.ServerSocket) (define-alias java.net.Socket) (define-alias java.io.InputStreamReader) (define-alias java.io.OutputStreamWriter) (define-alias gnu.kawa.io.InPort) (define-alias gnu.kawa.io.OutPort) (define-alias java.io.File) (define-alias java.lang.String) (define-alias java.lang.StringBuilder) (define-alias java.lang.Throwable) (define-alias gnu.text.SourceError) (define-alias gnu.expr.ModuleInfo) (define-alias java.lang.Iterable) (define-alias java.lang.Thread) (define-alias java.util.concurrent.LinkedBlockingQueue) (define-alias java.util.concurrent.Exchanger) (define-alias java.util.concurrent.TimeUnit) (define-alias com.sun.jdi.VirtualMachine) (define-alias com.sun.jdi.Mirror) (define-alias com.sun.jdi.Value) (define-alias com.sun.jdi.ThreadReference) (define-alias com.sun.jdi.ObjectReference) (define-alias com.sun.jdi.ArrayReference) (define-alias com.sun.jdi.StringReference) (define-alias com.sun.jdi.Method) (define-alias com.sun.jdi.ClassType) (define-alias com.sun.jdi.ReferenceType) (define-alias com.sun.jdi.StackFrame) (define-alias com.sun.jdi.Field) (define-alias com.sun.jdi.LocalVariable) (define-alias com.sun.jdi.Location) (define-alias com.sun.jdi.AbsentInformationException) (define-alias com.sun.jdi.event.Event) (define-alias com.sun.jdi.event.ExceptionEvent) (define-alias com.sun.jdi.event.StepEvent) (define-alias com.sun.jdi.event.BreakpointEvent) (define-alias gnu.mapping.Environment) (define-simple-class () (owner :: #:init (!s java.lang.Thread currentThread)) (peer :: ) (queue :: #:init ()) (lock #:init ())) ;;;; Entry Points (df create-swank-server (port-number) (setup-server port-number announce-port)) (df start-swank (port-file) (let ((announce (fun ((socket )) (with (f (call-with-output-file port-file)) (format f "~d\n" (! get-local-port socket)))))) (spawn (fun () (setup-server 0 announce))))) (df setup-server ((port-number ) announce) (! set-name (current-thread) "swank") (let ((s ( port-number))) (announce s) (let ((c (! accept s))) (! close s) (log "connection: ~s\n" c) (fin (dispatch-events c) (log "closing socket: ~a\n" s) (! close c))))) (df announce-port ((socket )) (log "Listening on port: ~d\n" (! get-local-port socket))) ;;;; Event dispatcher (define-variable *the-vm* #f) (define-variable *last-exception* #f) (define-variable *last-stacktrace* #f) (df %vm (=> ) *the-vm*) ;; FIXME: this needs factorization. But I guess the whole idea of ;; using bidirectional channels just sucks. Mailboxes owned by a ;; single thread to which everybody can send are much easier to use. (df dispatch-events ((s )) (mlet* ((charset "iso-8859-1") (ins ( (! getInputStream s) charset)) (outs ( (! getOutputStream s) charset)) ((in . _) (spawn/chan/catch (fun (c) (reader ins c)))) ((out . _) (spawn/chan/catch (fun (c) (writer outs c)))) ((dbg . _) (spawn/chan/catch vm-monitor)) (user-env (interaction-environment)) (x (seq (! set-flag user-env #t #|:THREAD_SAFE|# 8) (! set-flag user-env #f #|:DIRECT_INHERITED_ON_SET|# 16) #f)) ((listener . _) (spawn/chan (fun (c) (listener c user-env)))) (inspector #f) (threads '()) (repl-thread #f) (extra '()) (vm (let ((vm #f)) (fun () (or vm (rpc dbg `(get-vm))))))) (while #t (mlet ((c . event) (recv* (append (list in out dbg listener) (if inspector (list inspector) '()) (map car threads) extra))) ;;(log "event: ~s\n" event) (mcase (list c event) ((_ (':emacs-rex ('|swank:debugger-info-for-emacs| from to) pkg thread id)) (send dbg `(debug-info ,thread ,from ,to ,id))) ((_ (':emacs-rex ('|swank:throw-to-toplevel|) pkg thread id)) (send dbg `(throw-to-toplevel ,thread ,id))) ((_ (':emacs-rex ('|swank:sldb-continue|) pkg thread id)) (send dbg `(thread-continue ,thread ,id))) ((_ (':emacs-rex ('|swank:frame-source-location| frame) pkg thread id)) (send dbg `(frame-src-loc ,thread ,frame ,id))) ((_ (':emacs-rex ('|swank:frame-locals-and-catch-tags| frame) pkg thread id)) (send dbg `(frame-details ,thread ,frame ,id))) ((_ (':emacs-rex ('|swank:sldb-disassemble| frame) pkg thread id)) (send dbg `(disassemble-frame ,thread ,frame ,id))) ((_ (':emacs-rex ('|swank:backtrace| from to) pkg thread id)) (send dbg `(thread-frames ,thread ,from ,to ,id))) ((_ (':emacs-rex ('|swank:list-threads|) pkg thread id)) (send dbg `(list-threads ,id))) ((_ (':emacs-rex ('|swank:debug-nth-thread| n) _ _ _)) (send dbg `(debug-nth-thread ,n))) ((_ (':emacs-rex ('|swank:quit-thread-browser|) _ _ id)) (send dbg `(quit-thread-browser ,id))) ((_ (':emacs-rex ('|swank:init-inspector| str . _) pkg _ id)) (set inspector (make-inspector user-env (vm))) (send inspector `(init ,str ,id))) ((_ (':emacs-rex ('|swank:inspect-frame-var| frame var) pkg thread id)) (mlet ((im . ex) (chan)) (set inspector (make-inspector user-env (vm))) (send dbg `(get-local ,ex ,thread ,frame ,var)) (send inspector `(init-mirror ,im ,id)))) ((_ (':emacs-rex ('|swank:inspect-current-condition|) pkg thread id)) (mlet ((im . ex) (chan)) (set inspector (make-inspector user-env (vm))) (send dbg `(get-exception ,ex ,thread)) (send inspector `(init-mirror ,im ,id)))) ((_ (':emacs-rex ('|swank:inspect-nth-part| n) pkg _ id)) (send inspector `(inspect-part ,n ,id))) ((_ (':emacs-rex ('|swank:inspector-pop|) pkg _ id)) (send inspector `(pop ,id))) ((_ (':emacs-rex ('|swank:quit-inspector|) pkg _ id)) (send inspector `(quit ,id))) ((_ (':emacs-interrupt id)) (let* ((vm (vm)) (t (find-thread id (map cdr threads) repl-thread vm))) (send dbg `(interrupt-thread ,t)))) ((_ (':emacs-rex form _ _ id)) (send listener `(,form ,id))) ((_ ('get-vm c)) (send dbg `(get-vm ,c))) ((_ ('get-channel c)) (mlet ((im . ex) (chan)) (pushf im extra) (send c ex))) ((_ ('forward x)) (send out x)) ((_ ('set-listener x)) (set repl-thread x)) ((_ ('publish-vm vm)) (set *the-vm* vm)) ))))) (df find-thread (id threads listener (vm )) (cond ((== id ':repl-thread) listener) ((== id 't) listener ;;(if (null? threads) ;; listener ;; (vm-mirror vm (car threads))) ) (#t (let ((f (find-if threads (fun (t :: ) (= id (! uniqueID (as (vm-mirror vm t))))) #f))) (cond (f (vm-mirror vm f)) (#t listener)))))) ;;;; Reader thread (df reader ((in ) (c )) (! set-name (current-thread) "swank-net-reader") (let ((rt (!s gnu.kawa.lispexpr.ReadTable createInitial))) ; ':' not special (while #t (send c (decode-message in rt))))) (df decode-message ((in ) (rt ) => ) (let* ((header (read-chunk in 6)) (len (!s java.lang.Integer parseInt header 16))) (call-with-input-string (read-chunk in len) (fun ((port )) (%read port rt))))) (df read-chunk ((in ) (len ) => ) (let ((chars ( #:length len))) (let loop ((offset :: 0)) (cond ((= offset len) ( chars)) (#t (let ((count (! read in chars offset (- len offset)))) (assert (not (= count -1)) "partial packet") (loop (+ offset count)))))))) ;;; FIXME: not thread safe (df %read ((port ) (table )) (let ((old (!s gnu.kawa.lispexpr.ReadTable getCurrent))) (try-finally (seq (!s gnu.kawa.lispexpr.ReadTable setCurrent table) (read port)) (!s gnu.kawa.lispexpr.ReadTable setCurrent old)))) ;;;; Writer thread (df writer ((out ) (c )) (! set-name (current-thread) "swank-net-writer") (while #t (encode-message out (recv c)))) (df encode-message ((out ) (message )) (let ((builder ( (as 512)))) (print-for-emacs message builder) (! write out (! toString (format "~6,'0x" (! length builder)))) (! write out builder) (! flush out))) (df print-for-emacs (obj (out )) (let ((pr (fun (o) (! append out (! toString (format "~s" o))))) (++ (fun ((s )) (! append out (! toString s))))) (cond ((null? obj) (++ "nil")) ((string? obj) (pr obj)) ((number? obj) (pr obj)) ;;((keyword? obj) (++ ":") (! append out (to-str obj))) ((symbol? obj) (pr obj)) ((pair? obj) (++ "(") (let loop ((obj obj)) (print-for-emacs (car obj) out) (let ((cdr (cdr obj))) (cond ((null? cdr) (++ ")")) ((pair? cdr) (++ " ") (loop cdr)) (#t (++ " . ") (print-for-emacs cdr out) (++ ")")))))) (#t (error "Unprintable object" obj))))) ;;;; SLIME-EVAL (df eval-for-emacs ((form ) env (id ) (c )) ;;(! set-uncaught-exception-handler (current-thread) ;; ( (fun (t e) (reply-abort c id)))) (reply c (%eval form env) id)) (define-variable *slime-funs*) (set *slime-funs* (tab)) (df %eval (form env) (apply (lookup-slimefun (car form) *slime-funs*) env (cdr form))) (df lookup-slimefun ((name ) tab) ;; name looks like '|swank:connection-info| (or (get tab name #f) (ferror "~a not implemented" name))) (df %defslimefun ((name ) (fun )) (let ((string (symbol->string name))) (cond ((regex-match #/:/ string) (put *slime-funs* name fun)) (#t (let ((qname (string->symbol (string-append "swank:" string)))) (put *slime-funs* qname fun)))))) (define-syntax defslimefun (syntax-rules () ((defslimefun name (args ...) body ...) (seq (df name (args ...) body ...) (%defslimefun 'name name))))) (defslimefun connection-info ((env )) (let ((prop (fun (name) (!s java.lang.System getProperty name)))) `(:pid 0 :style :spawn :lisp-implementation (:type "Kawa" :name "kawa" :version ,(scheme-implementation-version)) :machine (:instance ,(prop "java.vm.name") :type ,(prop "os.name") :version ,(prop "java.runtime.version")) :features () :package (:name "??" :prompt ,(! getName env)) :encoding (:coding-systems ("iso-8859-1")) ))) ;;;; Listener (df listener ((c ) (env )) (! set-name (current-thread) "swank-listener") (log "listener: ~s ~s ~s ~s\n" (current-thread) (! hashCode (current-thread)) c env) (let ((out (make-swank-outport (rpc c `(get-channel))))) (set (current-output-port) out) (let ((vm (as (rpc c `(get-vm))))) (send c `(set-listener ,(vm-mirror vm (current-thread)))) (request-uncaught-exception-events vm) ;;stack snaphost are too expensive ;;(request-caught-exception-events vm) ) (rpc c `(get-vm)) (listener-loop c env out))) (define-simple-class () ((*init*) (invoke-special (this) '*init* )) ((abort) :: void (primitive-throw (this)))) (df listener-loop ((c ) (env ) port) (while (not (nul? c)) ;;(log "listener-loop: ~s ~s\n" (current-thread) c) (mlet ((form id) (recv c)) (let ((restart (fun () (close-port port) (reply-abort c id) (send (car (spawn/chan (fun (cc) (listener (recv cc) env)))) c) (set c #!null)))) (! set-uncaught-exception-handler (current-thread) ( (fun (t e) (restart)))) (try-catch (let* ((val (%eval form env))) (force-output) (reply c val id)) (ex (invoke-debugger ex) (restart)) (ex (invoke-debugger ex) (restart)) (ex (let ((flag (!s java.lang.Thread interrupted))) (log "listener-abort: ~s ~a\n" ex flag)) (restart)) ))))) (df invoke-debugger (condition) ;;(log "should now invoke debugger: ~a" condition) (try-catch (break condition) (ex (seq)))) (defslimefun |swank-repl:create-repl| (env #!rest _) (list "user" "user")) (defslimefun interactive-eval (env str) (values-for-echo-area (eval (read-from-string str) env))) (defslimefun interactive-eval-region (env (s )) (with (port (call-with-input-string s)) (values-for-echo-area (let next ((result (values))) (let ((form (read port))) (cond ((== form #!eof) result) (#t (next (eval form env))))))))) (defslimefun |swank-repl:listener-eval| (env string) (let* ((form (read-from-string string)) (list (values-to-list (eval form env)))) `(:values ,@(map pprint-to-string list)))) (defslimefun pprint-eval (env string) (let* ((form (read-from-string string)) (l (values-to-list (eval form env)))) (apply cat (map pprint-to-string l)))) (defslimefun eval-and-grab-output (env string) (let ((form (read (open-input-string string)))) (let-values ((values (eval form env))) (list "" (format #f "~{~S~^~%~}" values))))) (df call-with-abort (f) (try-catch (f) (ex (exception-message ex)))) (df exception-message ((ex )) (typecase ex ( (! to-string ex)) ( (format "~a: ~a" (class-name-sans-package ex) (! getMessage ex))))) (df values-for-echo-area (values) (let ((values (values-to-list values))) (cond ((null? values) "; No value") (#t (format "~{~a~^, ~}" (map pprint-to-string values)))))) ;;;; Compilation (defslimefun compile-file-for-emacs (env (filename ) load? #!optional options) (let ((jar (cat (path-sans-extension (filepath filename)) ".jar"))) (wrap-compilation (fun ((m )) (!s kawa.lang.CompileFile read filename m)) jar (if (lisp-bool load?) env #f) #f))) (df wrap-compilation (f jar env delete?) (let ((start-time (current-time)) (messages ())) (try-catch (let ((c (as (f messages)))) (set (@ explicit c) #t) (! compile-to-archive c (! get-module c) jar)) (ex (log "error during compilation: ~a\n~a" ex (! getStackTrace ex)) (! error messages (as #\f) (to-str (exception-message ex)) #!null) #f)) (log "compilation done.\n") (let ((success? (zero? (! get-error-count messages)))) (when (and env success?) (log "loading ...\n") (eval `(load ,jar) env) (log "loading ... done.\n")) (when delete? (ignore-errors (delete-file jar) #f)) (let ((end-time (current-time))) (list ':compilation-result (compiler-notes-for-emacs messages) (if success? 't 'nil) (/ (- end-time start-time) 1000.0)))))) (defslimefun compile-string-for-emacs (env string buffer offset dir) (wrap-compilation (fun ((m )) (let ((c (as (call-with-input-string string (fun ((p )) (! set-path p (format "~s" `(buffer ,buffer offset ,offset str ,string))) (!s kawa.lang.CompileFile read p m)))))) (let ((o (@ currentOptions c))) (! set o "warn-invoke-unknown-method" #t) (! set o "warn-undefined-variable" #t)) (let ((m (! getModule c))) (! set-name m (format ":~a/~a" buffer (current-time)))) c)) "/tmp/kawa-tmp.zip" env #t)) (df compiler-notes-for-emacs ((messages )) (packing (pack) (do ((e (! get-errors messages) (@ next e))) ((nul? e)) (pack (source-error>elisp e))))) (df source-error>elisp ((e ) => ) (list ':message (to-string (@ message e)) ':severity (case (integer->char (@ severity e)) ((#\e #\f) ':error) ((#\w) ':warning) (else ':note)) ':location (error-loc>elisp e))) (df error-loc>elisp ((e )) (cond ((nul? (@ filename e)) `(:error "No source location")) ((! starts-with (@ filename e) "(buffer ") (mlet (('buffer b 'offset ('quote ((:position o) _)) 'str s) (read-from-string (@ filename e))) (let ((off (line>offset (1- (@ line e)) s)) (col (1- (@ column e)))) `(:location (:buffer ,b) (:position ,(+ o off col)) nil)))) (#t `(:location (:file ,(to-string (@ filename e))) (:line ,(@ line e) ,(1- (@ column e))) nil)))) (df line>offset ((line ) (s ) => ) (let ((offset :: 0)) (dotimes (i line) (set offset (! index-of s (as #\newline) offset)) (assert (>= offset 0)) (set offset (as (+ offset 1)))) (log "line=~a offset=~a\n" line offset) offset)) (defslimefun load-file (env filename) (format "Loaded: ~a => ~s" filename (eval `(load ,filename) env))) ;;;; Completion (defslimefun simple-completions (env (pattern ) _) (let* ((env (as env)) (matches (packing (pack) (let ((iter (! enumerate-all-locations env))) (while (! has-next iter) (let ((l (! next-location iter))) (typecase l ( (let ((name (!! get-name get-key-symbol l))) (when (! starts-with name pattern) (pack name))))))))))) `(,matches ,(cond ((null? matches) pattern) (#t (fold+ common-prefix matches)))))) (df common-prefix ((s1 ) (s2 ) => ) (let ((limit (min (! length s1) (! length s2)))) (let loop ((i 0)) (cond ((or (= i limit) (not (== (! char-at s1 i) (! char-at s2 i)))) (! substring s1 0 i)) (#t (loop (1+ i))))))) (df fold+ (f list) (let loop ((s (car list)) (l (cdr list))) (cond ((null? l) s) (#t (loop (f s (car l)) (cdr l)))))) ;;; Quit (defslimefun quit-lisp (env) (exit)) ;;(defslimefun set-default-directory (env newdir)) ;;;; Dummy defs (defslimefun buffer-first-change (#!rest y) '()) (defslimefun swank-require (#!rest y) '()) (defslimefun frame-package-name (#!rest y) '()) ;;;; arglist (defslimefun operator-arglist (env name #!rest _) (mcase (try-catch `(ok ,(eval (read-from-string name) env)) (ex 'nil)) (('ok obj) (mcase (arglist obj) ('#f 'nil) ((args rtype) (format "(~a~{~^ ~a~})~a" name (map (fun (e) (if (equal (cadr e) "java.lang.Object") (car e) e)) args) (if (equal rtype "java.lang.Object") "" (format " => ~a" rtype)))))) (_ 'nil))) (df arglist (obj) (typecase obj ( (let* ((mref (module-method>meth-ref obj))) (list (mapi (! arguments mref) (fun ((v )) (list (! name v) (! typeName v)))) (! returnTypeName mref)))) ( #f))) ;;;; M-. (defslimefun find-definitions-for-emacs (env name) (mcase (try-catch `(ok ,(eval (read-from-string name) env)) (ex `(error ,(exception-message ex)))) (('ok obj) (mapi (all-definitions obj) (fun (d) `(,(format "~a" d) ,(src-loc>elisp (src-loc d)))))) (('error msg) `((,name (:error ,msg)))))) (define-simple-class () (file #:init #f) (line #:init #f) ((*init* file name) (set (@ file (this)) file) (set (@ line (this)) line)) ((lineNumber) :: (or line (absent))) ((lineNumber (s :: )) :: int (! lineNumber (this))) ((method) :: (absent)) ((sourcePath) :: (or file (absent))) ((sourcePath (s :: )) :: (! sourcePath (this))) ((sourceName) :: (absent)) ((sourceName (s :: )) :: (! sourceName (this))) ((declaringType) :: (absent)) ((codeIndex) :: -1) ((virtualMachine) :: *the-vm*) ((compareTo o) :: (typecase o ( (- (! codeIndex (this)) (! codeIndex o)))))) (df absent () (primitive-throw ())) (df all-definitions (o) (typecase o ( (list o)) ( (list o)) ( (append (mappend all-definitions (gf-methods o)) (let ((s (! get-setter o))) (if s (all-definitions s) '())))) ( (list o)) ( (all-definitions (! get-class o))) ( (list o)) ( (all-definitions (! getReflectClass o))) ( '()) )) (df gf-methods ((f )) (let* ((o :: (vm-mirror *the-vm* f)) (f (! field-by-name (! reference-type o) "methods")) (ms (vm-demirror *the-vm* (! get-value o f)))) (filter (array-to-list ms) (fun (x) (not (nul? x)))))) (df src-loc (o => ) (typecase o ( (src-loc (@ method o))) ( (module-method>src-loc o)) ( ( #f #f)) ( (class>src-loc o)) ( ( #f #f)) ( (bytemethod>src-loc o)))) (df module-method>src-loc ((f )) (! location (module-method>meth-ref f))) (df module-method>meth-ref ((f ) => ) (let* ((module (! reference-type (as (vm-mirror *the-vm* (@ module f))))) (1st-method-by-name (fun (name) (let ((i (! methods-by-name module name))) (cond ((! is-empty i) #f) (#t (1st i))))))) (as (or (1st-method-by-name (! get-name f)) (let ((mangled (mangled-name f))) (or (1st-method-by-name mangled) (1st-method-by-name (cat mangled "$V")) (1st-method-by-name (cat mangled "$X")))))))) (df mangled-name ((f )) (let* ((name0 (! get-name f)) (name (cond ((nul? name0) (format "lambda~d" (@ selector f))) (#t (!s gnu.expr.Compilation mangleName name0))))) name)) (df class>src-loc ((c ) => ) (let* ((type (class>ref-type c)) (locs (! all-line-locations type))) (cond ((not (! isEmpty locs)) (1st locs)) (#t ( (1st (! source-paths type "Java")) #f))))) (df class>ref-type ((class ) => ) (! reflectedType (as (vm-mirror *the-vm* class)))) (df class>class-type ((class ) => ) (as (class>ref-type class))) (df bytemethod>src-loc ((m ) => ) (let* ((cls (class>class-type (! get-reflect-class (! get-declaring-class m)))) (name (! get-name m)) (sig (! get-signature m)) (meth (! concrete-method-by-name cls name sig))) (! location meth))) (df src-loc>elisp ((l )) (df src-loc>list ((l )) (list (ignore-errors (! source-name l "Java")) (ignore-errors (! source-path l "Java")) (ignore-errors (! line-number l "Java")))) (mcase (src-loc>list l) ((name path line) (cond ((not path) `(:error ,(call-with-abort (fun () (! source-path l))))) ((! starts-with (as path) "(buffer ") (mlet (('buffer b 'offset o 'str s) (read-from-string path)) `(:location (:buffer ,b) (:position ,(+ o (line>offset line s))) nil))) (#t `(:location ,(or (find-file-in-path name (source-path)) (find-file-in-path path (source-path)) (ferror "Can't find source-path: ~s ~s ~a" path name (source-path))) (:line ,(or line -1)) ())))))) (df src-loc>str ((l )) (cond ((nul? l) "") (#t (format "~a ~a ~a" (or (ignore-errors (! source-path l)) (ignore-errors (! source-name l)) (ignore-errors (!! name declaring-type l))) (ignore-errors (!! name method l)) (ignore-errors (! lineNumber l)))))) ;;;;;; class-path hacking ;; (find-file-in-path "kawa/lib/kawa/hashtable.scm" (source-path)) (df find-file-in-path ((filename ) (path )) (let ((f ( filename))) (cond ((! isAbsolute f) `(:file ,filename)) (#t (let ((result #f)) (find-if path (fun (dir) (let ((x (find-file-in-dir f dir))) (set result x))) #f) result))))) (df find-file-in-dir ((file ) (dir )) (let ((filename :: (! getPath file))) (or (let ((child ( ( dir) filename))) (and (! exists child) `(:file ,(! getPath child)))) (try-catch (and (not (nul? (! getEntry ( dir) filename))) `(:zip ,dir ,filename)) (ex #f))))) (define swank-java-source-path (let* ((jre-home :: (!s getProperty "java.home")) (parent :: (! get-parent ( jre-home)))) (list (! get-path ( parent "src.zip"))))) (df source-path () (mlet ((base) (search-path-prop "user.dir")) (append (list base) (map (fun ((s )) (let ((f ( s)) (base :: (as base))) (cond ((! isAbsolute f) s) (#t (! getPath ( base s)))))) (class-path)) swank-java-source-path))) (df class-path () (append (search-path-prop "java.class.path") (search-path-prop "sun.boot.class.path"))) (df search-path-prop ((name )) (array-to-list (! split (!s java.lang.System getProperty name) (@s pathSeparator)))) ;;;; Disassemble (defslimefun disassemble-form (env form) (mcase (read-from-string form) (('quote name) (let ((f (eval name env))) (typecase f ( (disassemble-to-string (module-method>meth-ref f)))))))) (df disassemble-to-string ((mr ) => ) (with-sink #f (fun (out) (disassemble-meth-ref mr out)))) (df disassemble-meth-ref ((mr ) (out )) (let* ((t (! declaring-type mr))) (disas-header mr out) (disas-code (! constant-pool t) (! constant-pool-count t) (! bytecodes mr) out))) (df disas-header ((mr ) (out )) (let* ((++ (fun ((str )) (! write out str))) (? (fun (flag str) (if flag (++ str))))) (? (! is-static mr) "static ") (? (! is-final mr) "final ") (? (! is-private mr) "private ") (? (! is-protected mr) "protected ") (? (! is-public mr) "public ") (++ (! name mr)) (++ (! signature mr)) (++ "\n"))) (df disas-code ((cpool ) (cpoolcount ) (bytecode ) (out )) (let* ((ct ( "foo")) (met (! addMethod ct "bar" 0)) (ca ( met)) (constants (let* ((bs ()) (s ( bs))) (! write-short s cpoolcount) (! write s cpool) (! flush s) (! toByteArray bs)))) (vm-set-slot *the-vm* ct "constants" ( ( ( constants)))) (! setCode ca bytecode) (let ((w ( ct out 0))) (! print ca w) (! flush w)))) (df with-sink (sink (f )) (cond ((instance? sink ) (f sink)) ((== sink #t) (f (as (current-output-port)))) ((== sink #f) (let* ((buffer ()) (out ( buffer))) (f out) (! flush out) (! toString buffer))) (#t (ferror "Invalid sink designator: ~s" sink)))) (df test-disas ((c ) (m )) (let* ((vm (as *the-vm*)) (c (as (1st (! classes-by-name vm c)))) (m (as (1st (! methods-by-name c m))))) (with-sink #f (fun (out) (disassemble-meth-ref m out))))) ;; (test-disas "java.lang.Class" "toString") ;;;; Macroexpansion (defslimefun swank-expand-1 (env s) (%swank-macroexpand s env)) (defslimefun swank-expand (env s) (%swank-macroexpand s env)) (defslimefun swank-expand-all (env s) (%swank-macroexpand s env)) (df %swank-macroexpand (string env) (pprint-to-string (%macroexpand (read-from-string string) env))) (df %macroexpand (sexp env) (expand sexp #:env env)) ;;;; Inspector (define-simple-class () (object #:init #!null) (parts :: #:init () ) (stack :: #:init '()) (content :: #:init '())) (df make-inspector (env (vm ) => ) (car (spawn/chan (fun (c) (inspector c env vm))))) (df inspector ((c ) env (vm )) (! set-name (current-thread) "inspector") (let ((state :: ()) (open #t)) (while open (mcase (recv c) (('init str id) (set state ()) (let ((obj (try-catch (eval (read-from-string str) env) (ex ex)))) (reply c (inspect-object obj state vm) id))) (('init-mirror cc id) (set state ()) (let* ((mirror (recv cc)) (obj (vm-demirror vm mirror))) (reply c (inspect-object obj state vm) id))) (('inspect-part n id) (let ((part (! get (@ parts state) n))) (reply c (inspect-object part state vm) id))) (('pop id) (reply c (inspector-pop state vm) id)) (('quit id) (reply c 'nil id) (set open #f)))))) (df inspect-object (obj (state ) (vm )) (set (@ object state) obj) (set (@ parts state) ()) (pushf obj (@ stack state)) (set (@ content state) (inspector-content `("class: " (:value ,(! getClass obj)) "\n" ,@(inspect obj vm)) state)) (cond ((nul? obj) (list ':title "#!null" ':id 0 ':content `())) (#t (list ':title (pprint-to-string obj) ':id (assign-index obj state) ':content (let ((c (@ content state))) (content-range c 0 (len c))))))) (df inspect (obj vm) (let ((obj (as (vm-mirror vm obj)))) (typecase obj ( (inspect-array-ref vm obj)) ( (inspect-obj-ref vm obj))))) (df inspect-array-ref ((vm ) (obj )) (packing (pack) (let ((i 0)) (for (((v :: ) (! getValues obj))) (pack (format "~d: " i)) (pack `(:value ,(vm-demirror vm v))) (pack "\n") (set i (1+ i)))))) (df inspect-obj-ref ((vm ) (obj )) (let* ((type (! referenceType obj)) (fields (! allFields type)) (values (! getValues obj fields)) (ifields '()) (sfields '()) (imeths '()) (smeths '()) (frob (lambda (lists) (apply append (reverse lists))))) (for (((f :: ) fields)) (let* ((val (as (! get values f))) (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n"))) (if (! is-static f) (pushf l sfields) (pushf l ifields)))) (for (((m :: ) (! allMethods type))) (let ((l `(,(! name m) ,(! signature m) "\n"))) (if (! is-static m) (pushf l smeths) (pushf l imeths)))) `(,@(frob ifields) "--- static fields ---\n" ,@(frob sfields) "--- methods ---\n" ,@(frob imeths) "--- static methods ---\n" ,@(frob smeths)))) (df inspector-content (content (state )) (map (fun (part) (mcase part ((':value val) `(:value ,(pprint-to-string val) ,(assign-index val state))) (x (to-string x)))) content)) (df assign-index (obj (state ) => ) (! add (@ parts state) obj) (1- (! size (@ parts state)))) (df content-range (l start end) (let* ((len (length l)) (end (min len end))) (list (subseq l start end) len start end))) (df inspector-pop ((state ) vm) (cond ((<= 2 (len (@ stack state))) (let ((obj (cadr (@ stack state)))) (set (@ stack state) (cddr (@ stack state))) (inspect-object obj state vm))) (#t 'nil))) ;;;; IO redirection (define-simple-class () (q :: #:init ( (as 100))) ((*init*) (invoke-special (this) '*init*)) ((write (buffer :: ) (from :: ) (to :: )) :: (synchronized (this) (assert (not (== q #!null))) (! put q `(write ,( buffer from to))))) ((close) :: (synchronized (this) (! put q 'close) (set! q #!null))) ((flush) :: (synchronized (this) (assert (not (== q #!null))) (let ((ex ())) (! put q `(flush ,ex)) (! exchange ex #!null))))) (df swank-writer ((in ) (q )) (! set-name (current-thread) "swank-redirect-thread") (let* ((out (as (recv in))) (builder ()) (flush (fun () (unless (zero? (! length builder)) (send out `(forward (:write-string ,( builder)))) (! setLength builder 0)))) (closed #f)) (while (not closed) (mcase (! poll q (as long 200) (@s MILLISECONDS)) ('#!null (flush)) (('write s) (! append builder (as s)) (when (> (! length builder) 4000) (flush))) (('flush ex) (flush) (! exchange (as ex) #!null)) ('close (set closed #t) (flush)))))) (df make-swank-outport ((out )) (let ((w ())) (mlet ((in . _) (spawn/chan (fun (c) (swank-writer c (@ q w))))) (send in out)) ( w #t #t))) ;;;; Monitor ;;(define-simple-class () ;; (threadmap type: (tab))) (df vm-monitor ((c )) (! set-name (current-thread) "swank-vm-monitor") (let ((vm (vm-attach))) (log-vm-props vm) (request-breakpoint vm) (mlet* (((ev . _) (spawn/chan/catch (fun (c) (let ((q (! eventQueue vm))) (while #t (send c `(vm-event ,(to-list (! remove q))))))))) (to-string (vm-to-string vm)) (state (tab))) (send c `(publish-vm ,vm)) (while #t (mcase (recv* (list c ev)) ((_ . ('get-vm cc)) (send cc vm)) ((,c . ('debug-info thread from to id)) (reply c (debug-info thread from to state) id)) ((,c . ('throw-to-toplevel thread id)) (set state (throw-to-toplevel thread id c state))) ((,c . ('thread-continue thread id)) (set state (thread-continue thread id c state))) ((,c . ('frame-src-loc thread frame id)) (reply c (frame-src-loc thread frame state) id)) ((,c . ('frame-details thread frame id)) (reply c (list (frame-locals thread frame state) '()) id)) ((,c . ('disassemble-frame thread frame id)) (reply c (disassemble-frame thread frame state) id)) ((,c . ('thread-frames thread from to id)) (reply c (thread-frames thread from to state) id)) ((,c . ('list-threads id)) (reply c (list-threads vm state) id)) ((,c . ('interrupt-thread ref)) (set state (interrupt-thread ref state c))) ((,c . ('debug-nth-thread n)) (let ((t (nth (get state 'all-threads #f) n))) ;;(log "thread ~d : ~a\n" n t) (set state (interrupt-thread t state c)))) ((,c . ('quit-thread-browser id)) (reply c 't id) (set state (del state 'all-threads))) ((,ev . ('vm-event es)) ;;(log "vm-events: len=~a\n" (len es)) (for (((e :: ) (as es))) (set state (process-vm-event e c state)))) ((_ . ('get-exception from tid)) (mlet ((_ _ es) (get state tid #f)) (send from (let ((e (car es))) (typecase e ( (! exception e)) ( e)))))) ((_ . ('get-local rc tid frame var)) (send rc (frame-local-var tid frame var state))) ))))) (df reply ((c ) value id) (send c `(forward (:return (:ok ,value) ,id)))) (df reply-abort ((c ) id) (send c `(forward (:return (:abort nil) ,id)))) (df process-vm-event ((e ) (c ) state) ;;(log "vm-event: ~s\n" e) (typecase e ( ;;(log "exception: ~s\n" (! exception e)) ;;(log "exception-message: ~s\n" ;; (exception-message (vm-demirror *the-vm* (! exception e)))) ;;(log "exception-location: ~s\n" (src-loc>str (! location e))) ;;(log "exception-catch-location: ~s\n" (src-loc>str (! catch-location e))) (cond ((! notifyUncaught (as (! request e))) (process-exception e c state)) (#t (let* ((t (! thread e)) (r (! request e)) (ex (! exception e))) (unless (eq? *last-exception* ex) (set *last-exception* ex) (set *last-stacktrace* (copy-stack t))) (! resume t)) state))) ( (let* ((r (! request e)) (k (! get-property r 'continuation))) (! disable r) (log "k: ~s\n" k) (k e)) state) ( (log "breakpoint event: ~a\n" e) (debug-thread (! thread e) e state c)) )) (df process-exception ((e ) (c ) state) (let* ((tref (! thread e)) (tid (! uniqueID tref)) (s (get state tid #f))) (mcase s ('#f ;; XXX redundant in debug-thread (let* ((level 1) (state (put state tid (list tref level (list e))))) (send c `(forward (:debug ,tid ,level ,@(debug-info tid 0 15 state)))) (send c `(forward (:debug-activate ,tid ,level))) state)) ((_ level exs) (send c `(forward (:debug-activate ,(! uniqueID tref) ,level))) (put state tid (list tref (1+ level) (cons e exs))))))) (define-simple-class () (loc :: ) (args) (names) (values :: ) (self) ((*init* (loc :: ) args names (values :: ) self) (set (@ loc (this)) loc) (set (@ args (this)) args) (set (@ names (this)) names) (set (@ values (this)) values) (set (@ self (this)) self)) ((toString) :: (format "#" (src-loc>str loc)))) (df copy-stack ((t )) (packing (pack) (iter (! frames t) (fun ((f )) (let ((vars (ignore-errors (! visibleVariables f)))) (pack ( (or (ignore-errors (! location f)) #!null) (ignore-errors (! getArgumentValues f)) (or vars #!null) (or (and vars (ignore-errors (! get-values f vars))) #!null) (ignore-errors (! thisObject f))))))))) (define-simple-class () (thread :: ) ((*init* (thread :: )) (set (@ thread (this)) thread)) ((request) :: #!null) ((virtualMachine) :: (! virtualMachine thread))) (df break (#!optional condition) ((breakpoint condition))) ;; We set a breakpoint on this function. It returns a function which ;; specifies what the debuggee should do next (the actual return value ;; is set via JDI). Lets hope that the compiler doesn't optimize this ;; away. (df breakpoint (condition => ) (fun () #!null)) ;; Enable breakpoints event on the breakpoint function. (df request-breakpoint ((vm )) (let* ((swank-classes (! classesByName vm "swank-kawa")) (swank-classes-legacy (! classesByName vm "swank$Mnkawa")) (class :: (1st (if (= (length swank-classes) 0) swank-classes-legacy swank-classes))) (meth :: (1st (! methodsByName class "breakpoint"))) (erm (! eventRequestManager vm)) (req (! createBreakpointRequest erm (! location meth)))) (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) (! put-property req 'swank #t) (! put-property req 'argname "condition") (! enable req))) (df log-vm-props ((vm )) (letrec-syntax ((p (syntax-rules () ((p name) (log "~s: ~s\n" 'name (! name vm))))) (p* (syntax-rules () ((p* n ...) (seq (p n) ...))))) (p* canBeModified canRedefineClasses canAddMethod canUnrestrictedlyRedefineClasses canGetBytecodes canGetConstantPool canGetSyntheticAttribute canGetSourceDebugExtension canPopFrames canForceEarlyReturn canGetMethodReturnValues canGetInstanceInfo ))) ;;;;; Debugger (df debug-thread ((tref ) (ev ) state (c )) (unless (! is-suspended tref) (! suspend tref)) (let* ((id (! uniqueID tref)) (level 1) (state (put state id (list tref level (list ev))))) (send c `(forward (:debug ,id ,level ,@(debug-info id 0 10 state)))) (send c `(forward (:debug-activate ,id ,level))) state)) (df interrupt-thread ((tref ) state (c )) (debug-thread tref ( tref) state c)) (df debug-info ((tid ) (from ) to state) (mlet ((thread-ref level evs) (get state tid #f)) (let* ((tref (as thread-ref)) (vm (! virtualMachine tref)) (ev (as (car evs))) (ex (typecase ev ( (breakpoint-condition ev)) ( (! exception ev)) ( ( "Interrupt")))) (desc (typecase ex ( ;;(log "ex: ~a ~a\n" ex (vm-demirror vm ex)) (! toString (vm-demirror vm ex))) ( (! toString ex)))) (type (format " [type ~a]" (typecase ex ( (! name (! referenceType ex))) ( (!! getName getClass ex))))) (bt (thread-frames tid from to state))) `((,desc ,type nil) (("quit" "terminate current thread")) ,bt ())))) (df breakpoint-condition ((e ) => ) (let ((frame (! frame (! thread e) 0))) (1st (! get-argument-values frame)))) (df thread-frames ((tid ) (from ) to state) (mlet ((thread level evs) (get state tid #f)) (let* ((thread (as thread)) (fcount (! frameCount thread)) (stacktrace (event-stacktrace (car evs))) (missing (cond ((zero? (len stacktrace)) 0) (#t (- (len stacktrace) fcount)))) (fstart (max (- from missing) 0)) (flen (max (- to from missing) 0)) (frames (! frames thread fstart (min flen (- fcount fstart))))) (packing (pack) (let ((i from)) (dotimes (_ (max (- missing from) 0)) (pack (list i (format "~a" (stacktrace i)))) (set i (1+ i))) (iter frames (fun ((f )) (let ((s (frame-to-string f))) (pack (list i s)) (set i (1+ i)))))))))) (df event-stacktrace ((ev )) (let ((nothing (fun () ())) (vm (! virtualMachine ev))) (typecase ev ( (let ((condition (vm-demirror vm (breakpoint-condition ev)))) (cond ((instance? condition ) (throwable-stacktrace vm condition)) (#t (nothing))))) ( (throwable-stacktrace vm (vm-demirror vm (! exception ev)))) ( (nothing))))) (df throwable-stacktrace ((vm ) (ex )) (cond ((== ex (ignore-errors (vm-demirror vm *last-exception*))) *last-stacktrace*) (#t (! getStackTrace ex)))) (df frame-to-string ((f )) (let ((loc (! location f)) (vm (! virtualMachine f))) (format "~a (~a)" (!! name method loc) (call-with-abort (fun () (format "~{~a~^ ~}" (mapi (! getArgumentValues f) (fun (arg) (pprint-to-string (vm-demirror vm arg)))))))))) (df frame-src-loc ((tid ) (n ) state) (try-catch (mlet* (((frame vm) (nth-frame tid n state)) (vm (as vm))) (src-loc>elisp (typecase frame ( (! location frame)) ( (@ loc frame)) ( (let* ((classname (! getClassName frame)) (classes (! classesByName vm classname)) (t (as (1st classes)))) (1st (! locationsOfLine t (! getLineNumber frame)))))))) (ex (let ((msg (! getMessage ex))) `(:error ,(if (== msg #!null) (! toString ex) msg)))))) (df nth-frame ((tid ) (n ) state) (mlet ((tref level evs) (get state tid #f)) (let* ((thread (as tref)) (fcount (! frameCount thread)) (stacktrace (event-stacktrace (car evs))) (missing (cond ((zero? (len stacktrace)) 0) (#t (- (len stacktrace) fcount)))) (vm (! virtualMachine thread)) (frame (cond ((< n missing) (stacktrace n)) (#t (! frame thread (- n missing)))))) (list frame vm)))) ;;;;; Locals (df frame-locals ((tid ) (n ) state) (mlet ((thread _ _) (get state tid #f)) (let* ((thread (as thread)) (vm (! virtualMachine thread)) (p (fun (x) (pprint-to-string (call-with-abort (fun () (vm-demirror vm x))))))) (map (fun (x) (mlet ((name value) x) (list ':name name ':value (p value) ':id 0))) (%frame-locals tid n state))))) (df frame-local-var ((tid ) (frame ) (var ) state => ) (cadr (nth (%frame-locals tid frame state) var))) (df %frame-locals ((tid ) (n ) state) (mlet ((frame _) (nth-frame tid n state)) (typecase frame ( (let* ((visible (try-catch (! visibleVariables frame) (ex '()))) (map (! getValues frame visible)) (p (fun (x) x))) (packing (pack) (let ((self (ignore-errors (! thisObject frame)))) (when self (pack (list "this" (p self))))) (iter (! entrySet map) (fun ((e )) (let ((var (as (! getKey e))) (val (as (! getValue e)))) (pack (list (! name var) (p val))))))))) ( (packing (pack) (when (@ self frame) (pack (list "this" (@ self frame)))) (iter (! entrySet (@ values frame)) (fun ((e )) (let ((var (as (! getKey e))) (val (as (! getValue e)))) (pack (list (! name var) val))))))) ( '())))) (df disassemble-frame ((tid ) (frame ) state) (mlet ((frame _) (nth-frame tid frame state)) (typecase frame ( "") ( (let* ((l (! location frame)) (m (! method l)) (c (! declaringType l))) (disassemble-to-string m)))))) ;;;;; Restarts ;; FIXME: factorize (df throw-to-toplevel ((tid ) (id ) (c ) state) (mlet ((tref level exc) (get state tid #f)) (let* ((t (as tref)) (ev (car exc))) (typecase ev ( ; actually uncaughtException (! resume t) (reply-abort c id) ;;(send-debug-return c tid state) (do ((level level (1- level)) (exc exc (cdr exc))) ((null? exc)) (send c `(forward (:debug-return ,tid ,level nil)))) (del state tid)) ( ;; XXX race condition? (log "resume from from break (suspendCount: ~d)\n" (! suspendCount t)) (let ((vm (! virtualMachine t)) (k (fun () (primitive-throw ())))) (reply-abort c id) (! force-early-return t (vm-mirror vm k)) (! resume t) (do ((level level (1- level)) (exc exc (cdr exc))) ((null? exc)) (send c `(forward (:debug-return ,tid ,level nil)))) (del state tid))) ( (log "resume from from interrupt\n") (let ((vm (! virtualMachine t))) (! stop t (vm-mirror vm ())) (! resume t) (reply-abort c id) (do ((level level (1- level)) (exc exc (cdr exc))) ((null? exc)) (send c `(forward (:debug-return ,tid ,level nil)))) (del state tid)) ))))) (df thread-continue ((tid ) (id ) (c ) state) (mlet ((tref level exc) (get state tid #f)) (log "thread-continue: ~a ~a ~a \n" tref level exc) (let* ((t (as tref))) (! resume t)) (reply-abort c id) (do ((level level (1- level)) (exc exc (cdr exc))) ((null? exc)) (send c `(forward (:debug-return ,tid ,level nil)))) (del state tid))) (df thread-step ((t ) k) (let* ((vm (! virtual-machine t)) (erm (! eventRequestManager vm)) ( ) (req (! createStepRequest erm t (@s STEP_MIN) (@s STEP_OVER)))) (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) (! addCountFilter req 1) (! put-property req 'continuation k) (! enable req))) (df eval-in-thread ((t ) sexp #!optional (env :: (!s current))) (let* ((vm (! virtualMachine t)) (sc :: (1st (! classes-by-name vm "kawa.standard.Scheme"))) (ev :: (1st (! methods-by-name sc "eval" (cat "(Ljava/lang/Object;Lgnu/mapping/Environment;)" "Ljava/lang/Object;"))))) (! invokeMethod sc t ev (list sexp env) (@s INVOKE_SINGLE_THREADED)))) ;;;;; Threads (df list-threads (vm :: state) (let* ((threads (! allThreads vm))) (put state 'all-threads threads) (packing (pack) (pack '(\:id \:name \:status \:priority)) (iter threads (fun ((t )) (pack (list (! uniqueID t) (! name t) (let ((s (thread-status t))) (if (! is-suspended t) (cat "SUSPENDED/" s) s)) 0))))))) (df thread-status (t :: ) (let ((s (! status t))) (cond ((= s (@s THREAD_STATUS_UNKNOWN)) "UNKNOWN") ((= s (@s THREAD_STATUS_ZOMBIE)) "ZOMBIE") ((= s (@s THREAD_STATUS_RUNNING)) "RUNNING") ((= s (@s THREAD_STATUS_SLEEPING)) "SLEEPING") ((= s (@s THREAD_STATUS_MONITOR)) "MONITOR") ((= s (@s THREAD_STATUS_WAIT)) "WAIT") ((= s (@s THREAD_STATUS_NOT_STARTED)) "NOT_STARTED") (#t "")))) ;;;;; Bootstrap (df vm-attach (=> ) (attach (getpid) 20)) (df attach (pid timeout) (log "attaching: ~a ~a\n" pid timeout) (let* (( ) ( ) (vmm (!s com.sun.jdi.Bootstrap virtualMachineManager)) (pa (as (or (find-if (! attaching-connectors vmm) (fun (x :: ) (! equals (! name x) "com.sun.jdi.ProcessAttach")) #f) (error "ProcessAttach connector not found")))) (args (! default-arguments pa))) (! set-value (as (! get args (to-str "pid"))) pid) (when timeout (! set-value (as (! get args (to-str "timeout"))) timeout)) (log "attaching2: ~a ~a\n" pa args) (! attach pa args))) (df getpid () (let ((p (make-process (command-parse "echo $PPID") #!null))) (! waitFor p) (! read-line ( ( (! get-input-stream p)))))) (df request-uncaught-exception-events ((vm )) (let* ((erm (! eventRequestManager vm)) (req (! createExceptionRequest erm #!null #f #t))) (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) (! addThreadFilter req (vm-mirror vm (current-thread))) (! enable req))) (df request-caught-exception-events ((vm )) (let* ((erm (! eventRequestManager vm)) (req (! createExceptionRequest erm #!null #t #f))) (! setSuspendPolicy req (@ SUSPEND_EVENT_THREAD req)) (! addThreadFilter req (vm-mirror vm (current-thread))) (! addClassExclusionFilter req "java.lang.ClassLoader") (! addClassExclusionFilter req "java.net.URLClassLoader") (! addClassExclusionFilter req "java.net.URLClassLoader$1") (! enable req))) (df set-stacktrace-recording ((vm ) (flag )) (for (((e :: ) (!! exceptionRequests eventRequestManager vm))) (when (! notify-caught e) (! setEnabled e flag)))) ;; (set-stacktrace-recording *the-vm* #f) (df vm-to-string ((vm )) (let* ((obj (as (1st (! classesByName vm "java.lang.Object")))) (met (as (1st (! methodsByName obj "toString"))))) (fun ((o ) (t )) (! value (as (! invokeMethod o t met '() (@s INVOKE_SINGLE_THREADED))))))) (define-simple-class () (var #:allocation 'static)) (define-variable *global-get-mirror* #!null) (define-variable *global-set-mirror* #!null) (define-variable *global-get-raw* #!null) (define-variable *global-set-raw* #!null) (df init-global-field ((vm )) (when (nul? *global-get-mirror*) (set (@s var) #!null) ; prepare class (let* ((swank-global-variable-classes (! classes-by-name vm "swank-global-variable")) (swank-global-variable-classes-legacy (! classes-by-name vm "swank$Mnglobal$Mnvariable")) (c (as (1st (if (= (length swank-global-variable-classes) 0) swank-global-variable-classes-legacy swank-global-variable-classes)))) (f (! fieldByName c "var"))) (set *global-get-mirror* (fun () (! getValue c f))) (set *global-set-mirror* (fun ((v )) (! setValue c f v)))) (set *global-get-raw* (fun () '() (@s var))) (set *global-set-raw* (fun (x) (set (@s var) x))))) (df vm-mirror ((vm ) obj) (synchronized vm (init-global-field vm) (*global-set-raw* obj) (*global-get-mirror*))) (df vm-demirror ((vm ) (v )) (synchronized vm (if (== v #!null) #!null (typecase v ( (init-global-field vm) (*global-set-mirror* v) (*global-get-raw*)) ( (! value v)) ( (! value v)) ( (! value v)) ( (! value v)) ( (! value v)) ( (! value v)) ( (! value v)) ( (! value v)))))) (df vm-set-slot ((vm ) (o ) (name ) value) (let* ((o (as (vm-mirror vm o))) (t (! reference-type o)) (f (! field-by-name t name))) (! set-value o f (vm-mirror vm value)))) (define-simple-class () (f :: ) ((*init* (f :: )) (set (@ f (this)) f)) ((uncaughtException (t :: ) (e :: )) :: (! println (@s java.lang.System err) (to-str "uhexc:::")) (! apply2 f t e) #!void)) ;;;; Channels (df spawn (f) (let ((thread ( (%%runnable f)))) (! start thread) thread)) ;; gnu.mapping.RunnableClosure uses the try{...}catch(Throwable){...} ;; idiom which defeats all attempts to use a break-on-error-style ;; debugger. Previously I had my own version of RunnableClosure ;; without that deficiency but something in upstream changed and it no ;; longer worked. Now we use the normal RunnableClosure and at the ;; cost of taking stack snapshots on every throw. (df %%runnable (f => ) ;;( f) ;;( f) ;;(runnable f) (%runnable f) ) (df %runnable (f => ) (runnable (fun () (try-catch (f) (ex (log "exception in thread ~s: ~s" (current-thread) ex) (! printStackTrace ex)))))) (df chan () (let ((lock ()) (im ()) (ex ())) (set (@ lock im) lock) (set (@ lock ex) lock) (set (@ peer im) ex) (set (@ peer ex) im) (cons im ex))) (df immutable? (obj) (or (== obj #!null) (symbol? obj) (number? obj) (char? obj) (instance? obj ) (null? obj))) (df send ((c ) value => ) (df pass (obj) (cond ((immutable? obj) obj) ((string? obj) (! to-string obj)) ((pair? obj) (let loop ((r (list (pass (car obj)))) (o (cdr obj))) (cond ((null? o) (reverse! r)) ((pair? o) (loop (cons (pass (car o)) r) (cdr o))) (#t (append (reverse! r) (pass o)))))) ((instance? obj ) (let ((o :: obj)) (assert (== (@ owner o) (current-thread))) (synchronized (@ lock c) (set (@ owner o) (@ owner (@ peer c)))) o)) ((or (instance? obj ) (instance? obj )) ;; those can be shared, for pragmatic reasons obj ) (#t (error "can't send" obj (class-name-sans-package obj))))) ;;(log "send: ~s ~s -> ~s\n" value (@ owner c) (@ owner (@ peer c))) (assert (== (@ owner c) (current-thread))) ;;(log "lock: ~s send\n" (@ owner (@ peer c))) (synchronized (@ owner (@ peer c)) (! put (@ queue (@ peer c)) (pass value)) (! notify (@ owner (@ peer c)))) ;;(log "unlock: ~s send\n" (@ owner (@ peer c))) ) (df recv ((c )) (cdr (recv/timeout (list c) 0))) (df recv* ((cs )) (recv/timeout cs 0)) (df recv/timeout ((cs ) (timeout )) (let ((self (current-thread)) (end (if (zero? timeout) 0 (+ (current-time) timeout)))) ;;(log "lock: ~s recv\n" self) (synchronized self (let loop () ;;(log "receive-loop: ~s\n" self) (let ((ready (find-if cs (fun ((c )) (not (! is-empty (@ queue c)))) #f))) (cond (ready ;;(log "unlock: ~s recv\n" self) (cons ready (! take (@ queue (as ready))))) ((zero? timeout) ;;(log "wait: ~s recv\n" self) (! wait self) (loop)) (#t (let ((now (current-time))) (cond ((<= end now) 'timeout) (#t ;;(log "wait: ~s recv\n" self) (! wait self (- end now)) (loop))))))))))) (df rpc ((c ) msg) (mlet* (((im . ex) (chan)) ((op . args) msg)) (send c `(,op ,ex . ,args)) (recv im))) (df spawn/chan (f) (mlet ((im . ex) (chan)) (let ((thread ( (%%runnable (fun () (f ex)))))) (set (@ owner ex) thread) (! start thread) (cons im thread)))) (df spawn/chan/catch (f) (spawn/chan (fun (c) (try-catch (f c) (ex (send c `(error ,(! toString ex) ,(class-name-sans-package ex) ,(map (fun (e) (! to-string e)) (array-to-list (! get-stack-trace ex)))))))))) ;;;; Logging (define swank-log-port (current-error-port)) (df log (fstr #!rest args) (synchronized swank-log-port (apply format swank-log-port fstr args) (force-output swank-log-port)) #!void) ;;;; Random helpers (df 1+ (x) (+ x 1)) (df 1- (x) (- x 1)) (df len (x => ) (typecase x ( (length x)) ( (! length x)) ( (string-length x)) ( (vector-length x)) ( (! size x)) ( (@ length x)))) ;;(df put (tab key value) (hash-table-set! tab key value) tab) ;;(df get (tab key default) (hash-table-ref/default tab key default)) ;;(df del (tab key) (hash-table-delete! tab key) tab) ;;(df tab () (make-hash-table)) (df put (tab key value) (hashtable-set! tab key value) tab) (df get (tab key default) (hashtable-ref tab key default)) (df del (tab key) (hashtable-delete! tab key) tab) (df tab () (make-eqv-hashtable)) (df equal (x y => ) (equal? x y)) (df current-thread (=> ) (!s java.lang.Thread currentThread)) (df current-time (=> ) (!s java.lang.System currentTimeMillis)) (df nul? (x) (== x #!null)) (df read-from-string (str) (call-with-input-string str read)) ;;(df print-to-string (obj) (call-with-output-string (fun (p) (write obj p)))) (df pprint-to-string (obj) (let* ((w ()) (p ( w #t #f))) (try-catch (print-object obj p) (ex (format p "#" ex (class-name-sans-package ex)))) (! flush p) (to-string (! getBuffer w)))) (df print-object (obj stream) (typecase obj #; ((or (eql #!null) (eql #!eof) ) (write obj stream)) (#t #;(print-unreadable-object obj stream) (write obj stream) ))) (df print-unreadable-object ((o ) stream) (let* ((string (! to-string o)) (class (! get-class o)) (name (! get-name class)) (simplename (! get-simple-name class))) (cond ((! starts-with string "#<") (format stream "~a" string)) ((or (! starts-with string name) (! starts-with string simplename)) (format stream "#<~a>" string)) (#t (format stream "#<~a ~a>" name string))))) (define cat string-append) (df values-to-list (values) (typecase values ( (array-to-list (! getValues values))) ( (list values)))) ;; (to-list (as-list (values 1 2 2))) (df array-to-list ((array ) => ) (packing (pack) (dotimes (i (@ length array)) (pack (array i))))) (df lisp-bool (obj) (cond ((== obj 'nil) #f) ((== obj 't) #t) (#t (error "Can't map lisp boolean" obj)))) (df path-sans-extension ((p path) => ) (let ((ex (! get-extension p)) (str (! to-string p))) (to-string (cond ((not ex) str) (#t (! substring str 0 (- (len str) (len ex) 1))))))) (df class-name-sans-package ((obj )) (cond ((nul? obj) "<#!null>") (#t (try-catch (let* ((c (! get-class obj)) (n (! get-simple-name c))) (cond ((equal n "") (! get-name c)) (#t n))) (e (format "#<~a: ~a>" e (! get-message e))))))) (df list-env (#!optional (env :: (!s current))) (let ((enum (! enumerateAllLocations env))) (packing (pack) (while (! hasMoreElements enum) (pack (! nextLocation enum)))))) (df list-file (filename) (with (port (call-with-input-file filename)) (let* ((lang (!s gnu.expr.Language getDefaultLanguage)) (messages ()) (comp (! parse lang (as port) messages 0))) (! get-module comp)))) (df list-decls (file) (let* ((module (as (list-file file)))) (do ((decl :: (! firstDecl module) (! nextDecl decl))) ((nul? decl)) (format #t "~a ~a:~d:~d\n" decl (! getFileName decl) (! getLineNumber decl) (! getColumnNumber decl) )))) (df %time (f) (define-alias ) (define-alias ) (let* ((gcs (!s getGarbageCollectorMXBeans)) (mem (!s getMemoryMXBean)) (jit (!s getCompilationMXBean)) (oldjit (! getTotalCompilationTime jit)) (oldgc (packing (pack) (iter gcs (fun ((gc )) (pack (cons gc (list (! getCollectionCount gc) (! getCollectionTime gc)))))))) (heap (!! getUsed getHeapMemoryUsage mem)) (nonheap (!! getUsed getNonHeapMemoryUsage mem)) (start (!s java.lang.System nanoTime)) (values (f)) (end (!s java.lang.System nanoTime)) (newheap (!! getUsed getHeapMemoryUsage mem)) (newnonheap (!! getUsed getNonHeapMemoryUsage mem))) (format #t "~&") (let ((njit (! getTotalCompilationTime jit))) (format #t "; JIT compilation: ~:d ms (~:d)\n" (- njit oldjit) njit)) (iter gcs (fun ((gc )) (mlet ((_ count time) (assoc gc oldgc)) (format #t "; GC ~a: ~:d ms (~d)\n" (! getName gc) (- (! getCollectionTime gc) time) (- (! getCollectionCount gc) count))))) (format #t "; Heap: ~@:d (~:d)\n" (- newheap heap) newheap) (format #t "; Non-Heap: ~@:d (~:d)\n" (- newnonheap nonheap) newnonheap) (format #t "; Elapsed time: ~:d us\n" (/ (- end start) 1000)) values)) (define-syntax time (syntax-rules () ((time form) (%time (lambda () form))))) (df gc () (let* ((mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) (oheap (!! getUsed getHeapMemoryUsage mem)) (onheap (!! getUsed getNonHeapMemoryUsage mem)) (_ (! gc mem)) (heap (!! getUsed getHeapMemoryUsage mem)) (nheap (!! getUsed getNonHeapMemoryUsage mem))) (format #t "; heap: ~@:d (~:d) non-heap: ~@:d (~:d)\n" (- heap oheap) heap (- onheap nheap) nheap))) (df room () (let* ((pools (!s java.lang.management.ManagementFactory getMemoryPoolMXBeans)) (mem (!s java.lang.management.ManagementFactory getMemoryMXBean)) (heap (!! getUsed getHeapMemoryUsage mem)) (nheap (!! getUsed getNonHeapMemoryUsage mem))) (iter pools (fun ((p )) (format #t "~&; ~a~1,16t: ~10:d\n" (! getName p) (!! getUsed getUsage p)))) (format #t "; Heap~1,16t: ~10:d\n" heap) (format #t "; Non-Heap~1,16t: ~10:d\n" nheap))) ;; (df javap (class #!key method signature) ;; (let* (( ) ;; (bytes ;; (typecase class ;; ( (read-bytes ( (to-str class)))) ;; ( class) ;; ( (read-class-file class)))) ;; (cdata ( ( bytes))) ;; (p ( ;; ( bytes) ;; (current-output-port) ;; ()))) ;; (cond (method ;; (dolist ((m ) ;; (array-to-list (! getMethods cdata))) ;; (when (and (equal (to-str method) (! getName m)) ;; (or (not signature) ;; (equal signature (! getInternalSig m)))) ;; (! printMethodSignature p m (! getAccess m)) ;; (! printExceptions p m) ;; (newline) ;; (! printVerboseHeader p m) ;; (! printcodeSequence p m)))) ;; (#t (p:print))) ;; (values))) (df read-bytes ((is ) => ) (let ((os ())) (let loop () (let ((c (! read is))) (cond ((= c -1)) (#t (! write os c) (loop))))) (! to-byte-array os))) (df read-class-file ((name ) => ) (let ((f (cat (! replace (to-str name) (as #\.) (as #\/)) ".class"))) (mcase (find-file-in-path f (class-path)) ('#f (ferror "Can't find classfile for ~s" name)) ((:zip zipfile entry) (let* ((z ( (as zipfile))) (e (! getEntry z (as entry)))) (read-bytes (! getInputStream z e)))) ((:file s) (read-bytes ( (as s))))))) (df all-instances ((vm ) (classname )) (mappend (fun ((c )) (to-list (! instances c (as long 9999)))) (%all-subclasses vm classname))) (df %all-subclasses ((vm ) (classname )) (mappend (fun ((c )) (cons c (to-list (! subclasses c)))) (to-list (! classes-by-name vm classname)))) (df with-output-to-string (thunk => ) (call-with-output-string (fun (s) (parameterize ((current-output-port s)) (thunk))))) (df find-if ((i ) test default) (let ((iter (! iterator i)) (found #f)) (while (and (not found) (! has-next iter)) (let ((e (! next iter))) (when (test e) (set found #t) (set default e)))) default)) (df filter ((i ) test => ) (packing (pack) (for ((e i)) (when (test e) (pack e))))) (df iter ((i ) f) (for ((e i)) (f e))) (df mapi ((i ) f => ) (packing (pack) (for ((e i)) (pack (f e))))) (df nth ((i ) (n )) (let ((iter (! iterator i))) (dotimes (i n) (! next iter)) (! next iter))) (df 1st ((i )) (!! next iterator i)) (df to-list ((i ) => ) (packing (pack) (for ((e i)) (pack e)))) (df as-list ((o ) => ) (!s java.util.Arrays asList o)) (df mappend (f list) (apply append (map f list))) (df subseq (s from to) (typecase s ( (apply list (! sub-list s from to))) ( (apply vector (! sub-list s from to))) ( (! substring s from to)) ( (let* ((len (as (- to from))) (t ( #:length len))) (!s java.lang.System arraycopy s from t 0 len) t)))) (df to-string (obj => ) (typecase obj ( ( obj)) ((satisfies string?) obj) ((satisfies symbol?) (symbol->string obj)) ( ( obj)) ( ( obj)) (#t (error "Not a string designator" obj (class-name-sans-package obj))))) (df to-str (obj => ) (cond ((instance? obj ) obj) ((string? obj) (! toString obj)) ((symbol? obj) (! getName (as obj))) (#t (error "Not a string designator" obj (class-name-sans-package obj))))) )) ;; Local Variables: ;; mode: goo ;; compile-command: "\ ;; rm -rf classes && \ ;; JAVA_OPTS=-Xss2M kawa --r7rs -d classes -C swank-kawa.scm && \ ;; jar cf swank-kawa.jar -C classes ." ;; End: slime-2.20/contrib/swank-larceny.scm000066400000000000000000000115151315100173500174670ustar00rootroot00000000000000;; swank-larceny.scm --- Swank server for Larceny ;; ;; License: Public Domain ;; Author: Helmut Eller ;; ;; In a shell execute: ;; larceny -r6rs -program swank-larceny.scm ;; and then `M-x slime-connect' in Emacs. (library (swank os) (export getpid make-server-socket accept local-port close-socket) (import (rnrs) (primitives foreign-procedure ffi/handle->address ffi/string->asciiz sizeof:pointer sizeof:int %set-pointer %get-int)) (define getpid (foreign-procedure "getpid" '() 'int)) (define fork (foreign-procedure "fork" '() 'int)) (define close (foreign-procedure "close" '(int) 'int)) (define dup2 (foreign-procedure "dup2" '(int int) 'int)) (define bytevector-content-offset$ sizeof:pointer) (define execvp% (foreign-procedure "execvp" '(string boxed) 'int)) (define (execvp file . args) (let* ((nargs (length args)) (argv (make-bytevector (* (+ nargs 1) sizeof:pointer)))) (do ((offset 0 (+ offset sizeof:pointer)) (as args (cdr as))) ((null? as)) (%set-pointer argv offset (+ (ffi/handle->address (ffi/string->asciiz (car as))) bytevector-content-offset$))) (%set-pointer argv (* nargs sizeof:pointer) 0) (execvp% file argv))) (define pipe% (foreign-procedure "pipe" '(boxed) 'int)) (define (pipe) (let ((array (make-bytevector (* sizeof:int 2)))) (let ((r (pipe% array))) (values r (%get-int array 0) (%get-int array sizeof:int))))) (define (fork/exec file . args) (let ((pid (fork))) (cond ((= pid 0) (apply execvp file args)) (#t pid)))) (define (start-process file . args) (let-values (((r1 down-out down-in) (pipe)) ((r2 up-out up-in) (pipe)) ((r3 err-out err-in) (pipe))) (assert (= 0 r1)) (assert (= 0 r2)) (assert (= 0 r3)) (let ((pid (fork))) (case pid ((-1) (error "Failed to fork a subprocess.")) ((0) (close up-out) (close err-out) (close down-in) (dup2 down-out 0) (dup2 up-in 1) (dup2 err-in 2) (apply execvp file args) (exit 1)) (else (close down-out) (close up-in) (close err-in) (list pid (make-fd-io-stream up-out down-in) (make-fd-io-stream err-out err-out))))))) (define (make-fd-io-stream in out) (let ((write (lambda (bv start count) (fd-write out bv start count))) (read (lambda (bv start count) (fd-read in bv start count))) (closeit (lambda () (close in) (close out)))) (make-custom-binary-input/output-port "fd-stream" read write #f #f closeit))) (define write% (foreign-procedure "write" '(int ulong int) 'int)) (define (fd-write fd bytevector start count) (write% fd (+ (ffi/handle->address bytevector) bytevector-content-offset$ start) count)) (define read% (foreign-procedure "read" '(int ulong int) 'int)) (define (fd-read fd bytevector start count) ;;(printf "fd-read: ~a ~s ~a ~a\n" fd bytevector start count) (read% fd (+ (ffi/handle->address bytevector) bytevector-content-offset$ start) count)) (define (make-server-socket port) (let* ((args `("/bin/bash" "bash" "-c" ,(string-append "netcat -s 127.0.0.1 -q 0 -l -v " (if port (string-append "-p " (number->string port)) "")))) (nc (apply start-process args)) (err (transcoded-port (list-ref nc 2) (make-transcoder (latin-1-codec)))) (line (get-line err)) (pos (last-index-of line '#\]))) (cond (pos (let* ((tail (substring line (+ pos 1) (string-length line))) (port (get-datum (open-string-input-port tail)))) (list (car nc) (cadr nc) err port))) (#t (error "netcat failed: " line))))) (define (accept socket codec) (let* ((line (get-line (caddr socket))) (pos (last-index-of line #\]))) (cond (pos (close-port (caddr socket)) (let ((stream (cadr socket))) (let ((io (transcoded-port stream (make-transcoder codec)))) (values io io)))) (else (error "accept failed: " line))))) (define (local-port socket) (list-ref socket 3)) (define (last-index-of str chr) (let loop ((i (string-length str))) (cond ((<= i 0) #f) (#t (let ((i (- i 1))) (cond ((char=? (string-ref str i) chr) i) (#t (loop i)))))))) (define (close-socket socket) ;;(close-port (cadr socket)) #f ) ) (library (swank sys) (export implementation-name eval-in-interaction-environment) (import (rnrs) (primitives system-features aeryn-evaluator)) (define (implementation-name) "larceny") ;; see $LARCENY/r6rsmode.sch: ;; Larceny's ERR5RS and R6RS modes. ;; Code names: ;; Aeryn ERR5RS ;; D'Argo R6RS-compatible ;; Spanky R6RS-conforming (not yet implemented) (define (eval-in-interaction-environment form) (aeryn-evaluator form)) ) (import (rnrs) (rnrs eval) (larceny load)) (load "swank-r6rs.scm") (eval '(start-server #f) (environment '(swank))) slime-2.20/contrib/swank-listener-hooks.lisp000066400000000000000000000064121315100173500211650ustar00rootroot00000000000000;;; swank-listener-hooks.lisp --- listener with special hooks ;; ;; Author: Alan Ruttenberg ;; Provides *slime-repl-eval-hooks* special variable which ;; can be used for easy interception of SLIME REPL form evaluation ;; for purposes such as integration with application event loop. (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-repl)) (defvar *slime-repl-advance-history* nil "In the dynamic scope of a single form typed at the repl, is set to nil to prevent the repl from advancing the history - * ** *** etc.") (defvar *slime-repl-suppress-output* nil "In the dynamic scope of a single form typed at the repl, is set to nil to prevent the repl from printing the result of the evalation.") (defvar *slime-repl-eval-hook-pass* (gensym "PASS") "Token to indicate that a repl hook declines to evaluate the form") (defvar *slime-repl-eval-hooks* nil "A list of functions. When the repl is about to eval a form, first try running each of these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* is considered a replacement for calling eval. If there are no hooks, or all pass, then eval is used.") (export '*slime-repl-eval-hooks*) (defslimefun repl-eval-hook-pass () "call when repl hook declines to evaluate the form" (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) (defslimefun repl-suppress-output () "In the dynamic scope of a single form typed at the repl, call to prevent the repl from printing the result of the evalation." (setq *slime-repl-suppress-output* t)) (defslimefun repl-suppress-advance-history () "In the dynamic scope of a single form typed at the repl, call to prevent the repl from advancing the history - * ** *** etc." (setq *slime-repl-advance-history* nil)) (defun %eval-region (string) (with-input-from-string (stream string) (let (- values) (loop (let ((form (read stream nil stream))) (when (eq form stream) (fresh-line) (finish-output) (return (values values -))) (setq - form) (if *slime-repl-eval-hooks* (setq values (run-repl-eval-hooks form)) (setq values (multiple-value-list (eval form)))) (finish-output)))))) (defun run-repl-eval-hooks (form) (loop for hook in *slime-repl-eval-hooks* for res = (catch *slime-repl-eval-hook-pass* (multiple-value-list (funcall hook form))) until (not (eq res *slime-repl-eval-hook-pass*)) finally (return (if (eq res *slime-repl-eval-hook-pass*) (multiple-value-list (eval form)) res)))) (defun %listener-eval (string) (clear-user-input) (with-buffer-syntax () (swank-repl::track-package (lambda () (let ((*slime-repl-suppress-output* :unset) (*slime-repl-advance-history* :unset)) (multiple-value-bind (values last-form) (%eval-region string) (unless (or (and (eq values nil) (eq last-form nil)) (eq *slime-repl-advance-history* nil)) (setq *** ** ** * * (car values) /// // // / / values)) (setq +++ ++ ++ + + last-form) (unless (eq *slime-repl-suppress-output* t) (funcall swank-repl::*send-repl-results-function* values))))))) nil) (setq swank-repl::*listener-eval-function* '%listener-eval) (provide :swank-listener-hooks) slime-2.20/contrib/swank-macrostep.lisp000066400000000000000000000176421315100173500202230ustar00rootroot00000000000000;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el ;; ;; Authors: Luís Oliveira ;; Jon Oddie ;; ;; License: Public Domain (defpackage swank-macrostep (:use cl swank) (:import-from swank #:*macroexpand-printer-bindings* #:with-buffer-syntax #:with-bindings #:to-string #:macroexpand-all #:compiler-macroexpand-1 #:defslimefun #:collect-macro-forms) (:export #:macrostep-expand-1 #:macro-form-p)) (in-package #:swank-macrostep) (defslimefun macrostep-expand-1 (string compiler-macros? context) (with-buffer-syntax () (let ((form (read-from-string string))) (multiple-value-bind (expansion error-message) (expand-form-once form compiler-macros? context) (if error-message `(:error ,error-message) (multiple-value-bind (macros compiler-macros) (collect-macro-forms-in-context expansion context) (let* ((all-macros (append macros compiler-macros)) (pretty-expansion (pprint-to-string expansion)) (positions (collect-form-positions expansion pretty-expansion all-macros)) (subform-info (loop for form in all-macros for (start end) in positions when (and start end) collect (let ((op-name (to-string (first form))) (op-type (if (member form macros) :macro :compiler-macro))) (list op-name op-type start))))) `(:ok ,pretty-expansion ,subform-info)))))))) (defun expand-form-once (form compiler-macros? context) (multiple-value-bind (expansion expanded?) (macroexpand-1-in-context form context) (if expanded? (values expansion nil) (if (not compiler-macros?) (values nil "Not a macro form") (multiple-value-bind (expansion expanded?) (compiler-macroexpand-1 form) (if expanded? (values expansion nil) (values nil "Not a macro or compiler-macro form"))))))) (defslimefun macro-form-p (string compiler-macros? context) (with-buffer-syntax () (let ((form (handler-case (read-from-string string) (error (condition) (unless (debug-on-swank-error) (return-from macro-form-p `(:error ,(format nil "Read error: ~A" condition)))))))) `(:ok ,(macro-form-type form compiler-macros? context))))) (defun macro-form-type (form compiler-macros? context) (cond ((or (not (consp form)) (not (symbolp (car form)))) nil) ((multiple-value-bind (expansion expanded?) (macroexpand-1-in-context form context) (declare (ignore expansion)) expanded?) :macro) ((and compiler-macros? (multiple-value-bind (expansion expanded?) (compiler-macroexpand-1 form) (declare (ignore expansion)) expanded?)) :compiler-macro) (t nil))) ;;;; Hacks to support macro-expansion within local context (defparameter *macrostep-tag* (gensym)) (defparameter *macrostep-placeholder* '*macrostep-placeholder*) (define-condition expansion-in-context-failed (simple-error) ()) (defmacro throw-expansion (form &environment env) (throw *macrostep-tag* (macroexpand-1 form env))) (defmacro throw-collected-macro-forms (form &environment env) (throw *macrostep-tag* (collect-macro-forms form env))) (defun macroexpand-1-in-context (form context) (handler-case (macroexpand-and-catch `(throw-expansion ,form) context) (error () (macroexpand-1 form)))) (defun collect-macro-forms-in-context (form context) (handler-case (macroexpand-and-catch `(throw-collected-macro-forms ,form) context) (error () (collect-macro-forms form)))) (defun macroexpand-and-catch (form context) (catch *macrostep-tag* (macroexpand-all (enclose-form-in-context form context)) (error 'expansion-in-context-failed))) (defun enclose-form-in-context (form context) (with-buffer-syntax () (destructuring-bind (prefix suffix) context (let* ((placeholder-form (read-from-string (concatenate 'string prefix (prin1-to-string *macrostep-placeholder*) suffix))) (substituted-form (subst form *macrostep-placeholder* placeholder-form))) (if (not (equal placeholder-form substituted-form)) substituted-form (error 'expansion-in-context-failed)))))) ;;;; Tracking Pretty Printer (defun marker-char-p (char) (<= #xe000 (char-code char) #xe8ff)) (defun make-marker-char (id) ;; using the private-use characters U+E000..U+F8FF as markers, so ;; that's our upper limit for how many we can use. (assert (<= 0 id #x8ff)) (code-char (+ #xe000 id))) (defun marker-char-id (char) (assert (marker-char-p char)) (- (char-code char) #xe000)) (defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32))) (defun whitespacep (char) (member char +whitespace+)) (defun pprint-to-string (object &optional pprint-dispatch) (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*))) (with-bindings *macroexpand-printer-bindings* (to-string object)))) #-clisp (defun collect-form-positions (expansion printed-expansion forms) (loop for (start end) in (collect-marker-positions (pprint-to-string expansion (make-tracking-pprint-dispatch forms)) (length forms)) collect (when (and start end) (list (find-non-whitespace-position printed-expansion start) (find-non-whitespace-position printed-expansion end))))) ;; The pprint-dispatch table constructed by ;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack ;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS ;; entry point a no-op in thi case, so that basic macro-expansion will ;; still work (without detection of inner macro forms) #+clisp (defun collect-form-positions (expansion printed-expansion forms) nil) (defun make-tracking-pprint-dispatch (forms) (let ((original-table *print-pprint-dispatch*) (table (copy-pprint-dispatch))) (flet ((maybe-write-marker (position stream) (when position (write-char (make-marker-char position) stream)))) (set-pprint-dispatch 'cons (lambda (stream cons) (let ((pos (position cons forms))) (maybe-write-marker pos stream) ;; delegate printing to the original table. (funcall (pprint-dispatch cons original-table) stream cons) (maybe-write-marker pos stream))) most-positive-fixnum table)) table)) (defun collect-marker-positions (string position-count) (let ((positions (make-array position-count :initial-element nil))) (loop with p = 0 for char across string unless (whitespacep char) do (if (marker-char-p char) (push p (aref positions (marker-char-id char))) (incf p))) (map 'list #'reverse positions))) (defun find-non-whitespace-position (string position) (loop with non-whitespace-position = -1 for i from 0 and char across string unless (whitespacep char) do (incf non-whitespace-position) until (eql non-whitespace-position position) finally (return i))) (provide :swank-macrostep) slime-2.20/contrib/swank-media.lisp000066400000000000000000000021141315100173500172710ustar00rootroot00000000000000;;; swank-media.lisp --- insert other media (images) ;; ;; Authors: Christophe Rhodes ;; ;; Licence: GPLv2 or later ;; (in-package :swank) ;; this file is empty of functionality. The slime-media contrib ;; allows swank to return messages other than :write-string as repl ;; results; this is used in the R implementation of swank to display R ;; objects with graphical representations (such as trellis objects) as ;; image presentations in the swank repl. In R, this is done by ;; having a hook function for the preparation of the repl results, in ;; addition to the already-existing hook for sending the repl results ;; (*send-repl-results-function*, used by swank-presentations.lisp). ;; The swank-media.R contrib implementation defines a generic function ;; for use as this hook, along with methods for commonly-encountered ;; graphical R objects. (This strategy is harder in CL, where methods ;; can only be defined if their specializers already exist; in R's S3 ;; object system, methods are ordinary functions with a special naming ;; convention) (provide :swank-media) slime-2.20/contrib/swank-mit-scheme.scm000066400000000000000000000630131315100173500200650ustar00rootroot00000000000000;;; swank-mit-scheme.scm --- SLIME server for MIT Scheme ;; ;; Copyright (C) 2008 Helmut Eller ;; ;; This file is licensed under the terms of the GNU General Public ;; License as distributed with Emacs (press C-h C-c for details). ;;;; Installation: #| 1. You need MIT Scheme 9.2 2. The Emacs side needs some fiddling. I have the following in my .emacs: (setq slime-lisp-implementations '((mit-scheme ("mit-scheme") :init mit-scheme-init))) (defun mit-scheme-init (file encoding) (format "%S\n\n" `(begin (load-option 'format) (load-option 'sos) (eval '(create-package-from-description (make-package-description '(swank) (list (list)) (vector) (vector) (vector) false)) (->environment '(package))) (load ,(expand-file-name ".../contrib/swank-mit-scheme.scm" ; <-- insert your path slime-path) (->environment '(swank))) (eval '(start-swank ,file) (->environment '(swank)))))) (defun mit-scheme () (interactive) (slime 'mit-scheme)) (defun find-mit-scheme-package () (save-excursion (let ((case-fold-search t)) (and (re-search-backward "^[;]+ package: \\((.+)\\).*$" nil t) (match-string-no-properties 1))))) (setq slime-find-buffer-package-function 'find-mit-scheme-package) (add-hook 'scheme-mode-hook (lambda () (slime-mode 1))) The `mit-scheme-init' function first loads the SOS and FORMAT libraries, then creates a package "(swank)", and loads this file into that package. Finally it starts the server. `find-mit-scheme-package' tries to figure out which package the buffer belongs to, assuming that ";;; package: (FOO)" appears somewhere in the file. Luckily, this assumption is true for many of MIT Scheme's own files. Alternatively, you could add Emacs style -*- slime-buffer-package: "(FOO)" -*- file variables. 4. Start everything with `M-x mit-scheme'. |# ;;; package: (swank) (if (< (car (get-subsystem-version "Release")) '9) (error "This file requires MIT Scheme Release 9")) (define (swank port) (accept-connections (or port 4005) #f)) ;; ### hardcoded port number for now. netcat-openbsd doesn't print ;; the listener port anymore. (define (start-swank port-file) (accept-connections 4055 port-file) ) ;;;; Networking (define (accept-connections port port-file) (let ((sock (open-tcp-server-socket port (host-address-loopback)))) (format #t "Listening on port: ~s~%" port) (if port-file (write-port-file port port-file)) (dynamic-wind (lambda () #f) (lambda () (serve (tcp-server-connection-accept sock #t #f))) (lambda () (close-tcp-server-socket sock))))) (define (write-port-file portnumber filename) (call-with-output-file filename (lambda (p) (write portnumber p)))) (define *top-level-restart* #f) (define (serve socket) (with-simple-restart 'disconnect "Close connection." (lambda () (with-keyboard-interrupt-handler (lambda () (main-loop socket)))))) (define (disconnect) (format #t "Disconnecting ...~%") (invoke-restart (find-restart 'disconnect))) (define (main-loop socket) (do () (#f) (with-simple-restart 'abort "Return to SLIME top-level." (lambda () (fluid-let ((*top-level-restart* (find-restart 'abort))) (dispatch (read-packet socket) socket 0)))))) (define (with-keyboard-interrupt-handler fun) (define (set-^G-handler exp) (eval `(vector-set! keyboard-interrupt-vector (char->ascii #\G) ,exp) (->environment '(runtime interrupt-handler)))) (dynamic-wind (lambda () #f) (lambda () (set-^G-handler `(lambda (char) (with-simple-restart 'continue "Continue from interrupt." (lambda () (error "Keyboard Interrupt."))))) (fun)) (lambda () (set-^G-handler '^G-interrupt-handler)))) ;;;; Reading/Writing of SLIME packets (define (read-packet in) "Read an S-expression from STREAM using the SLIME protocol." (let* ((len (read-length in)) (buffer (make-string len))) (fill-buffer! in buffer) (read-from-string buffer))) (define (write-packet message out) (let* ((string (write-to-string message))) (log-event "WRITE: [~a]~s~%" (string-length string) string) (write-length (string-length string) out) (write-string string out) (flush-output out))) (define (fill-buffer! in buffer) (read-string! buffer in)) (define (read-length in) (if (eof-object? (peek-char in)) (disconnect)) (do ((len 6 (1- len)) (sum 0 (+ (* sum 16) (char->hex-digit (read-char in))))) ((zero? len) sum))) (define (ldb size position integer) "LoaD a Byte of SIZE bits at bit position POSITION from INTEGER." (fix:and (fix:lsh integer (- position)) (1- (fix:lsh 1 size)))) (define (write-length len out) (do ((pos 20 (- pos 4))) ((< pos 0)) (write-hex-digit (ldb 4 pos len) out))) (define (write-hex-digit n out) (write-char (hex-digit->char n) out)) (define (hex-digit->char n) (digit->char n 16)) (define (char->hex-digit c) (char->digit c 16)) ;;;; Event dispatching (define (dispatch request socket level) (log-event "READ: ~s~%" request) (case (car request) ((:emacs-rex) (apply emacs-rex socket level (cdr request))))) (define (swank-package) (or (name->package '(swank)) (name->package '(user)))) (define *buffer-package* #f) (define (find-buffer-package name) (if (elisp-false? name) #f (let ((v (ignore-errors (lambda () (name->package (read-from-string name)))))) (and (package? v) v)))) (define swank-env (->environment (swank-package))) (define (user-env buffer-package) (cond ((string? buffer-package) (let ((p (find-buffer-package buffer-package))) (if (not p) (error "Invalid package name: " buffer-package)) (package/environment p))) (else (nearest-repl/environment)))) ;; quote keywords (define (hack-quotes list) (map (lambda (x) (cond ((symbol? x) `(quote ,x)) (#t x))) list)) (define (emacs-rex socket level sexp package thread id) (let ((ok? #f) (result #f) (condition #f)) (dynamic-wind (lambda () #f) (lambda () (bind-condition-handler (list condition-type:serious-condition) (lambda (c) (set! condition c) (invoke-sldb socket (1+ level) c)) (lambda () (fluid-let ((*buffer-package* package)) (set! result (eval (cons* (car sexp) socket (hack-quotes (cdr sexp))) swank-env)) (set! ok? #t))))) (lambda () (write-packet `(:return ,(if ok? `(:ok ,result) `(:abort ,(if condition (format #f "~a" (condition/type condition)) ""))) ,id) socket))))) (define (swank:connection-info _) (let ((p (environment->package (user-env #f)))) `(:pid ,(unix/current-pid) :package (:name ,(write-to-string (package/name p)) :prompt ,(write-to-string (package/name p))) :lisp-implementation (:type "MIT Scheme" :version ,(get-subsystem-version-string "release")) :encoding (:coding-systems ("iso-8859-1")) ))) (define (swank:quit-lisp _) (%exit)) ;;;; Evaluation (define (swank-repl:listener-eval socket string) ;;(call-with-values (lambda () (eval-region string socket)) ;; (lambda values `(:values . ,(map write-to-string values)))) `(:values ,(write-to-string (eval-region string socket)))) (define (eval-region string socket) (let ((sexp (read-from-string string))) (if (eof-object? exp) (values) (with-output-to-repl socket (lambda () (eval sexp (user-env *buffer-package*))))))) (define (with-output-to-repl socket fun) (let ((p (make-port repl-port-type socket))) (dynamic-wind (lambda () #f) (lambda () (with-output-to-port p fun)) (lambda () (flush-output p))))) (define (swank:interactive-eval socket string) ;;(call-with-values (lambda () (eval-region string)) format-for-echo-area) (format-values (eval-region string socket)) ) (define (format-values . values) (if (null? values) "; No value" (with-string-output-port (lambda (out) (write-string "=> " out) (do ((vs values (cdr vs))) ((null? vs)) (write (car vs) out) (if (not (null? (cdr vs))) (write-string ", " out))))))) (define (swank:pprint-eval _ string) (pprint-to-string (eval (read-from-string string) (user-env *buffer-package*)))) (define (swank:interactive-eval-region socket string) (format-values (eval-region string socket))) (define (swank:set-package _ package) (set-repl/environment! (nearest-repl) (->environment (read-from-string package))) (let* ((p (environment->package (user-env #f))) (n (write-to-string (package/name p)))) (list n n))) (define (repl-write-substring port string start end) (cond ((< start end) (write-packet `(:write-string ,(substring string start end)) (port/state port)))) (- end start)) (define (repl-write-char port char) (write-packet `(:write-string ,(string char)) (port/state port))) (define repl-port-type (make-port-type `((write-substring ,repl-write-substring) (write-char ,repl-write-char)) #f)) (define (swank-repl:create-repl socket . _) (let* ((env (user-env #f)) (name (format #f "~a" (package/name (environment->package env))))) (list name name))) ;;;; Compilation (define (swank:compile-string-for-emacs _ string . x) (apply (lambda (errors seconds) `(:compilation-result ,errors t ,seconds nil nil)) (call-compiler (lambda () (let* ((sexps (snarf-string string)) (env (user-env *buffer-package*)) (scode (syntax `(begin ,@sexps) env)) (compiled-expression (compile-scode scode #t))) (scode-eval compiled-expression env)))))) (define (snarf-string string) (with-input-from-string string (lambda () (let loop () (let ((e (read))) (if (eof-object? e) '() (cons e (loop)))))))) (define (call-compiler fun) (let ((time #f)) (with-timings fun (lambda (run-time gc-time real-time) (set! time real-time))) (list 'nil (internal-time/ticks->seconds time)))) (define (swank:compiler-notes-for-emacs _) nil) (define (swank:compile-file-for-emacs socket file load?) (apply (lambda (errors seconds) (list ':compilation-result errors 't seconds load? (->namestring (pathname-name file)))) (call-compiler (lambda () (with-output-to-repl socket (lambda () (compile-file file))))))) (define (swank:load-file socket file) (with-output-to-repl socket (lambda () (pprint-to-string (load file (user-env *buffer-package*)))))) (define (swank:disassemble-form _ string) (let ((sexp (let ((sexp (read-from-string string))) (cond ((and (pair? sexp) (eq? (car sexp) 'quote)) (cadr sexp)) (#t sexp))))) (with-output-to-string (lambda () (compiler:disassemble (eval sexp (user-env *buffer-package*))))))) (define (swank:disassemble-symbol _ string) (with-output-to-string (lambda () (compiler:disassemble (eval (read-from-string string) (user-env *buffer-package*)))))) ;;;; Macroexpansion (define (swank:swank-macroexpand-all _ string) (with-output-to-string (lambda () (pp (syntax (read-from-string string) (user-env *buffer-package*)))))) (define swank:swank-macroexpand-1 swank:swank-macroexpand-all) (define swank:swank-macroexpand swank:swank-macroexpand-all) ;;; Arglist (define (swank:operator-arglist socket name pack) (let ((v (ignore-errors (lambda () (string-trim-right (with-output-to-string (lambda () (carefully-pa (eval (read-from-string name) (user-env pack)))))))))) (if (condition? v) 'nil v))) (define (carefully-pa o) (cond ((arity-dispatched-procedure? o) ;; MIT Scheme crashes for (pa /) (display "arity-dispatched-procedure")) ((procedure? o) (pa o)) (else (error "Not a procedure")))) ;;; Some unimplemented stuff. (define (swank:buffer-first-change . _) nil) (define (swank:filename-to-modulename . _) nil) (define (swank:swank-require . _) nil) ;; M-. is beyond my capabilities. (define (swank:find-definitions-for-emacs . _) nil) ;;; Debugger (define-structure (sldb-state (conc-name sldb-state.)) condition restarts) (define *sldb-state* #f) (define (invoke-sldb socket level condition) (fluid-let ((*sldb-state* (make-sldb-state condition (bound-restarts)))) (dynamic-wind (lambda () #f) (lambda () (write-packet `(:debug 0 ,level ,@(sldb-info *sldb-state* 0 20)) socket) (sldb-loop level socket)) (lambda () (write-packet `(:debug-return 0 ,level nil) socket))))) (define (sldb-loop level socket) (write-packet `(:debug-activate 0 ,level) socket) (with-simple-restart 'abort (format #f "Return to SLDB level ~a." level) (lambda () (dispatch (read-packet socket) socket level))) (sldb-loop level socket)) (define (sldb-info state start end) (let ((c (sldb-state.condition state)) (rs (sldb-state.restarts state))) (list (list (condition/report-string c) (format #f " [~a]" (%condition-type/name (condition/type c))) nil) (sldb-restarts rs) (sldb-backtrace c start end) ;;'((0 "dummy frame")) '()))) (define %condition-type/name (eval '%condition-type/name (->environment '(runtime error-handler)))) (define (sldb-restarts restarts) (map (lambda (r) (list (symbol->string (restart/name r)) (with-string-output-port (lambda (p) (write-restart-report r p))))) restarts)) (define (swank:throw-to-toplevel . _) (invoke-restart *top-level-restart*)) (define (swank:sldb-abort . _) (abort (sldb-state.restarts *sldb-state*))) (define (swank:sldb-continue . _) (continue (sldb-state.restarts *sldb-state*))) (define (swank:invoke-nth-restart-for-emacs _ _sldb-level n) (invoke-restart (list-ref (sldb-state.restarts *sldb-state*) n))) (define (swank:debugger-info-for-emacs _ from to) (sldb-info *sldb-state* from to)) (define (swank:backtrace _ from to) (sldb-backtrace (sldb-state.condition *sldb-state*) from to)) (define (sldb-backtrace condition from to) (sldb-backtrace-aux (condition/continuation condition) from to)) (define (sldb-backtrace-aux k from to) (let ((l (map frame>string (substream (continuation>frames k) from to)))) (let loop ((i from) (l l)) (if (null? l) '() (cons (list i (car l)) (loop (1+ i) (cdr l))))))) ;; Stack parser fails for this: ;; (map (lambda (x) x) "/tmp/x.x") (define (continuation>frames k) (let loop ((frame (continuation->stack-frame k))) (cond ((not frame) (stream)) (else (let ((next (ignore-errors (lambda () (stack-frame/next-subproblem frame))))) (cons-stream frame (if (condition? next) (stream next) (loop next)))))))) (define (frame>string frame) (if (condition? frame) (format #f "Bogus frame: ~a ~a" frame (condition/report-string frame)) (with-string-output-port (lambda (p) (print-frame frame p))))) (define (print-frame frame port) (define (invalid-subexpression? subexpression) (or (debugging-info/undefined-expression? subexpression) (debugging-info/unknown-expression? subexpression))) (define (invalid-expression? expression) (or (debugging-info/undefined-expression? expression) (debugging-info/compiled-code? expression))) (with-values (lambda () (stack-frame/debugging-info frame)) (lambda (expression environment subexpression) (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) (fluid-let ((*unparse-primitives-by-name?* #t)) (write (unsyntax (if (invalid-subexpression? subexpression) expression subexpression)) port))) ((debugging-info/noise? expression) (write-string ";" port) (write-string ((debugging-info/noise expression) #f) port)) (else (write-string ";undefined expression" port)))))) (define (substream s from to) (let loop ((i 0) (l '()) (s s)) (cond ((or (= i to) (stream-null? s)) (reverse l)) ((< i from) (loop (1+ i) l (stream-cdr s))) (else (loop (1+ i) (cons (stream-car s) l) (stream-cdr s)))))) (define (swank:frame-locals-and-catch-tags _ frame) (list (map frame-var>elisp (frame-vars (sldb-get-frame frame))) '())) (define (frame-vars frame) (with-values (lambda () (stack-frame/debugging-info frame)) (lambda (expression environment subexpression) (cond ((environment? environment) (environment>frame-vars environment)) (else '()))))) (define (environment>frame-vars environment) (let loop ((e environment)) (cond ((environment->package e) '()) (else (append (environment-bindings e) (if (environment-has-parent? e) (loop (environment-parent e)) '())))))) (define (frame-var>elisp b) (list ':name (write-to-string (car b)) ':value (cond ((null? (cdr b)) "{unavailable}") (else (>line (cadr b)))) ':id 0)) (define (sldb-get-frame index) (stream-ref (continuation>frames (condition/continuation (sldb-state.condition *sldb-state*))) index)) (define (frame-var-value frame var) (let ((binding (list-ref (frame-vars frame) var))) (cond ((cdr binding) (cadr binding)) (else unspecific)))) (define (swank:inspect-frame-var _ frame var) (reset-inspector) (inspect-object (frame-var-value (sldb-get-frame frame) var))) ;;;; Completion (define (swank:simple-completions _ string package) (let ((strings (all-completions string (user-env package) string-prefix?))) (list (sort strings stringstring (environment-names env)))) (keep-matching-items ss (lambda (s) (match? pattern s))))) ;; symbol->string is too slow (define %symbol->string symbol-name) (define (environment-names env) (append (environment-bound-names env) (if (environment-has-parent? env) (environment-names (environment-parent env)) '()))) (define (longest-common-prefix strings) (define (common-prefix s1 s2) (substring s1 0 (string-match-forward s1 s2))) (reduce common-prefix "" strings)) ;;;; Apropos (define (swank:apropos-list-for-emacs _ name #!optional external-only case-sensitive package) (let* ((pkg (and (string? package) (find-package (read-from-string package)))) (parent (and (not (default-object? external-only)) (elisp-false? external-only))) (ss (append-map (lambda (p) (map (lambda (s) (cons p s)) (apropos-list name p (and pkg parent)))) (if pkg (list pkg) (all-packages)))) (ss (sublist ss 0 (min (length ss) 200)))) (map (lambda (e) (let ((p (car e)) (s (cdr e))) (list ':designator (format #f "~a ~a" s (package/name p)) ':variable (>line (ignore-errors (lambda () (package-lookup p s))))))) ss))) (define (swank:list-all-package-names . _) (map (lambda (p) (write-to-string (package/name p))) (all-packages))) (define (all-packages) (define (package-and-children package) (append (list package) (append-map package-and-children (package/children package)))) (package-and-children system-global-package)) ;;;; Inspector (define-structure (inspector-state (conc-name istate.)) object parts next previous content) (define istate #f) (define (reset-inspector) (set! istate #f)) (define (swank:init-inspector _ string) (reset-inspector) (inspect-object (eval (read-from-string string) (user-env *buffer-package*)))) (define (inspect-object o) (let ((previous istate) (content (inspect o)) (parts (make-eqv-hash-table))) (set! istate (make-inspector-state o parts #f previous content)) (if previous (set-istate.next! previous istate)) (istate>elisp istate))) (define (istate>elisp istate) (list ':title (>line (istate.object istate)) ':id (assign-index (istate.object istate) (istate.parts istate)) ':content (prepare-range (istate.parts istate) (istate.content istate) 0 500))) (define (assign-index o parts) (let ((i (hash-table/count parts))) (hash-table/put! parts i o) i)) (define (prepare-range parts content from to) (let* ((cs (substream content from to)) (ps (prepare-parts cs parts))) (list ps (if (< (length cs) (- to from)) (+ from (length cs)) (+ to 1000)) from to))) (define (prepare-parts ps parts) (define (line label value) `(,(format #f "~a: " label) (:value ,(>line value) ,(assign-index value parts)) "\n")) (append-map (lambda (p) (cond ((string? p) (list p)) ((symbol? p) (list (symbol->string p))) (#t (case (car p) ((line) (apply line (cdr p))) (else (error "Invalid part:" p)))))) ps)) (define (swank:inspect-nth-part _ index) (inspect-object (hash-table/get (istate.parts istate) index 'no-such-part))) (define (swank:quit-inspector _) (reset-inspector)) (define (swank:inspector-pop _) (cond ((istate.previous istate) (set! istate (istate.previous istate)) (istate>elisp istate)) (else 'nil))) (define (swank:inspector-next _) (cond ((istate.next istate) (set! istate (istate.next istate)) (istate>elisp istate)) (else 'nil))) (define (swank:inspector-range _ from to) (prepare-range (istate.parts istate) (istate.content istate) from to)) (define-syntax stream* (syntax-rules () ((stream* tail) tail) ((stream* e1 e2 ...) (cons-stream e1 (stream* e2 ...))))) (define (iline label value) `(line ,label ,value)) (define-generic inspect (o)) (define-method inspect ((o )) (cond ((environment? o) (inspect-environment o)) ((vector? o) (inspect-vector o)) ((procedure? o) (inspect-procedure o)) ((compiled-code-block? o) (inspect-code-block o)) ;;((system-pair? o) (inspect-system-pair o)) ((probably-scode? o) (inspect-scode o)) (else (inspect-fallback o)))) (define (inspect-fallback o) (let* ((class (object-class o)) (slots (class-slots class))) (stream* (iline "Class" class) (let loop ((slots slots)) (cond ((null? slots) (stream)) (else (let ((n (slot-name (car slots)))) (stream* (iline n (slot-value o n)) (loop (cdr slots)))))))))) (define-method inspect ((o )) (if (or (pair? (cdr o)) (null? (cdr o))) (inspect-list o) (inspect-cons o))) (define (inspect-cons o) (stream (iline "car" (car o)) (iline "cdr" (cdr o)))) (define (inspect-list o) (let loop ((i 0) (o o)) (cond ((null? o) (stream)) ((or (pair? (cdr o)) (null? (cdr o))) (stream* (iline i (car o)) (loop (1+ i) (cdr o)))) (else (stream (iline i (car o)) (iline "tail" (cdr o))))))) (define (inspect-environment o) (stream* (iline "(package)" (environment->package o)) (let loop ((bs (environment-bindings o))) (cond ((null? bs) (if (environment-has-parent? o) (stream (iline "()" (environment-parent o))) (stream))) (else (let* ((b (car bs)) (s (car b))) (cond ((null? (cdr b)) (stream* s " {" (environment-reference-type o s) "}\n" (loop (cdr bs)))) (else (stream* (iline s (cadr b)) (loop (cdr bs))))))))))) (define (inspect-vector o) (let ((len (vector-length o))) (let loop ((i 0)) (cond ((= i len) (stream)) (else (stream* (iline i (vector-ref o i)) (loop (1+ i)))))))) (define (inspect-procedure o) (cond ((primitive-procedure? o) (stream (iline "name" (primitive-procedure-name o)) (iline "arity" (primitive-procedure-arity o)) (iline "doc" (primitive-procedure-documentation o)))) ((compound-procedure? o) (stream (iline "arity" (procedure-arity o)) (iline "lambda" (procedure-lambda o)) (iline "env" (ignore-errors (lambda () (procedure-environment o)))))) (else (stream (iline "block" (compiled-entry/block o)) (with-output-to-string (lambda () (compiler:disassemble o))))))) (define (inspect-code-block o) (stream-append (let loop ((i (compiled-code-block/constants-start o))) (cond ((>= i (compiled-code-block/constants-end o)) (stream)) (else (stream* (iline i (system-vector-ref o i)) (loop (+ i compiled-code-block/bytes-per-object)))))) (stream (iline "debuginfo" (compiled-code-block/debugging-info o)) (iline "env" (compiled-code-block/environment o)) (with-output-to-string (lambda () (compiler:disassemble o)))))) (define (inspect-scode o) (stream (pprint-to-string o))) (define (probably-scode? o) (define tests (list access? assignment? combination? comment? conditional? definition? delay? disjunction? lambda? quotation? sequence? the-environment? variable?)) (let loop ((tests tests)) (cond ((null? tests) #f) (((car tests) o)) (else (loop (cdr tests)))))) (define (inspect-system-pair o) (stream (iline "car" (system-pair-car o)) (iline "cdr" (system-pair-cdr o)))) ;;;; Auxilary functions (define nil '()) (define t 't) (define (elisp-false? o) (member o '(nil ()))) (define (elisp-true? o) (not (elisp-false? o))) (define (>line o) (let ((r (write-to-string o 100))) (cond ((not (car r)) (cdr r)) (else (string-append (cdr r) " .."))))) ;; Must compile >line otherwise we can't write unassigend-reference-traps. (set! >line (compile-procedure >line)) (define (read-from-string s) (with-input-from-string s read)) (define (pprint-to-string o) (with-string-output-port (lambda (p) (fluid-let ((*unparser-list-breadth-limit* 10) (*unparser-list-depth-limit* 4) (*unparser-string-length-limit* 100)) (pp o p))))) ;(define (1+ n) (+ n 1)) (define (1- n) (- n 1)) (define (package-lookup package name) (let ((p (if (package? package) package (find-package package)))) (environment-lookup (package/environment p) name))) (define log-port (current-output-port)) (define (log-event fstring . args) ;;(apply format log-port fstring args) #f ) ;;; swank-mit-scheme.scm ends here slime-2.20/contrib/swank-mlworks.sml000066400000000000000000000221511315100173500175370ustar00rootroot00000000000000(* swank-mlworks.sml -- SWANK server for MLWorks * * This code has been placed in the Public Domain. *) (* This is an experiment to see how the interfaces/modules would look * in a language with a supposedly "good" module system. * * MLWorks is probably the only SML implementation that tries to * support "interactive programming". Since MLWorks wasn't maintained * the last 15 or so years, big chunks of the SML Basis Library are * missing or not the way as required by the standard. That makes it * rather hard to do anything; it also shows that MLWorks hasn't been * "used in anger" for a long time. *) structure Swank = struct structure Util = struct fun utf8ToString (v:Word8Vector.vector) : string = Byte.bytesToString v fun stringToUtf8 s = Byte.stringToBytes s end structure Map = struct datatype ('a, 'b) map = Alist of {list: ('a * 'b) list ref, eq: ('a * 'a) -> bool} fun stringMap () = Alist {list = ref [], eq = (fn (x:string,y:string) => x = y)} fun lookup (Alist {list, eq}, key) = let fun search [] = NONE | search ((key', value) :: xs) = if eq (key', key) then SOME value else search xs in search (!list) end fun put (Alist {list, eq}, key, value) = let val l = (key, value) :: (!list) in list := l end end structure CharBuffer = struct local structure C = CharArray datatype buffer = B of {array : C.array ref, index: int ref} in fun new hint = B {array = ref (C.array (hint, #"\000")), index = ref 0} fun append (buffer as B {array, index}, char) = let val a = !array val i = !index val len = C.length a in if i < len then (C.update (a, i, char); index := i + 1; ()) else let val aa = C.array (2 * len, #"\000") fun copy (src, dst) = let val len = C.length src fun loop i = if i = len then () else (C.update (dst, i, C.sub (src, i)); loop (i + 1)) in loop 0 end in copy (a, aa); C.update (aa, i, char); array := aa; index := i + 1; () end end fun toString (B {array, index}) = let val a = !array val i = !index in CharVector.tabulate (i, fn i => C.sub (a, i)) end end end structure Sexp = struct structure Type = struct datatype sexp = Int of int | Str of string | Lst of sexp list | Sym of string | QSym of string * string | T | Nil | Quote end open Type exception ReadError fun fromUtf8 v = let val len = Word8Vector.length v val index = ref 0 fun getc () = case getc' () of SOME c => c | NONE => raise ReadError and getc' () = let val i = !index in if i = len then NONE else (index := i + 1; SOME (Byte.byteToChar (Word8Vector.sub (v, i)))) end and ungetc () = index := !index - 1 and sexp () : sexp = case getc () of #"\"" => string (CharBuffer.new 100) | #"(" => lst () | #"'" => Lst [Quote, sexp ()] | _ => (ungetc(); token ()) and string buf : sexp = case getc () of #"\"" => Str (CharBuffer.toString buf) | #"\\" => (CharBuffer.append (buf, getc ()); string buf) | c => (CharBuffer.append (buf, c); string buf) and lst () = let val x = sexp () in case getc () of #")" => Lst [x] | #" " => let val Lst y = lst () in Lst (x :: y) end | _ => raise ReadError end and token () = let val tok = token' (CharBuffer.new 50) val c0 = String.sub (tok, 0) in if Char.isDigit c0 then (case Int.fromString tok of SOME i => Int i | NONE => raise ReadError) else Sym (tok) end and token' buf : string = case getc' () of NONE => CharBuffer.toString buf | SOME #"\\" => (CharBuffer.append (buf, getc ()); token' buf) | SOME #" " => (ungetc (); CharBuffer.toString buf) | SOME #")" => (ungetc (); CharBuffer.toString buf) | SOME c => (CharBuffer.append (buf, c); token' buf) in sexp () end fun toString sexp = case sexp of (Str s) => "\"" ^ String.toCString s ^ "\"" | (Lst []) => "nil" | (Lst xs) => "(" ^ String.concatWith " " (map toString xs) ^ ")" | Sym (name) => name | QSym (pkg, name) => pkg ^ ":" ^ name | Quote => "quote" | T => "t" | Nil => "nil" | Int i => Int.toString i fun toUtf8 sexp = Util.stringToUtf8 (toString sexp) end structure Net = struct local structure S = Socket structure I = INetSock structure W = Word8Vector fun createSocket (port) = let val sock : S.passive I.stream_sock = I.TCP.socket () val SOME localhost = NetHostDB.fromString "127.0.0.1" in S.Ctl.setREUSEADDR (sock, true); S.bind (sock, I.toAddr (localhost, port)); S.listen (sock, 2); sock end fun addrToString sockAddr = let val (ip, port) = I.fromAddr sockAddr in NetHostDB.toString ip ^ ":" ^ Int.toString port end exception ShortRead of W.vector exception InvalidHexString of string in fun acceptConnection port = let val sock = createSocket port val addr = S.Ctl.getSockName sock val _ = print ("Listening on: " ^ addrToString addr ^ "\n") val (peer, addr) = S.accept sock in S.close sock; print ("Connection from: " ^ addrToString addr ^ "\n"); peer end fun receivePacket socket = let val v = S.recvVec (socket, 6) val _ = if W.length v = 6 then () else raise ShortRead v val s = Util.utf8ToString v val _ = print ("s = " ^ s ^ "\n") val len = case StringCvt.scanString (Int.scan StringCvt.HEX) s of SOME len => len | NONE => raise InvalidHexString s val _ = print ("len = " ^ Int.toString len ^ "\n") val payload = S.recvVec (socket, len) val plen = W.length payload val _ = print ("plen = " ^ Int.toString plen ^ "\n") val _ = if plen = len then () else raise ShortRead payload in payload end fun nibbleToHex i:string = Int.fmt StringCvt.HEX i fun loadNibble i pos = Word32.toInt (Word32.andb (Word32.>> (Word32.fromInt i, Word.fromInt (pos * 4)), 0wxf)) fun hexDigit i pos = nibbleToHex (loadNibble i pos) fun lenToHex i = concat [hexDigit i 5, hexDigit i 4, hexDigit i 3, hexDigit i 2, hexDigit i 1, hexDigit i 0] fun sendPacket (payload:W.vector, socket) = let val len = W.length payload val header = Util.stringToUtf8 (lenToHex len) val packet = W.concat [header, payload] in print ("len = " ^ Int.toString len ^ "\n" ^ "header = " ^ lenToHex len ^ "\n" ^ "paylad = " ^ Util.utf8ToString payload ^ "\n"); S.sendVec (socket, {buf = packet, i = 0, sz = NONE}) end end end structure Rpc = struct open Sexp.Type val funTable : (string, sexp list -> sexp) Map.map = Map.stringMap () fun define name f = Map.put (funTable, name, f) exception UnknownFunction of string fun call (name, args) = (print ("call: " ^ name ^ "\n"); case Map.lookup (funTable, name) of SOME f => f args | NONE => raise UnknownFunction name) local fun getpid () = Word32.toInt (Posix.Process.pidToWord (Posix.ProcEnv.getpid ())) in fun connectionInfo [] = Lst [Sym ":pid", Int (getpid ()), Sym ":lisp-implementation", Lst [Sym ":type", Str "MLWorks", Sym ":name", Str "mlworks", Sym ":version", Str "2.x"], Sym ":machine", Lst [Sym ":instance", Str "", Sym ":type", Str "", Sym ":version", Str ""], Sym ":features", Nil, Sym ":package", Lst [Sym ":name", Str "root", Sym ":prompt", Str "-"]] end fun nyi _ = Nil local structure D = Shell.Dynamic in fun interactiveEval [Str string] = let val x = D.eval string in Str (concat [D.printValue x, " : ", D.printType (D.getType x)]) end end val _ = (define "swank:connection-info" connectionInfo; define "swank:swank-require" nyi; define "swank:interactive-eval" interactiveEval; ()) end structure EventLoop = struct open Sexp.Type fun execute (sexp, pkg) = (print ("sexp = " ^ (Sexp.toString sexp) ^ "\n"); case sexp of Lst (Sym name :: args) => Rpc.call (name, args)) fun emacsRex (sexp, pkg, id as Int _, sock) = let val result = (Lst [Sym (":ok"), execute (sexp, pkg)] handle exn => (Lst [Sym ":abort", Str (exnName exn ^ ": " ^ exnMessage exn)])) val reply = Lst [Sym ":return", result, id] in Net.sendPacket (Sexp.toUtf8 reply, sock) end fun dispatch (Lst ((Sym key) :: args), sock) = case key of ":emacs-rex" => let val [sexp, pkg, _, id] = args in emacsRex (sexp, pkg, id, sock) end fun processRequests socket:unit = let val sexp = Sexp.fromUtf8 (Net.receivePacket socket) in print ("request: " ^ Util.utf8ToString (Sexp.toUtf8 sexp) ^ "\n"); dispatch (sexp, socket); processRequests socket end end (* val _ = EventLoop.processRequests (Net.acceptConnection 4005) *) val _ = () end (* (Swank.EventLoop.processRequests (Swank.Net.acceptConnection 4005)) *) slime-2.20/contrib/swank-mrepl.lisp000066400000000000000000000111341315100173500173330ustar00rootroot00000000000000;;; swank-mrepl.lisp ;; ;; Licence: public domain (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (let ((api '( *emacs-connection* channel channel-id define-channel-method defslimefun dcase log-event process-requests send-to-remote-channel use-threads-p wait-for-event with-bindings with-connection with-top-level-restart with-slime-interrupts ))) (eval `(defpackage #:swank-api (:use) (:import-from #:swank . ,api) (:export . ,api))))) (defpackage :swank-mrepl (:use :cl :swank-api) (:export #:create-mrepl)) (in-package :swank-mrepl) (defclass listener-channel (channel) ((remote :initarg :remote) (env :initarg :env) (mode :initform :eval) (tag :initform nil))) (defun package-prompt (package) (reduce (lambda (x y) (if (<= (length x) (length y)) x y)) (cons (package-name package) (package-nicknames package)))) (defslimefun create-mrepl (remote) (let* ((pkg *package*) (conn *emacs-connection*) (thread (if (use-threads-p) (spawn-listener-thread conn) nil)) (ch (make-instance 'listener-channel :remote remote :thread thread))) (setf (slot-value ch 'env) (initial-listener-env ch)) (when thread (swank/backend:send thread `(:serve-channel ,ch))) (list (channel-id ch) (swank/backend:thread-id (or thread (swank/backend:current-thread))) (package-name pkg) (package-prompt pkg)))) (defun initial-listener-env (listener) `((*package* . ,*package*) (*standard-output* . ,(make-listener-output-stream listener)) (*standard-input* . ,(make-listener-input-stream listener)))) (defun spawn-listener-thread (connection) (swank/backend:spawn (lambda () (with-connection (connection) (dcase (swank/backend:receive) ((:serve-channel c) (loop (with-top-level-restart (connection (drop-unprocessed-events c)) (process-requests nil))))))) :name "mrepl thread")) (defun drop-unprocessed-events (channel) (with-slots (mode) channel (let ((old-mode mode)) (setf mode :drop) (unwind-protect (process-requests t) (setf mode old-mode))) (send-prompt channel))) (define-channel-method :process ((c listener-channel) string) (log-event ":process ~s~%" string) (with-slots (mode remote) c (ecase mode (:eval (mrepl-eval c string)) (:read (mrepl-read c string)) (:drop)))) (defun mrepl-eval (channel string) (with-slots (remote env) channel (let ((aborted t)) (with-bindings env (unwind-protect (let ((result (with-slime-interrupts (read-eval-print string)))) (send-to-remote-channel remote `(:write-result ,result)) (setq aborted nil)) (setf env (loop for (sym) in env collect (cons sym (symbol-value sym)))) (cond (aborted (send-to-remote-channel remote `(:evaluation-aborted))) (t (send-prompt channel)))))))) (defun send-prompt (channel) (with-slots (env remote) channel (let ((pkg (or (cdr (assoc '*package* env)) *package*)) (out (cdr (assoc '*standard-output* env))) (in (cdr (assoc '*standard-input* env)))) (when out (force-output out)) (when in (clear-input in)) (send-to-remote-channel remote `(:prompt ,(package-name pkg) ,(package-prompt pkg)))))) (defun mrepl-read (channel string) (with-slots (tag) channel (assert tag) (throw tag string))) (defun read-eval-print (string) (with-input-from-string (in string) (setq / ()) (loop (let* ((form (read in nil in))) (cond ((eq form in) (return)) (t (setq / (multiple-value-list (eval (setq + form)))))))) (force-output) (if / (format nil "~{~s~%~}" /) "; No values"))) (defun make-listener-output-stream (channel) (let ((remote (slot-value channel 'remote))) (swank/backend:make-output-stream (lambda (string) (send-to-remote-channel remote `(:write-string ,string)))))) (defun make-listener-input-stream (channel) (swank/backend:make-input-stream (lambda () (read-input channel)))) (defun set-mode (channel new-mode) (with-slots (mode remote) channel (unless (eq mode new-mode) (send-to-remote-channel remote `(:set-read-mode ,new-mode))) (setf mode new-mode))) (defun read-input (channel) (with-slots (mode tag remote) channel (force-output) (let ((old-mode mode) (old-tag tag)) (setf tag (cons nil nil)) (set-mode channel :read) (unwind-protect (catch tag (process-requests nil)) (setf tag old-tag) (set-mode channel old-mode))))) (provide :swank-mrepl) slime-2.20/contrib/swank-package-fu.lisp000066400000000000000000000044071315100173500202240ustar00rootroot00000000000000 (in-package :swank) (defslimefun package= (string1 string2) (let* ((pkg1 (guess-package string1)) (pkg2 (guess-package string2))) (and pkg1 pkg2 (eq pkg1 pkg2)))) (defslimefun export-symbol-for-emacs (symbol-str package-str) (let ((package (guess-package package-str))) (when package (let ((*buffer-package* package)) (export `(,(from-string symbol-str)) package))))) (defslimefun unexport-symbol-for-emacs (symbol-str package-str) (let ((package (guess-package package-str))) (when package (let ((*buffer-package* package)) (unexport `(,(from-string symbol-str)) package))))) #+sbcl (defun list-structure-symbols (name) (let ((dd (sb-kernel:find-defstruct-description name ))) (list* name (sb-kernel:dd-default-constructor dd) (sb-kernel:dd-predicate-name dd) (sb-kernel::dd-copier-name dd) (mapcar #'sb-kernel:dsd-accessor-name (sb-kernel:dd-slots dd))))) #+ccl (defun list-structure-symbols (name) (let ((definition (gethash name ccl::%defstructs%))) (list* name (ccl::sd-constructor definition) (ccl::sd-refnames definition)))) (defun list-class-symbols (name) (let* ((class (find-class name)) (slots (swank-mop:class-direct-slots class))) (labels ((extract-symbol (name) (if (and (consp name) (eql (car name) 'setf)) (cadr name) name)) (slot-accessors (slot) (nintersection (copy-list (swank-mop:slot-definition-readers slot)) (copy-list (swank-mop:slot-definition-readers slot)) :key #'extract-symbol))) (list* (class-name class) (mapcan #'slot-accessors slots))))) (defslimefun export-structure (name package) (let ((*package* (guess-package package))) (when *package* (let* ((name (from-string name)) (symbols (cond #+(or sbcl ccl) ((or (not (find-class name nil)) (subtypep name 'structure-object)) (list-structure-symbols name)) (t (list-class-symbols name))))) (export symbols) symbols)))) (provide :swank-package-fu) slime-2.20/contrib/swank-presentation-streams.lisp000066400000000000000000000310101315100173500223760ustar00rootroot00000000000000;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities ;;; to portions of output ;;; ;;; Authors: Alan Ruttenberg ;;; Matthias Koeppe ;;; Helmut Eller ;;; ;;; License: This code has been placed in the Public Domain. All warranties ;;; are disclaimed. (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-presentations)) ;; This file contains a mechanism for printing to the slime repl so ;; that the printed result remembers what object it is associated ;; with. This extends the recording of REPL results. ;; ;; There are two methods: ;; ;; 1. Depends on the ilisp bridge code being installed and ready to ;; intercept messages in the printed stream. We encode the ;; information with a message saying that we are starting to print ;; an object corresponding to a given id and another when we are ;; done. The process filter notices these and adds the necessary ;; text properties to the output. ;; ;; 2. Use separate protocol messages :presentation-start and ;; :presentation-end for sending presentations. ;; ;; We only do this if we know we are printing to a slime stream, ;; checked with the method slime-stream-p. Initially this checks for ;; the knows slime streams looking at *connections*. In cmucl, sbcl, and ;; openmcl it also checks if it is a pretty-printing stream which ;; ultimately prints to a slime stream. ;; ;; Method 1 seems to be faster, but the printed escape sequences can ;; disturb the column counting, and thus the layout in pretty-printing. ;; We use method 1 when a dedicated output stream is used. ;; ;; Method 2 is cleaner and works with pretty printing if the pretty ;; printers support "annotations". We use method 2 when no dedicated ;; output stream is used. ;; Control (defvar *enable-presenting-readable-objects* t "set this to enable automatically printing presentations for some subset of readable objects, such as pathnames." ) ;; doing it (defmacro presenting-object (object stream &body body) "What you use in your code. Wrap this around some printing and that text will be sensitive and remember what object it is in the repl" `(presenting-object-1 ,object ,stream #'(lambda () ,@body))) (defmacro presenting-object-if (predicate object stream &body body) "What you use in your code. Wrap this around some printing and that text will be sensitive and remember what object it is in the repl if predicate is true" (let ((continue (gensym))) `(let ((,continue #'(lambda () ,@body))) (if ,predicate (presenting-object-1 ,object ,stream ,continue) (funcall ,continue))))) ;;; Get pretty printer patches for SBCL at load (not compile) time. #+#:disable-dangerous-patching ; #+sbcl (eval-when (:load-toplevel) (handler-bind ((simple-error (lambda (c) (declare (ignore c)) (let ((clobber-it (find-restart 'sb-kernel::clobber-it))) (when clobber-it (invoke-restart clobber-it)))))) (sb-ext:without-package-locks (swank/sbcl::with-debootstrapping (load (make-pathname :name "sbcl-pprint-patch" :type "lisp" :directory (pathname-directory swank-loader:*source-directory*))))))) (let ((last-stream nil) (last-answer nil)) (defun slime-stream-p (stream) "Check if stream is one of the slime streams, since if it isn't we don't want to present anything. Two special return values: :DEDICATED -- Output ends up on a dedicated output stream :REPL-RESULT -- Output ends up on the :repl-results target. " (if (eq last-stream stream) last-answer (progn (setq last-stream stream) (if (eq stream t) (setq stream *standard-output*)) (setq last-answer (or #+openmcl (and (typep stream 'ccl::xp-stream) ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) #+cmu (or (and (typep stream 'lisp::indenting-stream) (slime-stream-p (lisp::indenting-stream-stream stream))) (and (typep stream 'pretty-print::pretty-stream) (fboundp 'pretty-print::enqueue-annotation) (let ((slime-stream-p (slime-stream-p (pretty-print::pretty-stream-target stream)))) (and ;; Printing through CMUCL pretty ;; streams is only cleanly ;; possible if we are using the ;; bridge-less protocol with ;; annotations, because the bridge ;; escape sequences disturb the ;; pretty printer layout. (not (eql slime-stream-p :dedicated-output)) ;; If OK, return the return value ;; we got from slime-stream-p on ;; the target stream (could be ;; :repl-result): slime-stream-p)))) #+sbcl (let () (declare (notinline sb-pretty::pretty-stream-target)) (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) (not *use-dedicated-output-stream*) (slime-stream-p (sb-pretty::pretty-stream-target stream)))) #+allegro (and (typep stream 'excl:xp-simple-stream) (slime-stream-p (excl::stream-output-handle stream))) (loop for connection in *connections* thereis (or (and (eq stream (connection.dedicated-output connection)) :dedicated) (eq stream (connection.socket-io connection)) (eq stream (connection.user-output connection)) (eq stream (connection.user-io connection)) (and (eq stream (connection.repl-results connection)) :repl-result))))))))) (defun can-present-readable-objects (&optional stream) (declare (ignore stream)) *enable-presenting-readable-objects*) ;; If we are printing to an XP (pretty printing) stream, printing the ;; escape sequences directly would mess up the layout because column ;; counting is disturbed. Use "annotations" instead. #+allegro (defun write-annotation (stream function arg) (if (typep stream 'excl:xp-simple-stream) (excl::schedule-annotation stream function arg) (funcall function arg stream nil))) #+cmu (defun write-annotation (stream function arg) (if (and (typep stream 'pp:pretty-stream) (fboundp 'pp::enqueue-annotation)) (pp::enqueue-annotation stream function arg) (funcall function arg stream nil))) #+sbcl (defun write-annotation (stream function arg) (let ((enqueue-annotation (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) (if (and enqueue-annotation (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) (funcall enqueue-annotation stream function arg) (funcall function arg stream nil)))) #-(or allegro cmu sbcl) (defun write-annotation (stream function arg) (funcall function arg stream nil)) (defstruct presentation-record (id) (printed-p) (target)) (defun presentation-start (record stream truncatep) (unless truncatep ;; Don't start new presentations when nothing is going to be ;; printed due to *print-lines*. (let ((pid (presentation-record-id record)) (target (presentation-record-target record))) (case target (:dedicated ;; Use bridge protocol (write-string "<" stream) (prin1 pid stream) (write-string "" stream)) (t (finish-output stream) (send-to-emacs `(:presentation-start ,pid ,target))))) (setf (presentation-record-printed-p record) t))) (defun presentation-end (record stream truncatep) (declare (ignore truncatep)) ;; Always end old presentations that were started. (when (presentation-record-printed-p record) (let ((pid (presentation-record-id record)) (target (presentation-record-target record))) (case target (:dedicated ;; Use bridge protocol (write-string ">" stream) (prin1 pid stream) (write-string "" stream)) (t (finish-output stream) (send-to-emacs `(:presentation-end ,pid ,target))))))) (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and ) (pp-end-block stream ">")) nil)) (defmethod print-object :around ((pathname pathname) stream) (swank::presenting-object-if (swank::can-present-readable-objects stream) pathname stream (call-next-method)))) (ccl::def-load-pointers clear-presentations () (swank::clear-presentation-tables))) (in-package :swank) #+cmu (progn (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) (presenting-object object stream (fwrappers:call-next-function))) (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) (presenting-object-if (can-present-readable-objects stream) pathname stream (fwrappers:call-next-function))) (defun monkey-patch-stream-printing () (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper))) #+sbcl (progn (defvar *saved-%print-unreadable-object* (fdefinition 'sb-impl::%print-unreadable-object)) (defun monkey-patch-stream-printing () (sb-ext:without-package-locks (when (eq (fdefinition 'sb-impl::%print-unreadable-object) *saved-%print-unreadable-object*) (setf (fdefinition 'sb-impl::%print-unreadable-object) (lambda (object stream type identity &optional 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))) (defun monkey-patch-stream-printing () (excl:fwrap 'excl::print-unreadable-object-1 'print-unreadable-present 'presenting-unreadable-wrapper) (excl:fwrap 'excl::pathname-printer 'print-pathname-present 'presenting-pathname-wrapper))) #-(or allegro sbcl cmu openmcl) (defun monkey-patch-stream-printing () (values)) ;; Hook into SWANK. (defslimefun init-presentation-streams () (monkey-patch-stream-printing) ;; FIXME: import/use swank-repl to avoid package qualifier. (setq swank-repl:*send-repl-results-function* 'present-repl-results-via-presentation-streams)) (provide :swank-presentation-streams) slime-2.20/contrib/swank-presentations.lisp000066400000000000000000000204301315100173500211110ustar00rootroot00000000000000;;; swank-presentations.lisp --- imitate LispM's presentations ;; ;; Authors: Alan Ruttenberg ;; Luke Gorrie ;; Helmut Eller ;; Matthias Koeppe ;; ;; License: This code has been placed in the Public Domain. All warranties ;; are disclaimed. ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-repl)) ;;;; Recording and accessing results of computations (defvar *record-repl-results* t "Non-nil means that REPL results are saved for later lookup.") (defvar *object-to-presentation-id* (make-weak-key-hash-table :test 'eq) "Store the mapping of objects to numeric identifiers") (defvar *presentation-id-to-object* (make-weak-value-hash-table :test 'eql) "Store the mapping of numeric identifiers to objects") (defun clear-presentation-tables () (clrhash *object-to-presentation-id*) (clrhash *presentation-id-to-object*)) (defvar *presentation-counter* 0 "identifier counter") (defvar *nil-surrogate* (make-symbol "nil-surrogate")) ;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the ;; rest of slime isn't thread safe either), do we really care? (defun save-presented-object (object) "Save OBJECT and return the assigned id. If OBJECT was saved previously return the old id." (let ((object (if (null object) *nil-surrogate* object))) ;; We store *nil-surrogate* instead of nil, to distinguish it from ;; an object that was garbage collected. (or (gethash object *object-to-presentation-id*) (let ((id (incf *presentation-counter*))) (setf (gethash id *presentation-id-to-object*) object) (setf (gethash object *object-to-presentation-id*) id) id)))) (defslimefun lookup-presented-object (id) "Retrieve the object corresponding to ID. The secondary value indicates the absence of an entry." (etypecase id (integer ;; (multiple-value-bind (object foundp) (gethash id *presentation-id-to-object*) (cond ((eql object *nil-surrogate*) ;; A stored nil object (values nil t)) ((null object) ;; Object that was replaced by nil in the weak hash table ;; when the object was garbage collected. (values nil nil)) (t (values object foundp))))) (cons (dcase id ((:frame-var thread-id frame index) (declare (ignore thread-id)) ; later (handler-case (frame-var-value frame index) (t (condition) (declare (ignore condition)) (values nil nil)) (:no-error (value) (values value t)))) ((:inspected-part part-index) (inspector-nth-part part-index)))))) (defslimefun lookup-presented-object-or-lose (id) "Get the result of the previous REPL evaluation with ID." (multiple-value-bind (object foundp) (lookup-presented-object id) (cond (foundp object) (t (error "Attempt to access unrecorded object (id ~D)." id))))) (defslimefun lookup-and-save-presented-object-or-lose (id) "Get the object associated with ID and save it in the presentation tables." (let ((obj (lookup-presented-object-or-lose id))) (save-presented-object obj))) (defslimefun clear-repl-results () "Forget the results of all previous REPL evaluations." (clear-presentation-tables) t) (defun present-repl-results (values) ;; Override a function in swank.lisp, so that ;; presentations are associated with every REPL result. (flet ((send (value) (let ((id (and *record-repl-results* (save-presented-object value)))) (send-to-emacs `(:presentation-start ,id :repl-result)) (send-to-emacs `(:write-string ,(prin1-to-string value) :repl-result)) (send-to-emacs `(:presentation-end ,id :repl-result)) (send-to-emacs `(:write-string ,(string #\Newline) :repl-result))))) (fresh-line) (finish-output) (if (null values) (send-to-emacs `(:write-string "; No value" :repl-result)) (mapc #'send values)))) ;;;; Presentation menu protocol ;; ;; To define a menu for a type of object, define a method ;; menu-choices-for-presentation on that object type. This function ;; should return a list of two element lists where the first element is ;; the name of the menu action and the second is a function that will be ;; called if the menu is chosen. The function will be called with 3 ;; arguments: ;; ;; choice: The string naming the action from above ;; ;; object: The object ;; ;; id: The presentation id of the object ;; ;; You might want append (when (next-method-p) (call-next-method)) to ;; pick up the Menu actions of superclasses. ;; (defvar *presentation-active-menu* nil) (defun menu-choices-for-presentation-id (id) (multiple-value-bind (ob presentp) (lookup-presented-object id) (cond ((not presentp) 'not-present) (t (let ((menu-and-actions (menu-choices-for-presentation ob))) (setq *presentation-active-menu* (cons id menu-and-actions)) (mapcar 'car menu-and-actions)))))) (defun swank-ioify (thing) (cond ((keywordp thing) thing) ((and (symbolp thing)(not (find #\: (symbol-name thing)))) (intern (symbol-name thing) 'swank-io-package)) ((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing)))) (t thing))) (defun execute-menu-choice-for-presentation-id (id count item) (let ((ob (lookup-presented-object id))) (assert (equal id (car *presentation-active-menu*)) () "Bug: Execute menu call for id ~a but menu has id ~a" id (car *presentation-active-menu*)) (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) (swank-ioify (funcall action item ob id))))) (defgeneric menu-choices-for-presentation (object) (:method (ob) (declare (ignore ob)) nil)) ; default method ;; Pathname (defmethod menu-choices-for-presentation ((ob pathname)) (let* ((file-exists (ignore-errors (probe-file ob))) (lisp-type (make-pathname :type "lisp")) (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal)) (let ((source (merge-pathnames lisp-type ob))) (and (ignore-errors (probe-file source)) source)))) (fasl-file (and file-exists (equal (ignore-errors (namestring (truename (compile-file-pathname (merge-pathnames lisp-type ob))))) (namestring (truename ob)))))) (remove nil (list* (and (and file-exists (not fasl-file)) (list "Edit this file" (lambda(choice object id) (declare (ignore choice id)) (ed-in-emacs (namestring (truename object))) nil))) (and file-exists (list "Dired containing directory" (lambda (choice object id) (declare (ignore choice id)) (ed-in-emacs (namestring (truename (merge-pathnames (make-pathname :name "" :type "") object)))) nil))) (and fasl-file (list "Load this fasl file" (lambda (choice object id) (declare (ignore choice id object)) (load ob) nil))) (and fasl-file (list "Delete this fasl file" (lambda (choice object id) (declare (ignore choice id object)) (let ((nt (namestring (truename ob)))) (when (y-or-n-p-in-emacs "Delete ~a? " nt) (delete-file nt))) nil))) (and source-file (list "Edit lisp source file" (lambda (choice object id) (declare (ignore choice id object)) (ed-in-emacs (namestring (truename source-file))) nil))) (and source-file (list "Load lisp source file" (lambda(choice object id) (declare (ignore choice id object)) (load source-file) nil))) (and (next-method-p) (call-next-method)))))) (defmethod menu-choices-for-presentation ((ob function)) (list (list "Disassemble" (lambda (choice object id) (declare (ignore choice id)) (disassemble object))))) (defslimefun inspect-presentation (id reset-p) (let ((what (lookup-presented-object-or-lose id))) (when reset-p (reset-inspector)) (inspect-object what))) (defslimefun init-presentations () ;; FIXME: import/use swank-repl to avoid package qualifier. (setq swank-repl:*send-repl-results-function* 'present-repl-results)) (provide :swank-presentations) slime-2.20/contrib/swank-quicklisp.lisp000066400000000000000000000010231315100173500202140ustar00rootroot00000000000000;;; swank-quicklisp.lisp -- Quicklisp support ;; ;; Authors: Matthew Kennedy ;; License: Public Domain ;; (in-package :swank) (defslimefun list-quicklisp-systems () "Returns the Quicklisp systems list." (if (member :quicklisp *features*) (let ((ql-dist-name (find-symbol "NAME" "QL-DIST")) (ql-system-list (find-symbol "SYSTEM-LIST" "QL"))) (mapcar ql-dist-name (funcall ql-system-list))) (error "Could not find Quicklisp already loaded."))) (provide :swank-quicklisp) slime-2.20/contrib/swank-r6rs.scm000066400000000000000000000277631315100173500167420ustar00rootroot00000000000000;; swank-r6rs.sls --- Shareable code between swank-ikarus and swank-larceny ;; ;; Licence: public domain ;; Author: Helmut Eller ;; ;; This is a Swank server barely capable enough to process simple eval ;; requests from Emacs before dying. No fancy features like ;; backtraces, module redefintion, M-. etc. are implemented. Don't ;; even think about pc-to-source mapping. ;; ;; Despite standard modules, this file uses (swank os) and (swank sys) ;; which define implementation dependend functionality. There are ;; multiple modules in this files, which is probably not standardized. ;; ;; Naive FORMAT implementation which supports: ~a ~s ~d ~x ~c (library (swank format) (export format printf fprintf) (import (rnrs)) (define (format f . args) (call-with-string-output-port (lambda (port) (apply fprintf port f args)))) (define (printf f . args) (let ((port (current-output-port))) (apply fprintf port f args) (flush-output-port port))) (define (fprintf port f . args) (let ((len (string-length f))) (let loop ((i 0) (args args)) (cond ((= i len) (assert (null? args))) ((and (char=? (string-ref f i) #\~) (< (+ i 1) len)) (dispatch-format (string-ref f (+ i 1)) port (car args)) (loop (+ i 2) (cdr args))) (else (put-char port (string-ref f i)) (loop (+ i 1) args)))))) (define (dispatch-format char port arg) (let ((probe (assoc char format-dispatch-table))) (cond (probe ((cdr probe) arg port)) (else (error "invalid format char: " char))))) (define format-dispatch-table `((#\a . ,display) (#\s . ,write) (#\d . ,(lambda (arg port) (put-string port (number->string arg 10)))) (#\x . ,(lambda (arg port) (put-string port (number->string arg 16)))) (#\c . ,(lambda (arg port) (put-char port arg)))))) ;; CL-style restarts to let us continue after errors. (library (swank restarts) (export with-simple-restart compute-restarts invoke-restart restart-name write-restart-report) (import (rnrs)) (define *restarts* '()) (define-record-type restart (fields name reporter continuation)) (define (with-simple-restart name reporter thunk) (call/cc (lambda (k) (let ((old-restarts *restarts*) (restart (make-restart name (coerce-to-reporter reporter) k))) (dynamic-wind (lambda () (set! *restarts* (cons restart old-restarts))) thunk (lambda () (set! *restarts* old-restarts))))))) (define (compute-restarts) *restarts*) (define (invoke-restart restart . args) (apply (restart-continuation restart) args)) (define (write-restart-report restart port) ((restart-reporter restart) port)) (define (coerce-to-reporter obj) (cond ((string? obj) (lambda (port) (put-string port obj))) (#t (assert (procedure? obj)) obj))) ) ;; This module encodes & decodes messages from the wire and queues them. (library (swank event-queue) (export make-event-queue wait-for-event enqueue-event read-event write-event) (import (rnrs) (rnrs mutable-pairs) (swank format)) (define-record-type event-queue (fields (mutable q) wait-fun) (protocol (lambda (init) (lambda (wait-fun) (init '() wait-fun))))) (define (wait-for-event q pattern) (or (poll q pattern) (begin ((event-queue-wait-fun q) q) (wait-for-event q pattern)))) (define (poll q pattern) (let loop ((lag #f) (l (event-queue-q q))) (cond ((null? l) #f) ((event-match? (car l) pattern) (cond (lag (set-cdr! lag (cdr l)) (car l)) (else (event-queue-q-set! q (cdr l)) (car l)))) (else (loop l (cdr l)))))) (define (event-match? event pattern) (cond ((or (number? pattern) (member pattern '(t nil))) (equal? event pattern)) ((symbol? pattern) #t) ((pair? pattern) (case (car pattern) ((quote) (equal? event (cadr pattern))) ((or) (exists (lambda (p) (event-match? event p)) (cdr pattern))) (else (and (pair? event) (event-match? (car event) (car pattern)) (event-match? (cdr event) (cdr pattern)))))) (else (error "Invalid pattern: " pattern)))) (define (enqueue-event q event) (event-queue-q-set! q (append (event-queue-q q) (list event)))) (define (write-event event port) (let ((payload (call-with-string-output-port (lambda (port) (write event port))))) (write-length (string-length payload) port) (put-string port payload) (flush-output-port port))) (define (write-length len port) (do ((i 24 (- i 4))) ((= i 0)) (put-string port (number->string (bitwise-bit-field len (- i 4) i) 16)))) (define (read-event port) (let* ((header (string-append (get-string-n port 2) (get-string-n port 2) (get-string-n port 2))) (_ (printf "header: ~s\n" header)) (len (string->number header 16)) (_ (printf "len: ~s\n" len)) (payload (get-string-n port len))) (printf "payload: ~s\n" payload) (read (open-string-input-port payload)))) ) ;; Entry points for SLIME commands. (library (swank rpc) (export connection-info interactive-eval ;;compile-string-for-emacs throw-to-toplevel sldb-abort operator-arglist buffer-first-change create-repl listener-eval) (import (rnrs) (rnrs eval) (only (rnrs r5rs) scheme-report-environment) (swank os) (swank format) (swank restarts) (swank sys) ) (define (connection-info . _) `(,@'() :pid ,(getpid) :package (:name ">" :prompt ">") :lisp-implementation (,@'() :name ,(implementation-name) :type "R6RS-Scheme"))) (define (interactive-eval string) (call-with-values (lambda () (eval-in-interaction-environment (read-from-string string))) (case-lambda (() "; no value") ((value) (format "~s" value)) (values (format "values: ~s" values))))) (define (throw-to-toplevel) (invoke-restart-by-name-or-nil 'toplevel)) (define (sldb-abort) (invoke-restart-by-name-or-nil 'abort)) (define (invoke-restart-by-name-or-nil name) (let ((r (find (lambda (r) (eq? (restart-name r) name)) (compute-restarts)))) (if r (invoke-restart r) 'nil))) (define (create-repl target) (list "" "")) (define (listener-eval string) (call-with-values (lambda () (eval-region string)) (lambda values `(:values ,@(map (lambda (v) (format "~s" v)) values))))) (define (eval-region string) (let ((sexp (read-from-string string))) (if (eof-object? exp) (values) (eval-in-interaction-environment sexp)))) (define (read-from-string string) (call-with-port (open-string-input-port string) read)) (define (operator-arglist . _) 'nil) (define (buffer-first-change . _) 'nil) ) ;; The server proper. Does the TCP stuff and exception handling. (library (swank) (export start-server) (import (rnrs) (rnrs eval) (swank os) (swank format) (swank event-queue) (swank restarts)) (define-record-type connection (fields in-port out-port event-queue)) (define (start-server port) (accept-connections (or port 4005) #f)) (define (start-server/port-file port-file) (accept-connections #f port-file)) (define (accept-connections port port-file) (let ((sock (make-server-socket port))) (printf "Listening on port: ~s\n" (local-port sock)) (when port-file (write-port-file (local-port sock) port-file)) (let-values (((in out) (accept sock (latin-1-codec)))) (dynamic-wind (lambda () #f) (lambda () (close-socket sock) (serve in out)) (lambda () (close-port in) (close-port out)))))) (define (write-port-file port port-file) (call-with-output-file (lambda (file) (write port file)))) (define (serve in out) (let ((err (current-error-port)) (q (make-event-queue (lambda (q) (let ((e (read-event in))) (printf "read: ~s\n" e) (enqueue-event q e)))))) (dispatch-loop (make-connection in out q)))) (define-record-type sldb-state (fields level condition continuation next)) (define (dispatch-loop conn) (let ((event (wait-for-event (connection-event-queue conn) 'x))) (case (car event) ((:emacs-rex) (with-simple-restart 'toplevel "Return to SLIME's toplevel" (lambda () (apply emacs-rex conn #f (cdr event))))) (else (error "Unhandled event: ~s" event)))) (dispatch-loop conn)) (define (recover thunk on-error-thunk) (let ((ok #f)) (dynamic-wind (lambda () #f) (lambda () (call-with-values thunk (lambda vals (set! ok #t) (apply values vals)))) (lambda () (unless ok (on-error-thunk)))))) ;; Couldn't resist to exploit the prefix feature. (define rpc-entries (environment '(prefix (swank rpc) swank:))) (define (emacs-rex conn sldb-state form package thread tag) (let ((out (connection-out-port conn))) (recover (lambda () (with-exception-handler (lambda (condition) (call/cc (lambda (k) (sldb-exception-handler conn condition k sldb-state)))) (lambda () (let ((value (apply (eval (car form) rpc-entries) (cdr form)))) (write-event `(:return (:ok ,value) ,tag) out))))) (lambda () (write-event `(:return (:abort) ,tag) out))))) (define (sldb-exception-handler connection condition k sldb-state) (when (serious-condition? condition) (let ((level (if sldb-state (+ (sldb-state-level sldb-state) 1) 1)) (out (connection-out-port connection))) (write-event `(:debug 0 ,level ,@(debugger-info condition connection)) out) (dynamic-wind (lambda () #f) (lambda () (sldb-loop connection (make-sldb-state level condition k sldb-state))) (lambda () (write-event `(:debug-return 0 ,level nil) out)))))) (define (sldb-loop connection state) (apply emacs-rex connection state (cdr (wait-for-event (connection-event-queue connection) '(':emacs-rex . _)))) (sldb-loop connection state)) (define (debugger-info condition connection) (list `(,(call-with-string-output-port (lambda (port) (print-condition condition port))) ,(format " [type ~s]" (if (record? condition) (record-type-name (record-rtd condition)) )) ()) (map (lambda (r) (list (format "~a" (restart-name r)) (call-with-string-output-port (lambda (port) (write-restart-report r port))))) (compute-restarts)) '() '())) (define (print-condition obj port) (cond ((condition? obj) (let ((list (simple-conditions obj))) (case (length list) ((0) (display "Compuond condition with zero components" port)) ((1) (assert (eq? obj (car list))) (print-simple-condition (car list) port)) (else (display "Compound condition:\n" port) (for-each (lambda (c) (display " " port) (print-simple-condition c port) (newline port)) list))))) (#t (fprintf port "Non-condition object: ~s" obj)))) (define (print-simple-condition condition port) (fprintf port "~a" (record-type-name (record-rtd condition))) (case (count-record-fields condition) ((0) #f) ((1) (fprintf port ": ") (do-record-fields condition (lambda (name value) (write value port)))) (else (fprintf port ":") (do-record-fields condition (lambda (name value) (fprintf port "\n~a: ~s" name value)))))) ;; Call FUN with RECORD's rtd and parent rtds. (define (do-record-rtds record fun) (do ((rtd (record-rtd record) (record-type-parent rtd))) ((not rtd)) (fun rtd))) ;; Call FUN with RECORD's field names and values. (define (do-record-fields record fun) (do-record-rtds record (lambda (rtd) (let* ((names (record-type-field-names rtd)) (len (vector-length names))) (do ((i 0 (+ 1 i))) ((= i len)) (fun (vector-ref names i) ((record-accessor rtd i) record))))))) ;; Return the number of fields in RECORD (define (count-record-fields record) (let ((i 0)) (do-record-rtds record (lambda (rtd) (set! i (+ i (vector-length (record-type-field-names rtd)))))) i)) ) slime-2.20/contrib/swank-repl.lisp000066400000000000000000000377161315100173500171740ustar00rootroot00000000000000;;; swank-repl.lisp --- Server side part of the Lisp listener. ;; ;; License: public domain (in-package swank) (defpackage swank-repl (:use cl swank/backend) (:export *send-repl-results-function*) (:import-from swank *default-worker-thread-bindings* *loopback-interface* add-hook *connection-closed-hook* eval-region with-buffer-syntax connection connection.socket-io connection.repl-results connection.user-input connection.user-output connection.user-io connection.trace-output connection.dedicated-output connection.env multithreaded-connection mconn.active-threads mconn.repl-thread mconn.auto-flush-thread use-threads-p *emacs-connection* default-connection with-connection send-to-emacs *communication-style* handle-requests wait-for-event make-tag thread-for-evaluation socket-quest authenticate-client encode-message auto-flush-loop clear-user-input current-thread-id cat with-struct* with-retry-restart with-bindings package-string-for-prompt find-external-format-or-lose defslimefun ;; FIXME: those should be exported from swank-repl only, but how to ;; do that whithout breaking init files? *use-dedicated-output-stream* *dedicated-output-stream-port* *globally-redirect-io* )) (in-package swank-repl) (defvar *use-dedicated-output-stream* nil "When T swank will attempt to create a second connection to Emacs which is used just to send output.") (defvar *dedicated-output-stream-port* 0 "Which port we should use for the dedicated output stream.") (defvar *dedicated-output-stream-buffering* (if (eq *communication-style* :spawn) t nil) "The buffering scheme that should be used for the output stream. Valid values are nil, t, :line") (defvar *globally-redirect-io* nil "When non-nil globally redirect all standard streams to Emacs.") (defun open-streams (connection properties) "Return the 5 streams for IO redirection: DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" (let* ((input-fn (lambda () (with-connection (connection) (with-simple-restart (abort-read "Abort reading input from Emacs.") (read-user-input-from-emacs))))) (dedicated-output (if *use-dedicated-output-stream* (open-dedicated-output-stream connection (getf properties :coding-system)))) (in (make-input-stream input-fn)) (out (or dedicated-output (make-output-stream (make-output-function connection)))) (io (make-two-way-stream in out)) (repl-results (make-output-stream-for-target connection :repl-result))) (typecase connection (multithreaded-connection (setf (mconn.auto-flush-thread connection) (spawn (lambda () (auto-flush-loop out)) :name "auto-flush-thread")))) (values dedicated-output in out io repl-results))) (defun make-output-function (connection) "Create function to send user output to Emacs." (lambda (string) (with-connection (connection) (send-to-emacs `(:write-string ,string))))) (defun 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." (make-output-stream (make-output-function-for-target connection target))) (defun open-dedicated-output-stream (connection coding-system) "Open a dedicated output connection to the Emacs on SOCKET-IO. Return an output stream suitable for writing program output. This is an optimized way for Lisp to deliver output to Emacs." (let ((socket (socket-quest *dedicated-output-stream-port* nil)) (ef (find-external-format-or-lose coding-system))) (unwind-protect (let ((port (local-port socket))) (encode-message `(:open-dedicated-output-stream ,port ,coding-system) (connection.socket-io connection)) (let ((dedicated (accept-connection socket :external-format ef :buffering *dedicated-output-stream-buffering* :timeout 30))) (authenticate-client dedicated) (close-socket socket) (setf socket nil) dedicated)) (when socket (close-socket socket))))) (defmethod thread-for-evaluation ((connection multithreaded-connection) (id (eql :find-existing))) (or (car (mconn.active-threads connection)) (find-repl-thread connection))) (defmethod thread-for-evaluation ((connection multithreaded-connection) (id (eql :repl-thread))) (find-repl-thread connection)) (defun find-repl-thread (connection) (cond ((not (use-threads-p)) (current-thread)) (t (let ((thread (mconn.repl-thread connection))) (cond ((not thread) nil) ((thread-alive-p thread) thread) (t (setf (mconn.repl-thread connection) (spawn-repl-thread connection "new-repl-thread")))))))) (defun spawn-repl-thread (connection name) (spawn (lambda () (with-bindings *default-worker-thread-bindings* (repl-loop connection))) :name name)) (defun repl-loop (connection) (handle-requests connection)) ;;;;; Redirection during requests ;;; ;;; We always redirect the standard streams to Emacs while evaluating ;;; an RPC. This is done with simple dynamic bindings. (defslimefun create-repl (target &key coding-system) (assert (eq target nil)) (let ((conn *emacs-connection*)) (initialize-streams-for-connection conn `(:coding-system ,coding-system)) (with-struct* (connection. @ conn) (setf (@ env) `((*standard-input* . ,(@ user-input)) ,@(unless *globally-redirect-io* `((*standard-output* . ,(@ user-output)) (*trace-output* . ,(or (@ trace-output) (@ user-output))) (*error-output* . ,(@ user-output)) (*debug-io* . ,(@ user-io)) (*query-io* . ,(@ user-io)) (*terminal-io* . ,(@ user-io)))))) (maybe-redirect-global-io conn) (add-hook *connection-closed-hook* 'update-redirection-after-close) (typecase conn (multithreaded-connection (setf (mconn.repl-thread conn) (spawn-repl-thread conn "repl-thread")))) (list (package-name *package*) (package-string-for-prompt *package*))))) (defun initialize-streams-for-connection (connection properties) (multiple-value-bind (dedicated in out io repl-results) (open-streams connection properties) (setf (connection.dedicated-output connection) dedicated (connection.user-io connection) io (connection.user-output connection) out (connection.user-input connection) in (connection.repl-results connection) repl-results) connection)) (defun read-user-input-from-emacs () (let ((tag (make-tag))) (force-output) (send-to-emacs `(:read-string ,(current-thread-id) ,tag)) (let ((ok nil)) (unwind-protect (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value))) (setq ok t)) (unless ok (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag))))))) ;;;;; Listener eval (defvar *listener-eval-function* 'repl-eval) (defvar *listener-saved-value* nil) (defslimefun listener-save-value (slimefun &rest args) "Apply SLIMEFUN to ARGS and save the value. The saved value should be visible to all threads and retrieved via LISTENER-GET-VALUE." (setq *listener-saved-value* (apply slimefun args)) t) (defslimefun listener-get-value () "Get the last value saved by LISTENER-SAVE-VALUE. The value should be produced as if it were requested through LISTENER-EVAL directly, so that spacial variables *, etc are set." (listener-eval (let ((*package* (find-package :keyword))) (write-to-string '*listener-saved-value*)))) (defslimefun listener-eval (string &key (window-width nil window-width-p)) (if window-width-p (let ((*print-right-margin* window-width)) (funcall *listener-eval-function* string)) (funcall *listener-eval-function* string))) (defslimefun clear-repl-variables () (let ((variables '(*** ** * /// // / +++ ++ +))) (loop for variable in variables do (setf (symbol-value variable) nil)))) (defvar *send-repl-results-function* 'send-repl-results-to-emacs) (defun repl-eval (string) (clear-user-input) (with-buffer-syntax () (with-retry-restart (:msg "Retry SLIME REPL evaluation request.") (track-package (lambda () (multiple-value-bind (values last-form) (eval-region string) (setq *** ** ** * * (car values) /// // // / / values +++ ++ ++ + + last-form) (funcall *send-repl-results-function* values)))))) nil) (defun track-package (fun) (let ((p *package*)) (unwind-protect (funcall fun) (unless (eq *package* p) (send-to-emacs (list :new-package (package-name *package*) (package-string-for-prompt *package*))))))) (defun send-repl-results-to-emacs (values) (finish-output) (if (null values) (send-to-emacs `(:write-string "; No value" :repl-result)) (dolist (v values) (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) :repl-result))))) (defslimefun redirect-trace-output (target) (setf (connection.trace-output *emacs-connection*) (make-output-stream-for-target *emacs-connection* target)) nil) ;;;; IO to Emacs ;;; ;;; This code handles redirection of the standard I/O streams ;;; (`*standard-output*', etc) into Emacs. The `connection' structure ;;; contains the appropriate streams, so all we have to do is make the ;;; right bindings. ;;;;; Global I/O redirection framework ;;; ;;; Optionally, the top-level global bindings of the standard streams ;;; can be assigned to be redirected to Emacs. When Emacs connects we ;;; redirect the streams into the connection, and they keep going into ;;; that connection even if more are established. If the connection ;;; handling the streams closes then another is chosen, or if there ;;; are no connections then we revert to the original (real) streams. ;;; ;;; It is slightly tricky to assign the global values of standard ;;; streams because they are often shadowed by dynamic bindings. We ;;; solve this problem by introducing an extra indirection via synonym ;;; streams, so that *STANDARD-INPUT* is a synonym stream to ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" ;;; variables, so they can always be assigned to affect a global ;;; change. ;;;;; Global redirection setup (defvar *saved-global-streams* '() "A plist to save and restore redirected stream objects. E.g. the value for '*standard-output* holds the stream object for *standard-output* before we install our redirection.") (defun setup-stream-indirection (stream-var &optional stream) "Setup redirection scaffolding for a global stream variable. Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as *STANDARD-INPUT*. 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to *CURRENT-STANDARD-INPUT*. This has the effect of making *CURRENT-STANDARD-INPUT* contain the effective global value for *STANDARD-INPUT*. This way we can assign the effective global value even when *STANDARD-INPUT* is shadowed by a dynamic binding." (let ((current-stream-var (prefixed-var '#:current stream-var)) (stream (or stream (symbol-value stream-var)))) ;; Save the real stream value for the future. (setf (getf *saved-global-streams* stream-var) stream) ;; Define a new variable for the effective stream. ;; This can be reassigned. (proclaim `(special ,current-stream-var)) (set current-stream-var stream) ;; Assign the real binding as a synonym for the current one. (let ((stream (make-synonym-stream current-stream-var))) (set stream-var stream) (set-default-initial-binding stream-var `(quote ,stream))))) (defun prefixed-var (prefix variable-symbol) "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*" (let ((basename (subseq (symbol-name variable-symbol) 1))) (intern (format nil "*~A-~A" (string prefix) basename) :swank))) (defvar *standard-output-streams* '(*standard-output* *error-output* *trace-output*) "The symbols naming standard output streams.") (defvar *standard-input-streams* '(*standard-input*) "The symbols naming standard input streams.") (defvar *standard-io-streams* '(*debug-io* *query-io* *terminal-io*) "The symbols naming standard io streams.") (defun init-global-stream-redirection () (when *globally-redirect-io* (cond (*saved-global-streams* (warn "Streams already redirected.")) (t (mapc #'setup-stream-indirection (append *standard-output-streams* *standard-input-streams* *standard-io-streams*)))))) (defun globally-redirect-io-to-connection (connection) "Set the standard I/O streams to redirect to CONNECTION. Assigns *CURRENT-* 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-* to *REAL-* for all standard streams." (dolist (stream-var (append *standard-output-streams* *standard-input-streams* *standard-io-streams*)) (set (prefixed-var '#:current stream-var) (getf *saved-global-streams* stream-var)))) ;;;;; Global redirection hooks (defvar *global-stdio-connection* nil "The connection to which standard I/O streams are globally redirected. NIL if streams are not globally redirected.") (defun maybe-redirect-global-io (connection) "Consider globally redirecting to CONNECTION." (when (and *globally-redirect-io* (null *global-stdio-connection*) (connection.user-io connection)) (unless *saved-global-streams* (init-global-stream-redirection)) (setq *global-stdio-connection* connection) (globally-redirect-io-to-connection connection))) (defun update-redirection-after-close (closed-connection) "Update redirection after a connection closes." (check-type closed-connection connection) (when (eq *global-stdio-connection* closed-connection) (if (and (default-connection) *globally-redirect-io*) ;; Redirect to another connection. (globally-redirect-io-to-connection (default-connection)) ;; No more connections, revert to the real streams. (progn (revert-global-io-redirection) (setq *global-stdio-connection* nil))))) (provide :swank-repl) slime-2.20/contrib/swank-sbcl-exts.lisp000066400000000000000000000055531315100173500201300ustar00rootroot00000000000000;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL ;; ;; Authors: Tobias C. Rittweiler ;; ;; License: Public Domain ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-arglists)) ;; We need to do this so users can place `slime-sbcl-exts' into their ;; ~/.emacs, and still use any implementation they want. #+sbcl (progn ;;; Display arglist of instructions. ;;; (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst)) argument-forms) (flet ((decode-instruction-arglist (instr-name instr-arglist) (let ((decoded-arglist (decode-arglist instr-arglist))) ;; The arglist of INST is (instruction ...INSTR-ARGLIST...). (push 'sb-assem::instruction (arglist.required-args decoded-arglist)) (values decoded-arglist (list instr-name) t)))) (if (null argument-forms) (call-next-method) (destructuring-bind (instruction &rest args) argument-forms (declare (ignore args)) (let* ((instr-name (typecase instruction (arglist-dummy (string-upcase (arglist-dummy.string-representation instruction))) (symbol (string-downcase instruction)))) (instr-fn #+#.(swank/backend:with-symbol 'op-encoder-name 'sb-assem) (or (sb-assem::op-encoder-name instr-name) (sb-assem::op-encoder-name (string-upcase instr-name))) #+#.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem) (sb-assem::inst-emitter-symbol instr-name) #+(and (not #.(swank/backend:with-symbol 'inst-emitter-symbol 'sb-assem)) #.(swank/backend:with-symbol '*assem-instructions* 'sb-assem)) (gethash instr-name sb-assem:*assem-instructions*))) (cond ((not instr-fn) (call-next-method)) ((functionp instr-fn) (with-available-arglist (arglist) (arglist instr-fn) (decode-instruction-arglist instr-name arglist))) (t (assert (symbolp instr-fn)) (with-available-arglist (arglist) (arglist instr-fn) ;; SB-ASSEM:INST invokes a symbolic INSTR-FN with ;; current segment and current vop implicitly. (decode-instruction-arglist instr-name (if (get instr-fn :macro) arglist (cddr arglist))))))))))) ) ; PROGN (provide :swank-sbcl-exts) slime-2.20/contrib/swank-snapshot.lisp000066400000000000000000000045641315100173500200640ustar00rootroot00000000000000 (defpackage swank-snapshot (:use cl) (:export restore-snapshot save-snapshot background-save-snapshot) (:import-from swank defslimefun)) (in-package swank-snapshot) (defslimefun save-snapshot (image-file) (swank/backend:save-image image-file (let ((c swank::*emacs-connection*)) (lambda () (resurrect c)))) (format nil "Dumped lisp to ~A" image-file)) (defslimefun restore-snapshot (image-file) (let* ((conn swank::*emacs-connection*) (stream (swank::connection.socket-io conn)) (clone (swank/backend:dup (swank/backend:socket-fd stream))) (style (swank::connection.communication-style conn)) (repl (if (swank::connection.user-io conn) t)) (args (list "--swank-fd" (format nil "~d" clone) "--swank-style" (format nil "~s" style) "--swank-repl" (format nil "~s" repl)))) (swank::close-connection conn nil nil) (swank/backend:exec-image image-file args))) (defslimefun background-save-snapshot (image-file) (let ((connection swank::*emacs-connection*)) (flet ((complete (success) (let ((swank::*emacs-connection* connection)) (swank::background-message "Dumping lisp image ~A ~:[failed!~;succeeded.~]" image-file success))) (awaken () (resurrect connection))) (swank/backend:background-save-image image-file :restart-function #'awaken :completion-function #'complete) (format nil "Started dumping lisp to ~A..." image-file)))) (in-package :swank) (defun swank-snapshot::resurrect (old-connection) (setq *log-output* nil) (init-log-output) (clear-event-history) (setq *connections* (delete old-connection *connections*)) (format *error-output* "args: ~s~%" (command-line-args)) (let* ((fd (read-command-line-arg "--swank-fd")) (style (read-command-line-arg "--swank-style")) (repl (read-command-line-arg "--swank-repl")) (* (format *error-output* "fd=~s style=~s~%" fd style)) (stream (make-fd-stream fd nil)) (connection (make-connection nil stream style))) (let ((*emacs-connection* connection)) (when repl (swank::create-repl nil)) (background-message "~A" "Lisp image restored")) (serve-requests connection) (simple-repl))) (defun read-command-line-arg (name) (let* ((args (command-line-args)) (pos (position name args :test #'equal))) (read-from-string (elt args (1+ pos))))) (in-package :swank-snapshot) (provide :swank-snapshot) slime-2.20/contrib/swank-sprof.lisp000066400000000000000000000134151315100173500173510ustar00rootroot00000000000000;;; swank-sprof.lisp ;; ;; Authors: Juho Snellman ;; ;; License: MIT ;; (in-package :swank) #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (require :sb-sprof)) #+sbcl(progn (defvar *call-graph* nil) (defvar *node-numbers* nil) (defvar *number-nodes* nil) (defun frame-name (name) (if (consp name) (case (first name) ((sb-c::xep sb-c::tl-xep sb-c::&more-processor sb-c::top-level-form sb-c::&optional-processor) (second name)) (sb-pcl::fast-method (cdr name)) ((flet labels lambda) (let* ((in (member :in name))) (if (stringp (cadr in)) (append (ldiff name in) (cddr in)) name))) (t name)) name)) (defun pretty-name (name) (let ((*package* (find-package :common-lisp-user)) (*print-right-margin* most-positive-fixnum)) (format nil "~S" (frame-name name)))) (defun samples-percent (count) (sb-sprof::samples-percent *call-graph* count)) (defun node-values (node) (values (pretty-name (sb-sprof::node-name node)) (samples-percent (sb-sprof::node-count node)) (samples-percent (sb-sprof::node-accrued-count node)))) (defun filter-swank-nodes (nodes) (let ((swank-packages (load-time-value (mapcar #'find-package '(swank swank/rpc swank/mop swank/match swank/backend))))) (remove-if (lambda (node) (let ((name (sb-sprof::node-name node))) (and (symbolp name) (member (symbol-package name) swank-packages :test #'eq)))) nodes))) (defun serialize-call-graph (&key exclude-swank) (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*))) (when exclude-swank (setf nodes (filter-swank-nodes nodes))) (setf nodes (sort (copy-list nodes) #'> ;; :key #'sb-sprof::node-count))) :key #'sb-sprof::node-accrued-count)) (setf *number-nodes* (make-hash-table)) (setf *node-numbers* (make-hash-table)) (loop for node in nodes for i from 1 with total = 0 collect (multiple-value-bind (name self cumulative) (node-values node) (setf (gethash node *node-numbers*) i (gethash i *number-nodes*) node) (incf total self) (list i name self cumulative total)) into list finally (return (let ((rest (- 100 total))) (return (append list `((nil "Elsewhere" ,rest nil nil))))))))) (defslimefun swank-sprof-get-call-graph (&key exclude-swank) (when (setf *call-graph* (sb-sprof:report :type nil)) (serialize-call-graph :exclude-swank exclude-swank))) (defslimefun swank-sprof-expand-node (index) (let* ((node (gethash index *number-nodes*))) (labels ((caller-count (v) (loop for e in (sb-sprof::vertex-edges v) do (when (eq (sb-sprof::edge-vertex e) node) (return-from caller-count (sb-sprof::call-count e)))) 0) (serialize-node (node count) (etypecase node (sb-sprof::cycle (list (sb-sprof::cycle-index node) (sb-sprof::cycle-name node) (samples-percent count))) (sb-sprof::node (let ((name (node-values node))) (list (gethash node *node-numbers*) name (samples-percent count))))))) (list :callers (loop for node in (sort (copy-list (sb-sprof::node-callers node)) #'> :key #'caller-count) collect (serialize-node node (caller-count node))) :calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node)) #'> :key #'sb-sprof::call-count))) (loop for edge in edges collect (serialize-node (sb-sprof::edge-vertex edge) (sb-sprof::call-count edge)))))))) (defslimefun swank-sprof-disassemble (index) (let* ((node (gethash index *number-nodes*)) (debug-info (sb-sprof::node-debug-info node))) (with-output-to-string (s) (typecase debug-info (sb-impl::code-component (sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info) (sb-vm::%code-code-size debug-info) :stream s)) (sb-di::compiled-debug-fun (let ((component (sb-di::compiled-debug-fun-component debug-info))) (sb-disassem::disassemble-code-component component :stream s))) (t `(:error "No disassembly available")))))) (defslimefun swank-sprof-source-location (index) (let* ((node (gethash index *number-nodes*)) (debug-info (sb-sprof::node-debug-info node))) (or (when (typep debug-info 'sb-di::compiled-debug-fun) (let* ((component (sb-di::compiled-debug-fun-component debug-info)) (function (sb-kernel::%code-entry-points component))) (when function (find-source-location function)))) `(:error "No source location available")))) (defslimefun swank-sprof-start (&key (mode :cpu)) (sb-sprof:start-profiling :mode mode)) (defslimefun swank-sprof-stop () (sb-sprof:stop-profiling)) ) (provide :swank-sprof) slime-2.20/contrib/swank-trace-dialog.lisp000066400000000000000000000213531315100173500205530ustar00rootroot00000000000000(defpackage :swank-trace-dialog (:use :cl) (:import-from :swank :defslimefun :from-string :to-string) (:export #:clear-trace-tree #:dialog-toggle-trace #:dialog-trace #:dialog-traced-p #:dialog-untrace #:dialog-untrace-all #:inspect-trace-part #:report-partial-tree #:report-specs #:report-total #:report-trace-detail #:report-specs #:trace-format #:still-inside #:exited-non-locally #:*record-backtrace* #:*traces-per-report* #:*dialog-trace-follows-trace* #:find-trace-part #:find-trace)) (in-package :swank-trace-dialog) (defparameter *record-backtrace* nil "Record a backtrace of the last 20 calls for each trace. Beware that this may have a drastic performance impact on your program.") (defparameter *traces-per-report* 150 "Number of traces to report to emacs in each batch.") ;;;; `trace-entry' model ;;;; (defvar *traces* (make-array 1000 :fill-pointer 0 :adjustable t)) (defvar *trace-lock* (swank/backend:make-lock :name "swank-trace-dialog lock")) (defvar *current-trace-by-thread* (make-hash-table)) (defclass trace-entry () ((id :reader id-of) (children :accessor children-of :initform nil) (backtrace :accessor backtrace-of :initform (when *record-backtrace* (useful-backtrace))) (spec :initarg :spec :accessor spec-of :initform (error "must provide a spec")) (args :initarg :args :accessor args-of :initform (error "must provide args")) (parent :initarg :parent :reader parent-of :initform (error "must provide a parent, even if nil")) (retlist :initarg :retlist :accessor retlist-of :initform 'still-inside))) (defmethod initialize-instance :after ((entry trace-entry) &rest initargs) (declare (ignore initargs)) (if (parent-of entry) (nconc (children-of (parent-of entry)) (list entry))) (swank/backend:call-with-lock-held *trace-lock* #'(lambda () (setf (slot-value entry 'id) (fill-pointer *traces*)) (vector-push-extend entry *traces*)))) (defmethod print-object ((entry trace-entry) stream) (print-unreadable-object (entry stream) (format stream "~a: ~a" (id-of entry) (spec-of entry)))) (defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) (defun find-trace (id) (when (<= 0 id (1- (length *traces*))) (aref *traces* id))) (defun find-trace-part (id part-id type) (let* ((trace (find-trace id)) (l (and trace (ecase type (:arg (args-of trace)) (:retval (swank::ensure-list (retlist-of trace))))))) (values (nth part-id l) (< part-id (length l))))) (defun useful-backtrace () (swank/backend:call-with-debugging-environment #'(lambda () (loop for i from 0 for frame in (swank/backend:compute-backtrace 0 20) collect (list i (swank::frame-to-string frame)))))) (defun current-trace () (gethash (swank/backend:current-thread) *current-trace-by-thread*)) (defun (setf current-trace) (trace) (setf (gethash (swank/backend:current-thread) *current-trace-by-thread*) trace)) ;;;; Control of traced specs ;;; (defvar *traced-specs* '()) (defslimefun dialog-trace (spec) (flet ((before-hook (args) (setf (current-trace) (make-instance 'trace-entry :spec spec :args args :parent (current-trace)))) (after-hook (retlist) (let ((trace (current-trace))) (when trace ;; the current trace might have been wiped away if the ;; user cleared the tree in the meantime. no biggie, ;; don't do anything. ;; (setf (retlist-of trace) retlist (current-trace) (parent-of trace)))))) (when (dialog-traced-p spec) (warn "~a is apparently already traced! Untracing and retracing." spec) (dialog-untrace spec)) (swank/backend:wrap spec 'trace-dialog :before #'before-hook :after #'after-hook) (pushnew spec *traced-specs*) (format nil "~a is now traced for trace dialog" spec))) (defslimefun dialog-untrace (spec) (swank/backend:unwrap spec 'trace-dialog) (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) (format nil "~a is now untraced for trace dialog" spec)) (defslimefun dialog-toggle-trace (spec) (if (dialog-traced-p spec) (dialog-untrace spec) (dialog-trace spec))) (defslimefun dialog-traced-p (spec) (find spec *traced-specs* :test #'equal)) (defslimefun dialog-untrace-all () (untrace) (mapcar #'dialog-untrace *traced-specs*)) (defparameter *dialog-trace-follows-trace* nil) (setq swank:*after-toggle-trace-hook* #'(lambda (spec traced-p) (when *dialog-trace-follows-trace* (cond (traced-p (dialog-trace spec) "traced for trace dialog as well") (t (dialog-untrace spec) "untraced for the trace dialog as well"))))) ;;;; A special kind of trace call ;;; (defun trace-format (format-spec &rest format-args) "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." (let* ((line (apply #'format nil format-spec format-args))) (make-instance 'trace-entry :spec line :args format-args :parent (current-trace) :retlist nil))) ;;;; Reporting to emacs ;;; (defparameter *visitor-idx* 0) (defparameter *visitor-key* nil) (defvar *unfinished-traces* '()) (defun describe-trace-for-emacs (trace) `(,(id-of trace) ,(and (parent-of trace) (id-of (parent-of trace))) ,(spec-of trace) ,(loop for arg in (args-of trace) for i from 0 collect (list i (swank::to-line arg))) ,(loop for retval in (swank::ensure-list (retlist-of trace)) for i from 0 collect (list i (swank::to-line retval))))) (defslimefun report-partial-tree (key) (unless (equal key *visitor-key*) (setq *visitor-idx* 0 *visitor-key* key)) (let* ((recently-finished (loop with i = 0 for trace in *unfinished-traces* while (< i *traces-per-report*) when (completed-p trace) collect trace and do (incf i) (setq *unfinished-traces* (remove trace *unfinished-traces*)))) (new (loop for i from (length recently-finished) below *traces-per-report* while (< *visitor-idx* (length *traces*)) for trace = (aref *traces* *visitor-idx*) collect trace unless (completed-p trace) do (push trace *unfinished-traces*) do (incf *visitor-idx*)))) (list (mapcar #'describe-trace-for-emacs (append recently-finished new)) (- (length *traces*) *visitor-idx*) key))) (defslimefun report-trace-detail (trace-id) (swank::call-with-bindings swank::*inspector-printer-bindings* #'(lambda () (let ((trace (find-trace trace-id))) (when trace (append (describe-trace-for-emacs trace) (list (backtrace-of trace) (swank::to-line trace)))))))) (defslimefun report-specs () (sort (copy-list *traced-specs*) #'string< :key #'princ-to-string)) (defslimefun report-total () (length *traces*)) (defslimefun clear-trace-tree () (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) *visitor-key* nil *unfinished-traces* nil) (swank/backend:call-with-lock-held *trace-lock* #'(lambda () (setf (fill-pointer *traces*) 0))) nil) ;; HACK: `swank::*inspector-history*' is unbound by default and needs ;; a reset in that case so that it won't error `swank::inspect-object' ;; before any other object is inspected in the slime session. ;; (unless (boundp 'swank::*inspector-history*) (swank::reset-inspector)) (defslimefun inspect-trace-part (trace-id part-id type) (multiple-value-bind (obj found) (find-trace-part trace-id part-id type) (if found (swank::inspect-object obj) (error "No object found with ~a, ~a and ~a" trace-id part-id type)))) (provide :swank-trace-dialog) slime-2.20/contrib/swank-util.lisp000066400000000000000000000051741315100173500172000ustar00rootroot00000000000000;;; swank-util.lisp --- stuff of questionable utility ;; ;; License: public domain (in-package :swank) (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body) "Just like do-symbols, but makes sure a symbol is visited only once." (let ((seen-ht (gensym "SEEN-HT"))) `(let ((,seen-ht (make-hash-table :test #'eq))) (do-symbols (,var ,package ,result-form) (unless (gethash ,var ,seen-ht) (setf (gethash ,var ,seen-ht) t) (tagbody ,@body)))))) (defun classify-symbol (symbol) "Returns a list of classifiers that classify SYMBOL according to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special variable.) The list may contain the following classification keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION, :TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE" (check-type symbol symbol) (flet ((type-specifier-p (s) (or (documentation s 'type) (not (eq (type-specifier-arglist s) :not-available))))) (let (result) (when (boundp symbol) (push (if (constantp symbol) :constant :boundp) result)) (when (fboundp symbol) (push :fboundp result)) (when (type-specifier-p symbol) (push :typespec result)) (when (find-class symbol nil) (push :class result)) (when (macro-function symbol) (push :macro result)) (when (special-operator-p symbol) (push :special-operator result)) (when (find-package symbol) (push :package result)) (when (and (fboundp symbol) (typep (ignore-errors (fdefinition symbol)) 'generic-function)) (push :generic-function result)) result))) (defun symbol-classification-string (symbol) "Return a string in the form -f-c---- where each letter stands for boundp fboundp generic-function class macro special-operator package" (let ((letters "bfgctmsp") (result (copy-seq "--------"))) (flet ((flip (letter) (setf (char result (position letter letters)) letter))) (when (boundp symbol) (flip #\b)) (when (fboundp symbol) (flip #\f) (when (typep (ignore-errors (fdefinition symbol)) 'generic-function) (flip #\g))) (when (type-specifier-p symbol) (flip #\t)) (when (find-class symbol nil) (flip #\c) ) (when (macro-function symbol) (flip #\m)) (when (special-operator-p symbol) (flip #\s)) (when (find-package symbol) (flip #\p)) result))) (provide :swank-util) slime-2.20/contrib/swank.rb000066400000000000000000000167441315100173500156660ustar00rootroot00000000000000# swank.rb --- swank server for Ruby. # # This is my first Ruby program and looks probably rather strange. Some # people write Scheme interpreters when learning new languages, I # write swank backends. # # Only a few things work. # 1. Start the server with something like: ruby -r swank -e swank # 2. Use M-x slime-connect to establish a connection require "socket" def swank(port=4005) accept_connections port, false end def start_swank(port_file) accept_connections false, port_file end def accept_connections(port, port_file) server = TCPServer.new("localhost", port || 0) puts "Listening on #{server.addr.inspect}\n" if port_file write_port_file server.addr[1], port_file end socket = begin server.accept ensure server.close end begin serve socket.to_io ensure socket.close end end def write_port_file(port, filename) File.open(filename, File::CREAT|File::EXCL|File::WRONLY) do |f| f.puts port end end def serve(io) main_loop(io) end def main_loop(io) c = Connection.new(io) while true catch :swank_top_level do c.dispatch(read_packet(io)) end end end class Connection def initialize(io) @io = io end def dispatch(event) puts "dispatch: %s\n" % event.inspect case event[0] when :":emacs-rex" emacs_rex *event[1..4] else raise "Unhandled event: #{event.inspect}" end end def send_to_emacs(obj) payload = write_sexp_to_string(obj) @io.write("%06x" % payload.length) @io.write payload @io.flush end def emacs_rex(form, pkg, thread, id) proc = $rpc_entries[form[0]] args = form[1..-1]; begin raise "Undefined function: #{form[0]}" unless proc value = proc[*args] rescue Exception => exc begin pseudo_debug exc ensure send_to_emacs [:":return", [:":abort"], id] end else send_to_emacs [:":return", [:":ok", value], id] end end def pseudo_debug(exc) level = 1 send_to_emacs [:":debug", 0, level] + sldb_info(exc, 0, 20) begin sldb_loop exc ensure send_to_emacs [:":debug-return", 0, level, :nil] end end def sldb_loop(exc) $sldb_context = [self,exc] while true dispatch(read_packet(@io)) end end def sldb_info(exc, start, _end) [[exc.to_s, " [%s]" % exc.class.name, :nil], sldb_restarts(exc), sldb_backtrace(exc, start, _end), []] end def sldb_restarts(exc) [["Quit", "SLIME top-level."]] end def sldb_backtrace(exc, start, _end) bt = [] exc.backtrace[start.._end].each_with_index do |frame, i| bt << [i, frame] end bt end def frame_src_loc(exc, frame) string = exc.backtrace[frame] match = /([^:]+):([0-9]+)/.match(string) if match file,line = match[1..2] [:":location", [:":file", file], [:":line", line.to_i], :nil] else [:":error", "no src-loc for frame: #{string}"] end end end $rpc_entries = Hash.new $rpc_entries[:"swank:connection-info"] = lambda do || [:":pid", $$, :":package", [:":name", "ruby", :":prompt", "ruby> "], :":lisp-implementation", [:":type", "Ruby", :":name", "ruby", :":version", RUBY_VERSION]] end def swank_interactive_eval(string) eval(string,TOPLEVEL_BINDING).inspect end $rpc_entries[:"swank:interactive-eval"] = \ $rpc_entries[:"swank:interactive-eval-region"] = \ $rpc_entries[:"swank:pprint-eval"] = lambda { |string| swank_interactive_eval string } $rpc_entries[:"swank:throw-to-toplevel"] = lambda { throw :swank_top_level } $rpc_entries[:"swank:backtrace"] = lambda do |from, to| conn, exc = $sldb_context conn.sldb_backtrace(exc, from, to) end $rpc_entries[:"swank:frame-source-location"] = lambda do |frame| conn, exc = $sldb_context conn.frame_src_loc(exc, frame) end #ignored $rpc_entries[:"swank:buffer-first-change"] = \ $rpc_entries[:"swank:operator-arglist"] = lambda do :nil end $rpc_entries[:"swank:simple-completions"] = lambda do |prefix, pkg| swank_simple_completions prefix, pkg end # def swank_simple_completions(prefix, pkg) def read_packet(io) header = read_chunk(io, 6) len = header.hex payload = read_chunk(io, len) #$deferr.puts payload.inspect read_sexp_from_string(payload) end def read_chunk(io, len) buffer = io.read(len) raise "short read" if buffer.length != len buffer end def write_sexp_to_string(obj) string = "" write_sexp_to_string_loop obj, string string end def write_sexp_to_string_loop(obj, string) if obj.is_a? String string << "\"" string << obj.gsub(/(["\\])/,'\\\\\1') string << "\"" elsif obj.is_a? Array string << "(" max = obj.length-1 obj.each_with_index do |e,i| write_sexp_to_string_loop e, string string << " " unless i == max end string << ")" elsif obj.is_a? Symbol or obj.is_a? Numeric string << obj.to_s elsif obj == false string << "nil" elsif obj == true string << "t" else raise "Can't write: #{obj.inspect}" end end def read_sexp_from_string(string) stream = StringInputStream.new(string) reader = LispReader.new(stream) reader.read end class LispReader def initialize(io) @io = io end def read(allow_consing_dot=false) skip_whitespace c = @io.getc case c when ?( then read_list(true) when ?" then read_string when ?' then read_quote when nil then raise EOFError.new("EOF during read") else @io.ungetc(c) obj = read_number_or_symbol if obj == :"." and not allow_consing_dot raise "Consing-dot in invalid context" end obj end end def read_list(head) list = [] loop do skip_whitespace c = @io.readchar if c == ?) break else @io.ungetc(c) obj = read(!head) if obj == :"." error "Consing-dot not implemented" # would need real conses end head = false list << obj end end list end def read_string string = "" loop do c = @io.getc case c when ?" break when ?\\ c = @io.getc case c when ?\\, ?" then string << c else raise "Invalid escape char: \\%c" % c end else string << c end end string end def read_quote [:quote, read] end def read_number_or_symbol token = read_token if token.empty? raise EOFError.new elsif /^[0-9]+$/.match(token) token.to_i elsif /^[0-9]+\.[0-9]+$/.match(token) token.to_f else token.intern end end def read_token token = "" loop do c = @io.getc if c.nil? break elsif terminating?(c) @io.ungetc(c) break else token << c end end token end def skip_whitespace loop do c = @io.getc case c when ?\s, ?\n, ?\t then next when nil then break else @io.ungetc(c); break end end end def terminating?(char) " \n\t()\"'".include?(char) end end class StringInputStream def initialize(string) @string = string @pos = 0 @max = string.length end def pos() @pos end def getc if @pos == @max nil else c = @string[@pos] @pos += 1 c end end def readchar getc or raise EOFError.new end def ungetc(c) if @pos > 0 && @string[@pos-1] == c @pos -= 1 else raise "Invalid argument: %c [at %d]" % [c, @pos] end end end slime-2.20/contrib/test/000077500000000000000000000000001315100173500151615ustar00rootroot00000000000000slime-2.20/contrib/test/slime-autodoc-tests.el000066400000000000000000000176271315100173500214250ustar00rootroot00000000000000(require 'slime-autodoc) (require 'slime-tests) (require 'cl-lib) (defun slime-autodoc-to-string () "Retrieve and return autodoc for form at point." (let ((autodoc (car (slime-eval `(swank:autodoc ',(slime-autodoc--parse-context) :print-right-margin ,(window-width (minibuffer-window))))))) (if (eq autodoc :not-available) :not-available (slime-autodoc--canonicalize-whitespace autodoc)))) (defun slime-check-autodoc-at-point (arglist) (slime-test-expect (format "Autodoc in `%s' (at %d) is as expected" (buffer-string) (point)) arglist (slime-autodoc-to-string))) (defmacro define-autodoc-tests (&rest specs) `(progn ,@(cl-loop for (buffer-sexpr wished-arglist . options) in specs for fails-for = (plist-get options :fails-for) for skip-trailing-test-p = (plist-get options :skip-trailing-test-p) for i from 1 when (featurep 'ert) collect `(define-slime-ert-test ,(intern (format "autodoc-tests-%d" i)) () ,(format "Check autodoc works ok for %s" buffer-sexpr) ,@(if fails-for `(:expected-result '(satisfies (lambda (result) (ert-test-result-type-p result (if (member (slime-lisp-implementation-name) ',fails-for) :failed :passed)))))) (slime-sync-to-top-level 0.3) (slime-check-top-level) (with-temp-buffer (setq slime-buffer-package "COMMON-LISP-USER") (lisp-mode) (insert ,buffer-sexpr) (search-backward "*HERE*") (delete-region (match-beginning 0) (match-end 0)) (should (equal ,wished-arglist (slime-autodoc-to-string))) (unless ,skip-trailing-test-p (insert ")") (backward-char) (should (equal ,wished-arglist (slime-autodoc-to-string))))) (slime-sync-to-top-level 0.3))))) (define-autodoc-tests ;; Test basics ("(swank::emacs-connected*HERE*" "(emacs-connected)") ("(swank::emacs-connected *HERE*" "(emacs-connected)") ("(swank::create-socket*HERE*" "(create-socket host port &key backlog)") ("(swank::create-socket *HERE*" "(create-socket ===> host <=== port &key backlog)") ("(swank::create-socket foo *HERE*" "(create-socket host ===> port <=== &key backlog)") ;; Test that autodoc differentiates between exported and ;; unexported symbols. ("(swank:create-socket*HERE*" :not-available) ;; Test if cursor is on non-existing required parameter ("(swank::create-socket foo bar *HERE*" "(create-socket host port &key backlog)") ;; Test cursor in front of opening parenthesis ("(swank::with-struct *HERE*(foo. x y) *struct* body1)" "(with-struct (conc-name &rest names) obj &body body)" :skip-trailing-test-p t) ;; Test variable content display ("(progn swank::default-server-port*HERE*" "DEFAULT-SERVER-PORT => 4005") ;; Test that "variable content display" is not triggered for ;; trivial constants. ("(swank::create-socket t*HERE*" "(create-socket ===> host <=== port &key backlog)") ("(swank::create-socket :foo*HERE*" "(create-socket ===> host <=== port &key backlog)") ;; Test with syntactic sugar ("#'(lambda () (swank::create-socket*HERE*" "(create-socket host port &key backlog)") ("`(lambda () ,(swank::create-socket*HERE*" "(create-socket host port &key backlog)") ("(remove-if #'(lambda () (swank::create-socket*HERE*" "(create-socket host port &key backlog)") ("`(remove-if #'(lambda () ,@(swank::create-socket*HERE*" "(create-socket host port &key backlog)") ;; Test &optional ("(swank::symbol-status foo *HERE*" "(symbol-status symbol &optional\ ===> (package (symbol-package symbol)) <===)" :fails-for ("allegro" "ccl")) ;; Test context-sensitive autodoc (DEFMETHOD) ("(defmethod swank::arglist-dispatch (*HERE*" "(defmethod arglist-dispatch\ (===> operator <=== arguments) &body body)") ("(defmethod swank::arglist-dispatch :before (*HERE*" "(defmethod arglist-dispatch :before\ (===> operator <=== arguments) &body body)") ;; Test context-sensitive autodoc (APPLY) ("(apply 'swank::eval-for-emacs*HERE*" "(apply 'eval-for-emacs &optional form buffer-package id &rest args)") ("(apply #'swank::eval-for-emacs*HERE*" "(apply #'eval-for-emacs &optional form buffer-package id &rest args)" :fails-for ("ccl")) ("(apply 'swank::eval-for-emacs foo *HERE*" "(apply 'eval-for-emacs &optional form\ ===> buffer-package <=== id &rest args)") ("(apply #'swank::eval-for-emacs foo *HERE*" "(apply #'eval-for-emacs &optional form\ ===> buffer-package <=== id &rest args)" :fails-for ("ccl")) ;; Test context-sensitive autodoc (ERROR, CERROR) ("(error 'simple-condition*HERE*" "(error 'simple-condition &rest arguments\ &key format-arguments format-control)" :fails-for ("ccl")) ("(cerror \"Foo\" 'simple-condition*HERE*" "(cerror \"Foo\" 'simple-condition\ &rest arguments &key format-arguments format-control)" :fails-for ("allegro" "ccl")) ;; Test &KEY and nested arglists ("(swank::with-retry-restart (:msg *HERE*" "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" :fails-for ("allegro" "ccl")) ("(swank::with-retry-restart (:msg *HERE*(foo" "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)" :skip-trailing-test-p t :fails-for ("allegro" "ccl")) ("(swank::start-server \"/tmp/foo\" :dont-close *HERE*" "(start-server port-file &key (style swank:*communication-style*)\ ===> (dont-close swank:*dont-close*) <===)" :fails-for ("allegro" "ccl")) ;; Test declarations and type specifiers ("(declare (string *HERE*" "(declare (string &rest ===> variables <===))" :fails-for ("allegro") :fails-for ("ccl")) ("(declare ((string *HERE*" "(declare ((string &optional ===> size <===) &rest variables))") ("(declare (type (string *HERE*" "(declare (type (string &optional ===> size <===) &rest variables))") ;; Test local functions ("(flet ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") ("(macrolet ((foo (x y) `(+ ,x ,y))) (foo *HERE*" "(foo ===> x <=== y)") ("(labels ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)") ("(labels ((foo (x y) (+ x y)) (bar (y) (foo *HERE*" "(foo ===> x <=== y)" :fails-for ("cmucl" "sbcl" "allegro" "ccl"))) (def-slime-test autodoc-space (input-keys expected-message) "Emulate the inserting something followed by the space key event and verify that the right thing appears in the echo area (after a short delay)." '(("( s w a n k : : o p e r a t o r - a r g l i s t SPC" "(operator-arglist name package)")) (when noninteractive (slime-skip-test "Can't use unread-command-events in batch mode")) (let* ((keys (eval `(kbd ,input-keys))) (tag (cons nil nil)) (timerfun (lambda (tag) (throw tag nil))) (timer (run-with-timer 0.1 nil timerfun tag))) (with-temp-buffer (lisp-mode) (unwind-protect (catch tag (message nil) (select-window (display-buffer (current-buffer) t)) (setq unread-command-events (listify-key-sequence keys)) (accept-process-output) (recursive-edit)) (setq unread-command-events nil) (cancel-timer timer)) (slime-test-expect "Message after SPC" expected-message (current-message)) (accept-process-output nil (* eldoc-idle-delay 2)) (slime-test-expect "Message after edloc delay" expected-message (current-message))))) (provide 'slime-autodoc-tests) slime-2.20/contrib/test/slime-c-p-c-tests.el000066400000000000000000000051541315100173500206560ustar00rootroot00000000000000(require 'slime-c-p-c) (require 'slime-tests) (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-output" "swank::compile-file-pathname") "swank::compile-file")) ("cl:m-v-l" (("cl:multiple-value-list" "cl:multiple-values-limit") "cl:multiple-value")) ("common-lisp" (("common-lisp-user:" "common-lisp:") "common-lisp"))) (let ((completions (slime-completions prefix))) (slime-test-expect "Completion set" expected-completions completions))) (def-slime-test complete-form (buffer-sexpr wished-completion &optional skip-trailing-test-p) "" '(("(defmethod arglist-dispatch *HERE*" "(defmethod arglist-dispatch (operator arguments) body...)") ("(with-struct *HERE*" "(with-struct (conc-name names...) obj body...)") ("(with-struct *HERE*" "(with-struct (conc-name names...) obj body...)") ("(with-struct (*HERE*" "(with-struct (conc-name names...)" t) ("(with-struct (foo. bar baz *HERE*" "(with-struct (foo. bar baz names...)" t)) (slime-check-top-level) (with-temp-buffer (lisp-mode) (setq slime-buffer-package "SWANK") (insert buffer-sexpr) (search-backward "*HERE*") (delete-region (match-beginning 0) (match-end 0)) (slime-complete-form) (slime-check-completed-form buffer-sexpr wished-completion) ;; Now the same but with trailing `)' for paredit users... (unless skip-trailing-test-p (erase-buffer) (insert buffer-sexpr) (search-backward "*HERE*") (delete-region (match-beginning 0) (match-end 0)) (insert ")") (backward-char) (slime-complete-form) (slime-check-completed-form (concat buffer-sexpr ")") wished-completion)) )) (defun slime-check-completed-form (buffer-sexpr wished-completion) (slime-test-expect (format "Completed form for `%s' is as expected" buffer-sexpr) wished-completion (buffer-string) 'equal)) (provide 'slime-c-p-c-tests) slime-2.20/contrib/test/slime-cl-indent-test.txt000066400000000000000000000437241315100173500216750ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; This file is .txt, because it's not meant to be evaluated. ;;;; common-lisp-run-indentation-tests in slime-cl-ident.el ;;;; parses this and runs the specified tests. ;;; Test: indent-1 (defun foo () t) ;;; Test: indent-2 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: nil (defun foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest)) ;;; Test: indent-3 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: nil (defun foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest)) ;;; Test: indent-4 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: t (defun foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest)) ;;; Test: indent-5 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defun foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest)) ;;; Test: indent-6 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: nil (defmacro foo ((foo &optional opt1 opt2 &rest rest)) (list foo opt1 opt2 rest)) ;;; Test: indent-7 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: nil (defmacro foo ((foo &optional opt1 opt2 &rest rest)) (list foo opt1 opt2 rest)) ;;; Test: indent-8 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: t (defmacro foo ((foo &optional opt1 opt2 &rest rest)) (list foo opt1 opt2 rest)) ;;; Test: indent-9 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defmacro foo ((foo &optional opt1 opt2 &rest rest)) (list foo opt1 opt2 rest)) ;;; Test: indent-10 (let ((x y) (foo #-foo (no-foo) #+foo (yes-foo)) (bar #-bar (no-bar) #+bar (yes-bar))) (list foo bar x)) ;;; Test: indent-11 ;; ;; lisp-loop-indent-subclauses: t (loop for i from 0 below 2 for j from 0 below 2 when foo do (fubar) (bar) (moo) and collect cash into honduras else do ;; this is the body of the first else ;; the body is ... (indented to the above comment) (ZMACS gets this wrong) and do this and do that and when foo do the-other and cry when this-is-a-short-condition do (body code of the when) when here's something I used to botch do (here is a body) (rest of body indented same) do (exdented loop body) (I'm not sure I like this but it's compatible) when funny-predicate do ;; Here's a comment (body filled to comment)) ;;; Test: indent-12 (defun foo (x) (tagbody foo (bar) baz (when (losing) (with-big-loser (yow) ((lambda () foo) big))) (flet ((foo (bar baz zap) (zip)) (zot () quux)) (do () ((lose) (foo 1)) (quux) foo (lose)) (cond ((x) (win 1 2 (foo))) (t (lose 3)))))) ;;; Test: indent-13 (if* (eq t nil) then () () elseif (dsf) thenret x else (balbkj) (sdf)) ;;; Test: indent-14 (list foo #+foo (foo) #-foo (no-foo)) ;;; Test: indent-15 ;; ;; lisp-loop-indent-subclauses: t (loop for x in foo1 for y in quux1 ) ;;; Test: indent-16 ;; ;; lisp-loop-indent-subclauses: nil (loop for x in foo1 for y in quux1 ) ;;; Test: indent-17 ;; ;; lisp-loop-indent-subclauses: nil ;; lisp-loop-indent-forms-like-keywords: t (loop for x in foo for y in quux finally (foo) (fo) (zoo) do (print x) (print y) (print 'ok!)) ;;; Test: indent-18 ;; ;; lisp-loop-indent-subclauses: nil ;; lisp-loop-indent-forms-like-keywords: nil (loop for x in foo for y in quux finally (foo) (fo) (zoo) do (print x) (print y) (print 'ok!)) ;;; Test: indent-19 ;; ;; lisp-loop-indent-subclauses: t ;; lisp-loop-indent-forms-like-keywords: nil (loop for x in foo for y in quux finally (foo) (fo) (zoo) do (print x) (print y) (print 'ok!)) ;;; Test: indent-20 ;; ;; lisp-loop-indent-subclauses: nil ;; lisp-loop-indent-forms-like-keywords: nil (loop for f in files collect (open f :direction :output) do (foo) (bar) (quux)) ;;; Test: indent-21 ;; ;; lisp-loop-indent-subclauses: t (loop for f in files collect (open f :direction :output) do (foo) (bar) (quux)) ;;; Test: indent-22 (defsetf foo bar "the doc string") ;;; Test: indent-23 (defsetf foo bar "the doc string") ;;; Test: indent-24 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t (defsetf foo (x y &optional a z) (a b c) stuff) ;;; Test: indent-25 ;; ;; lisp-align-keywords-in-calls: t (make-instance 'foo :bar t :quux t :zot t) ;;; Test: indent-26 ;; ;; lisp-align-keywords-in-calls: nil (make-instance 'foo :bar t :quux t :zot t) ;;; Test: indent-27 ;; ;; lisp-lambda-list-indentation: nil (defun example (a b &optional o1 o2 o3 o4 &rest r &key k1 k2 k3 k4) 'hello) ;;; Test: indent-28 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (destructuring-bind (foo &optional x y &key bar quux) foo body) ;;; Test: indent-29 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (named-lambda foo (x &optional y z &rest more) body) ;;; Test: indent-30 (foo fii (or x y) t bar) ;;; Test: indent-31 (foo (bar)) ;;; Test: indent-32 ;; ;; comment-indent-function: (lambda () nil) ;; comment-column: nil (unknown (;; KLUDGE: comment-indent hackery to get ;; the comment right. Otherwise we get a ;; space before the first ;. bar quux zot) (#|fii|# zot) ( quux)) ;;; Test: indent-33 (complex-indent.1 ((x z f ((fox foo foo)) :note (ding bar quux zot) :wait (this! is a funcall)) ;; Not 100% sure this should not be a step left. (abbb) (abb)) (bodyform) (another)) ;;; Test: indent-34 (complex-indent.2 (bar quux zot) (a b c d) (form1) (form2)) ;;; Test: indent-35 (complex-indent.3 (:wait fii (this is a funcall)) (bodyform) (another)) ;;; Test: indent-36 (defmacro foo (body) `(let (,@(stuff) ,(more-stuff) ,(even-more) (foo foo)) ,@bofy)) ;;; Test: indent-37 (defun foo () `(list foo bar ,@(quux fo foo))) ;;; Test: indent-38 (defmacro foofoo (body) `(foo `(let (,',@,(stuff) ,(more-stuff) ,(even-more) (foo foo)) ,@bofy))) ;;; Test: indent-39 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defstruct (foo (:constructor make-foo (&optional bar quux &key zot fii))) bar quux zot fii) ;;; Test: indent-40 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defmethod foo :around (zot &key x y) (list zot)) ;;; Test: indent-41 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (progn (defmethod foo :around (fii &key x y) (list fii))) ;;; Test: indent-42 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (progn (defgeneric foo (x y &optional a b) (:method :around (a b &optional x y) (list a b x y)))) ;;; Test: indent-43 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defgeneric foo (x &optional a b) (:method (x y &optional a b) (list x y a b))) ;;; Test: indent-44 (let (definer foo bar quux) ...) ;;; Test: indent-45 (let (definition foo bar quux) ...) ;;; Test: indent-46 (let (foo bar quux) ...) ;;; Test: indent-47 (with-compilation-unit (:foo t :quux nil) ...) ;;; Test: indent-48 (cond ((> x y) (foo) ;; This isn't ideal -- I at least would align with (FOO here. (bar) (quux) (zot)) (qux (foo) (bar) (zot)) (zot (foo) (foo2)) (t (foo) (bar))) ;;; Test: indent-49 (cond ((> x y) (foo) ;; This isn't ideal -- I at least would align with (FOO here. (bar)) (qux (foo) (bar)) (zot (foo)) (t (foo) (bar))) ;;; Test: indent-50 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: nil (defun foo (x &optional opt1 opt2 &rest rest &allow-other-keys) (list opt1 opt2 rest)) ;;; Test: indent-51 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: nil (defun foo (x &optional opt1 opt2 &rest rest &allow-other-keys) (list opt1 opt2 rest)) ;;; Test: indent-52 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: t (defun foo (x &optional opt1 opt2 &rest rest &allow-other-keys) (list opt1 opt2 rest)) ;;; Test: indent-53 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defun foo (x &optional opt1 opt2 &rest rest &allow-other-keys) (list opt1 opt2 rest)) ;;; Test: indent-54 ;; (loop (foo) ;; comment (bar) (quux)) ;;; Test: indent-55 ;; (loop ;; comment (foo) (bar)) ;;; Test: indent-56 ;; (loop (foo) ;; comment (bar)) ;;; Test: indent-57 ;; (loop ;; comment (foo) (bar)) ;;; Test: indent-58 ;; ;; lisp-loop-indent-subclauses: t (loop ;; comment at toplevel of the loop with foo = t do (foo foo) (foo)) ;;; Test: indent-59 ;; ;; lisp-loop-indent-subclauses: nil (loop ;; comment at toplevel of the loop with foo = t do (foo foo) (foo)) ;;; Test: indent-60 ;; ;; lisp-loop-indent-subclauses: t (loop ;; comment at toplevel of the loop with foo = t do (foo foo)) ;;; Test: indent-61 ;; ;; lisp-loop-indent-subclauses: nil (loop ;; comment at toplevel of the loop with foo = t do (foo foo) (foo)) ;;; Test: indent-62 ;; ;; lisp-loop-indent-subclauses: t (loop with foo = t do (foo foo) ;; comment inside clause (bar)) ;;; Test: indent-63 ;; ;; lisp-loop-indent-subclauses: nil (loop with foo = t do (foo foo) ;; comment inside clause (bar)) ;;; Test: indent-64 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defmethod (setf foo) :around (zot &key x y) (list zot)) ;;; Test: indent-65 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defmethod (setf foo) :around (zot &key x y) (list zot)) ;;; Test: indent-66 ;; (define-condition foo (bar quux zot) () (:report "foo")) ;;; Test: indent-67 ;; (defclass foo (bar quxx xoo) () (:metaclass foo-class)) ;;; Test: indent-68 ;; ;; lisp-loop-indent-subclauses: nil (progn (loop repeat 1000 do ;; This is the ;; beginning (foo)) (loop repeat 100 ;; This too ;; is a beginning do (foo))) ;;; Test: indent-69 ;; ;; lisp-loop-indent-subclauses: t (progn (loop repeat 1000 do ;; This is the ;; beginning (foo)) (loop repeat 100 ;; This too ;; is a beginning do (foo))) ;;; Test: indent-70 ;; ;; lisp-loop-indent-subclauses: nil (progn (loop :repeat 1000 #:do ;; This is the ;; beginning (foo)) (loop #:repeat 100 ;; This too ;; is a beginning :do (foo))) ;;; Test: indent-71 ;; ;; lisp-loop-indent-subclauses: t (progn (loop #:repeat 1000 #:do ;; This is the ;; beginning (foo)) (loop :repeat 100 ;; This too ;; is a beginning #:do (foo))) ;;; Test: indent-72 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: nil (flet ((foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest))) ...) ;;; Test: indent-73 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: nil (flet ((foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest))) ...) ;;; Test: indent-74 ;; ;; lisp-lambda-list-keyword-parameter-alignment: nil ;; lisp-lambda-list-keyword-alignment: t (flet ((foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest))) ...) ;;; Test: indent-75 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (flet ((foo (foo &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest))) ...) ;;; Test: indent-76 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (macrolet ((foo (foo (&optional xopt1 xopt2 &rest xrest) &optional opt1 opt2 &rest rest) (list foo opt1 opt2 rest))) ...) ;;; Test: indent-77 ;; ;; lisp-align-keywords-in-calls: t (foo *foo* :bar t :quux #+quux t #-quux nil :zot t) ;;; Test: indent-78 ;; ;; lisp-align-keywords-in-calls: t (foo *foo* :fii t :bar t :quux #+quux t #+zot nil :zot t) ;;; Test: indent-79 (foo #+quux :quux #+quux t #-quux :zoo #-quux t) ;;; Test: indent-80 ;; ;; lisp-align-keywords-in-calls: t (foo *foo* :fii t :bar t #+quux :quux #+quux t :zot t) ;;; Test: indent-81 ;; ;; lisp-align-keywords-in-calls: t (foo *foo* :fii t :bar t #+quux #+quux :quux t :zot t) ;;; Test: indent-82 ;; ;; lisp-align-keywords-in-calls: t (foo *foo* :fii t :bar t #+quux :quux #+quux t :zot t) ;;; Test: indent-83 ;; ;; lisp-align-keywords-in-calls: t (foo *foo* :fii t :bar t #+quux #+quux :quux t :zot t) ;;; Test: indent-84 (and ;; Foo (something) ;; Quux (more)) ;;; Test: indent-85 (and ;; Foo (something) ;; Quux (more)) ;;; Test: indent-86 (foo ( bar quux zor)) ;;; Test: indent-87 ;; ;; lisp-lambda-list-keyword-parameter-alignment: t ;; lisp-lambda-list-keyword-alignment: t (defmacro foo ((foo &optional (opt1 (or (this) (that))) (opt2 (the-default) opt2-p) (opt3 (the-default (foo) (bar))) &rest rest)) (list foo opt1 opt2 rest)) ;;; Test: indent-88 (defstruct (foo (:constructor make-foo (bar &aux (quux (quux-from-bar bar :for 'foo))))) bar quux) ;;; Test: indent-89 (define-tentative-thing foo (bar) quux) ;;; Test: indent-90 (define-tentative-thing foo bar quux) ;;; Test: indent-91 ;; ;; lisp-loop-indent-body-forms-relative-to-loop-start: t (loop for foo in bar do (progn foo bar baz)) ;;; Test: indent-92 ;; ;; lisp-loop-indent-body-forms-relative-to-loop-start: t ;; lisp-loop-clauses-indentation: 4 (loop for foo in bar do (progn foo bar baz)) ;;; Test: indent-93 ;; ;; lisp-loop-clauses-indentation: 4 (loop for foo in bar doing (progn foo bar baz)) ;;; Test: indent-94 ;; ;; lisp-loop-clauses-indentation: 4 ;; lisp-loop-body-forms-indentation: 1 (loop for foo in bar doing (list foo bar baz)) ;;; Test: indent-95 ;; ;; lisp-loop-body-forms-indentation: 1 ;; lisp-loop-indent-body-forms-relative-to-loop-start: t (loop for foo in bar do (list foo bar baz)) slime-2.20/contrib/test/slime-enclosing-context-tests.el000066400000000000000000000033131315100173500234150ustar00rootroot00000000000000(require 'slime-enclosing-context) (require 'slime-tests) (require 'cl-lib) (def-slime-test enclosing-context.1 (buffer-sexpr wished-bound-names wished-bound-functions) "Check that finding local definitions work." '(("(flet ((,nil ())) (let ((bar 13) (,foo 42)) *HERE*))" ;; We used to return ,foo here, but we do not anymore. We ;; still return ,nil for the `slime-enclosing-bound-functions', ;; though. The first one is used for local M-., whereas the ;; latter is used for local autodoc. It does not seem too ;; important for local M-. to work on such names. \(The reason ;; that it does not work anymore, is that ;; `slime-symbol-at-point' now does TRT and does not return a ;; leading comma anymore.\) ("bar" nil nil) ((",nil" "()"))) ("(flet ((foo ())) (quux) (bar *HERE*))" ("foo") (("foo" "()")))) (slime-check-top-level) (with-temp-buffer (let ((tmpbuf (current-buffer))) (lisp-mode) (insert buffer-sexpr) (search-backward "*HERE*") (cl-multiple-value-bind (bound-names points) (slime-enclosing-bound-names) (slime-check "Check enclosing bound names" (cl-loop for name in wished-bound-names always (member name bound-names)))) (cl-multiple-value-bind (fn-names fn-arglists points) (slime-enclosing-bound-functions) (slime-check "Check enclosing bound functions" (cl-loop for (name arglist) in wished-bound-functions always (and (member name fn-names) (member arglist fn-arglists))))) ))) (provide 'slime-enclosing-context-tests) slime-2.20/contrib/test/slime-fontifying-fu-tests.el000066400000000000000000000046271315100173500225470ustar00rootroot00000000000000(require 'slime-fontifying-fu) (require 'slime-tests) (def-slime-test font-lock-magic (buffer-content) "Some testing for the font-lock-magic. *YES* should be highlighted as a suppressed form, *NO* should not." '(("(defun *NO* (x y) (+ x y))") ("(defun *NO*") ("*NO*) #-(and) (*YES*) (*NO* *NO*") ("\( \(defun *NO*") ("\) \(defun *NO* \( \)") ("#+#.foo \(defun *NO* (x y) (+ x y))") ("#+#.foo \(defun *NO* (x ") ("#+( \(defun *NO* (x ") ("#+(test) \(defun *NO* (x ") ("(eval-when (...) \(defun *NO* (x ") ("(eval-when (...) #+(and) \(defun *NO* (x ") ("#-(and) (defun *YES* (x y) (+ x y))") (" #-(and) (defun *YES* (x y) (+ x y)) #+(and) (defun *NO* (x y) (+ x y))") ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))") ("#| #+(or) |# *NO*") ("#| #+(or) x |# *NO*") ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*") ("#+#.foo (defun foo (bar)) #-(and) *YES* *NO* bar ") ("#+(foo) (defun foo (bar)) #-(and) *YES* *NO* bar") ("#| #+(or) |# *NO* foo #-(and) *YES* *NO*") ("#- (and) \(*YES*) \(*NO*) #-(and) \(*YES*) \(*NO*)") ("#+nil (foo) #-(and) #+nil ( asdf *YES* a fsdfad) \( asdf *YES* ) \(*NO*) ") ("*NO* #-(and) \(progn #-(and) (defun *YES* ...) #+(and) (defun *YES* ...) (defun *YES* ...) *YES* *YES* *YES* *YES* \) *NO*") ("#-(not) *YES* *NO* *NO* #+(not) *NO* *NO* *NO* #+(not a b c) *NO* *NO* *NO*")) (slime-check-top-level) (with-temp-buffer (insert buffer-content) (slime-initialize-lisp-buffer-for-test-suite :autodoc t :font-lock-magic t) ;; Can't use `font-lock-fontify-buffer' because for the case when ;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on ;; actual display. (font-lock-default-fontify-buffer) (when (search-backward "*NO*" nil t) (slime-test-expect "Not suppressed by reader conditional?" 'slime-reader-conditional-face (get-text-property (point) 'face) #'(lambda (x y) (not (eq x y))))) (goto-char (point-max)) (when (search-backward "*YES*" nil t) (slime-test-expect "Suppressed by reader conditional?" 'slime-reader-conditional-face (get-text-property (point) 'face))))) (provide 'slime-fontifying-fu-tests) slime-2.20/contrib/test/slime-indentation-tests.el000066400000000000000000000062561315100173500222770ustar00rootroot00000000000000(require 'slime-indentation) (require 'slime-tests) (define-common-lisp-style "common-lisp-indent-test" ;; Used to specify a few complex indentation specs for testing. (:inherit "basic") (:indentation (complex-indent.1 ((&whole 4 (&whole 1 1 1 1 (&whole 1 1) &rest 1) &body) &body)) (complex-indent.2 (4 (&whole 4 &rest 1) &body)) (complex-indent.3 (4 &body)))) (defun slime-indentation-mess-up-indentation () (while (not (eobp)) (forward-line 1) (unless (looking-at "^$") (cl-case (random 2) (0 ;; Delete all leading whitespace -- except for ;; comment lines. (while (and (looking-at " ") (not (looking-at " ;"))) (delete-char 1))) (1 ;; Insert whitespace random. (let ((n (1+ (random 24)))) (while (> n 0) (cl-decf n) (insert " "))))))) (buffer-string)) (eval-and-compile (defun slime-indentation-test-form (test-name bindings expected) `(define-slime-ert-test ,test-name () ,(format "An indentation test named `%s'" test-name) (with-temp-buffer (lisp-mode) (setq indent-tabs-mode nil) (common-lisp-set-style "common-lisp-indent-test") (let ,(cons `(expected ,expected) bindings) (insert expected) (goto-char (point-min)) (let ((mess (slime-indentation-mess-up-indentation))) (when (string= mess expected) (ert-fail "Could not mess up indentation?")) (indent-region (point-min) (point-max)) (delete-trailing-whitespace) (should (equal expected (buffer-string)))))))) (defun slime-indentation-test-forms-for-file (file) (with-current-buffer (find-file-noselect (concat slime-path "/contrib/test/slime-cl-indent-test.txt")) (goto-char (point-min)) (cl-loop while (re-search-forward ";;; Test:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t) for test-name = (intern (match-string-no-properties 1)) for bindings = (save-restriction (narrow-to-region (point) (progn (forward-comment (point-max)) (point))) (save-excursion (goto-char (point-min)) (cl-loop while (re-search-forward "\\([^\s]*\\)[\t\n\s]*:[\t\n\s]*\\(.*\\)[\t\n\s]" nil t) collect (list (intern (match-string-no-properties 1)) (car (read-from-string (match-string-no-properties 2))))))) for expected = (buffer-substring-no-properties (point) (scan-sexps (point) 1)) collect (slime-indentation-test-form test-name bindings expected))))) (defmacro slime-indentation-define-tests () `(progn ,@(slime-indentation-test-forms-for-file "slime-cl-indent-test.txt"))) (slime-indentation-define-tests) (provide 'slime-indentation-tests) slime-2.20/contrib/test/slime-macrostep-tests.el000066400000000000000000000255711315100173500217610ustar00rootroot00000000000000;; Tests for slime-macrostep. The following are expected failures: ;; - Under CLISP, highlighting of macro sub-forms fails because our ;; pretty-printer dispatch table hacking causes infinite recursion: ;; see comment in swank-macrostep.lisp ;; - COLLECT-MACRO-FORMS does not catch compiler macros under CLISP ;; and ABCL ;; - Under CCL and ECL, compiler macro calls returned by ;; COLLECT-MACRO-FORMS are not EQ to the original form, and so are ;; not detected by the tracking pretty-printer mechanism. This ;; could be fixed by adding :TEST #'EQUAL to the POSITION call ;; within MAKE-TRACKING-PPRINT-DISPATCH, at the cost of introducing ;; false positives. ;; ECL has two other issues: ;; - it currently lacks a working SLIME defimplementation for ;; MACROEXPAND-ALL (Github issue #157), without which none of the ;; expand-in-context stuff works. ;; - the environments consed up by its WALKER:MACROEXPAND-ALL ;; function are slightly broken, and do not work when passed to ;; MACROEXPAND-1 unless fixed up via ;; (subst 'si::macro 'walker::macro env) (require 'slime-macrostep) (require 'slime-tests) (require 'cl-lib) (defun slime-macrostep-eval-definitions (definitions) (slime-check-top-level) (slime-compile-string definitions 0) (slime-sync-to-top-level 5)) (defmacro slime-macrostep-with-text (buffer-text &rest body) (declare (indent 1)) `(with-temp-buffer (lisp-mode) (save-excursion (insert ,buffer-text)) ,@body)) (defun slime-macrostep-search (form) "Search forward for FORM, leaving point at its first character." (let ((case-fold-search t) (search-spaces-regexp "\\s-+")) (re-search-forward (regexp-quote form))) (goto-char (match-beginning 0))) (def-slime-test (slime-macrostep-expand-defmacro) (definition buffer-text original expansion) "Test that simple macrostep expansion works." '(("(defmacro macrostep-dummy-macro (&rest args) `(expansion of ,@args))" "(progn (first body form) (second body form) (macrostep-dummy-macro (first (argument)) second (third argument)) (remaining body forms))" "(macrostep-dummy-macro (first (argument)) second (third argument))" "(expansion of (first (argument)) second (third argument))")) (slime-macrostep-eval-definitions definition) (slime-macrostep-with-text buffer-text (slime-macrostep-search original) (macrostep-expand) (slime-test-expect "Macroexpansion is correct" expansion (downcase (slime-sexp-at-point)) #'slime-test-macroexpansion=))) (def-slime-test (slime-macrostep-fontify-macros (:fails-for "clisp" "ECL")) (definition buffer-text original subform) "Test that macro forms in expansions are font-locked" '(("(defmacro macrostep-dummy-1 (&rest args) `(expansion including (macrostep-dummy-2 ,@args))) (defmacro macrostep-dummy-2 (&rest args) `(final expansion of ,@args))" "(progn (first body form) (second body form) (macrostep-dummy-1 (first (argument)) second (third argument)) (remaining body forms))" "(macrostep-dummy-1 (first (argument)) second (third argument))" "(macrostep-dummy-2 (first (argument)) second (third argument))")) (slime-macrostep-eval-definitions definition) (slime-macrostep-with-text buffer-text (slime-macrostep-search original) (macrostep-expand) (slime-macrostep-search subform) (forward-char) ; move over open paren (slime-check "Head of macro form in expansion is fontified correctly" (eq (get-char-property (point) 'font-lock-face) 'macrostep-macro-face)))) (def-slime-test (slime-macrostep-fontify-compiler-macros (:fails-for "armedbear" "clisp" "ccl" "ECL")) (definition buffer-text original subform) "Test that compiler-macro forms in expansions are font-locked" '(("(defmacro macrostep-dummy-3 (&rest args) `(expansion including (macrostep-dummy-4 ,@args))) (defun macrostep-dummy-4 (&rest args) args) (define-compiler-macro macrostep-dummy-4 (&rest args) `(compile-time expansion of ,@args))" "(progn (first body form) (second body form) (macrostep-dummy-3 first second third) (remaining body forms))" "(macrostep-dummy-3 first second third)" "(macrostep-dummy-4 first second third)")) (slime-macrostep-eval-definitions definition) (slime-macrostep-with-text buffer-text (slime-macrostep-search original) (let ((macrostep-expand-compiler-macros t)) (macrostep-expand)) (slime-macrostep-search subform) (forward-char) ; move over open paren (slime-check "Head of compiler-macro in expansion is fontified correctly" (eq (get-char-property (point) 'font-lock-face) 'macrostep-compiler-macro-face)))) (def-slime-test (slime-macrostep-expand-macrolet (:fails-for "ECL")) (definitions buffer-text expansions) "Test that calls to macrolet-defined macros are expanded." '((nil "(macrolet ((test (&rest args) `(expansion of ,@args))) (first body form) (second body form) (test (strawberry pie) and (apple pie)) (final body form))" (("(test (strawberry pie) and (apple pie))" "(EXPANSION OF (STRAWBERRY PIE) AND (APPLE PIE))"))) ;; From swank.lisp: (nil "(macrolet ((define-xref-action (xref-type handler) `(defmethod xref-doit ((type (eql ,xref-type)) thing) (declare (ignorable type)) (funcall ,handler thing)))) (define-xref-action :calls #'who-calls) (define-xref-action :calls-who #'calls-who) (define-xref-action :references #'who-references) (define-xref-action :binds #'who-binds) (define-xref-action :macroexpands #'who-macroexpands) (define-xref-action :specializes #'who-specializes) (define-xref-action :callers #'list-callers) (define-xref-action :callees #'list-callees))" (("(define-xref-action :calls #'who-calls)" "(DEFMETHOD XREF-DOIT ((TYPE (EQL :CALLS)) THING) (DECLARE (IGNORABLE TYPE)) (FUNCALL #'WHO-CALLS THING))") ("(define-xref-action :macroexpands #'who-macroexpands)" "(DEFMETHOD XREF-DOIT ((TYPE (EQL :MACROEXPANDS)) THING) (DECLARE (IGNORABLE TYPE)) (FUNCALL #'WHO-MACROEXPANDS THING))") ("(define-xref-action :callees #'list-callees)" "(DEFMETHOD XREF-DOIT ((TYPE (EQL :CALLEES)) THING) (DECLARE (IGNORABLE TYPE)) (FUNCALL #'LIST-CALLEES THING))"))) ;; Test expansion of shadowed definitions (nil "(macrolet ((test-macro (&rest forms) (cons 'outer-definition forms))) (test-macro first (call)) (macrolet ((test-macro (&rest forms) (cons 'inner-definition forms))) (test-macro (second (call)))))" (("(test-macro first (call))" "(OUTER-DEFINITION FIRST (CALL))") ("(test-macro (second (call)))" "(INNER-DEFINITION (SECOND (CALL)))"))) ;; Expansion of macro-defined local macros ("(defmacro with-local-dummy-macro (&rest body) `(macrolet ((dummy (&rest args) `(expansion (of) ,@args))) ,@body))" "(with-local-dummy-macro (dummy form (one)) (dummy (form two)))" (("(dummy form (one))" "(EXPANSION (OF) FORM (ONE))") ("(dummy (form two))" "(EXPANSION (OF) (FORM TWO))")))) (when definitions (slime-macrostep-eval-definitions definitions)) (slime-macrostep-with-text buffer-text ;; slime-test-macroexpansion= does not expect tab characters, ;; so make sure that Emacs does not insert them (let ((indent-tabs-mode nil)) (cl-loop for (original expansion) in expansions do (goto-char (point-min)) (slime-macrostep-search original) (macrostep-expand) (slime-test-expect "Macroexpansion is correct" expansion (slime-sexp-at-point) #'slime-test-macroexpansion=))))) (def-slime-test (slime-macrostep-fontify-local-macros (:fails-for "clisp" "ECL")) () "Test that locally-bound macros are highlighted in expansions." '(()) (slime-macrostep-with-text "(macrolet ((frob (&rest args) (if (zerop (length args)) nil `(cons ,(car args) (frob ,@(cdr args)))))) (frob 1 2 3 4 5))" (let ((expansions '(("(frob 1 2 3 4 5)" "(CONS 1 (FROB 2 3 4 5))" "(FROB 2 3 4 5)") ("(FROB 2 3 4 5)" "(CONS 2 (FROB 3 4 5))" "(FROB 3 4 5)") ("(FROB 3 4 5)" "(CONS 3 (FROB 4 5))" "(FROB 4 5)") ("(FROB 4 5)" "(CONS 4 (FROB 5))" "(FROB 5)") ("(FROB 5)" "(CONS 5 (FROB))" "(FROB)") ;; ("(FROB)" ;; "NIL" ;; nil) ))) (cl-loop for (original expansion subform) in expansions do (goto-char (point-min)) (slime-macrostep-search original) (macrostep-expand) (slime-test-expect "Macroexpansion is correct" expansion (slime-sexp-at-point) #'slime-test-macroexpansion=) (when subform (slime-macrostep-search subform) (forward-char) (slime-check "Head of macro form in expansion is fontified correctly" (eq (get-char-property (point) 'font-lock-face) 'macrostep-macro-face))))))) (def-slime-test (slime-macrostep-handle-unreadable-objects) (definitions buffer-text subform expansion) "Check that macroexpansion succeeds in a context containing unreadable objects." '(("(defmacro macrostep-dummy-5 (&rest args) `(expansion of ,@args))" "(progn # (macrostep-dummy-5 quux frob))" "(macrostep-dummy-5 quux frob)" "(EXPANSION OF QUUX FROB)")) (slime-macrostep-eval-definitions definitions) (slime-macrostep-with-text buffer-text (slime-macrostep-search subform) (macrostep-expand) (slime-test-expect "Macroexpansion is correct" expansion (slime-sexp-at-point) #'slime-test-macroexpansion=))) (provide 'slime-macrostep-tests) slime-2.20/contrib/test/slime-mdot-fu-tests.el000066400000000000000000000021621315100173500213260ustar00rootroot00000000000000(require 'slime-mdot-fu) (require 'slime-tests) (def-slime-test find-local-definitions.1 (buffer-sexpr definition target-regexp) "Check that finding local definitions work." '(((defun foo (x) (let ((y (+ x 1))) (- x y *HERE*))) y "(y (+ x 1))") ((defun bar (x) (flet ((foo (z) (+ x z))) (* x (foo *HERE*)))) foo "(foo (z) (+ x z))") ((defun quux (x) (flet ((foo (z) (+ x z))) (let ((foo (- 1 x))) (+ x foo *HERE*)))) foo "(foo (- 1 x)") ((defun zurp (x) (macrolet ((frob (x y) `(quux ,x ,y))) (frob x *HERE*))) frob "(frob (x y)")) (slime-check-top-level) (with-temp-buffer (let ((tmpbuf (current-buffer))) (insert (prin1-to-string buffer-sexpr)) (search-backward "*HERE*") (slime-edit-local-definition (prin1-to-string definition)) (slime-sync) (slime-check "Check that we didnt leave the temp buffer." (eq (current-buffer) tmpbuf)) (slime-check "Check that we are at the local definition." (looking-at (regexp-quote target-regexp)))))) (provide 'slime-mdot-fu-tests) slime-2.20/contrib/test/slime-parse-tests.el000066400000000000000000000041671315100173500210740ustar00rootroot00000000000000(require 'slime-parse) (require 'slime-tests) (defun slime-check-buffer-form (result-form) (slime-test-expect (format "Buffer form correct in `%s' (at %d)" (buffer-string) (point)) result-form (slime-parse-form-upto-point 10))) (def-slime-test form-up-to-point.1 (buffer-sexpr result-form &optional skip-trailing-test-p) "" `(("(char= #\\(*HERE*" ("char=" "#\\(" ,slime-cursor-marker)) ("(char= #\\( *HERE*" ("char=" "#\\(" "" ,slime-cursor-marker)) ("(char= #\\) *HERE*" ("char=" "#\\)" "" ,slime-cursor-marker)) ("(char= #\\*HERE*" ("char=" "#\\" ,slime-cursor-marker) t) ("(defun*HERE*" ("defun" ,slime-cursor-marker)) ("(defun foo*HERE*" ("defun" "foo" ,slime-cursor-marker)) ("(defun foo (x y)*HERE*" ("defun" "foo" ("x" "y") ,slime-cursor-marker)) ("(defun foo (x y*HERE*" ("defun" "foo" ("x" "y" ,slime-cursor-marker))) ("(apply 'foo*HERE*" ("apply" "'foo" ,slime-cursor-marker)) ("(apply #'foo*HERE*" ("apply" "#'foo" ,slime-cursor-marker)) ("(declare ((vector bit *HERE*" ("declare" (("vector" "bit" "" ,slime-cursor-marker)))) ("(with-open-file (*HERE*" ("with-open-file" ("" ,slime-cursor-marker))) ("(((*HERE*" ((("" ,slime-cursor-marker)))) ("(defun #| foo #| *HERE*" ("defun" "" ,slime-cursor-marker)) ("(defun #-(and) (bar) f*HERE*" ("defun" "f" ,slime-cursor-marker)) ("(remove-if #'(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") ,slime-cursor-marker))) ("`(remove-if ,(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") ,slime-cursor-marker))) ("`(remove-if ,@(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") ,slime-cursor-marker)))) (slime-check-top-level) (with-temp-buffer (lisp-mode) (insert buffer-sexpr) (search-backward "*HERE*") (delete-region (match-beginning 0) (match-end 0)) (slime-check-buffer-form result-form) (unless skip-trailing-test-p (insert ")") (backward-char) (slime-check-buffer-form result-form)) )) (provide 'slime-parse-tests) slime-2.20/contrib/test/slime-presentations-tests.el000066400000000000000000000041071315100173500226520ustar00rootroot00000000000000(require 'slime-presentations) (require 'slime-tests) (require 'slime-repl-tests "test/slime-repl-tests") (define-slime-ert-test pick-up-presentation-at-point () "Ensure presentations are found consistently." (cl-labels ((assert-it (point &optional negate) (let ((result (cl-first (slime-presentation-around-or-before-point point)))) (unless (if negate (not result) result) (ert-fail (format "Failed to pick up presentation at point %s" point)))))) (with-temp-buffer (slime-insert-presentation "1234567890" `(:inspected-part 42)) (insert " ") (assert-it 1) (assert-it 2) (assert-it 3) (assert-it 4) (assert-it 5) (assert-it 10) (assert-it 11) (assert-it 12 t)))) (def-slime-test (pretty-presentation-results (:fails-for "allegro")) (input result-contents) "Test some more simple situations dealing with print-width and stuff. Very much like `repl-test-2', but should be more stable when presentations are enabled, except in allegro." '(("\ (with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) 0)" "\ SWANK> \ (with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) 0) {((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) }0 SWANK> *[]") ;; Two times to test the effect of FRESH-LINE. ("\ (with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) 0)" "SWANK> \ (with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t :right-margin 75) 0) {((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) }0 SWANK> *[]")) (slime-test-repl-test input result-contents)) (provide 'slime-presentations-tests) slime-2.20/contrib/test/slime-repl-tests.el000066400000000000000000000267651315100173500207340ustar00rootroot00000000000000(require 'slime-repl) (require 'slime-tests) (require 'cl-lib) (defmacro slime-repl-test-markers (expected-string-spec &rest marker-specs) "For (MARKER SIG FORM) in MARKER-SPECS, produce suitable `should' assertions. The assertions compare values in symbols `expected-MARKER' and `observed-MARKER'. The former is obtained by searching EXPECTED-STRING-SPEC for the string sig SIG, the latter by evaling FORM in the test buffer." (declare (indent 1)) (cl-loop for (marker signature observer-form) in marker-specs for expected-sym = (make-symbol (format "expected-%s" marker)) for observed-sym = (make-symbol (format "observed-%s" marker)) collect `(,expected-sym (progn (goto-char (point-min)) (when (search-forward ,signature nil t) (replace-match "") (point-marker)))) into expected-bindings collect `(,observed-sym ,observer-form) into observed-bindings collect `(when (and ,observed-sym (not ,expected-sym)) (ert-fail (format "Didn't expect to observe %s, but did and its %s" ',marker ,observed-sym))) into assertions collect `(when (and (not ,observed-sym) ,expected-sym) (ert-fail (format "Expected %s to be %s, bit didn't observe anything" ',marker ,expected-sym))) into assertions collect `(when (and ,observed-sym ,expected-sym) (should (= ,observed-sym ,expected-sym))) into assertions finally (return `(progn (let (,@observed-bindings (observed-string (buffer-substring-no-properties (point-min) (point-max)))) (with-current-buffer (get-buffer-create "*slime-repl test buffer*") (erase-buffer) (insert ,expected-string-spec) (let (,@expected-bindings) (should (equal observed-string (buffer-string))) ,@assertions))))))) (defun slime-check-buffer-contents (_msg expected-string-spec) (slime-repl-test-markers expected-string-spec (point "*" (point)) (output-start "{" (next-single-property-change (point-min) 'slime-repl-output)) (output-end "}" (previous-single-property-change (point-max) 'slime-repl-output)) (input-start "[" slime-repl-input-start-mark) (point-max "]" (point-max)) (next-input-start "^" nil))) (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-repl: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))))) (defmacro with-canonicalized-slime-repl-buffer (&rest body) "Evaluate BODY within a fresh REPL buffer. The REPL prompt is canonicalized to \"SWANK\"---we do actually switch to that package, though." (declare (debug (&rest form)) (indent 0)) `(let ((%old-prompt% (slime-lisp-package-prompt-string))) (unwind-protect (progn (with-current-buffer (slime-output-buffer) (setf (slime-lisp-package-prompt-string) "SWANK")) (kill-buffer (slime-output-buffer)) (with-current-buffer (slime-output-buffer) ,@body)) (setf (slime-lisp-package-prompt-string) %old-prompt%)))) (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> *[]") ("(abort)" "SWANK> (abort) ; Evaluation aborted on NIL. SWANK> *[]") ("(progn (princ 10) (force-output) (abort))" "SWANK> (progn (princ 10) (force-output) (abort)) {10}; Evaluation aborted on NIL. SWANK> *[]") ("(progn (princ 10) (abort))" ;; output can be flushed after aborting "SWANK> (progn (princ 10) (abort)) {10}; Evaluation aborted on NIL. SWANK> *[]") ("(if (fresh-line) 1 0)" "SWANK> (if (fresh-line) 1 0) { }1 SWANK> *[]") ("(values 1 2 3)" "SWANK> (values 1 2 3) 1 2 3 SWANK> *[]")) (with-canonicalized-slime-repl-buffer (insert input) (slime-check-buffer-contents "Buffer contains input" (concat "SWANK> [" input "*]")) (call-interactively 'slime-repl-return) (slime-sync-to-top-level 5) (slime-check-buffer-contents "Buffer contains result" result-contents))) (def-slime-test repl-test-2 (input result-contents) "Test some more simple situations dealing with print-width and stuff" '(("(with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)" "SWANK> (with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0) {((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) }0 SWANK> *[]") ;; Two times to test the effect of FRESH-LINE. ("(with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)" "SWANK> (with-standard-io-syntax (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0) {((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)) }0 SWANK> *[]")) (slime-skip-test "Repl test is unstable without the slime-presentations contrib.") (slime-test-repl-test input result-contents)) (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-canonicalized-slime-repl-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> ")) (with-canonicalized-slime-repl-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> ")) (with-canonicalized-slime-repl-buffer (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-test-expect "Buffer contains result" final-contents (buffer-string) #'equal))) (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 0.1)" "foo*" "SWANK> (sleep 0.1) NIL SWANK> [foo*]") ("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1) NIL SWANK> [*foo]") ("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort)) ; Evaluation aborted on NIL. SWANK> [*foo]")) (with-canonicalized-slime-repl-buffer (insert command) (call-interactively 'slime-repl-return) (save-excursion (insert (cl-delete ?* input))) (forward-char (cl-position ?* input)) (slime-sync-to-top-level 5) (slime-check-buffer-contents "Buffer contains result" final-contents))) (def-slime-test interrupt-in-blocking-read () "Let's see what happens if we interrupt a blocking read operation." '(()) (slime-skip-test "TODO: skip for now, but analyse this failure!") (slime-check-top-level) (with-canonicalized-slime-repl-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 move-around-and-be-nasty () "Test moving around in repl, and watching attempts to destroy prompt fail" '(()) (slime-skip-test "TODO: Test causes instability for other tests.") (slime-check-top-level) (with-canonicalized-slime-repl-buffer (let ((start (point))) (insert "foo") (beginning-of-line) (should (equal (buffer-substring-no-properties (point-min) (point-max)) "SWANK> foo")) (should (equal (point) start)) (unwind-protect (progn (let ((inhibit-field-text-motion t)) (goto-char (line-beginning-position))) (should-error (delete-char 1))) (goto-char (line-end-position)))))) (def-slime-test mixed-output-and-results (prompt eval-input result-contents) "Test that output goes to the correct places." '(("(princ 123)" (cl:loop repeat 2 do (cl:princ 456)) "SWANK> (princ 123) 123 123 456456 SWANK> ")) (with-canonicalized-slime-repl-buffer (insert prompt) (call-interactively 'slime-repl-return) (slime-sync-to-top-level 5) (slime-eval eval-input) (slime-sync-to-top-level 5) (slime-test-expect "Buffer contains result" result-contents (buffer-string)))) (provide 'slime-repl-tests) slime-2.20/doc/000077500000000000000000000000001315100173500133075ustar00rootroot00000000000000slime-2.20/doc/.cvsignore000066400000000000000000000003171315100173500153100ustar00rootroot00000000000000contributors.texi slime.aux slime.cp slime.dvi slime.fn slime.fns slime.info slime.ky slime.kys slime.log slime.pdf slime.pg slime.ps slime.tmp slime.toc slime.tp slime.vr slime.vrs slime.html html html.tgz slime-2.20/doc/Makefile000066400000000000000000000074011315100173500147510ustar00rootroot00000000000000# 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 help: @echo -e "\ Most important targets:\n\ all generate info, pdf, and html documents\n\ slime.info generate the slime.info file\n\ slime.html generate a single html file\n\ html/index.html generate on html file per node in html/ directory\n\ html.tgz create a tarball of all html files\n\ clean remove generated files" 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 --css-include=slime.css $< html/index.html: $(TEXI) makeinfo -o html --css-include=slime.css --html $< html.tgz: html/index.html tar -czf $@ html DOCDIR=/project/slime/public_html/doc # invoke this like: make CLUSER=heller publish publish: slime.pdf html.tgz scp slime.pdf html.tgz $(CLUSER)@common-lisp.net:$(DOCDIR) ssh $(CLUSER)@common-lisp.net "cd $(DOCDIR); tar -zxf html.tgz" slime.pdf: $(TEXI) texi2pdf $< install: install-info uninstall: uninstall-info # Create contributors.texi, a texinfo table listing all known # contributors of code. # # The gist of this horror show is that the contributor list is piped # into texinfo-tabulate.awk with one name per line, sorted # by number of contributions. LAST_CHANGELOG_COMMIT=ab6d1bd5c9d3c5b4a6299b8c864ce4acfd25cbcc contributors.texi: ../slime.el Makefile texinfo-tabulate.awk git show $(LAST_CHANGELOG_COMMIT):ChangeLog \ $(LAST_CHANGELOG_COMMIT):contrib/ChangeLog | \ sed -ne '/^[0-9]/{s/^[^ ]* *//; s/ *<.*//; p;}' | \ (cat; git log $(LAST_CHANGELOG_COMMIT).. --format='%aN') | \ sort | \ uniq -c | \ sort -nr | \ sed -e 's/^[^A-Z]*//; /^$$/d' | \ LC_ALL=C awk -f texinfo-tabulate.awk \ > $@ #.INTERMEDIATE: contributors.texi # Debian's install-info wants a --section argument. install-info: 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 slime.cp slime.cps slime.fn slime.fns slime.ky rm -f slime.kys slime.log slime.pg slime.tmp slime.toc slime.tp rm -f slime.vr slime.vrs rm -f slime.info slime.pdf slime.dvi slime.ps slime.html rm -rf html html.tgz slime-2.20/doc/contributors.texi000066400000000000000000000061651315100173500167470ustar00rootroot00000000000000@multitable @columnfractions 0.333333 0.333333 0.333333 @item Helmut Eller @tab Tobias C. Rittweiler @tab Stas Boukarev @item Luke Gorrie @tab Matthias Koeppe @tab Nikodemus Siivola @item Marco Baringer @tab João Távora @tab Alan Ruttenberg @item Luís Oliveira @tab Mark Evenson @tab Christophe Rhodes @item Edi Weitz @tab Martin Simmons @tab Juho Snellman @item Attila Lendvai @tab Peter Seibel @tab Geo Carncross @item Douglas Crosher @tab Daniel Barlow @tab Wolfgang Jenkner @item Gábor Melis @tab Michael Weber @tab Didier Verna @item Stelian Ionescu @tab Lawrence Mitchell @tab Anton Kovalenko @item Terje Norderhaug @tab Brian Downing @tab Bill Clementson @item Andras Simon @tab Zach Beane @tab Ivan Shvedunov @item Francois-Rene Rideau @tab Espen Wiborg @tab António Menezes Leitão @item Adlai Chandrasekhar @tab Utz-Uwe Haus @tab Thomas Schilling @item Thomas F. Burdick @tab Takehiko Abe @tab Richard M Kreuter @item Raymond Toy @tab Matthew Danish @tab Mark Harig @item James Bielman @tab Harald Hanche-Olsen @tab Ariel Badichi @item Andreas Fuchs @tab Willem Broekema @tab Taylor R. Campbell @item Phil Hargett @tab Paulo Madeira @tab Lars Magne Ingebrigtsen @item John Paul Wallington @tab Joerg Hoehle @tab David Reitter @item Bryan O'Connor @tab Alan Shutko @tab Travis Cross @item Tobias Rittweiler @tab Tiago Maduro-Dias @tab Stefan Kamphausen @item Sean O'Rourke @tab Robert Lehr @tab Robert E. Brown @item Nathan Trapuzzano @tab Nathan Bird @tab Jouni K Seppanen @item Jan Moringen @tab Ivan Toshkov @tab Ian Eslick @item Geoff Wozniak @tab Gary King @tab Eric Blood @item Eduardo Muñoz @tab Christian Lynbech @tab Chris Capel @item Bjørn Nordbø @tab Bart Botta @tab Anton Vodonosov @item Alexey Dejneka @tab Alan Caulkins @tab Yaroslav Kavenchuk @item Wolfgang Mederle @tab Wojciech Kaczmarek @tab William Bland @item Vitaly Mayatskikh @tab Tom Pierce @tab Tim Daly Jr. @item Syohei YOSHIDA @tab Sven Van Caekenberghe @tab Svein Ove Aas @item Steve Smith @tab StanisBaw Halik @tab Samuel Freilich @item Russell McManus @tab Rui Patrocínio @tab Robert P. Goldman @item Robert Macomber @tab Robert Brown @tab Reini Urban @item R. Matthew Emerson @tab Pawel Ostrowski @tab Paul Collins @item Olof-Joachim Frahm @tab Neil Van Dyke @tab NIIMI Satoshi @item Mészáros Levente @tab Mikel Bancroft @tab Matthew D. Swank @item Matt Pillsbury @tab Masayuki Onjo @tab Mark Wooding @item Mark H. David @tab Marco Monteiro @tab Lynn Quam @item Levente Mészáros @tab Leo Liu @tab Lasse Rasinen @item Knut Olav Bøhmer @tab Kai Kaminski @tab Julian Stecklina @item Juergen Gmeiner @tab Jon Allen Boone @tab John Smith @item Johan Bockgård @tab Jan Rychter @tab James McIlree @item Ivan Boldyrev @tab Ignas Mikalajunas @tab Hannu Koivisto @item Gerd Flaig @tab Gail Zacharias @tab Frederic Brunel @item Dustin Long @tab Douglas Katzman @tab Daniel Koning @item Daniel Kochmański @tab Dan Weinreb @tab Dan Pierson @item Cyrus Harmon @tab Cecil Westerhof @tab Brian Mastenbrook @item Brandon Bergren @tab Bozhidar Batsov @tab Bob Halley @item Barry Fishman @tab B.Scott Michel @tab Andrew Myers @item Aleksandar Bakic @tab Alain Picard @tab Adam Bozanich @end multitable slime-2.20/doc/slime-refcard.pdf000066400000000000000000001215651315100173500165310ustar00rootroot00000000000000%PDF-1.4 3 0 obj << /Length 2570 /Filter /FlateDecode >> stream xڵZMsϯ)%X 2JU2n9Jmf}쁒hIeJԐ=C~{4DJMT.6Ex?LLӝ̕P*w:"Uzןr2qOׇbgM>@NྐྵhOph"O2@I&Ɉ:٭@N'U2b:].4JQzqQf~ Na|όH{yGUa'J2w/بـu ʌxt-ezgCzRvK# J Lǧ#'H4g X&d*tK0T Bԝ4O զjnfX[n'~y/yIZg!XMcx]@ eJ2>J**6b=P.bdؒRGDØa]4Ҷ<~(l΢ԇۍj/\b^;z>k"*$|w6vaFa‚%5ݡUU)^6bny hKP~8q)aUXȒ8cmKi:2U8vߴy=e-@r\k1?p<ӅH?FQKw V7n#%n`E0Tx3k!e^L\x ݜ,|ݢ22RҘ2<I}cm;J5o?BlؑK(nCe2,=4cZ[xNk$Gw&4Y5 {&^yԩrWR'Y$c̐%Yit &Si5W\Xq\)86,+0@케K)26An`ba-jr-yj_)]|#JDRJgA hle(HWɍT&Rf,,rrcTw\]ZUMJٸMz{tCGGCp}";йPQD[+95=wHE?Ō?,S$iPEmv=n-JI//4woAΠ3&Co u| J.ȴdUVQSkJ1VH|H*^t℮{,(tAgaoHr͂.،۱TT6̞p3Y$:]ij6 FƮzҏ8ؾWc͈߬'ʷ vh"PП9CBBs3G \.j`/lY{˜+9HTaYJ /Q W?.`kSZ.j^8aSNc㄀fʟ? T;)[*yL-M]'1$4m(4vcfYI;54\gs;O1I 8b k13 pG2wL)T>c6ɋP>`H;wUO|/`էr S>endstream endobj 2 0 obj << /Type /Page /Contents 3 0 R /Resources 1 0 R /MediaBox [0 0 595.2756 841.8898] /Parent 21 0 R >> endobj 1 0 obj << /Font << /F15 6 0 R /F17 9 0 R /F16 12 0 R /F18 13 0 R /F8 16 0 R /F19 17 0 R /F20 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 19 0 obj << /Length1 772 /Length2 1135 /Length3 532 /Length 1698 /Filter /FlateDecode >> stream xRkTSWʣACR$!/Hg(/%Xi0DXBDH%Ja Fؠ!V+HSnHJ)= &7lZJek7zM !I0\I8 G_F0k} ) \Xnt(x"B B^azߺ Ɓ O!DP"2]/u!2L&_+Q!9@t 9D$L@PVXMZfQ 2l pڻ3C +k qSg8![Y7H0JK,FPaX (#0W~ʙ/?h %bkE}M};w"aG)e&$|Փg [m-zݝd y{W _|ny |~{sRkFLB唸?QKn-T.Z|0 :y2b'cJ灐 2Qz ?돪;iNlX1:EF9KͭRU%?S67${-lq*ɽaNl-5-w4xýӼ+eGND|giȋgi2~gXb}>ʧô bt$ F :r3D aewOUΌέ0wh9-WOH~P` 5ñ!VP7(0֎pukJ' ۗ.SrAݥ7Fݘq9zrj*>=qc {g 5y?Z6vmz;[x5ָp6})Nu%4oUm}=i/.[BVc2ZUxkTjGٵ*gOwr.轗e$X:[ XwiLÅcӦ}1ug cg}&kՑ q~-kWS{hIb1M޸?D~ɹѳL.sT,ȮěTY}&?u-7D}T CWZjN_t74~zz~?w<홞NDGSgJ-ne' @? fO-?kwOwXxUwv'.i{wu;ܮ5avv*2.DWP1o|qV}lުyv4u?by\J?g5Na' '0O'endstream endobj 20 0 obj << /Type /Font /Subtype /Type1 /Encoding 22 0 R /FirstChar 60 /LastChar 62 /Widths 23 0 R /BaseFont /YELWLG+CMMIB10 /FontDescriptor 18 0 R >> endobj 18 0 obj << /Ascent 694 /CapHeight 686 /Descent -194 /FontName /YELWLG+CMMIB10 /ItalicAngle -14.04 /StemV 113 /XHeight 444 /FontBBox [-15 -250 1216 750] /Flags 4 /CharSet (/less/greater) /FontFile 19 0 R >> endobj 23 0 obj [894 0 894 ] endobj 22 0 obj << /Type /Encoding /Differences [ 0 /.notdef 60/less 61/.notdef 62/greater 63/.notdef] >> endobj 24 0 obj << /Length 180 /Filter /FlateDecode >> stream xm1 @E t.]A1[ZYZZ( ),> stream x3632W0P0Q52P02Q03RH1*2(XAs< -=\ %E\N \. ц \. ~QC 00؁<Q!f zB@~f9~f Pt*U %3bf̖P{tChe.WO@. Aendstream endobj 17 0 obj << /Type /Font /Subtype /Type3 /Name /F19 /FontMatrix [0.01205 0 0 0.01205 0 0] /FontBBox [ 4 -20 28 62 ] /Resources << /ProcSet [ /PDF /ImageB ] >> /FirstChar 60 /LastChar 62 /Widths 26 0 R /Encoding 27 0 R /CharProcs 28 0 R >> endobj 26 0 obj [32.27 0 32.27 ] endobj 27 0 obj << /Type /Encoding /Differences [60/a60 61/.notdef 62/a62] >> endobj 28 0 obj << /a60 24 0 R /a62 25 0 R >> endobj 15 0 obj << /Length1 1375 /Length2 8853 /Length3 532 /Length 9685 /Filter /FlateDecode >> stream xeT\۶qMpCAp->CL,l< { dXؚ`70- z o)9߱!-l ;jQ. :e迖a.1Ofng'`؂.myp/ݣD2]}׎.iVqfm4I` |8W^\myGǥ'#WS"Z=4R+;4++VR@P H3}>JN~,q#ʾIIA(fKj `qEeD:0 7:Ӄ90y3M'N&ByB>"7 _^l/ߙfSn']mD׭o 3<1Q 'x:z9Ylc[1<(c *fd58Lj\lŸVoj+F`?ȫyu W6'MpH f1U!`(| @rqko`Lx.Q<{Qөj\n=wB}aӴ_.<@# i:XÐ5%l}n\z)LbXzKzvReƛ'|ot~׸X)/Ld/^]Cc)1cXMv`÷EZ+xxhRHۿ >~|сf'j8QlqVɦjbc(7XmuюaMz!Ba9s((FSinHND\˦ w;e@7&ҨJk]P rWU[iC[n !{,_ŏWY_Wl1'p%r 5PL3,M1B*r0Y6, |ʚS;5 1a׉IG-QTձi5%Ҧ"ڈa]<wuu϶f{[i1 CozJ1XT2B4*$ړKJ#){6/B}=:EJ |7dlG0BrbcSOzsR(;g_ _XcEhYRF3]K"8b"#M{y.&,.&Gw+&ZdxجBG+Ezv{!~/'6˩- 5{G];.`Q,1zuvK27w~\@ip:ܫ N8톥xf0Ӗ<> wpGb$:y7p??Ud-d]a&:G)"L ]B\U6䃒S y>tpK !GM 6zKu:ڠ~-^L%Wpk< D2{Yt ^Yo`<> ة # }-.9*G/S1 Q ,ȥ}6G\ To4f3/DM&ݓEX{=1$UrEiM/a{M(Az̠V/SAy\JvE^ Wr]/X߽( VQ2]HLviWbS=xp6q}y5Vy\v }ߐ^j\܃ քHUc\}Q{#205p,Xk:#6l_WomN Yi自1;_ѹg28'#}{H5.5"6?1nvqij!7$ xr+фJ*"zP4$Jx: ldsC~cGsp՚BvSz @NIRzfAo3Sos}n{X>qoÂs3c]n#"BA^l+6S/(eh:0J:G+[9_%o"Q .róFy]}NZPhnss&9僾?"+UjA1ڊbGw/H1h'V;U\=-IɆJBäo^]_1t\9) "S xوv5Q*I4-` (%(Lg\EiYe|r@R <%-R:Ӹ@!5# JU+دVYvukvV֚` Ѭ)0[|UA9)o)3i^ bMV@9҈P(uB  '$mDS'32:;- Jf xh;J\8$)3*l{tDG?nsDW8KҎ 5~kp,OLnp *lfɼu1H/|;fF+m1{yq0W ˜xG;OJJF/`L#uXѠV`r=Kj 'sIp4;kas5>Ax]$r25xW<+ja]~6m/?\PB 4gcKh:}DYKLy3bZLk㽋Du?_8~n(Cte*׾.MHνxZhpݠ.}GUᕛ)ф`TNi6hb҆se(Mw :6-d}x:G˘0تrtT6R'y!y7[Ұ068Ԛt13C~h:+O cZ8VU h]+Umx]v&=l6ܘs8qi ;=s4uVkLpVIWm!H.ӒW#t@΄a L;1u fJ7hԆBoyp-%fa.[WyR3rǤ3zhA5P !ztjP&?z '@+om+`i*ǂ5ZGiG#͘p@>B )AQ*8w A[:uS蚩=UJ<HgwI 2|~z}XWc ЃQ:9*V 9ᗚM.%9 VRu{䲶7@d+&݀:^۹>vgJ(&dT)Vwiߟ+5 4KxJ9o3JOprZ`127bT?l2 Rz@Rgb;z^N$7m`?0 b'Jcm"uY瓿%,yiX O]gJl4B/ㆁɥߨBW] Sج^ϥ-oAZK+3ZxeHbi+<=u}](٪cmyV,P?VpAViuYLK,*HaE D$]GGX҇/Pݏa.z]ZR37%/b^ńof̽rW-M_EF0x7\8>FPuάwSQŵyr:`6}r;~+ H$^\#wϰV*J~]fBN=|/Ac,3үԔ~$*3CJ^4wrGy *ueucq墦8bck7 Ǎίr[ d0Cp_}XAsJ#t^9ފ(?&FߝrmvqGD:$wepG >j]\|X>`VND);*~G*ĐF|x9v1`;| qf*1@7B;;am[ ^4Ƶa#63Wn!h4:K'Τ}-xa[1]j~_;#swHc:m'~څ#biTư{F-w;>Ei8@ '4(~LX =ҳދTijH(4fo( j}&mʈ4&sIتSX 'GΚBEx\#As-=)n_M&+Ț^TcOerH!X/ [c뻂غd4j1; $'u^n} Xݛ5IqJ4ev__'}bo4lwcZmsxPYټՕ)mz|IpW'?B|0mgS=wj."PWm",FCUߣ1Vmg#T}1+lIg`r|B4?f%mt|XJSb/@,NA7XtI HAGػl^HO* sh70NNU/f^&3nBk7ḃC\8!T!>6 ֳD ky.gjA] 61:%#;x}}o swӷzz}~}CfAa iݞ6Y`'2N3%UI\j2)=4[mG|0.z7E #+:E~(q!:5 <$щM3b<8kpL.[Sw$xd4d'  /]6=׆Ax`&X yl ~…+RM&kc Jp"ȑjUKeF,|OB>+EDugrLuG[kvSưmz$෮+2g*'lcz K;%m!*=Ur4]%c=V>8 i`L {x,vpq/t'zjF5k҈d~ Z ɍ?C0fSqvABiRA'ﰕylCA|F%Y.dY(D\GqWd7n~Rjt8\ Cj+:@:uuu R6JP>fyKy!\- Zԟ !ћ-U<>aX>`%c(}g{q1GTgy%qf.4-zzpK7R< ';G4DSu}S;_`qND9Ne5(%y1ٿ8 Wxa@!sɟïe ǁڰiF}C@sV5vWj{AFx%֫M!:N_קq' cO Qٌu軏gKq-e%^BϕNTY3'YVm&p`Өjyia8UaQnb9,̳N32`0w.\3^~0Qvǵ\?Έ@ӷZϷi!No=:#Eϟ)3$. ]OUs;lԮ-mP)+x"Y['мL{" |tNNIeW|j0IT +AĚ0~W;d3*jc|JK-ͨ43GV2h/ /;"_2o\+OE=5`ś泘7O|BughqJ( vOhyc|y pa1bGY#ڠrzoǭ -͜tmrri(†Qc:RfmWdAh&ef00.=}0y6yt#`qV4ؠ'ώ+l[$y~Z n1UԷK3e|YW| :GG++o::ǡ Omj4+C2 #rX<fW>RƐ{vwۨ$>>~QXGrs(W5U S?ɶzݷ@~jՍh+$trL m8YBҟc;׿Goܝ|5:6x1ݽ~`'0C7"9O #i/W&2"5~HoTҸH8 (ۙS8ipPli#>>)!K o Er1IѲ2g*&] !%DU*fMbjdcEE6:b{@TXE6v[b*oV3PEdb;+Upqk6RJp5R2 TIٻ09>wiOv;Kă>)TbΈJZU4HʵB.Ua^n6~$oɆNnPٯ>)}SiQz~ɥQ{+&Ӭ/2|W RF? [ITa &S%6"֌Bs߮hG9GK2SMwR_gFA/U ၘGJm`zb BE7o&Y5ts5eWd"Bٟ r(SJ<PZ\_YK~:PDY_ lu3+)s3DZA5$ӌhKH0ȧ:x)ce&UtuB n\wALL20;ۦa{+7k2XJTޖqʇv9 ;ԯ_-N]ucڛZJWsizѽVִb0GA.ƻ_31ֳuio7KAPF?dےSC+ zL&< w]}CtHWlhĉn{84Ml:v6< QST˼+`AjM?0x!>+nnv(S"ŸVl89طFywY[KW Fŗ#5U ~l!jR ml-@Є>TzBen[ŗ/Dck0 brB_&XMendstream endobj 16 0 obj << /Type /Font /Subtype /Type1 /Encoding 29 0 R /FirstChar 11 /LastChar 122 /Widths 30 0 R /BaseFont /HKUFKS+CMR10 /FontDescriptor 14 0 R >> endobj 14 0 obj << /Ascent 694 /CapHeight 683 /Descent -194 /FontName /HKUFKS+CMR10 /ItalicAngle 0 /StemV 69 /XHeight 431 /FontBBox [-251 -250 1009 969] /Flags 4 /CharSet (/ff/fi/ampersand/parenleft/parenright/comma/hyphen/one/E/G/I/L/N/P/R/S/T/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z) /FontFile 15 0 R >> endobj 30 0 obj [583 556 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 778 0 389 389 0 0 278 333 0 0 0 500 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 681 0 785 0 361 0 0 625 0 750 0 681 0 736 556 722 0 0 0 0 0 0 0 0 0 0 0 0 500 556 444 556 444 306 500 556 278 0 528 278 833 556 500 556 528 392 394 389 556 528 722 528 528 444 ] endobj 29 0 obj << /Type /Encoding /Differences [ 0 /.notdef 11/ff/fi 13/.notdef 38/ampersand 39/.notdef 40/parenleft/parenright 42/.notdef 44/comma/hyphen 46/.notdef 49/one 50/.notdef 69/E 70/.notdef 71/G 72/.notdef 73/I 74/.notdef 76/L 77/.notdef 78/N 79/.notdef 80/P 81/.notdef 82/R/S/T 85/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z 123/.notdef] >> endobj 31 0 obj << /Length 189 /Filter /FlateDecode >> stream x] @ S:Y Rк( N&G: p$HSDSitxEfFMxԠ3Q5o3t *Dd<-@ 7 U s@ווʾ%32UAфHd(l̞̮̪lK[uJ]endstream endobj 32 0 obj << /Length 186 /Filter /FlateDecode >> stream x]1 @EG,i]vX4\VZ@rDѕ(u"p6SAM5oi Y~ޘT+dDܪmkN/E %߱'&RKFendstream endobj 13 0 obj << /Type /Font /Subtype /Type3 /Name /F18 /FontMatrix [0.01205 0 0 0.01205 0 0] /FontBBox [ 5 -21 32 62 ] /Resources << /ProcSet [ /PDF /ImageB ] >> /FirstChar 60 /LastChar 62 /Widths 33 0 R /Encoding 34 0 R /CharProcs 35 0 R >> endobj 33 0 obj [37.1 0 37.1 ] endobj 34 0 obj << /Type /Encoding /Differences [60/a60 61/.notdef 62/a62] >> endobj 35 0 obj << /a60 31 0 R /a62 32 0 R >> endobj 11 0 obj << /Length1 1385 /Length2 8216 /Length3 532 /Length 9054 /Filter /FlateDecode >> stream xU\[گq(EK(R4(n!8 hݵ8)Z܊{kiqW{~ s{pc3 _ ׁrq8ppw89Y8la.`%~ |_6./Mq$8 )* C7Ft9zTGa!o!.Nuohml@xc@pNq8p p \kp+? \5|կ~$%!޾'*mo7͞!M'}>$Jcؓ//.V?͵<ݚ~R[?w-+ǐ›B3kZd;E g'嫠7_؅zCrv6Pᨦ6`j0jk|v%6\I)2m(:{=av+=j.KΨNTrC683ew?f@=jUȴk.&ȷ75$(+l}Vq²nNL;Zv-/AN RTzoHVw8T3KzB}EB_)]凐tLq?o4 *}u<7(@GO`'Q89_*a7Fs/nPFzubiر~lOĆOy Av` sap2q=[1ׯ"_@4ô3.ARI{?q'~hF*#a^!.{ƀa|NIHSv Yȣ ƽ:#P'uSD;92!=yc"eeo6ҹ VflAӓsxFK6=ܔTRH2橘+ƀ~UZV,rBJGxՅyVR@&쬼\]h o;12Ho5 c<+ Z(OGƼ2ݱb_-HPYQ(+xUijj'޷M8rB,ɇ=FcQvxufqͮ.QPw(N.ZV jD0WɤL8|EdN a=3L* tvi:3*5ƿtG Xnܕ-jo瑞De=]Z|?cG||>C@;zOqSa/I/֛biwR}b#H>MNĥ7_:OZ2, ӚQ!7I29yƲqE}ҷF潯~;*,aj'JdGk,Y}j,Ot'LegG1@|ڂ\nGUzhcG/{J߇4Ͼ4$+#$UuXb\GZg q&T DyqyS"`~93k9HlamAD:!6Q_Ouޣu" 8y@e,.8d9 NΖ,\wn&j{ eE{R=ۧ BQpuZ:{v鴞a>XM^g ({پ±seVF-NYIaJ`rYshb}?ƄAeMƞl!an c#.mw7ժjbyi:b&Yi)w҃L,e•iyH{(PR %u*G"3hBNHU(+ b Uw)F!v$Ѹnnu;[c{]AQgCt7ۯ& 0UuXSzEĭ$^>h%z"oSs;qʚ"_(Y5qC7*D*i^x1kn'RD77`^O7_号^טG~7w56cԬ򯽏7`,1!3x-.m=a+{d\4xjw~ƶFnz_)΃>˙N2~S'.}& +}0`z)3`O1gDD[*B)§=F"8}-ԋo^6IPl*G5l2^J"BtHPdn!Sfn7PEP2@ 23M{X`.$_ $aWZYsa\.݂@r \N.]|x5pZшJ/y&A+-֣VyW=מ yanoXZKPW::`d:!{QKw 7%M8O DۨrΡBCW|̉V"Dn0U龡Fm06/S-T}r)Rp?K 2xǰM[;HC>af< mu Cㇳr>ZF*F.䍮.7'*ٺO4p]~8`0ytP{yr>oL Ԝ~α-e%)Zo9kzЬs &%3.$E0euc,sF>1HVupz-k6y3Y8?7`XŒ" º]Ogs")qv>c狳 {?A 7$"z yXK! [v;VdYR< z'6FnMɆXī^:={6\ZӘ:9A@̖[ywQ p 6;5)4ճȵ/}m J ~}N D'+~Q8{5nR>IӺ3 Ej D8 ̏/l#i) J LjUұevJy&NUA\'eeyxi:AP!̠gZs okB>Ɂ4Un7ClL)UT9LFߛwѶa-& < A4^F^$[M4rv=o ^z>;Tt Xmәr6""d돪gŅXUbX:[2_F:7{;40MG.OZ6` =v%v׶kTgDg^4ǎ{zNq cKCsxMCH07.Q L͖m;K YkcqRSTR/Uk1+ 1E_9'`}^J6i4h[6-1.=4I[:渒9LeaZe2o*# Q+V]%f{dg tjm|XRJ8fA6șｗ %5gxz^,JH޹U\ju>{B@qLՈ-0tg"ym9)^i9;x{2J%J+L6N!B W=9O褐w㍍&6®`O6O4Fcu:י`hNg$H ._ !>s2FLBxcDCUuITi9OEC%GK,$Lk;)rq9sVU\ q| eZ=%[RripgpiAm sm:nfs2dwu Ljy(rXQ(r(grcZżZOأyH c&2YԔ kVE ilwq'x6;YNg飏JXX^==z{eSq^x\̹] fz=hI5Owi ͗X?Nz#$1f-GYiر=2l =o{f;5ZcFHOv aZ?I]yt79)cXRJH#S#3oײA D36FޛZ~g p :YVO{!϶$3YmtjL35\P̝#^Hr x uG PVJ(a nQslo5b0|p&eA`?.;%֋N/%{o\Coi&{j`.j{,dzr\f  'ڂ ғEd*JJ,fY~Lh`uU+YKYc?I*PQ9<K%\i ʖl~1V8V~EU&Oז;nw |,~id`ccl U:KN? 0Qw?bO>Yȴ({b/ق"!+L#kVgj<;%Rjve7ɭ+Ff6l-n9|GƘ̱Z +'MX:UyfU SyUjt^營cM9 FZ%fGwzGLPw˯ȮO}DqnN4WNxNk>`*醈eU`V~@&&iZ &]d>F6xD(Hʗk;յgK$t`[V(;_x W|Kf&w\gtZo p~0 Gd"/endstream endobj 12 0 obj << /Type /Font /Subtype /Type1 /Encoding 36 0 R /FirstChar 12 /LastChar 126 /Widths 37 0 R /BaseFont /GYERDI+CMBX10 /FontDescriptor 10 0 R >> endobj 10 0 obj << /Ascent 694 /CapHeight 686 /Descent -194 /FontName /GYERDI+CMBX10 /ItalicAngle 0 /StemV 114 /XHeight 444 /FontBBox [-301 -250 1164 946] /Flags 4 /CharSet (/fi/asterisk/comma/hyphen/period/four/five/colon/C/D/E/F/I/M/R/T/bracketright/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/w/x/y/z/tilde) /FontFile 11 0 R >> endobj 37 0 obj [639 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 575 0 319 383 319 0 0 0 0 0 575 575 0 0 0 0 319 0 0 0 0 0 0 0 0 831 882 756 724 0 0 436 0 0 0 1092 0 0 0 0 862 0 800 0 0 0 0 0 0 0 0 319 0 0 0 559 639 511 639 527 351 575 639 319 0 607 319 958 639 575 639 607 474 454 447 639 0 831 607 607 511 0 0 0 575 ] endobj 36 0 obj << /Type /Encoding /Differences [ 0 /.notdef 12/fi 13/.notdef 42/asterisk 43/.notdef 44/comma/hyphen/period 47/.notdef 52/four/five 54/.notdef 58/colon 59/.notdef 67/C/D/E/F 71/.notdef 73/I 74/.notdef 77/M 78/.notdef 82/R 83/.notdef 84/T 85/.notdef 93/bracketright 94/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u 118/.notdef 119/w/x/y/z 123/.notdef 126/tilde 127/.notdef] >> endobj 8 0 obj << /Length1 1106 /Length2 4777 /Length3 532 /Length 5490 /Filter /FlateDecode >> stream xe\krؔH0 H7:  1HwҍH#% !)]( zfws>y/ug A v(* @Jڊ! D@C E#PP4L X|hYsa= ٺ8u-;~,٬7gog8]/BMU3au· e"K^'K!| Pm7 ߿f7bDk*y@f6, ~l?2˻B3]bzr( q D8՜MK3rTHzg$e`:9n;f|LU勀 fZ GբHx'U}z-an{(e^1TL֡0U'ʍ臝*IP;% :nzqN^[1 }n܇v["l{aﷃ%Е%yۤ1lsZu>s!b`r6|>e !ad[k]{Ր=F&Y%=D?5agC+QpP5>;ĄHχiW cJ[-\ۥXQ+ބY OޞĐ'Gޔ&UzhGSexGsp. /<)-42N#:;yKp-v;5jogbE|a +kC yS[eUqST&i6njqO[4Z h#߮z.HNJ(H/z_9?py?FDCO݅-L6>YC;6ʸ%MJ#_ZXӨ"Ա|ZhT;f2q*)<6_pt.Հoqi6gf< <~BF jOT7Z VΐgX4jm5XrTȏQ6SM5n^?O~CJZ"?|*Kj9RS5#"9ƬZ2ϐzrN.R˞d!c4rq@FS"mLuSTȞKY!KֹpSäƦh%cs@v>f4ݝDEK9ĕTNzw?imj_O^TDt9rd8)Mc /-5 !@_qt.μWTgs +wE޲hР^gYs7;(@y:%3DZ* N/.;wc^qe= LR+Pe W2#{4a #^g(J&1shIM>6ZQ ѣ~a֓Eu&':K9ʼdw= NG E+Pagܿ~ɯHϖ]d5=jmёOlx՘C `Nӽ;@MX^#J;94}w;10Xm C0eYK1Kx VD%W(cf{5aMɄuӺ q2 ۽WN@5@kMnK !D䪛^/{n/Tpx WmwK$mlE͝]%ֲWҺf&ӻ9_;0hA.[,S(K ~~tg<BQ]>tz$hwt1/ظ [ct:aWF*WfNUaڒΚ \6zѼǁ!~4YbWEaihbBcĘkb"Yڶ^#3aߍbӯyt)mDl1[Hzna^tzKkisk\U?* +|l>$;T[kǫDJ,љ4iTNːn 6ϋ,eW#\keV4 pQ^zj.F͌JZ{ba:O@l> @SҘ PdzGzRG;dS^9ձ'蒺==N<\L) wHh\l54ܶ>Qdi'q9=4%S }R,Ë-z2 vtr?r;-ac'F͏0:rh4f 9  ?_~cN*,ŧ j da'/Ϸd')*&͟nROIb Uo3ʣՒqp7[͆r^FZ!0%q ? o0Y[N)EӰ[A<,Lxo?_mCnWfEpX WSdµQ:'R ~Z]gvihk$P+?,YtUҞxѢn}΋Q[zYŨݲPb&c1nxbv)+h8%rߜ,OlP25}@T%ܒH J~!BT ]xe^~6 oI) YgB#OOm)£NfEgTI)hv9\+(|L,[ 8:uN:(> XP K;`䮣7©JBar#iSS 1K՗ՉI߭V#XO]vR|v>$rhn;z}T( ks%MPC.p!~AxO<7Jچ>A@PF EOŜбWPX˓a|#ۤpԻR"i7RڮVW\t|Y𷊟X)/(Tmaoaėw5}-ъ]|:ψ=b{&UF9$m?\Oܣ,/+{msUW/> endobj 7 0 obj << /Ascent 694 /CapHeight 686 /Descent -194 /FontName /FFIEEE+CMBX12 /ItalicAngle 0 /StemV 109 /XHeight 444 /FontBBox [-53 -251 1139 750] /Flags 4 /CharSet (/slash/A/C/E/G/I/P/R/a/b/c/e/g/h/i/l/m/n/o/p/r/s/t/u/v/y) /FontFile 8 0 R >> endobj 39 0 obj [562 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 850 0 812 0 738 0 884 0 419 0 0 0 0 0 0 769 0 839 0 0 0 0 0 0 0 0 0 0 0 0 0 0 547 625 500 0 513 0 562 625 312 0 0 312 937 625 562 625 0 459 444 437 625 594 0 0 594 ] endobj 38 0 obj << /Type /Encoding /Differences [ 0 /.notdef 47/slash 48/.notdef 65/A 66/.notdef 67/C 68/.notdef 69/E 70/.notdef 71/G 72/.notdef 73/I 74/.notdef 80/P 81/.notdef 82/R 83/.notdef 97/a/b/c 100/.notdef 101/e 102/.notdef 103/g/h/i 106/.notdef 108/l/m/n/o/p 113/.notdef 114/r/s/t/u/v 119/.notdef 121/y 122/.notdef] >> endobj 5 0 obj << /Length1 981 /Length2 3845 /Length3 532 /Length 4511 /Filter /FlateDecode >> stream xWXS붆P:(EQ'PB% HJHBBBM4ҫHHU:HGAiFH]g/Y9o;{L\bxqI"e`*)HZ8 Ġax" hx:R`@RVQZ^QJ¸Nx@HKg!`hwF4`( D}A <"<8/D+) x iH =B ľV}8W(51 -K#rCԀTo筆]47&]n +Z̆an1ݲP>:wV_=x޵bokuک jK5%*7ԔyS NB&氖ǟ=)))#QfOjzH3qi. ͸DRښMVbuQ;[c*ޜxn6`]d8q."̿m4[yj\X.?e %\aEq#r*F2m?* ijc]g~dLLB?PC_NGZf7F'<϶xz4*䓸ay9L=X,5qܶHŜY`{A|m"CPl(Mc*%[-%?;9Pׁ=W[Eonc+C4dȐ <{Wuh=RAŸHQ +¬.p5z/*KK(Z}A3 28O 7 s'"3g:<]קRSKL=t.ڭ)<2zar%&^QWZS.%;N:а/|t̑^jcZr3H&9 9HRxdaׯ쁵WR{嵞Q pIf͛Iy~pprAّTj(!"sybl>Qxz] ~P[Kvg* #}Z[7UO5*Dy.Z& /eo6`,u8NWTIƆ>6>VzP]@=f_ oke֞>VW;y Em0Esj0k_JL×'8k]Za%giL$2/Lm@1<mKmQ<%#W>]nh,&E#;> 2DG':6fr3m_cU4q}L`x_!KiXƞCAX/n6?-\UDۙPr[ˇ+TF9">NNC15r')²5ehwqh64U2w}|ƀ+UpVJ: =UIn yuk?x>N]̵V!hz^-Trw?U:O͘Oo;KsRvۖQIT Ǣ7-{^7R:?en64 tsy|> Rd7B/!E8WuGV 3^ψY[ jwb GWL"-g*F긶Rd| .yN(hSc}=79@5&TxjrGw9/W(tXp^Ӓ>^d?Oȑb;g૦ny^;)<╽S^Ym=OMAS/.Uu ϓOVGt$ w )GE\JJg@;.Ly+ثq,OJch~΢5q1ڗ/E1:wEY]TUYs:sB^ pe2|zϡnd"{x,e!r(AIW8N ԬW&YBɤwNi{/_ `|o̝|gs1P3kv P{,;~,z=S&PrvGΈ]$Z{XX\cʤd ڽ}_ʮlS`TLbCZ[ aLL( ?EĠ|lڕ#%=s8(j0J9,R$-] ikpH8B{hK' =_B*4]9נ 'b̅v:Mxȅh:wn~S{EQ?J Z#^,jGC\/vi62˝$1 oV}4!`f[`JRn%734Z\%CW4޴426(+˞[a>^Jeqg99ѩqwX|1W-+ u}fiN7KTv0(݌i4-FXN309`06.8>/B7Ε_endstream endobj 6 0 obj << /Type /Font /Subtype /Type1 /Encoding 40 0 R /FirstChar 67 /LastChar 117 /Widths 41 0 R /BaseFont /OBGQJX+CMR17 /FontDescriptor 4 0 R >> endobj 4 0 obj << /Ascent 694 /CapHeight 683 /Descent -195 /FontName /OBGQJX+CMR17 /ItalicAngle 0 /StemV 53 /XHeight 430 /FontBBox [-33 -250 945 749] /Flags 4 /CharSet (/C/E/I/L/M/Q/R/S/a/c/d/e/f/i/k/n/r/u) /FontFile 5 0 R >> endobj 41 0 obj [668 0 628 0 0 0 328 0 0 576 850 0 0 0 720 680 511 0 0 0 0 0 0 0 0 0 0 0 0 0 459 0 406 511 406 276 0 0 250 0 485 0 0 511 0 0 0 354 0 0 511 ] endobj 40 0 obj << /Type /Encoding /Differences [ 0 /.notdef 67/C 68/.notdef 69/E 70/.notdef 73/I 74/.notdef 76/L/M 78/.notdef 81/Q/R/S 84/.notdef 97/a 98/.notdef 99/c/d/e/f 103/.notdef 105/i 106/.notdef 107/k 108/.notdef 110/n 111/.notdef 114/r 115/.notdef 117/u 118/.notdef] >> endobj 21 0 obj << /Type /Pages /Count 1 /Kids [2 0 R] >> endobj 42 0 obj << /Type /Catalog /Pages 21 0 R >> endobj 43 0 obj << /Producer (pdfeTeX-1.21a) /Creator (TeX) /CreationDate (D:20070808204403+03'00') /PTEX.Fullbanner (This is pdfeTeX, Version 3.141592-1.21a-2.2 (Web2C 7.5.4) kpathsea version 3.5.4) >> endobj xref 0 44 0000000000 65535 f 0000002772 00000 n 0000002657 00000 n 0000000009 00000 n 0000039833 00000 n 0000035049 00000 n 0000039678 00000 n 0000034251 00000 n 0000028486 00000 n 0000034095 00000 n 0000027412 00000 n 0000018080 00000 n 0000027254 00000 n 0000017680 00000 n 0000016118 00000 n 0000006156 00000 n 0000015961 00000 n 0000005754 00000 n 0000004885 00000 n 0000002910 00000 n 0000004727 00000 n 0000040496 00000 n 0000005128 00000 n 0000005099 00000 n 0000005234 00000 n 0000005493 00000 n 0000005999 00000 n 0000006032 00000 n 0000006110 00000 n 0000016761 00000 n 0000016434 00000 n 0000017147 00000 n 0000017415 00000 n 0000017925 00000 n 0000017956 00000 n 0000018034 00000 n 0000028073 00000 n 0000027739 00000 n 0000034721 00000 n 0000034500 00000 n 0000040216 00000 n 0000040059 00000 n 0000040554 00000 n 0000040605 00000 n trailer << /Size 44 /Root 42 0 R /Info 43 0 R /ID [<656A70C0ECFB206DD7A3620093F72DFD> <656A70C0ECFB206DD7A3620093F72DFD>] >> startxref 40808 %%EOF slime-2.20/doc/slime-refcard.tex000066400000000000000000000060561315100173500165550ustar00rootroot00000000000000\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-]}{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 M-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} slime-2.20/doc/slime-small.eps000066400000000000000000001622701315100173500162470ustar00rootroot00000000000000%!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=RRajSr)m.C/Qo)F4~> _#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=RRajSr)m.C/Qo)F4~> _#FK8r;$?d!r;cn\,QX2rVZTlrpKdkrquWgqYU6joD]L&q=RRajSr)m.C/Qo)F4~> _>al?q!dM,hr['q!?_R[B6U<\@8]>TW+a/a2[rL%+WD>YGn1p]$&prp\j^`J,~> _>al?q!dM,hr['q!?_R[B6U<\@8]>SYMdk^:j@0%*ZE"VkT`^]$&prp\j^`J,~> _>al?q!dM,hr['q!?_R[B6U<\@8]>V6mGObffhD%+WSI]!S?7]$&prp\j^`J,~> h>[WWrVZQgrV-NkqY^ h>[WWrVZQgrV-NkqY^ h>[WWrVZQgrV-NkqY^ 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 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$ ir9kpr:omMj4hu'_7R1c\\?)/fAPl]p%eObqu70'nC=kd^ULV[^W jSp5!r:odDfu^e(TW#$4`5KX*VPBrn_U.-&nbE%]rr3Q/q<,T+jM8%%Z,#G4_<:Xnn,E[lpZKc$ a7&Kap$)PFrpLj&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^ jo5bfq=3Rs^o=!Gi9omnrSSgZlL"&YYFr&9f&uZ$rr<#tp><.DeZ=^dN2tLtZ/>9Sn,E[jn'nDq i76B&ouR3]rm_J2i8E\]lL+,hXhEQ]r;-F*rqPZpWTqU,S"$+djLMq`p\t!g&GtqFVs_s0PE:m' dI*aUmeck\%0$%_\AdC jo5bfq=3Rs^o<.@kMOqDf\blXZ/>9Sn,E[jn'n>j l0%6kp#H,8roXCIl07L4liue!VnLpWr;-F*rqPZpU?psugt^`FlE\(_p\t!g#5dlKeD0-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-^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 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!..6VONkLO74rsA]! 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[jYHcQQVT\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!rrtPJ-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 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. 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,]Yh5KTpi4+XNg21qu79-puK!(]V_$rahOU;XgPg[`;[sb_8jX6_T0^rbl>Tg]XkMY]Z7S& lM:GPs*t~> lMhLrq^+GGDrH$k-tNg6m"n%.TTrr)KAU@6X6M04ZUeaK6bo_n:Z #QFM[][>QDT_b)XJoCQl!b$#!r/(B(#,]f9YL;q7?rtG7p aJ\=FRtGWaCk.ehkH;Ybq>U lMhLrq5n-eBIif!jg,#r7Cns#2\M/WRC;6r;RH.n^X?!kMOn;\\?GCi98jmg%>7?rtG7p aJ%t]gsjQFbL>5+l__M^q>UZt61LRbiolg)'+ DS#K lMhLrqW[@`tra2kNTTsr7Eg%>7?rtG7p aK`[cQ_V:6_PWU!_RIAFq>U li.XtqecA:l@c2,KfRt>Q`91rN.JsuVRB+iSf03H[9p[_/X@p DfU)Zc27M4s*t~> li.Xtq_: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.XtqZ$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!qXE4IViB2rJdMm: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#9GgmJ+DfC7$EH1aIEH,r:Df4cS C>N]ADLg"2oDa=~> m/Ie!qXE4IYJdZ8Q_Uh#W1TWNSu]!!rjfXQ`\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 m/IdtoA@0Qm,[!Rd`fq]fA>EIkNhL$rp(]om- 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=LfXQ`\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 mJe4+pufYhmH*0ScH=AWfAG`Rm)YrVR@I?IG(m-?li-5fmFmD,jS&QPrUea:lf[0Wce%(;l_<&( rU0\3rqgYOGLOcGA&c>kQ%//]gsjj/jQq=l<`iImLkgbBC15c3q>UllF"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>UO_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"e6iB2qN,Ck.ehkH)G]q>Ujs8VtM "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>l9s8DTBUfs`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"e6s+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* 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# mf+U0lc>gejP88/db<[EJQl`&E,p%!F8u8]s)W8]F)uC"Er>oXF8c+MrUea:lf[0Wce%(;l_<&( rTsRaEu0K/s)W8\pM7(Cl/C@EfAGcWkF8u,Y!WUODs"OHGhQONTiS)`&P#>DLbL5,(lEIta q>UEnq<,Sllf6aKbb& 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`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 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,rq1Wo)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+@1F*%BYErl,^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*%BYErlYe_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;^[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 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~> n,F"!puK'/]V_$rai29/T:E-p]_o\Ja8O3iaMkj"ZbO35m`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$^ 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 mf*jso\XW*i4kqFKmn5cF+oR7r0m\[rN-%2*Qc^^kO,mVFFV)rqYfrV[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_aQfSYEIhXGM(0;-\$lM1tq]!.Oops)n 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 mf*aqqX2)'ahP'TR[0G:U].=lUB%"dSGnipS>!!h^Wa6tg[G";qWl/*`3#B$X-fcs`jF_!roX4p b5LtbUO`4i":U&LeeW;`jt[/R*+VZ*@iSHbFb `4sd\r:Br=~> mJd^qpj[O*\aA4t^TjH#OH>CuM#`>1K)U-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.>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.>s8W&?s8N)drVo=`mE;NMYaV8sY*l&rV6m@kUV="&Tsr7Abfcd* \"T:rUR/+$_kXWXXd>f`R&7O6\E!A`s8W&ifV6TtT:E:/`4r( li.EIK7Mg$DMG[ZmHWWfg&0A#dJh30]!eJtHt[AE%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'\,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(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 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!ce8eaiYT$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^ 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^ li6t,2#YM9`T5ar\[SrOZ*:I+Y+i57WlW?)]V_$rai:i_S?g88cfjE(X2M-,USas8W&?s8N)drr6C(n'RuSZCIMqTpi4+^oONY\tb[rX-fcs^km]f [@`trTpi4+^8n`HbI=17Z([Vja/I2Kqu?]on^ li6s<2#i8_K_Y2kIsud#H[:"iH-j`V^2IeN^Yl_cHtd>EP/$(g^YmtZ`Se@iI"Ig.lD;5Xq>TOV 'SZMXfV7ibXGM(VX4?ZRH@gg(s8W%Os8QW\s8W)ol,0@_ad[p&KqQ]XKQ_1:jM6t.GDi`ZheJ;= ad[p&KqQ]XT"oMd_r/.gI"7L#kH2M^q>UEkm`hftad[p7R`OcP@;2l`EH?5FcZsikhL'a#It3(> JqEcNKSBHWo)F4~> li6s*2#hW_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^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 li6s*!<<%>#6+SXEcH)Lrbs4VDt*13kA"YEV;]=)D_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#``4s8W&?s8Q*ds8W)li3U>6VO+?aR&7OGY.D'T`3#B$]:k[ta*G"q R\@fXQ`\39ZFnr/_o0L4nA`NApAW/4aTMI` b5VC_!WVQXs*t~> li6s,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/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 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=+)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)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@mJ>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 nc'-kiPqjt^:9S9c"q??s8V$VEr^jlF!^j-s8R0?F8G@U>,:HCg=+9qguRgq^rr^gl/C@Ee_T?S IEq!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&>V90o[oo,eZ=UMM6#1qU"4elrVc_LL&Qf)s%<.Ra/A4ERtGX5TZul! F+3lVHuHjZ]9%DS=&!$r>&8_S`95UOL@kE@JBOYRc(Ti2JssdGW6"<#q nc'-^a/J@jl07NeV.FL`rVtgTEr^jlF!^j-s8R0V90o[oo(kMOn;fAGcWU"4/ZrVc_:F8g7Zs%<.Ra._k\gsjQuh<"$i @;P]2C0e=5iS)`&P&IF@T$,U;j6OjiG4b_0DTeR;jk\J3eD0-OU<)Zrq nc'-^a10:/]Y),+XLuKmrVuKgaoKffasI)1s8U7>aR@orYfV90o[on^[@`trSY!75U"76\rVc` nc'9SXPhXI]=Z#7iGIaturhU/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; 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% 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 nc'9D^Wa*WQ^[p@,uP\Yu4BZCIMq`knUVYab5VDEb5]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;5+lc?3`J,TEHETOj1lJgOHcIUk7m%)Ml p[6;%m,ZsOeD0-OKthI!F8l.BF8g6%rr)e:s)J8>EcV-Xrr2uFo)F4~> nc*F?cciegSZABQZH'5YfBDDaVS'sU^rQEPa2#%)\tb[rahbO*_PWU!_U,F?bl.S@aQ:(S^SmHs\=]:sae[;P p[6;5`3#B$UR/+$]>)8Yb5VADb5TQ+rr)f 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?>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?>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?>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 ]&:>mFOtothVTGi%`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 WOpDIV`!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(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;WWfs UR/+$]t;8*s8U6^^p;1nTpr=._7ub3Xi/Yoh=T(ns#A0ngTo&4Tpr nc'0VN6pChNd>MP?uq+#^s1EcrSSpRe^;LNXIG6(H?!kGIYWcWX4>"cJq))3aJeCGRtGX,OLsHM n,MYikMY1HdE024XJ(o@M1^8)MlYCsFL1&DZ2C^'RfS.[raGtABP;P_M(>%9lEJOb\AdC nc'-UK#m38g!S!WZHh%XioTA$kp,ETk2bLYgtC6*c-4M^f%8d9kI7I4D92%aU?psreBH@piT^@- s6LTgl07BnjPo.Uh:pZ8eC2juhrj 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[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 nc'-bOa-9ThUp<(bfS/]g>1Zai?R: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"1kmJ?DRJ,~> nc'0c_RddlS=?C\^WO$WQC=G@rMCg5T:D77S>36u[&]smQCOPP[D]AsaN3T2aK`[cQ_V:;X-]^_ [K!?GX/;YaSfsVNn4![_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_D0 ?>FP%s8R0 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 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 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/*tuiXm"ldU[-spg=kEGm%J%[Ec_9\ F8p8uEbXn&iSWPOjQrUXCiTISKDtljF8krNCT?[Zg=4X.iT]X5i:cr_ASLMnhV-W5eGdkrd.P]b dJhQ"e(ipGlEB+=rq$/?~> nc'*uho]#2Vgs3UcF+Nj]Y_mm\#W0X3RR\maIZJbHOhn6A>ZCI5MT;/?cX0M?) !3Z=%#cpAX[`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 nG`s&Ec9mW>*dk.l0.9jj8.^Uj5f:`kNV9ulb&!^@*`TTp2Y6SK6,B6kH:lNinrPgg)Jf%gtglF iSihXk3(smm-NEPaL8PS[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.aN28S!1EhR#aLaO`7) 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[@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<-]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*%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 nGa!1Kn]R+KS, 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~> 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 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&9IkmF+\OTEcH*nEH;$WK6.%l!/(.J*J8oml$$cPeS8uAr;Q`rcuX8KEGoZ:An,7V Z!1E2=V@H2=JDQn=^#$8?FjUifkbX(rpg#=~> nGa!Xb0'bab0&',aN)s3Sp8b5]i2ankeRaS>SQqoSi[s8Mi:)#qb$grf$2s6]jdrn>H5`9>/- a85bWs2t?@&Bb$qb0\;RaiMQtaN=D[d)u@f!7:TB*RN*Ul,: 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]cprcClrr@]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 nG`d!F*%B]F*!!6rcA)=rGrbSF*%A&s8R0?s)\3]K6.'6s8R.]s+C:M%,cbZF8buUEVT "EXTaF+aC3"oiXbs8R`Mrr@]Js8IWRre#63rVgm:rrCFCEs@8;EcH*npAJt1oE'")p&8q0E 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 nG`d+Kn]R,KnY`jre:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO s7h 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& 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 s7hL&_.+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 nG`dRb0'bab0&*2rlY6?rQ5oUb0'b,s8U7As2tAad)uC2s8U6as3U`E$hM`fb5_Lab5_Las8C(? s7jb:rt<]Ys3Sp8b5]i2b5_Lab5_Las8C+?s7seCs2rL>b3dRUmJd+ch#>G#s2tAas8U7>rrgLE b0'b^ap%gfb5_LgrVllEqZ$QA"TQikb5_I`rVllbqoSocrQ>0?rQ>0?!m:QCqoT*Bb5_Lab4#@\~> nG`O$L&V,PK`RD;re:@OrIl$eKn]P\s8RfQs+UK,PD0$js8Re,s-*E]$fmM*L&_1,L&_1,s8@WO s7h 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&#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 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&#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#leses)\5?F*$gM J,~> nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/G#s2tAas8U7>rrpRFb0'ba rQ5!: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#QJjds)\5?F70'Y~> nG`OKb5VG@aoTlhrlY6?rQ5WMb0'b,s8U7As2tAad)u=es2kBBd/G#s2tAas8U7>rrpRFb0'ba rQ5s8N/Cs8W)@#QMrhs2tBAb3o:[~> nG`O$L&V,PK`RD;re:@OrIkLVKn]P\s8RfOrrRn 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#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/s2t&'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)WhlF8l4EsM_dF8p=]s)[W. J,~> nG`OKb5VG@aoTlhrlY6?s2kKEb5]W,rVll?rVlrAd)u=es2kBBd/"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 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/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 nG`NoF8l4>Erq!oF8Z(%!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"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 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 o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4 o`#!5WoMY0s5WDE!6>&<_uB_Wrr2u=p&G&loD\l4 pAY0R pAY0R pAY0R 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?WrN+! *KF."q>WDSWrN+ZElV1?j&I*?j)R-[j8]."!36%u%rt[Ms8V+Zrr3MLs2S,[a8b1? pAY-nEr>qDEo[2[ElS0?WrN+! *KF."q>WDSWrN+ZElV1?j&I*?j)R-[j8]."!36%u%rt[Ms8V+Zrr3MLs2S,[a8b1? pAY-nEr>qDEo[2[ElS0?WrN+! *KF."q>WDSWrN+ZElV1?j&I*?j)R-[j8]."!36%u%rt[Ms8V+Zrr3MLs2S,[a8b1? pAY+mrW";dWrE(!s/H(!!!$">ErT,[EiK*>3<6)Ws8Q*ts8Q(,s)K,[ 3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[ <<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,[EiK*>3<6)Ws8Q*ts8Q(,s)K,[ 3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[ <<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,[EiK*>3<6)Ws8Q*ts8Q(,s)K,[ 3E9&Z*E<*[qYrPUWrN+!!!#"ZW`:&[ <<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*[ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? s/H(Zs&E(qruqHCs8T)!+" a8\/"EZP2[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*[ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? s/H(Zs&E(qruqHCs8T)!+" a8\/"EZP2[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*[ErV."WW9(!*QS*Xs&K$ts&BI,EZL2? s/H(Zs&E(qruqHCs8T)!+" a8\/"EZP2[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(!!;QTosts8Q(%WW3$!a8,`C!36)!UJq!;uls<=]$/WrE'>rrB)! WW<&!Wr;r"j)P-"p&BO~> nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTosts8Q(%WW3$!a8,`C!36)!UJq!;uls<=]$/WrE'>rrB)! WW<&!Wr;r"j)P-"p&BO~> nc':'WW9(!WW<&!WrK(!WW3$!a8`.>rVumt#QFe(s/H(!!;QTosts8Q(%WW3$!a8,`C!36)!UJq!;uls<=]$/WrE'>rrB)! WW<&!Wr;r"j)P-"p&BO~> p\u.P3<8([WrK(!rrB)!WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+>!<<'!WrH(!s8R*[j8Y." iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> p\u.P3<8([WrK(!rrB)!WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+>!<<'!WrH(!s8R*[j8Y." iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> p\u.P3<8([WrK(!rrB)!WW<"ts&B=(*EE,>3N<)Ss8Q(2s/L+>!<<'!WrH(!s8R*[j8Y." iuO/[!<<'!Wr2l8EZP0[!07'ZWlG+>iuO/#*TQ0?*>s2S.9rsJh,s8R*[j/N+>!35kp!NH.t s8Q(8rrB)!3E?)"ErV."ruG,>a)^4?s2P,>pA]X~> p\t5nr;Zp?WrI,WW<)! !35tss&BR/WW;)Z!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> p\t5nr;Zp?WrI,WW<)! !35tss&BR/WW;)Z!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> p\t5nr;Zp?WrI,WW<)! !35tss&BR/WW;)Z!!"&>iuS+!!`f8#rVupuqYpp'WrN+Z*<6([rrB(prrM-[rDa3bEcV0[ WrH(!s,R$Xs/Q%u!EI2>!!+,#pA]X~> pAY6TWiF,s8V->s8T+!j8Z+Z WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z #fluFWiH+!a/]+s2V/"a8c2" WlP/>j/T-Os*t~> pAY6TWiF,s8V->s8T+!j8Z+Z WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z #fluFWiH+!a/]+s2V/"a8c2" WlP/>j/T-Os*t~> pAY6TWiF,s8V->s8T+!j8Z+Z WiG[j#KQlEa8c2"j8K#XWWV;]j5^(;s/H;'a8c1[WoO*Y!6>*=!6>*=!QV5>rr^=As2Y$:s5X.Z #fluFWiH+!a/]+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 slime-2.20/doc/slime-small.pdf000066400000000000000000000163571315100173500162350ustar00rootroot00000000000000%PDF-1.3 %쏢 5 0 obj <> stream x+T03T0A(˥d^U`djhg 6406ҳu ,LML, -\jendstream endobj 6 0 obj 67 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 9 0 obj <> endobj 10 0 obj <> endobj 8 0 obj <>stream AdobedC  $, !$4.763.22:ASF:=N>22HbINVX]^]8EfmeZlS[]YC**Y;2;YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYf" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?( (.X(USH=zb|SfTU$!eV>aҭ F3LQXu#+&T(;f+,އ)'f(0\^J NIn+jYB=m<_N0]Ң[,PGXT1h\lqg&gqҺuz+>#`~qM Т:}ۜ`Zt 2=Eg_Lq$*ヂk?ΌR?i9XN1ݛTX~tlgEx[n{t$XGqS{Ad@|ď5k)$#$ʌDQE1Q@ E6v8f.Ksc=VyQ 7>^3>Ud]EgfFp8ϰKQ (9;{ȄN_$ĪXGNح7=w.Tߚ]AQ]K1KR' ;ZvmLrҹ)cm>(뢵8Ѡ %OcHEYR}oV"ߕ/M?Ess8|R/E}&P4nU)NU[yV/-fvvz֍lf (1SLna,I 仱t޷Dc?K!ŵň칿MVM•(ݝ6"\΍ o0$dAY653?iJ*)[CR𪞨?^jL$2p ?|V7>Y ՛U < o˟RjQ:p~_<-?jϷOܼ rk|X(A4%j$̲fVh90$R 0M}QӒA)"QYĘb I2XgѾ>c#+6wXݎ-f䓨1_^ ˵_-(UQ.uyeM W-v2ުFی{G :77zm1FۂTMJ/ėq+ hx\6]]U*ocIF*Xq?1+Q+ (354gDBK{>[ +O_SC' 6KIчAJAJ()+2bo敍e=sv֡fP1ZhFeAO͏+MYwF1ׯjӶ4۾7Ck{a1##\g+7v?O IICSMk5BMVry:nO~( D* J5#EQF٦U7?Y2FјU V b?CC~:O/Ͳ_Ef(be9#ZlUFIRXtMK̍ AZ៺Q 'ݏN7J;FקАUz#*̛ww>γ՗7ʛ(ΨIu.6.>֧D|=vAy*ȘemsԔ*ZΚm$oÁIH[k1+Sܐ?֧4BsO&3rWuVkT)S,?bA Vz~Kߴ8?)-$TҌ2>.p?<gYy }v}u_TFsb#r΅{q樵-bj7޿.TnVbH[o1>1ǫΨ+hS{{%ճRIQ>r$"S|,54@;C=N$dV2S!PW: VZXC idXMwE9[xzEyk3"#X`ĨSV46h.Y@`A;?Um&鸶ԖR>2qI]!Z`Wll=؞O|wMҤ;ƿWRb4cbTv5pʹ?^+T&Hx"\15Vz4d% 1'zT3+4!#!Xx#޳m.Y8f{eB \}0l sETQ>['?tv0JRdud.b^֫{miKzjjqm.*uNq5 X+5"mpav Q@~SY)B " wm*.֌aЃ@FvjUHFDUmhۏje?֮ZW1L$=HЫ;?cR #A8pc_j|{#IF2ԭï4ʲȪ}J7fim#hz!J>Lv.sgJ+]po+U5V)??Q ܰH=q~tH"]jH$`k)uΤWr=QX~Qk"8Iࠜ sS}k# F5m۰*%W{+MAPXjI#mtJRT|ϴz\vAƑ.ǺYinE 1qZ =@r((LNqOxtF\Z(URvH1" A&ԹZTP;hDT7w&Dځyރ>_=?McXgASugihbppwg ۉ* X8wX- [ѼXσ'z9+8 k$E :|,"I&@>Ee'ܪc9`?)+NX4Ky-u@W3WR{m+a8(? EI'p3G(9T~ۈc]nOj56ڂ4wJl& b~OAqj[a1_:LJ鮿 'z[3Y-f,u??fͷG|c;=M9Ջ)Ҙ _E1^Ztm~$8?z֫iא%WVR9մd.J@gЪo=XVP3~7Ic<1/c{f"A#"&guTwa%`فM孛]^7/Y_?#sڨV4w67=_ZM.f#n,3g9\cR3-undY$Ė xx-Z9&o/P>ku({[Ue*`LA iSw`?cWB#XAH]TzR{+*2Pox5űAcu'>~?Q–p&O %iB@=vsͦ6sB}UBiCNj?[Ҳtqqڦ9U݋`6ֺ?4lf[mqez#>Þ3J1@od1.┨ffڗZJGq+KFco~&T`W{R_}P-Kcc?$85hqjZv=>!Kf?'ieH+B3Ԕ湦yТ*+6V-Ai=ϗpS8,@iW=:Ze{kex|I#Pฏfu *N0" ,j3$1;b GnL7PK<ߺms'Kw+{56ˁOjMd7Pymo0`R(lei$X9<k(4?VfHfO+i39nF1.;yh_>wX&r( +ǡ<S<rn<}*)cՕGAd汴/ `-qOrEq,J=ޱm|}݄P@,̸ p,#g=SSPA]۳0"sӌW=}_%k< IR 3Yq藓jS[ {S- (Ny5{4nŴ+.(*[:c4ڂIij,A.qH?:^m,K"frUx'zT6F*ܨퟡ 5;;abC.1ufܯyy q"B=jf 啪HRPOQ D ܋eceo4Q*A}09ϵsxj-M~ok%2p6(y`=0H×O]i?V,??;ߒh[YG6SƮna*8?R+ Wga0@ |%g(p8R9ZxCוbR d#htVx'aXV};QMn  erT{r Ee"x"C|_JgZ4H)kzb †%sc-!?Cj; _Έ45s@n0;`H2;'\f|v[3ʼbOC pOGtQb/E񥥤Zg$brH(70 DFh8 dgӚjM`ֱk-.R8e^XNheyo+M%_d>kĚlt[d˂7 51Qlf?iP3x$sSan. "MoҹK QI`FIv;7uogq wdey5+"FNQK w+&wHGU`J}+4++s5ح͕h<{XG$տ i:d>uQFc g?>v9#h((((((((((((((((( endstream endobj 2 0 obj <>endobj xref 0 11 0000000000 65535 f 0000000384 00000 n 0000006864 00000 n 0000000325 00000 n 0000000170 00000 n 0000000015 00000 n 0000000152 00000 n 0000000432 00000 n 0000000532 00000 n 0000000473 00000 n 0000000502 00000 n trailer << /Size 11 /Root 1 0 R /Info 2 0 R /ID [(i9JI³}ij)(i9JI³}ij)] >> startxref 7066 %%EOF slime-2.20/doc/slime.css000066400000000000000000000020731315100173500151340ustar00rootroot00000000000000body { font-family: Georgia, serif; line-height: 1.3; padding-left: 5em; padding-right: 1em; padding-bottom: 1em; max-width: 60em; } table { border-collapse: collapse } span.roman { font-family: century schoolbook, serif; font-weight: normal; } h1, h2, h3, h4, h5, h6 { font-family: Helvetica, sans-serif } h4 { margin-top: 2.5em; } dfn { font-family: inherit; font-variant: italic; font-weight: bolder } var { font-variant: slanted; } td { padding-right: 1em; padding-left: 1em } sub { font-size: smaller } .node { padding: 0; margin: 0 } dd { padding-top: 1em; padding-bottom: 2em } pre.example { font-family: monospace; background-color: #E9FFE9; border: 1px solid #9D9; padding-top: 0.5em; padding-bottom: 0.5em; } a:link { color: #383; text-decoration: none; padding: 1px 2px 1px 2px; } a:visited { color: #161; text-decoration: none; padding: 1px 2px 1px 2px; } a:hover { color: #161; text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #666; } a:focus { color: #161; text-decoration: none; padding: 1px 2px 1px 2px; border: none; } slime-2.20/doc/slime.texi000066400000000000000000003425351315100173500153270ustar00rootroot00000000000000\input texinfo @c %**start of header @setfilename slime.info @documentencoding UTF-8 @codequoteundirected on @codequotebacktick on @dircategory Emacs @direntry * SLIME: (slime). Superior Lisp Interaction Mode for Emacs. @end direntry @c %**end of header @set EDITION 2.20 @set SLIMEVER 2.20 @set UPDATED @today{} @set TITLE SLIME User Manual @settitle @value{TITLE}, version @value{EDITION} @copying Written by Luke Gorrie and others. 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 @c Macros @macro SLIME @acronym{SLIME} @end macro @macro SLDB @acronym{SLDB} @end macro @macro REPL @acronym{REPL} @end macro @macro Git @acronym{Git} @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 Merge the variable and concept indices because both are rather short @synindex cp vr @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}. (Last updated @value{UPDATED}) @insertcopying @end ifnottex @menu * Introduction:: * Getting started:: * SLIME mode:: * Debugger:: * Misc:: * Customization:: * Tips and Tricks:: * Contributed Packages:: * Credits:: * Key Index:: * Command Index:: * Variable Index:: @detailmenu --- The Detailed Node Listing --- Getting started * Platforms:: * Downloading:: * Installation:: * Running:: * Setup Tuning:: Downloading @SLIME{} * Git:: * Git Incantations:: Setup Tuning * Basic customization:: * Multiple Lisps:: * Loading Swank faster:: Using @SLIME{} mode * User-interface conventions:: * Evaluation:: * Compilation:: * Completion:: * Finding definitions:: * Documentation:: * Cross-reference:: * Macro-expansion:: * Disassembly:: * Recovery:: * Inspector:: * Profiling:: * Other:: * Semantic indentation:: * Reader conditionals:: User-interface conventions * Temporary buffers:: * Inferior-lisp:: * Multithreading:: * Key bindings:: SLDB: the @SLIME{} debugger * Examining frames:: * Restarts:: * Frame Navigation:: * Stepping:: * Miscellaneous:: Misc * slime-selector:: * slime-macroexpansion-minor-mode:: * Multiple connections:: Customization * Emacs-side customization:: * Lisp-side:: Emacs-side * Hooks:: Lisp-side (Swank) * Communication style:: * Other configurables:: Tips and Tricks * Connecting to a remote lisp:: * Global IO Redirection:: * Auto-SLIME:: Connecting to a remote lisp * Setting up the lisp image:: * Setting up Emacs:: * Setting up pathname translations:: Contributed Packages * Loading Contribs:: * REPL:: * slime-mrepl:: * inferior-slime-mode:: * Compound Completion:: * Fuzzy Completion:: * slime-autodoc-mode:: * ASDF:: * Banner:: * Editing Commands:: * Fancy Inspector:: * Presentations:: * Typeout frames:: * TRAMP:: * Documentation Links:: * Xref and Class Browser:: * Highlight Edits:: * Scratch Buffer:: * SLIME Trace Dialog:: * slime-sprof:: * slime-fancy:: * Quicklisp:: REPL: the ``top level'' * REPL commands:: * Input Navigation:: * Shortcuts:: @end detailmenu @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 24 and 23.4 are supported. @emph{XEmacs is not supported anymore}. 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 Clozure Common Lisp (@acronym{CCL}), version 1.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, version 2.51 or newer with the patches from @url{http://www.grumblesmurf.org/lisp/corman-patches}) @item Scieneer Common Lisp (@acronym{SCL}), version 1.2.7 or newer @item Embedded Common Lisp (@acronym{ECL}) @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 @Git{} repository directly. You can download the latest released version from our website: @url{http://github.com/slime/slime/} We recommend that users who participate in the @code{slime-devel} mailing list use the @Git{} version of the code. @menu * Git:: * Git Incantations:: @end menu @c ----------------------- @node Git @subsection Downloading from Git @SLIME{} is available from the @Git{} repository on @file{github.com}. 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 download from @Git{} then remember to @code{git pull} occasionally. Improvements are continually being committed, and the @code{FAIRLY-STABLE} tag is moved forward from time to time. @c ----------------------- @node Git Incantations @subsection Git incantations To download the very latest @SLIME{} you first configure your @code{GitROOT} and login to the repository. @example git clone https://github.com/slime/slime.git @end example You might substitute @code{https} for @code{http} if you're having problems with that protocol. If you want to hack on @SLIME{}, use Github's @emph{fork} functionality and submit a @emph{pull request}. Be sure to first read the @uref{https://github.com/slime/slime/blob/master/CONTRIBUTING.md,,CONTRIBUTING.md} file first. @c ----------------------- @node Installation @section Installation The easiest way to install and keep @SLIME{} up-to-date is using Emacs's built-in package manager. @SLIME{} is available from the @uref{http://melpa.org,,MELPA} repository. After @uref{http://melpa.org/#/getting-started,,setting up the MELPA repository}, @SLIME{} can be installed via @kbd{M-x package-install RET slime RET}. You should then define your default Lisp in your @file{.emacs} as follows: @example (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") @end example At this point, you should be ready to start @ref{Running,,running SLIME}. This is the minimal configuration with the fewest frills. If the basic setup is working, you can try additional modules (@ref{Loading Contribs}). @subsection Installing from Git If you'd rather install @SLIME{} directly from its @uref{https://github.com/slime/slime,,git repository}, you will need to add a few extra lines in your @file{.emacs}: @vindex inferior-lisp-program @vindex load-path @example ;; @emph{Setup load-path, autoloads and your lisp system} ;; @emph{Not needed if you install SLIME via MELPA} (add-to-list 'load-path "~/dir/to/cloned/slime") (require 'slime-autoloads) (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") @end example You may optionally byte-compile @SLIME{} using @code{make compile contrib-compile}. @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. @node Setup Tuning @section Setup Tuning This section explains ways to perform basic extensions to @SLIME{}, and how to configure @SLIME{} for multiple Lisp systems and how to reduce @SLIME{}'s startup time. Please proceed with this section only if your basic setup works. If you are happy with the basic setup, skip this section. For contrib modules @pxref{Loading Contribs}. @menu * Basic customization:: * Multiple Lisps:: * Loading Swank faster:: @end menu @node Basic customization @subsection Basic customization Once you have the basic no-frills setup working, you can enhance your @SLIME{} installation with bundled extensions: @example ;; @emph{Setup load-path, autoloads and your lisp system} (add-to-list 'load-path "~/dir/to/cloned/slime") (require 'slime-autoloads) ;; @emph{Also setup the slime-fancy contrib} (add-to-list 'slime-contribs 'slime-fancy) @end example See @pxref{Loading Contribs} for more information on @SLIME{}'s contrib system. To customize a particular binding in one of @SLIME{}'s keymaps, you can add one of the following to your init file: @example (add-hook 'slime-load-hook (lambda () (define-key slime-prefix-map (kbd "M-h") 'slime-documentation-lookup))) @end example The former technique works only for @SLIME{}'s core keymaps, not it's contribs'. For those you can use the latter form which works for any Emacs library. See also @pxref{Customization} for more advanced configuration options. @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 @vindex slime-default-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. When called without a prefix, either the name specified in @code{slime-default-lisp}, or the first item of the list will be used. The elements of the list should look like @lisp (NAME (PROGRAM PROGRAM-ARGS...) &key CODING-SYSTEM INIT INIT-FUNCTION ENV) @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. (@pxref{slime-net-coding-system})x @item INIT should be a function which takes two arguments: a filename and a character encoding. The function should return a Lisp expression as a string which instructs Lisp to start the Swank server and to write the port number to the file. At startup, @SLIME{} starts the Lisp process and sends the result of this function to Lisp's standard input. As default, @code{slime-init-command} is used. An example is shown in @ref{init-example,,Loading Swank faster}. @item INIT-FUNCTION should be a function which takes no arguments. It is called after the connection is established. (See also @ref{slime-connected-hook}.) @item ENV specifies a list of environment variables for the subprocess. E.g. @lisp (sbcl-cvs ("/home/me/sbcl-cvs/src/runtime/sbcl" "--core" "/home/me/sbcl-cvs/output/sbcl.core") :env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/")) @end lisp initializes @code{SBCL_HOME} in the subprocess. @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") * (swank-loader:dump-image "sbcl.core-with-swank") @end example @noindent Then add this to your @file{.emacs}: @anchor{init-example} @lisp (setq slime-lisp-implementations '((sbcl ("sbcl" "--core" "sbcl.core-with-swank") :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 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:: * Evaluation:: * Compilation:: * Completion:: * Finding definitions:: * Documentation:: * Cross-reference:: * Macro-expansion:: * Disassembly:: * Recovery:: * Inspector:: * Profiling:: * Other:: * 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:: * Key bindings:: @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. @vindex slime-description-autofocus Initial focus of those ``description'' buffers depends on the variable @code{slime-description-autofocus}. If @code{nil} (the default), description buffers do not receive focus automatically, and vice versa. @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 inferior-slime-mode. Many people load the better integrated @SLIME{} @REPL{} contrib module (@pxref{REPL}) and ignore the @code{*inferior-lisp*} buffer. (@pxref{Loading Contribs} for information on how to enable the REPL.) @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 situations: 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 @node Key bindings @subsection Key bindings In general we try to make our key bindings fit with the overall Emacs style. We also have the following somewhat unusual convention of our 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! @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 , describe-key, ``What does this key do?''} Describes current function bound to @kbd{} 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 is breaks links PDF, despite that it's not l it's C-h @c @kbdanchorc{ l, , ``What starts with?''} @c Lists all keybindings that begin with @code{} for the focus buffer mode. @end table @emph{Note:} In this documentation the designation @kbd{C-h} is a @dfn{canonical 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}. 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{define-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 Evaluation @section Evaluation commands These commands each evaluate a Common Lisp expression in a different way. Usually they mimic commands for evaluating Emacs Lisp code. By default they show their results in the echo area, but a prefix argument causes the results to be inserted in the current buffer. @table @kbd @kbditem{C-x C-e, slime-eval-last-expression} Evaluate the expression before point and show the result in the echo area. @kbditem{C-M-x, slime-eval-defun} Evaluate the current toplevel form and show the result in the echo area. `C-M-x' treats `defvar' expressions specially. Normally, evaluating a `defvar' expression does nothing if the variable it defines already has a value. But `C-M-x' unconditionally resets the variable to the initial value specified in the `defvar' expression. This special feature is convenient for debugging Lisp programs. @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, rather than displaying it in the echo area. @table @kbd @kbditem{C-c :, slime-interactive-eval} Evaluate an expression read from the minibuffer. @kbditem{C-c C-r, slime-eval-region} Evaluate the region. @kbditem{C-c C-p, slime-pprint-eval-last-expression} Evaluate the expression before point and pretty-print the result in a fresh buffer. @kbditem{C-c E, slime-edit-value} Edit the value of a setf-able form in a new buffer @file{*Edit
*}. The value is inserted into a temporary buffer for editing and then set in Lisp when committed with @kbd{C-c C-c}. @kbditem{C-x M-e, slime-eval-last-expression-display-output} Display the output buffer and evaluate the expression preceding point. This is useful if the expression writes something to the output stream. @kbditem{C-c C-u, slime-undefine-function} Undefine the function, with @code{fmakunbound}, for the symbol at point. @end table @c ----------------------- @node Compilation @section Compilation commands @cindex Compilation @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 @cindex Compiling Functions @kbditem{C-c C-c, slime-compile-defun} Compile the top-level form at point. The region blinks shortly to give some feedback which part was chosen. With (positive) prefix argument the form is compiled with maximal debug settings (@kbd{C-u C-c C-c}). With negative prefix argument it is compiled for speed (@kbd{M-- C-c C-c}). If a numeric argument is passed set debug or speed settings to it depending on its sign. The code for the region is executed after compilation. In principle, the command writes the region to a file, compiles that file, and loads the resulting code. @kbditem{C-c C-k, slime-compile-and-load-file} Compile and load the current buffer's source file. If the compilation step fails, the file is not loaded. It's not always easy to tell whether the compilation failed: occasionally you may end up in the debugger during the load step. With (positive) prefix argument the file is compiled with maximal debug settings (@kbd{C-u C-c C-k}). With negative prefix argument it is compiled for speed (@kbd{M-- C-c C-k}). If a numeric argument is passed set debug or speed settings to it depending on its sign. @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 Lisp file. This command uses the Common Lisp LOAD function. @cmditem{slime-compile-region} Compile the selected region. @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. @kbditem{C-x `, next-error} Visit the next-error message. This is not actually a @SLIME{} command but @SLIME{} creates a hidden buffer so that most of the Compilation mode commands (@inforef{Compilation Mode,, emacs}) work similarly for Lisp as for batch compilers. @end table @node Completion @section Completion commands @cindex Completion @cindex Symbol Completion 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} @c @itemx ESC TAB @c @itemx C-M-i Complete the symbol at point. Note that three styles of completion are available in @SLIME{}; the default is similar to normal Emacs completion (@pxref{slime-completion-at-point-functions}). @end table @c ----------------------- @node Finding definitions @section Finding definitions (``Meta-Point'' commands). @cindex Meta-dot @cindex TAGS 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 switches 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 Documentation @section 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-d 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 ~, hyperspec-lookup-format} Lookup a @emph{format character} in the @cite{Common Lisp Hyperspec}. @kbditem{C-c C-d #, hyperspec-lookup-reader-macro} Lookup a @emph{reader macro} in the @cite{Common Lisp Hyperspec}. @end table @c ----------------------- @node Cross-reference @section Cross-reference commands @cindex xref @cindex Cross-referencing @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}. @menu * Xref buffer commands:: @end menu @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 @node Xref buffer commands @subsection Xref buffer commands Commands available in Xref buffers @table @kbd @kbditem{RET, slime-show-xref} Show definition at point in the other window. Do not leave Xref buffer. @kbditem{Space, slime-goto-xref} Show definition at point in the other window and close Xref buffer. @kbditem{C-c C-c, slime-recompile-xref} Recompile definition at point. @kbditem{C-c C-c, slime-recompile-all-xrefs} Recompile all definitions. @end table @c ----------------------- @node Macro-expansion @section Macro-expansion commands @cindex Macros @table @kbd @kbditem{C-c C-m, slime-expand-1} Macroexpand (or compiler-macroexpand) the expression starting at point once. If invoked with a prefix argument use macroexpand instead or macroexpand-1 (or compiler-macroexpand instead of compiler-macroexpand-1). @cmditem{slime-macroexpand-1} Macroexpand the expression starting 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 starting at point. @cmditem{slime-compiler-macroexpand-1} Display the compiler-macro expansion of sexp starting at point. @cmditem{slime-compiler-macroexpand} Repeatedy expand compiler macros of sexp starting at point. @end table For additional minor-mode commands and discussion, @pxref{slime-macroexpansion-minor-mode}. @c ----------------------- @node Disassembly @section 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 Recovery @section Abort/Recovery commands @table @kbd @kbditem{C-c C-b, slime-interrupt} Interrupt Lisp (send @code{SIGINT}). @cmditem{slime-restart-inferior-lisp} Restart the @code{inferior-lisp} process. @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}. @cmditem{slime-cd} Set the current directory of the Lisp process. This also changes the current directory of the REPL buffer. @cmditem{slime-pwd} Print the current directory of the Lisp process. @end table @c ----------------------- @node Inspector @section Inspector commands The @SLIME{} inspector is a 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. The inspector can easily be specialized for the objects in your own programs. For details see 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 recursively call the inspector on that value. If point is on an action then call that action. @kbditem{d, slime-inspector-describe} Describe the slot at point. @kbditem{e, slime-inspector-eval} Evaluate an expression in the context of the inspected object. @kbditem{v, slime-inspector-toggle-verbose} Toggle between verbose and terse mode. Default is determined by `swank:*inspector-verbose*'. @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{g, slime-inspector-reinspect} Reinspect. @kbditem{q, slime-inspector-quit} Dismiss the inspector buffer. @kbditem{p, slime-inspector-pprint} Pretty print in another buffer object at point. @kbditem{., slime-inspector-show-source} Find source of object at point. @kbditem{>, slime-inspector-fetch-all} Fetch all inspector contents and go to the end. @kbditem{M-RET, slime-inspector-copy-down} Store the value under point in the variable `*'. This can then be used to access the object in the REPL. @kbditempair{TAB, S-TAB, slime-inspector-next-inspectable-object, slime-inspector-previous-inspectable-object} Jump to the next and previous inspectable object respectively. @end table @c ----------------------- @node Profiling @section Profiling commands The profiling commands are based on CMUCL's profiler. These are simple wrappers around functions which usually print something to the output buffer. @table @kbd @cmditem{slime-toggle-profile-fdefinition} Toggle profiling of a function. @cmditem{slime-profile-package} Profile all functions in a package. @cmditem{slime-profile-by-substring} Profile all functions which names contain a substring. @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 @section 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, like @code{#+linux}, in source buffers and ``grays out'' code that will be skipped for the current Lisp connection. @c ----------------------- @node Debugger @chapter SLDB: the SLIME debugger @cindex 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:: * Stepping:: * 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. @kbditem{C-c C-c, sldb-recompile-frame-source} Recompile frame. @kbd{C-u C-c C-c} for recompiling with maximum debug settings. @end table @c ----------------------- @node Restarts @section Invoking restarts @table @kbd @kbditem{a, sldb-abort} Invoke the @code{ABORT} restart. @anchor{sldb-quit} @kbditem{q, sldb-quit} ``Quit'' -- For @SLIME{} evaluation requests, invoke a restart which restores to a known program state. For errors in other threads, see @ref{*SLDB-QUIT-RESTART*}. @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. @kbditem{>, sldb-end-of-backtrace} Fetch the entire backtrace and go to the last frame. @kbditem{<, sldb-beginning-of-backtrace} Goto the first frame. @end table @node Stepping @section Stepping @cindex Stepping Stepping is not available in all implementations and works very differently in those in which it is available. @table @kbd @kbditem{s, sldb-step} Step to the next expression in the frame. For CMUCL that means, set a breakpoint at all those code locations in the current code block which are reachable from the current code location. @kbditem{x, sldb-next} Step to the next form in the current function. @kbditem{o, sldb-out} Stop single-stepping temporarily, but resume it once the current function returns. @end table @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{B, sldb-break-with-default-debugger} Exit @SLDB{} and debug the condition using the Lisp system's default debugger. @kbditem{C, sldb-inspect-condition} Inspect the condition currently being debugged. @kbditem{:, slime-interactive-eval} Evaluate an expression entered in the minibuffer. @kbditem{A, sldb-break-with-system-debugger} Attach debugger (e.g. gdb) to the current lisp process. @end table @c ----------------------- @node Misc @chapter Misc @menu * slime-selector:: * slime-macroexpansion-minor-mode:: * Multiple connections:: @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}). @item c SLIME connections buffer (@pxref{Multiple connections}). @item n Cycle to the next Lisp connection (@pxref{Multiple connections}). @item t SLIME threads buffer (@pxref{Multiple connections}). @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-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. @kbditem{C-_, slime-macroexpand-undo} Undo last macroexpansion operation. @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. It is also available by the typing @kbd{c} from the @SLIME{} selector (@ref{slime-selector}). @kbditem{C-c C-x n, slime-cycle-connections} Change current Lisp connection by cycling through all connections. It is also available by the typing @kbd{n} from the SLIME selector (@ref{slime-selector}). @kbditem{C-c C-x t, slime-list-threads} Pop up a buffer listing the current threads. It is also available by the typing @kbd{t} from the @SLIME{} selector (@ref{slime-selector}). @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 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-completion-at-point-functions} @vindex slime-completion-at-point-functions @item slime-completion-at-point-functions A list of functions used for completion of Lisp symbols. This works as the standard @code{completion-at-point-functions} (@pxref{Completion in Buffers,,,elisp}). Three completion styles are available: @code{slime-simple-completion-at-point}, @code{slime-complete-symbol*} (@pxref{Compound Completion}), and @code{slime-fuzzy-complete-symbol} (@pxref{Fuzzy Completion}). The default is @code{slime-simple-completion-at-point}, which completes in the usual Emacs way. @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 filesystem but have different layouts, as is the case with @acronym{SMB}-based file sharing. @anchor{slime-net-coding-system} @vindex slime-net-coding-system @cindex Unicode @cindex UTF-8 @cindex ASCII @cindex LATIN-1 @cindex Character Encoding @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. (Different encodings can be used for different Lisps, see @ref{Multiple Lisps}.) @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}). @anchor{slime-connected-hook} @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. @anchor{*SLDB-QUIT-RESTART*} @vindex SWANK:*SLDB-QUIT-RESTART* @item SWANK:*SLDB-QUIT-RESTART* This variable names the restart that is invoked when pressing @kbd{q} (@pxref{sldb-quit}) in @SLDB{}. For @SLIME{} evaluation requests this is @emph{unconditionally} bound to a restart that returns to a safe point. This variable is supposed to customize what @kbd{q} does if an application's thread lands into the debugger (see @code{SWANK:*GLOBAL-DEBUGGER*}). @example (setf swank:*sldb-quit-restart* 'sb-thread:terminate-thread) @end example @vindex SWANK:*BACKTRACE-PRINTER-BINDINGS* @vindex SWANK:*MACROEXPAND-PRINTER-BINDINGS* @vindex SWANK:*SLDB-PRINTER-BINDINGS* @vindex SWANK:*SWANK-PPRINT-BINDINGS* @item SWANK:*BACKTRACE-PRINTER-BINDINGS* @itemx SWANK:*MACROEXPAND-PRINTER-BINDINGS* @itemx SWANK:*SLDB-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") (swank-loader:init) @end example inside a running lisp image@footnote{@SLIME{} also provides an @acronym{ASDF} system definition 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. Unfortunately NFS is usually slow, often buggy, and not always feasible, fortunately we have an ssh connection and Emacs' @code{tramp-mode} can do the rest. (See @inforef{Top, TRAMP User Manual,tramp}.) 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 @code{slime-tramp} contrib to setup the proper translations by simply doing: @example (add-to-list 'slime-filename-translations (slime-create-filename-translator :machine-instance "remote" :remote-host "remote.example.com" :username "user")) @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 @node Contributed Packages @chapter Contributed Packages In version 2.1 we moved some functionality to separate packages. This chapter tells you how to load contrib modules and describes what the particular packages do. @menu * Loading Contribs:: * REPL:: * slime-mrepl:: * inferior-slime-mode:: * Compound Completion:: * Fuzzy Completion:: * slime-autodoc-mode:: * ASDF:: * Banner:: * Editing Commands:: * Fancy Inspector:: * Presentations:: * Typeout frames:: * TRAMP:: * Documentation Links:: * Xref and Class Browser:: * Highlight Edits:: * Scratch Buffer:: * SLIME Trace Dialog:: * slime-sprof:: * SLIME Enhanced M-.:: * slime-fancy:: * Quicklisp:: @end menu @node Loading Contribs @section Loading Contrib Packages @cindex Contribs @cindex Contributions @cindex Plugins Contrib packages aren't loaded by default. You have to modify your setup a bit so that Emacs knows where to find them and which of them to load. Generally, you set the variable @code{slime-contribs} with the list of package-names that you want to use. For example, a setup to load the @code{slime-scratch} and @code{slime-editing-commands} packages looks like: @example ;; @emph{Setup load-path and autoloads} (add-to-list 'load-path "~/dir/to/cloned/slime") (require 'slime-autoloads) ;; @emph{Set your lisp system and some contribs} (setq inferior-lisp-program "/opt/sbcl/bin/sbcl") (setq slime-contribs '(slime-scratch slime-editing-commands)) @end example After starting @SLIME{}, the commands of both packages should be available. The REPL and @code{slime-fancy} modules deserve special mention. Many users consider the REPL (@pxref{REPL}) essential while @code{slime-fancy} (@pxref{slime-fancy}) loads the REPL and almost all of the popular contribs. So, if you aren't sure what to choose start with: @example (setq slime-contribs '(slime-repl)) ; repl only @end example If you like what you see try this: @example (setq slime-contribs '(slime-fancy)) ; almost everything @end example @subsection Loading and unloading ``on the fly'' We recommend that you setup contribs @emph{before} starting @SLIME{} via @kbd{M-x slime}, but if you want to enable more contribs @emph{after} you that, you can set the @code{slime-contribs} variable to another value and call @code{M-x slime-setup}. Note this though: @itemize @bullet @item If you've removed contribs from the list they won't be unloaded automatically. @item If you have more than one @SLIME{} connection currently active, you must manually repeat the @code{slime-setup} step for each of them. @end itemize Short of restarting Emacs, a reasonable way of unloading contribs is by calling an Emacs Lisp function whose name is obtained by adding @code{-unload} to the contrib's name, for every contrib you wish to unload. So, to remove @code{slime-repl}, you must call @code{slime-repl-unload}. Because the unload function will only, if ever, unload the Emacs Lisp side of the contrib, you may also need to restart your lisps. @c ----------------------- @node REPL @section REPL: the ``top level'' @cindex Listener @SLIME{} uses a custom Read-Eval-Print Loop (@REPL{}, also known as a ``top level'', or listener). 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 To load the REPL use @code{(add-to-list 'slime-contribs 'slime-repl)} in your @code{.emacs}. @table @kbd @kbditem{C-c C-z, slime-switch-to-output-buffer} Select the output buffer, preferably in a different window. @kbditem{C-c C-y, slime-call-defun} Insert a call to the function defined around point into the REPL. @kbditem{C-c C-j, slime-eval-last-expression-in-repl} Inserts the last expression to the REPL and evaluates it there. Switches to the current packae of the source buffer for the duration. If used with a prefix argument, doesn't switch back afterwards. @end table @menu * REPL commands:: * Input Navigation:: * Shortcuts:: @end menu @c ----------------------- @node REPL commands @subsection 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{TAB, slime-indent-and-complete-symbol} Indent the current line and perform symbol completion. @kbditem{C-j, slime-repl-newline-and-indent} Open and indent a new line. @kbditem{C-a, slime-repl-bol} Go to the beginning of the line, but stop at the @REPL{} prompt. @c @anchor{slime-interrupt} @kbditem{C-c C-c, slime-interrupt} Interrupt the Lisp process with @code{SIGINT}. @c @kbditem{C-c M-g, slime-quit} @c Quit @SLIME{}. @kbditem{C-c M-o, slime-repl-clear-buffer} Clear the entire buffer, leaving only a prompt. @kbditem{C-c C-o, slime-repl-clear-output} Remove the output and result of the previous expression from the buffer. @end table @c ----------------------- @node Input Navigation @subsection Input navigation @cindex Input History The input navigation (a.k.a. history) commands are modelled after @code{coming}-mode. Be careful if you are used to Bash-like keybindings: @kbd{M-p} and @kbd{M-n} use the current input as search pattern and only work Bash-like if the current line is empty. @kbd{C-} and @kbd{C-} work like the up and down keys in Bash. @table @kbd @kbditempair{C-, C-, slime-repl-forward-input, slime-repl-backward-input} Go to the next/previous history item. @kbditempair{M-n, M-p, slime-repl-next-input, slime-repl-previous-input} Search the next/previous item in the command history using the current input as search pattern. If @kbd{M-n}/@kbd{M-n} is typed two times in a row, the second invocation uses the same search pattern (even if the current input has changed). @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. Pressing RET on a line with old input copies that line to the newest prompt. @end table @vindex slime-repl-wrap-history The variable @code{slime-repl-wrap-history} controls wrap around behaviour, i.e. whether cycling should restart at the beginning of the history if the end is reached. @c ----------------------- @comment node-name, next, previous, up @node Shortcuts @subsection Shortcuts @cindex 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, in, in-package) Change the current package. @item compile-and-load (aka cl) Compile (if necessary) and load a lisp file. @item defparameter (aka !) Define a new global, special, variable. @item disconnect Disconnect all connections. @item help (aka ?) Display the help. @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 @node slime-mrepl @section Multiple REPLs The @code{slime-mrepl} package adds support for multiple listener buffers. The command @kbd{M-x slime-new-mrepl} creates a new buffer. In a multi-threaded Lisp, each listener is associated with a separate thread. In a single-threaded Lisp it's also possible to create multiple listener buffers but the commands are executed sequentially by the same process. @node inferior-slime-mode @section @code{inferior-slime-mode} The @code{inferior-slime-mode} is a minor mode is intended to use with the @code{*inferior-lisp*} lisp buffer. It provides some of the @SLIME{} commands, like symbol completion and documentation lookup. It also tracks the current directory of the Lisp process. To install it, add something like this to user @file{.emacs}: @example (add-to-list 'slime-contribs 'inferior-slime) @end example @table @kbd @cmditem{inferior-slime-mode} Turns inferior-slime-mode on or off. @end table @vindex inferior-slime-mode-map The variable @code{inferior-slime-mode-map} contains the extra keybindings. @node Compound Completion @section Compound Completion @anchor{slime-complete-symbol*} The package @code{slime-c-p-c} provides a different symbol completion algorithm, which 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 The variable @code{slime-c-p-c-unambiguous-prefix-p} specifies where point should be placed after completion. E.g. the possible completions for @code{f-o} are @code{finish-output} and @code{force-output}. By the default point is moved after the @code{f}, because that is the unambiguous prefix. If @code{slime-c-p-c-unambiguous-prefix-p} is nil, point moves to the end of the inserted text, after the @code{o} in this case. In addition, @code{slime-c-p-c} provides completion for character names (mostly useful for Unicode-aware implementations): @example CL-USER> #\Sp @end example Here @SLIME{} will usually complete the character to @code{#\Space}, but in a Unicode-aware implementation, this might provide the following completions: @example Space Space Sparkle Spherical_Angle Spherical_Angle_Opening_Left Spherical_Angle_Opening_Up @end example The package @code{slime-c-p-c} also provides context-sensitive completion for keywords. Example: @example CL-USER> (find 1 '(1 2 3) :s @end example Here @SLIME{} will complete @code{:start}, rather than suggesting all ever-interned keywords starting with @code{:s}. @table @kbd @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}, @code{defmethod}, and many other functions. Examples: @example (subseq "abc" --inserts--> start [end]) (find 17 --inserts--> sequence :from-end from-end :test test :test-not test-not :start start :end end :key key) (find 17 '(17 18 19) :test #'= --inserts--> :from-end from-end :test-not test-not :start start :end end :key key) (defclass foo () ((bar :initarg :bar))) (defmethod print-object --inserts--> (object stream) body...) (defmethod initialize-instance :after ((object foo) &key blub)) (make-instance 'foo --inserts--> :bar bar :blub blub initargs...) @end example @end table @node Fuzzy Completion @section Fuzzy Completion The package @code{slime-fuzzy} implements yet another symbol completion heuristic. @table @kbd @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. If you set the variable @code{slime-complete-symbol-function} to this command, fuzzy completion will also be used for @kbd{M-TAB}. @end table @subsection The Algorithm 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}''. The algorithm tries to expand every character in various ways and rates the list of possible completions with the following heuristic. 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. @subsection Duplicate Symbols In case a symbol is accessible via several packages, duplicate symbol filter specified via @code{*fuzzy-duplicate-symbol-filter*} swank variable is applied. @code{:nearest-package} value specifies that only symbols in the package with highest score should be kept. @code{:home-package} specifies that only the match that represents the home package of the symbol is used, and @code{:all} value specifies that duplicate symbol filter mode should be turned off. To specify a custom filter, set @code{*fuzzy-duplicate-symbol-filter*} to a function accepting three arguments: the name of package being examined, the list of names of all packages being examined with packages with highest matching score listed first and an @code{equal} hash-table that is shared between calls to the function and can be used for deduplication purposes. The function should return a deduplication filter function which accepts a symbol and returns true if the symbol should be kept. For example, the effect of @code{:nearest-package} can be also achieved by specifying the following custom filter in @file{~/.swank.lisp}: @example (setf *fuzzy-duplicate-symbol-filter* (lambda (cur-package all-packages dedup-table) (declare (ignore cur-package all-packages)) (lambda (symbol) (unless (gethash (symbol-name symbol) dedup-table) (setf (gethash (symbol-name symbol) dedup-table) t))))) @end example And instead of @code{:home-package}, the following can be used: @example (setf *fuzzy-duplicate-symbol-filter* (lambda (cur-package all-packages dedup-table) (declare (ignore dedup-table)) (let ((packages (mapcar #'find-package (remove cur-package all-packages)))) (lambda (symbol) (not (member (symbol-package symbol) packages)))))) @end example @node slime-autodoc-mode @section @code{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. Autodoc is implemented by means of @code{eldoc-mode} of Emacs. The mode can be enabled by default in your @code{~/.emacs}: @example (add-to-list 'slime-contribs 'slime-autodoc) @end example @table @kbd @cmditem{slime-arglist NAME} Show the argument list of the function NAME. @cmditem{slime-autodoc-mode} Toggles autodoc-mode on or off according to the argument, and toggles the mode when invoked without argument. @kbditem{C-c C-d a, slime-autodoc-manually} Like slime-autodoc, but when called twice, or after slime-autodoc was already automatically called, display multiline arglist. @end table @vindex slime-use-autodoc-mode If the variable @code{slime-use-autodoc-mode} is set (default), Emacs starts a timer, otherwise the information is only displayed after pressing SPC. @vindex slime-autodoc-use-multiline-p If @code{slime-autodoc-use-multiline-p} is set to non-nil, allow long autodoc messages to resize echo area display. @node ASDF @section ASDF @acronym{ASDF} is a popular ``system construction tool''. The package @code{slime-asdf} provides some commands to load and compile such systems from Emacs. @acronym{ASDF} itself is not included with @SLIME{}; you have to load that yourself into your Lisp. In particular, you must load @acronym{ASDF} before you connect, otherwise you will get errors about missing symbols. @table @kbd @cmditem{slime-load-system NAME} Compile and load an ASDF system. The default system name is taken from the first file matching *.asd in the current directory. @cmditem{slime-reload-system NAME} Recompile and load an ASDF system without recompiling its dependencies. @cmditem{slime-open-system NAME &optional LOAD} Open all files in a system, optionally load it if LOAD is non-nil. @cmditem{slime-browse-system NAME} Browse files in a system using Dired. @cmditem{slime-delete-system-fasls NAME} Delete FASLs produced by compiling a system. @cmditem{slime-rgrep-system NAME REGEXP} Run @code{rgrep} on the base directory of an ASDF system. @cmditem{slime-isearch-system NAME} Run @code{isearch-forward} on the files of an ASDF system. @cmditem{slime-query-replace-system NAME FROM TO &OPTIONAL DELIMITED} Run @code{query-replace} on an ASDF system. @end table The package also installs some new REPL shortcuts (@pxref{Shortcuts}): @table @kbd @item load-system Compile (as needed) and load an ASDF system. @item reload-system Recompile and load an ASDF system. @item compile-system Compile (but not load) an ASDF system. @item force-compile-system Recompile (but not load) an ASDF system. @item force-load-system Recompile and load an ASDF system. @item open-system Open all files in a system. @item browse-system Browse files in a system using Dired. @item delete-system-fasls Delete FASLs produced by compiling a system. @end table @node Banner @section Banner The package @code{slime-banner} installs a window header line ( @inforef{Header Lines, , elisp}.) in the REPL buffer. It also runs an animation at startup. @vindex slime-startup-animation @vindex slime-header-line-p By setting the variable @code{slime-startup-animation} to nil you can disable the animation respectively with the variable @code{slime-header-line-p} the header line. @node Editing Commands @section Editing Commands The package @code{slime-editing-commands} provides some commands to edit Lisp expressions. @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-c C-], slime-close-all-parens-in-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 REGION is true, operate on the region. Otherwise operate on the top-level sexp before point. @cmditem{slime-insert-balanced-comments} 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. @kbditem{M-C-a, slime-beginning-of-defun} @kbditem{M-C-e, slime-end-of-defun} @end table @node Fancy Inspector @section Fancy Inspector @cindex Methods An alternative to default inspector is provided by the package `slime-fancy-inspector'. This inspector knows a lot about CLOS objects and methods. It provides many ``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 key-bindings are the same as for the basic inspector (@pxref{Inspector}). @node Presentations @section Presentations @cindex Presentations A ``presentation''@footnote{Presentations are a feature originating from the Lisp machines. It was possible to define @code{present} methods specialized to various devices, e.g. to draw an object to bitmapped screen or to write some text to a character stream.} in @SLIME{} is a region of text associated with a Lisp object. Right-clicking on the text brings up a menu with operations for the particular object. Some operations, like inspecting, are available for all objects, but the object may also have specialized operations. For instance, pathnames have a dired operation. More importantly, it is possible to cut and paste presentations (i.e., Lisp objects, not just their printed presentation), using all standard Emacs commands. This way it is possible to cut and paste the results of previous computations in the REPL. This is of particular importance for unreadable objects. The package @code{slime-presentations} installs presentations in the REPL, i.e. the results of evaluation commands become presentations. In this way, presentations generalize the use of the standard Common Lisp REPL history variables @code{*}, @code{**}, @code{***}. Example: @example CL-USER> (find-class 'standard-class) @emph{#} CL-USER> @end example Presentations appear in red color in the buffer. (In this manual, we indicate the presentations @emph{like this}.) Using standard Emacs commands, the presentation can be copied to a new input in the REPL: @example CL-USER> (eql '@emph{#} '@emph{#}) @emph{T} @end example Note that standard evaluation and quoting rules still apply. So if a presentation is a list, it needs to be quoted in an evaluated context to avoid treating it as a function call: @example CL-USER> (list (find-class 'standard-class) 2 3 4) @emph{(# 2 3 4)} CL-USER> @emph{(# 2 3 4)} ; Funcall of # which is a non-function. ; Evaluation aborted. CL-USER> '@emph{(# 2 3 4)} (# 2 3 4) @end example When you copy an incomplete presentation or edit the text within a presentation, the presentation changes to plain text, losing the association with a Lisp object. In the buffer, this is indicated by changing the color of the text from red to black. This can be undone. Presentations are also available in the inspector (all inspectable parts are presentations) and the debugger (all local variables are presentations). This makes it possible to evaluate expressions in the REPL using objects that appear in local variables of some active debugger frame; this can be more convenient than using @code{M-x sldb-eval-in-frame}. @strong{Warning:} The presentations that stem from the inspector and debugger are only valid as long as the corresponding buffers are open. Using them later can cause errors or confusing behavior. For some Lisp implementations you can also install the package @code{slime-presentation-streams}, which enables presentations on the Lisp @code{*standard-output*} stream and similar streams. This means that not only results of computations, but also some objects that are printed to the standard output (as a side-effect of the computation) are associated with presentations. Currently, all unreadable objects and pathnames get printed as presentations. @example CL-USER> (describe (find-class 'standard-object)) @emph{#} is an instance of @emph{#}: The following slots have :INSTANCE allocation: PLIST NIL FLAGS 1 DIRECT-METHODS ((@emph{#} ... @end example Again, this makes it possible to inspect and copy-paste these objects. In addition to the standard Emacs commands, there are several keyboard commands, a menu-bar menu, and a context menu to operate on presentations. We describe the keyboard commands below; they are also shown in the menu-bar menu. @table @kbd @kbditem{C-c C-v SPC, slime-mark-presentation} If point is within a presentation, move point to the beginning of the presentation and mark to the end of the presentation. This makes it possible to copy the presentation. @kbditem{C-c C-v w, slime-copy-presentation-at-point-to-kill-ring} If point is within a presentation, copy the surrounding presentation to the kill ring. @kbditem{C-c C-v r, slime-copy-presentation-at-point-to-repl} If point is within a presentation, copy the surrounding presentation to the REPL. @kbditem{C-c C-v d, slime-describe-presentation-at-point} If point is within a presentation, describe the associated object. @kbditem{C-c C-v i, slime-inspect-presentation-at-point} If point is within a presentation, inspect the associated object with the @SLIME{} inspector. @kbditem{C-c C-v n, slime-next-presentation} Move point to the next presentation in the buffer. @kbditem{C-c C-v p, slime-previous-presentation} Move point to the previous presentation in the buffer. @end table Similar operations are also possible from the context menu of every presentation. Using @kbd{mouse-3} on a presentation, the context menu opens and offers various commands. For some objects, specialized commands are also offered. Users can define additional specialized commands by defining a method for @code{swank::menu-choices-for-presentation}. @strong{Warning:} On Lisp implementations without weak hash tables, all objects associated with presentations are protected from garbage collection. If your Lisp image grows too large because of that, use @kbd{C-c C-v M-o} (@code{slime-clear-presentations}) to remove these associations. You can also use the command @kbd{C-c M-o} (@code{slime-repl-clear-buffer}), which both clears the REPL buffer and removes all associations of objects with presentations. @strong{Warning:} Presentations can confuse new users. @example CL-USER> (cons 1 2) @emph{(1 . 2)} CL-USER> (eq '@emph{(1 . 2)} '@emph{(1 . 2)}) @emph{T} @end example One could have expected @code{NIL} here, because it looks like two fresh cons cells are compared regarding object identity. However, in the example the presentation @code{@emph{(1 . 2)}} was copied twice to the REPL. Thus @code{EQ} is really invoked with the same object, namely the cons cell that was returned by the first form entered in the REPL. @node Typeout frames @section Typeout frames @cindex Typeout Frame 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 should load the @code{slime-typeout-frame} package. (@pxref{Loading Contribs}.) The variable @code{slime-typeout-frame-properties} specifies the height and possibly other properties of the frame. Its value is passed to @code{make-frame}. (@inforef{Creating Frames, ,elisp}.) @node TRAMP @section TRAMP @cindex TRAMP The package @code{slime-tramp} provides some functions to set up filename translations for TRAMP. (@pxref{Setting up pathname translations}) @node Documentation Links @section Documentation Links For certain error messages, SBCL includes references to the ANSI Standard or the SBCL User Manual. The @code{slime-references} package turns those references into clickable links. This makes finding the referenced section of the HyperSpec much easier. @node Xref and Class Browser @section Xref and Class Browser A rudimentary class browser is provided by the @code{slime-xref-browser} package. @table @kbd @cmditem{slime-browse-classes} This command asks for a class name and displays inheritance tree of for the class. @cmditem{slime-browse-xrefs} This command prompts for a symbol and the kind of cross reference, e.g. callers. The cross reference tree rooted at the symbol is then then displayed. @end table @node Highlight Edits @section Highlight Edits @code{slime-highlight-edits} is a minor mode to highlight those regions in a Lisp source file which are modified. This is useful to quickly find those functions which need to be recompiled (with @kbd{C-c C-c}) @table @kbd @cmditem{slime-highlight-edits-mode} Turns @code{slime-highlight-edits-mode} on or off. @end table @node Scratch Buffer @section Scratch Buffer @anchor{slime-scratch} The @SLIME{} scratch buffer, in contrib package @code{slime-scratch}, imitates Emacs' usual @code{*scratch*} buffer. If @code{slime-scratch-file} is set, it is used to back the scratch buffer, making it persistent. The buffer is like any other Lisp buffer, except for the command bound to @kbd{C-j}. @table @kbd @kbditem{C-j, slime-eval-print-last-expression} Evaluate the expression sexp before point and insert print value into the current buffer. @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. @end table @node SLIME Trace Dialog @section SLIME Trace Dialog The @SLIME{} Trace Dialog, in package @code{slime-trace-dialog}, is a tracing facility, similar to Common Lisp's @code{trace}, but interactive rather than purely textual. It is an Emacs 24-only contrib. You use it just like you would regular @code{trace}: after tracing a function, calling it causes interesting information about that particular call to be reported. However, instead of printing the trace results to the the @code{*trace-output*} stream (usually the REPL), the @SLIME{} Trace Dialog collects and stores them in your lisp environment until, on user's request, they are fetched into Emacs and displayed in a dialog-like interactive view. To use this contrib, add it to @code{slime-contribs} in your @code{~/.emacs}, either directly by setting up @code{slime-fancy} (@pxref{slime-fancy}). @example ;; setting up 'slime-fancy would also have worked (add-to-list 'slime-contribs 'slime-trace-dialog) @end example After starting up @SLIME{}, @SLIME{}'s Trace Dialog installs a @emph{Trace} menu in the menu-bar of any @code{slime-mode} buffer and adds two new commands, with respective key-bindings: @table @kbd @kbditem{C-c M-t, slime-trace-dialog-toggle-trace} If point is on a symbol name, toggle tracing of its function definition. If point is not on a symbol, prompt user for a function. With a @kbd{C-u} prefix argument, and if your lisp implementation allows it, attempt to decipher lambdas, methods and other complicated function signatures. The function is traced for the @SLIME{} Trace Dialog only, i.e. it is not found in the list returned by Common Lisp's @code{trace}. @kbditem{C-c T, slime-trace-dialog} Pop to the interactive SLIME Trace Dialog buffer associated with the current connection (@pxref{Multiple connections}). @end table @page Consider the (useless) program: @example (defun foo (n) (if (plusp n) (* n (bar (1- n))) 1)) (defun bar (n) (if (plusp n) (* n (foo (1- n))) 1)) @end example After tracing both @code{foo} and @code{bar} with @kbd{C-c M-t}, calling call @code{(foo 2)} and moving to the trace dialog with @kbd{C-c T}, we are presented with this buffer. @example Traced specs (2) [refresh] [untrace all] [untrace] common-lisp-user::bar [untrace] common-lisp-user::foo Trace collection status (3/3) [refresh] [clear] 0 - common-lisp-user::foo | > 2 | < 2 1 `--- common-lisp-user::bar | > 1 | < 1 2 `-- common-lisp-user::foo > 0 < 1 @end example The dialog is divided into sections displaying the functions already traced, the trace collection progress and the actual trace tree that follow your program's logic. The most important key-bindings in this buffer are: @table @kbd @kbditem{g, slime-trace-dialog-fetch-status} Update information on the trace collection and traced specs. @kbditem{G, slime-trace-dialog-fetch-traces} Fetch the next batch of outstanding (not fetched yet) traces. With a @kbd{C-u} prefix argument, repeat until no more outstanding traces. @kbditem{C-k, slime-trace-dialog-clear-fetched-traces} Prompt for confirmation, then clear all traces, both fetched and outstanding. @end table The arguments and return values below each entry are interactive buttons. Clicking them opens the inspector (@pxref{Inspector}). Invoking @kbd{M-RET} (@code{slime-trace-dialog-copy-down-to-repl}) returns them to the REPL for manipulation (@pxref{REPL}). The number left of each entry indicates its absolute position in the calling order, which might differ from display order in case multiple threads call the same traced function. @code{slime-trace-dialog-hide-details-mode} hides arguments and return values so you can concentrate on the calling logic. Additionally, @code{slime-trace-dialog-autofollow-mode} will automatically display additional detail about an entry when the cursor moves over it. @node slime-sprof @section @code{slime-sprof} @code{slime-sprof} is a package for integrating SBCL's statistical profiler, sb-sprof. The variable @code{slime-sprof-exclude-swank} controls whether to display swank functions. The default value is NIL. @table @kbd @cmditem{slime-sprof-start} Start profiling. @cmditem{slime-sprof-stop} Stop profiling. @cmditem{slime-sprof-report} Report results of the profiling. @end table The following keys are defined in slime-sprof-browser mode: @table @kbd @kbditem{RET, slime-sprof-browser-toggle} Expand / collapse function details (callers, calls to) @kbditem{v, slime-sprof-browser-view-source} View function sources. @kbditem{d, slime-sprof-browser-disassemble-function} Disassemble function. @kbditem{s, slime-sprof-toggle-swank-exclusion} Toggle exclusion of swank functions from the report. @end table @node SLIME Enhanced M-. @section SLIME Enhanced M-. @code{slime-mdot-fu} enables meta-point to jump to local variables bound with @code{let} and @code{let*}, in addition to function bindings declared with @code{flet} and @code{labels}, via @code{slime-edit-local-definition}. @node slime-fancy @section Meta package: @code{slime-fancy} @code{slime-fancy} is a meta package which loads a combination of the most popular packages. @node Quicklisp @section Quicklisp The package @code{slime-quicklisp} adds support for loading Quicklisp systems in the REPL buffer. In order for this to work, Quicklisp should have already been loaded in the Lisp implementation. Refer to @url{https://www.quicklisp.org/} for Quicklisp installation details. The package installs the following REPL shortcuts (@pxref{Shortcuts}): @table @kbd @item quicklisp-quickload (aka ql) Load a Quicklisp system. @end table @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 ignored, because texinfo's built-in indexing produces nicer results. -- Helmut Eller @c@node Index to Functions @c@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-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 @unnumbered Key (Character) Index @printindex ky @node Command Index @unnumbered Command and Function Index @printindex fn @node Variable Index @unnumbered Variable and Concept Index @printindex vr @bye Local Variables: paragraph-start: "@[a-zA-Z]+\\({[^}]+}\\)?[ \n]\\|[ ]*$" paragraph-separate: "@[a-zA-Z]+\\({[^}]+}\\)?[ \n]\\|[ ]*$" End: slime-2.20/doc/texinfo-tabulate.awk000066400000000000000000000007641315100173500172750ustar00rootroot00000000000000#!/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"); } slime-2.20/lib/000077500000000000000000000000001315100173500133105ustar00rootroot00000000000000slime-2.20/lib/.nosearch000066400000000000000000000000751315100173500151150ustar00rootroot00000000000000;; normal-top-level-add-subdirs-to-load-path needs this file slime-2.20/lib/cl-lib.el000066400000000000000000000325021315100173500147760ustar00rootroot00000000000000;;; cl-lib.el --- Properly prefixed CL functions and macros -*- coding: utf-8 -*- ;; Copyright (C) 2012, 2013, 2014 Free Software Foundation, Inc. ;; Author: Stefan Monnier ;; vcomment: Emacs-24.3's version is 1.0 so this has to stay below. ;; Version: 0.5 ;; 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 3 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, see . ;;; Commentary: ;; This is a forward compatibility package, which provides (a subset of) the ;; features of the cl-lib package introduced in Emacs-24.3, for use on ;; previous emacsen. ;; Make sure this is installed *late* in your `load-path`, i.e. after Emacs's ;; built-in .../lisp/emacs-lisp directory, so that if/when you upgrade to ;; Emacs-24.3, the built-in version of the file will take precedence, otherwise ;; you could get into trouble (although we try to hack our way around the ;; problem in case it happens). ;; This code is largely copied from Emacs-24.3's cl.el, with the alias bindings ;; simply reversed. ;;; Code: ;; We need to handle the situation where this package is used with an Emacs ;; that comes with a real cl-lib (i.e. ≥24.3). ;; First line of defense: try to make sure the built-in cl-lib comes earlier in ;; load-path so we never get loaded: ;;;###autoload (let ((d (file-name-directory #$))) ;;;###autoload (when (member d load-path) ;;;###autoload (setq load-path (append (remove d load-path) (list d))))) (when (functionp 'macroexp--compiler-macro) ;; `macroexp--compiler-macro' was introduced as part of the big CL ;; reorganization which moved/reimplemented some of CL into core (mostly the ;; setf and compiler-macro support), so its presence indicates we're running ;; in an Emacs that comes with the new cl-lib.el, where this file should ;; never be loaded! (message "Real cl-lib shadowed by compatibility cl-lib? (%s)" load-file-name) (when load-file-name ;; (message "Let's try to patch things up") (let ((loaddir (file-name-directory load-file-name)) load-path-dir) ;; Find the problematic directory from load-path. (dolist (dir load-path) (if (equal loaddir (expand-file-name (file-name-as-directory dir))) (setq load-path-dir dir))) (when load-path-dir ;; (message "Let's move the offending dir to the end") (setq load-path (append (remove load-path-dir load-path) (list load-path-dir))) ;; Here we could manually load cl-lib and then return immediately. ;; But Emacs currently doesn't provide any way for a file to "return ;; immediately", so instead we make sure the rest of the file does not ;; throw away any pre-existing definition. )))) (require 'cl) ;; Some of Emacs-24.3's cl.el definition are not just aliases, because either ;; the feature was dropped from cl-lib.el or because the cl-lib version is ;; not fully compatible. ;; Let's just not include them here, since it is very important that if code ;; works with this cl-lib.el it should also work with Emacs-24.3's cl-lib.el, ;; whereas the reverse is much less important. (dolist (var '( ;; loop-result-var ;; loop-result ;; loop-initially ;; loop-finally ;; loop-bindings ;; loop-args ;; bind-inits ;; bind-block ;; lambda-list-keywords float-negative-epsilon float-epsilon least-negative-normalized-float least-positive-normalized-float least-negative-float least-positive-float most-negative-float most-positive-float ;; custom-print-functions )) (let ((new (intern (format "cl-%s" var)))) (unless (boundp new) (defvaralias new var)))) ;; The following cl-lib functions were already defined in the old cl.el, ;; with a different meaning: ;; - cl-position and cl-delete-duplicates ;; the two meanings are clearly different, but we can distinguish which was ;; meant by looking at the arguments. ;; - cl-member ;; the old meaning hasn't been used for a long time and is a subset of the ;; new, so we can simply override it. ;; - cl-adjoin ;; the old meaning is actually the same as the new except for optimizations. (dolist (fun '( (get* . cl-get) (random* . cl-random) (rem* . cl-rem) (mod* . cl-mod) (round* . cl-round) (truncate* . cl-truncate) (ceiling* . cl-ceiling) (floor* . cl-floor) (rassoc* . cl-rassoc) (assoc* . cl-assoc) ;; (member* . cl-member) ;Handle specially below. (delete* . cl-delete) (remove* . cl-remove) (defsubst* . cl-defsubst) (sort* . cl-sort) (function* . cl-function) (defmacro* . cl-defmacro) (defun* . cl-defun) (mapcar* . cl-mapcar) remprop getf tailp list-length nreconc revappend concatenate subseq random-state-p make-random-state signum isqrt lcm gcd notevery notany every some mapcon mapcan mapl maplist map equalp coerce tree-equal nsublis sublis nsubst-if-not nsubst-if nsubst subst-if-not subst-if subsetp nset-exclusive-or set-exclusive-or nset-difference set-difference nintersection intersection nunion union rassoc-if-not rassoc-if assoc-if-not assoc-if member-if-not member-if merge stable-sort search mismatch count-if-not count-if count position-if-not position-if ;; position ;Handle specially via defadvice below. find-if-not find-if find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not substitute-if substitute ;; delete-duplicates ;Handle specially via defadvice below. remove-duplicates delete-if-not delete-if remove-if-not remove-if replace fill reduce compiler-macroexpand define-compiler-macro assert check-type typep deftype defstruct callf2 callf letf* letf rotatef shiftf remf psetf declare the locally multiple-value-setq multiple-value-bind symbol-macrolet macrolet progv psetq do-all-symbols do-symbols dotimes dolist do* do loop return-from return block etypecase typecase ecase case load-time-value eval-when destructuring-bind gentemp gensym pairlis acons subst ;; adjoin ;It's already defined. copy-list ldiff list* cddddr cdddar cddadr cddaar cdaddr cdadar cdaadr cdaaar cadddr caddar cadadr cadaar caaddr caadar caaadr caaaar cdddr cddar cdadr cdaar caddr cadar caadr caaar tenth ninth eighth seventh sixth fifth fourth third endp rest second first svref copy-seq evenp oddp minusp plusp floatp-safe declaim proclaim nth-value multiple-value-call multiple-value-apply multiple-value-list values-list values pushnew decf incf dolist dotimes )) (let ((new (if (consp fun) (prog1 (cdr fun) (setq fun (car fun))) (intern (format "cl-%s" fun))))) (if (fboundp new) (unless (or (eq (symbol-function new) fun) (eq new (and (symbolp fun) (fboundp fun) (symbol-function fun)))) (message "%S already defined, not rebinding" new)) (defalias new fun)))) (unless (symbolp (symbol-function 'position)) (autoload 'cl-position "cl-seq") (defadvice cl-position (around cl-lib (cl-item cl-seq &rest cl-keys) activate) (let ((argk (ad-get-args 2))) (if (or (null argk) (keywordp (car argk))) ;; This is a call to cl-lib's `cl-position'. (setq ad-return-value (apply #'position (ad-get-arg 0) (ad-get-arg 1) argk)) ;; Must be a call to cl's old `cl-position'. ad-do-it)))) (unless (symbolp (symbol-function 'delete-duplicates)) (autoload 'cl-delete-duplicates "cl-seq") (defadvice cl-delete-duplicates (around cl-lib (cl-seq &rest cl-keys) activate) (let ((argk (ad-get-args 1))) (if (or (null argk) (keywordp (car argk))) ;; This is a call to cl-lib's `cl-delete-duplicates'. (setq ad-return-value (apply #'delete-duplicates (ad-get-arg 0) argk)) ;; Must be a call to cl's old `cl-delete-duplicates'. ad-do-it)))) (when (or (not (fboundp 'cl-member)) (eq (symbol-function 'cl-member) #'memq)) (defalias 'cl-member #'member*)) ;; `cl-labels' is not 100% compatible with `labels' when using dynamic scoping ;; (mostly because it does not turn lambdas that refer to those functions into ;; closures). OTOH it is compatible when using lexical scoping. (unless (fboundp 'cl-labels) (defmacro cl-labels (&rest args) (unless (and (boundp 'lexical-binding) lexical-binding) ;; We used to signal an error rather than a message, but in many uses of ;; cl-labels, the value of lexical-binding doesn't actually matter. ;; More importantly, the value of `lexical-binding' here is unreliable ;; (it does not necessarily reflect faithfully whether the output of this ;; macro will be interpreted as lexically bound code or not). (message "This `cl-labels' requires `lexical-binding' to be non-nil")) `(labels ,@args))) ;;;; ChangeLog: ;; 2014-02-25 Stefan Monnier ;; ;; Fixes: debbugs:16671 ;; ;; * cl-lib.el (cl-position, cl-delete-duplicate): Don't advise if >=24.3. ;; (load-path): Try to make sure we're at the end. ;; ;; 2014-01-25 Stefan Monnier ;; ;; * cl-lib.el: Resolve conflicts with old internal definitions ;; (bug#16353). ;; (dolist fun): Don't skip definitions silently. ;; (define-setf-expander): Remove, not in cl-lib. ;; (cl-position, cl-delete-duplicates): Add advice to distinguish the use ;; case. ;; (cl-member): Override old definition. ;; ;; 2013-05-22 Stefan Monnier ;; ;; * cl-lib.el (cl-labels): Demote error to message and improve it. ;; ;; 2012-11-30 Stefan Monnier ;; ;; * cl-lib.el: Try and patch things up in case we're hiding the real ;; cl-lib. ;; ;; 2012-11-22 Stefan Monnier ;; ;; Add cl-letf and cl-labels. ;; ;; 2012-11-16 Stefan Monnier ;; ;; * packages/cl-lib: New package. ;; (provide 'cl-lib) ;;; cl-lib.el ends here slime-2.20/lib/ert-x.el000066400000000000000000003166131315100173500147030ustar00rootroot00000000000000;;; ert.el --- Emacs Lisp Regression Testing ;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc. ;; Author: Christian M. Ohler ;; Keywords: lisp, tools ;; This file is NOT part of GNU Emacs. ;; 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 3 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, see `http://www.gnu.org/licenses/'. ;;; Commentary: ;; ERT is a tool for automated testing in Emacs Lisp. Its main ;; features are facilities for defining and running test cases and ;; reporting the results as well as for debugging test failures ;; interactively. ;; ;; The main entry points are `ert-deftest', which is similar to ;; `defun' but defines a test, and `ert-run-tests-interactively', ;; which runs tests and offers an interactive interface for inspecting ;; results and debugging. There is also ;; `ert-run-tests-batch-and-exit' for non-interactive use. ;; ;; The body of `ert-deftest' forms resembles a function body, but the ;; additional operators `should', `should-not' and `should-error' are ;; available. `should' is similar to cl's `assert', but signals a ;; different error when its condition is violated that is caught and ;; processed by ERT. In addition, it analyzes its argument form and ;; records information that helps debugging (`assert' tries to do ;; something similar when its second argument SHOW-ARGS is true, but ;; `should' is more sophisticated). For information on `should-not' ;; and `should-error', see their docstrings. ;; ;; See ERT's info manual as well as the docstrings for more details. ;; To compile the manual, run `makeinfo ert.texinfo' in the ERT ;; directory, then C-u M-x info ert.info in Emacs to view it. ;; ;; To see some examples of tests written in ERT, see its self-tests in ;; ert-tests.el. Some of these are tricky due to the bootstrapping ;; problem of writing tests for a testing tool, others test simple ;; functions and are straightforward. ;;; Code: (eval-when-compile (require 'cl)) (require 'button) (require 'debug) (require 'easymenu) (require 'ewoc) (require 'find-func) (require 'help) ;;; UI customization options. (defgroup ert () "ERT, the Emacs Lisp regression testing tool." :prefix "ert-" :group 'lisp) (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) :background "green3")) "Face used for expected results in the ERT results buffer." :group 'ert) (defface ert-test-result-unexpected '((((class color) (background light)) :background "red1") (((class color) (background dark)) :background "red3")) "Face used for unexpected results in the ERT results buffer." :group 'ert) ;;; Copies/reimplementations of cl functions. (defun ert--cl-do-remf (plist tag) "Copy of `cl-do-remf'. Modify PLIST by removing TAG." (let ((p (cdr plist))) (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) (defun ert--remprop (sym tag) "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." (let ((plist (symbol-plist sym))) (if (and plist (eq tag (car plist))) (progn (setplist sym (cdr (cdr plist))) t) (ert--cl-do-remf plist tag)))) (defun ert--remove-if-not (ert-pred ert-list) "A reimplementation of `remove-if-not'. ERT-PRED is a predicate, ERT-LIST is the input list." (loop for ert-x in ert-list if (funcall ert-pred ert-x) collect ert-x)) (defun ert--intersection (a b) "A reimplementation of `intersection'. Intersect the sets A and B. Elements are compared using `eql'." (loop for x in a if (memql x b) collect x)) (defun ert--set-difference (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eql'." (loop for x in a unless (memql x b) collect x)) (defun ert--set-difference-eq (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eq'." (loop for x in a unless (memq x b) collect x)) (defun ert--union (a b) "A reimplementation of `union'. Compute the union of the sets A and B. Elements are compared using `eql'." (append a (ert--set-difference b a))) (eval-and-compile (defvar ert--gensym-counter 0)) (eval-and-compile (defun ert--gensym (&optional prefix) "Only allows string PREFIX, not compatible with CL." (unless prefix (setq prefix "G")) (make-symbol (format "%s%s" prefix (prog1 ert--gensym-counter (incf ert--gensym-counter)))))) (defun ert--coerce-to-vector (x) "Coerce X to a vector." (when (char-table-p x) (error "Not supported")) (if (vectorp x) x (vconcat x))) (defun* ert--remove* (x list &key key test) "Does not support all the keywords of remove*." (unless key (setq key #'identity)) (unless test (setq test #'eql)) (loop for y in list unless (funcall test x (funcall key y)) collect y)) (defun ert--string-position (c s) "Return the position of the first occurrence of C in S, or nil if none." (loop for i from 0 for x across s when (eql x c) return i)) (defun ert--mismatch (a b) "Return index of first element that differs between A and B. Like `mismatch'. Uses `equal' for comparison." (cond ((or (listp a) (listp b)) (ert--mismatch (ert--coerce-to-vector a) (ert--coerce-to-vector b))) ((> (length a) (length b)) (ert--mismatch b a)) (t (let ((la (length a)) (lb (length b))) (assert (arrayp a) t) (assert (arrayp b) t) (assert (<= la lb) t) (loop for i below la when (not (equal (aref a i) (aref b i))) return i finally (return (if (/= la lb) la (assert (equal a b) t) nil))))))) (defun ert--subseq (seq start &optional end) "Return a subsequence of SEQ from START to END." (when (char-table-p seq) (error "Not supported")) (let ((vector (substring (ert--coerce-to-vector seq) start end))) (etypecase seq (vector vector) (string (concat vector)) (list (append vector nil)) (bool-vector (loop with result = (make-bool-vector (length vector) nil) for i below (length vector) do (setf (aref result i) (aref vector i)) finally (return result))) (char-table (assert nil))))) (defun ert-equal-including-properties (a b) "Return t if A and B have similar structure and contents. This is like `equal-including-properties' except that it compares the property values of text properties structurally (by recursing) rather than with `eq'. Perhaps this is what `equal-including-properties' should do in the first place; see Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; This implementation is inefficient. Rather than making it ;; efficient, let's hope bug 6581 gets fixed so that we can delete ;; it altogether. (not (ert--explain-not-equal-including-properties a b))) ;;; Defining and locating tests. ;; The data structure that represents a test case. (defstruct ert-test (name nil) (documentation nil) (body (assert nil)) (most-recent-result nil) (expected-result-type ':passed) (tags '())) (defun ert-test-boundp (symbol) "Return non-nil if SYMBOL names a test." (and (get symbol 'ert--test) t)) (defun ert-get-test (symbol) "If SYMBOL names a test, return that. Signal an error otherwise." (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) (get symbol 'ert--test)) (defun ert-set-test (symbol definition) "Make SYMBOL name the test DEFINITION, and return DEFINITION." (when (eq symbol 'nil) ;; We disallow nil since `ert-test-at-point' and related functions ;; want to return a test name, but also need an out-of-band value ;; on failure. Nil is the most natural out-of-band value; using 0 ;; or "" or signalling an error would be too awkward. ;; ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) (put symbol 'ert--test definition) definition) (defun ert-make-test-unbound (symbol) "Make SYMBOL name no test. Return SYMBOL." (ert--remprop symbol 'ert--test) symbol) (defun ert--parse-keys-and-body (keys-and-body) "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. KEYS-AND-BODY should have the form of a property list, with the exception that only keywords are permitted as keys and that the tail -- the body -- is a list of forms that does not start with a keyword. Returns a two-element list containing the keys-and-values plist and the body." (let ((extracted-key-accu '()) (remaining keys-and-body)) (while (and (consp remaining) (keywordp (first remaining))) (let ((keyword (pop remaining))) (unless (consp remaining) (error "Value expected after keyword %S in %S" keyword keys-and-body)) (when (assoc keyword extracted-key-accu) (warn "Keyword %S appears more than once in %S" keyword keys-and-body)) (push (cons keyword (pop remaining)) extracted-key-accu))) (setq extracted-key-accu (nreverse extracted-key-accu)) (list (loop for (key . value) in extracted-key-accu collect key collect value) remaining))) ;;;###autoload (defmacro* ert-deftest (name () &body docstring-keys-and-body) "Define NAME (a symbol) as a test. BODY is evaluated as a `progn' when the test is run. It should signal a condition on failure or just return if the test passes. `should', `should-not' and `should-error' are useful for assertions in BODY. Use `ert' to run tests interactively. Tests that are expected to fail can be marked as such using :expected-result. See `ert-test-result-type-p' for a description of valid values for RESULT-TYPE. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ \[:tags '(TAG...)] BODY...)" (declare (debug (&define :name test name sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 3) (indent 2)) (let ((documentation nil) (documentation-supplied-p nil)) (when (stringp (first docstring-keys-and-body)) (setq documentation (pop docstring-keys-and-body) documentation-supplied-p t)) (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) (tags nil tags-supplied-p)) body) (ert--parse-keys-and-body docstring-keys-and-body) `(progn (ert-set-test ',name (make-ert-test :name ',name ,@(when documentation-supplied-p `(:documentation ,documentation)) ,@(when expected-result-supplied-p `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) :body (lambda () ,@body))) ;; This hack allows `symbol-file' to associate `ert-deftest' ;; forms with files, and therefore enables `find-function' to ;; work with tests. However, it leads to warnings in ;; `unload-feature', which doesn't know how to undefine tests ;; and has no mechanism for extension. (push '(ert-deftest . ,name) current-load-list) ',name)))) ;; We use these `put' forms in addition to the (declare (indent)) in ;; the defmacro form since the `declare' alone does not lead to ;; correct indentation before the .el/.elc file is loaded. ;; Autoloading these `put' forms solves this. ;;;###autoload (progn ;; TODO(ohler): Figure out what these mean and make sure they are correct. (put 'ert-deftest 'lisp-indent-function 2) (put 'ert-info 'lisp-indent-function 1)) (defvar ert--find-test-regexp (concat "^\\s-*(ert-deftest" find-function-space-re "%s\\(\\s-\\|$\\)") "The regexp the `find-function' mechanisms use for finding test definitions.") (put 'ert-test-failed 'error-conditions '(error ert-test-failed)) (put 'ert-test-failed 'error-message "Test failed") (defun ert-pass () "Terminate the current test and mark it passed. Does not return." (throw 'ert--pass nil)) (defun ert-fail (data) "Terminate the current test and mark it failed. Does not return. DATA is displayed to the user and should state the reason of the failure." (signal 'ert-test-failed (list data))) ;;; The `should' macros. (defvar ert--should-execution-observer nil) (defun ert--signal-should-execution (form-description) "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." (when ert--should-execution-observer (funcall ert--should-execution-observer form-description))) (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) (let ((definition (indirect-function thing t))) (and (subrp definition) (eql (cdr (subr-arity definition)) 'unevalled))))) (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form ;; If `cl-macroexpand' isn't bound, the code that we're ;; compiling doesn't depend on cl and thus doesn't need an ;; environment arg for `macroexpand'. (if (fboundp 'cl-macroexpand) ;; Suppress warning about run-time call to cl funtion: we ;; only call it if it's fboundp. (with-no-warnings (cl-macroexpand form (and (boundp 'cl-macro-environment) cl-macro-environment))) (macroexpand form)))) (cond ((or (atom form) (ert--special-operator-p (car form))) (let ((value (ert--gensym "value-"))) `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) ,(funcall inner-expander `(setq ,value ,form) `(list ',whole :form ',form :value ,value) value) ,value))) (t (let ((fn-name (car form)) (arg-forms (cdr form))) (assert (or (symbolp fn-name) (and (consp fn-name) (eql (car fn-name) 'lambda) (listp (cdr fn-name))))) (let ((fn (ert--gensym "fn-")) (args (ert--gensym "args-")) (value (ert--gensym "value-")) (default-value (ert--gensym "ert-form-evaluation-aborted-"))) `(let ((,fn (function ,fn-name)) (,args (list ,@arg-forms))) (let ((,value ',default-value)) ,(funcall inner-expander `(setq ,value (apply ,fn ,args)) `(nconc (list ',whole) (list :form `(,,fn ,@,args)) (unless (eql ,value ',default-value) (list :value ,value)) (let ((-explainer- (and (symbolp ',fn-name) (get ',fn-name 'ert-explainer)))) (when -explainer- (list :explanation (apply -explainer- ,args))))) value) ,value)))))))) (defun ert--expand-should (whole form inner-expander) "Helper function for the `should' macro and its variants. Analyzes FORM and returns an expression that has the same semantics under evaluation but records additional debugging information. INNER-EXPANDER should be a function and is called with two arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is an expression that returns a description of FORM. INNER-EXPANDER should return code that calls INNER-FORM and performs the checks and error signalling specific to the particular variant of `should'. The code that INNER-EXPANDER returns must not call FORM-DESCRIPTION-FORM before it has called INNER-FORM." (lexical-let ((inner-expander inner-expander)) (ert--expand-should-1 whole form (lambda (inner-form form-description-form value-var) (let ((form-description (ert--gensym "form-description-"))) `(let (,form-description) ,(funcall inner-expander `(unwind-protect ,inner-form (setq ,form-description ,form-description-form) (ert--signal-should-execution ,form-description)) `,form-description value-var))))))) (defmacro* should (form) "Evaluate FORM. If it returns nil, abort the current test as failed. Returns the value of FORM." (ert--expand-should `(should ,form) form (lambda (inner-form form-description-form value-var) `(unless ,inner-form (ert-fail ,form-description-form))))) (defmacro* should-not (form) "Evaluate FORM. If it returns non-nil, abort the current test as failed. Returns nil." (ert--expand-should `(should-not ,form) form (lambda (inner-form form-description-form value-var) `(unless (not ,inner-form) (ert-fail ,form-description-form))))) (defun ert--should-error-handle-error (form-description-fn condition type exclude-subtypes) "Helper function for `should-error'. Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, and aborts the current test as failed if it doesn't." (let ((signalled-conditions (get (car condition) 'error-conditions)) (handled-conditions (etypecase type (list type) (symbol (list type))))) (assert signalled-conditions) (unless (ert--intersection signalled-conditions handled-conditions) (ert-fail (append (funcall form-description-fn) (list :condition condition :fail-reason (concat "the error signalled did not" " have the expected type"))))) (when exclude-subtypes (unless (member (car condition) handled-conditions) (ert-fail (append (funcall form-description-fn) (list :condition condition :fail-reason (concat "the error signalled was a subtype" " of the expected type")))))))) ;; FIXME: The expansion will evaluate the keyword args (if any) in ;; nonstandard order. (defmacro* should-error (form &rest keys &key type exclude-subtypes) "Evaluate FORM and check that it signals an error. The error signalled needs to match TYPE. TYPE should be a list of condition names. (It can also be a non-nil symbol, which is equivalent to a singleton list containing that symbol.) If EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its condition names is an element of TYPE. If EXCLUDE-SUBTYPES is non-nil, the error matches TYPE if it is an element of TYPE. If the error matches, returns (ERROR-SYMBOL . DATA) from the error. If not, or if no error was signalled, abort the test as failed." (unless type (setq type ''error)) (ert--expand-should `(should-error ,form ,@keys) form (lambda (inner-form form-description-form value-var) (let ((errorp (ert--gensym "errorp")) (form-description-fn (ert--gensym "form-description-fn-"))) `(let ((,errorp nil) (,form-description-fn (lambda () ,form-description-form))) (condition-case -condition- ,inner-form ;; We can't use ,type here because we want to evaluate it. (error (setq ,errorp t) (ert--should-error-handle-error ,form-description-fn -condition- ,type ,exclude-subtypes) (setq ,value-var -condition-))) (unless ,errorp (ert-fail (append (funcall ,form-description-fn) (list :fail-reason "did not signal an error"))))))))) ;;; Explanation of `should' failures. ;; TODO(ohler): Rework explanations so that they are displayed in a ;; similar way to `ert-info' messages; in particular, allow text ;; buttons in explanations that give more detail or open an ediff ;; buffer. Perhaps explanations should be reported through `ert-info' ;; rather than as part of the condition. (defun ert--proper-list-p (x) "Return non-nil if X is a proper list, nil otherwise." (loop for firstp = t then nil for fast = x then (cddr fast) for slow = x then (cdr slow) do (when (null fast) (return t)) (when (not (consp fast)) (return nil)) (when (null (cdr fast)) (return t)) (when (not (consp (cdr fast))) (return nil)) (when (and (not firstp) (eq fast slow)) (return nil)))) (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-not-equal'." (typecase x (fixnum (list x (format "#x%x" x) (format "?%c" x))) (t x))) (defun ert--explain-not-equal (a b) "Explainer function for `equal'. Returns a programmer-readable explanation of why A and B are not `equal', or nil if they are." (if (not (equal (type-of a) (type-of b))) `(different-types ,a ,b) (etypecase a (cons (let ((a-proper-p (ert--proper-list-p a)) (b-proper-p (ert--proper-list-p b))) (if (not (eql (not a-proper-p) (not b-proper-p))) `(one-list-proper-one-improper ,a ,b) (if a-proper-p (if (not (equal (length a) (length b))) `(proper-lists-of-different-length ,(length a) ,(length b) ,a ,b first-mismatch-at ,(ert--mismatch a b)) (loop for i from 0 for ai in a for bi in b for xi = (ert--explain-not-equal ai bi) do (when xi (return `(list-elt ,i ,xi))) finally (assert (equal a b) t))) (let ((car-x (ert--explain-not-equal (car a) (car b)))) (if car-x `(car ,car-x) (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) (if cdr-x `(cdr ,cdr-x) (assert (equal a b) t) nil)))))))) (array (if (not (equal (length a) (length b))) `(arrays-of-different-length ,(length a) ,(length b) ,a ,b ,@(unless (char-table-p a) `(first-mismatch-at ,(ert--mismatch a b)))) (loop for i from 0 for ai across a for bi across b for xi = (ert--explain-not-equal ai bi) do (when xi (return `(array-elt ,i ,xi))) finally (assert (equal a b) t)))) (atom (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) `(different-atoms ,(ert--explain-format-atom a) ,(ert--explain-format-atom b))) nil))))) (put 'equal 'ert-explainer 'ert--explain-not-equal) (defun ert--significant-plist-keys (plist) "Return the keys of PLIST that have non-null values, in order." (assert (zerop (mod (length plist) 2)) t) (loop for (key value . rest) on plist by #'cddr unless (or (null value) (memq key accu)) collect key into accu finally (return accu))) (defun ert--plist-difference-explanation (a b) "Return a programmer-readable explanation of why A and B are different plists. Returns nil if they are equivalent, i.e., have the same value for each key, where absent values are treated as nil. The order of key/value pairs in each list does not matter." (assert (zerop (mod (length a) 2)) t) (assert (zerop (mod (length b) 2)) t) ;; Normalizing the plists would be another way to do this but it ;; requires a total ordering on all lisp objects (since any object ;; is valid as a text property key). Perhaps defining such an ;; ordering is useful in other contexts, too, but it's a lot of ;; work, so let's punt on it for now. (let* ((keys-a (ert--significant-plist-keys a)) (keys-b (ert--significant-plist-keys b)) (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) (flet ((explain-with-key (key) (let ((value-a (plist-get a key)) (value-b (plist-get b key))) (assert (not (equal value-a value-b)) t) `(different-properties-for-key ,key ,(ert--explain-not-equal-including-properties value-a value-b))))) (cond (keys-in-a-not-in-b (explain-with-key (first keys-in-a-not-in-b))) (keys-in-b-not-in-a (explain-with-key (first keys-in-b-not-in-a))) (t (loop for key in keys-a when (not (equal (plist-get a key) (plist-get b key))) return (explain-with-key key))))))) (defun ert--abbreviate-string (s len suffixp) "Shorten string S to at most LEN chars. If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." (let ((n (length s))) (cond ((< n len) s) (suffixp (substring s (- n len))) (t (substring s 0 len))))) (defun ert--explain-not-equal-including-properties (a b) "Explainer function for `ert-equal-including-properties'. Returns a programmer-readable explanation of why A and B are not `ert-equal-including-properties', or nil if they are." (if (not (equal a b)) (ert--explain-not-equal a b) (assert (stringp a) t) (assert (stringp b) t) (assert (eql (length a) (length b)) t) (loop for i from 0 to (length a) for props-a = (text-properties-at i a) for props-b = (text-properties-at i b) for difference = (ert--plist-difference-explanation props-a props-b) do (when difference (return `(char ,i ,(substring-no-properties a i (1+ i)) ,difference context-before ,(ert--abbreviate-string (substring-no-properties a 0 i) 10 t) context-after ,(ert--abbreviate-string (substring-no-properties a (1+ i)) 10 nil)))) ;; TODO(ohler): Get `equal-including-properties' fixed in ;; Emacs, delete `ert-equal-including-properties', and ;; re-enable this assertion. ;;finally (assert (equal-including-properties a b) t) ))) (put 'ert-equal-including-properties 'ert-explainer 'ert--explain-not-equal-including-properties) ;;; Implementation of `ert-info'. ;; TODO(ohler): The name `info' clashes with ;; `ert--test-execution-info'. One or both should be renamed. (defvar ert--infos '() "The stack of `ert-info' infos that currently apply. Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") (defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) &body body) "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. To be used within ERT tests. MESSAGE-FORM should evaluate to a string that will be displayed together with the test result if the test fails. PREFIX-FORM should evaluate to a string as well and is displayed in front of the value of MESSAGE-FORM." (declare (debug ((form &rest [sexp form]) body)) (indent 1)) `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) ,@body)) ;;; Facilities for running a single test. (defvar ert-debug-on-error nil "Non-nil means enter debugger when a test fails or terminates with an error.") ;; The data structures that represent the result of running a test. (defstruct ert-test-result (messages nil) (should-forms nil) ) (defstruct (ert-test-passed (:include ert-test-result))) (defstruct (ert-test-result-with-condition (:include ert-test-result)) (condition (assert nil)) (backtrace (assert nil)) (infos (assert nil))) (defstruct (ert-test-quit (:include ert-test-result-with-condition))) (defstruct (ert-test-failed (:include ert-test-result-with-condition))) (defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) (defun ert--record-backtrace () "Record the current backtrace (as a list) and return it." ;; Since the backtrace is stored in the result object, result ;; objects must only be printed with appropriate limits ;; (`print-level' and `print-length') in place. For interactive ;; use, the cost of ensuring this possibly outweighs the advantage ;; of storing the backtrace for ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we ;; already have `ert-results-rerun-test-debugging-errors-at-point'. ;; For batch use, however, printing the backtrace may be useful. (loop ;; 6 is the number of frames our own debugger adds (when ;; compiled; more when interpreted). FIXME: Need to describe a ;; procedure for determining this constant. for i from 6 for frame = (backtrace-frame i) while frame collect frame)) (defun ert--print-backtrace (backtrace) "Format the backtrace BACKTRACE to the current buffer." ;; This is essentially a reimplementation of Fbacktrace ;; (src/eval.c), but for a saved backtrace, not the current one. (let ((print-escape-newlines t) (print-level 8) (print-length 50)) (dolist (frame backtrace) (ecase (first frame) ((nil) ;; Special operator. (destructuring-bind (special-operator &rest arg-forms) (cdr frame) (insert (format " %S\n" (list* special-operator arg-forms))))) ((t) ;; Function call. (destructuring-bind (fn &rest args) (cdr frame) (insert (format " %S(" fn)) (loop for firstp = t then nil for arg in args do (unless firstp (insert " ")) (insert (format "%S" arg))) (insert ")\n"))))))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. (defstruct ert--test-execution-info (test (assert nil)) (result (assert nil)) ;; A thunk that may be called when RESULT has been set to its final ;; value and test execution should be terminated. Should not ;; return. (exit-continuation (assert nil)) ;; The binding of `debugger' outside of the execution of the test. next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the ;; execution of the current test. We store it to avoid being ;; affected by any new bindings the test itself may establish. (I ;; don't remember whether this feature is important.) ert-debug-on-error) (defun ert--run-test-debugger (info debugger-args) "During a test run, `debugger' is bound to a closure that calls this function. This function records failures and errors and either terminates the test silently or calls the interactive debugger, as appropriate. INFO is the ert--test-execution-info corresponding to this test run. DEBUGGER-ARGS are the arguments to `debugger'." (destructuring-bind (first-debugger-arg &rest more-debugger-args) debugger-args (ecase first-debugger-arg ((lambda debug t exit nil) (apply (ert--test-execution-info-next-debugger info) debugger-args)) (error (let* ((condition (first more-debugger-args)) (type (case (car condition) ((quit) 'quit) (otherwise 'failed))) (backtrace (ert--record-backtrace)) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) (ecase type (quit (make-ert-test-quit :condition condition :backtrace backtrace :infos infos)) (failed (make-ert-test-failed :condition condition :backtrace backtrace :infos infos)))) ;; Work around Emacs' heuristic (in eval.c) for detecting ;; errors in the debugger. (incf num-nonmacro-input-events) ;; FIXME: We should probably implement more fine-grained ;; control a la non-t `debug-on-error' here. (cond ((ert--test-execution-info-ert-debug-on-error info) (apply (ert--test-execution-info-next-debugger info) debugger-args)) (t)) (funcall (ert--test-execution-info-exit-continuation info))))))) (defun ert--run-test-internal (ert-test-execution-info) "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." (lexical-let ((info ert-test-execution-info)) (setf (ert--test-execution-info-next-debugger info) debugger (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) (catch 'ert--pass ;; For now, each test gets its own temp buffer and its own ;; window excursion, just to be safe. If this turns out to be ;; too expensive, we can remove it. (with-temp-buffer (save-window-excursion (let ((debugger (lambda (&rest debugger-args) (ert--run-test-debugger info debugger-args))) (debug-on-error t) (debug-on-quit t) ;; FIXME: Do we need to store the old binding of this ;; and consider it in `ert--run-test-debugger'? (debug-ignored-errors nil) (ert--infos '())) (funcall (ert-test-body (ert--test-execution-info-test info)))))) (ert-pass)) (setf (ert--test-execution-info-result info) (make-ert-test-passed))) nil) (defun ert--force-message-log-buffer-truncation () "Immediately truncate *Messages* buffer according to `message-log-max'. This can be useful after reducing the value of `message-log-max'." (with-current-buffer (get-buffer-create "*Messages*") ;; This is a reimplementation of this part of message_dolog() in xdisp.c: ;; if (NATNUMP (Vmessage_log_max)) ;; { ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, ;; -XFASTINT (Vmessage_log_max) - 1, 0); ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); ;; } (when (and (integerp message-log-max) (>= message-log-max 0)) (let ((begin (point-min)) (end (save-excursion (goto-char (point-max)) (forward-line (- message-log-max)) (point)))) (delete-region begin end))))) (defvar ert--running-tests nil "List of tests that are currently in execution. This list is empty while no test is running, has one element while a test is running, two elements while a test run from inside a test is running, etc. The list is in order of nesting, innermost test first. The elements are of type `ert-test'.") (defun ert-run-test (ert-test) "Run ERT-TEST. Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (setf (ert-test-most-recent-result ert-test) nil) (block error (lexical-let ((begin-marker (with-current-buffer (get-buffer-create "*Messages*") (set-marker (make-marker) (point-max))))) (unwind-protect (lexical-let ((info (make-ert--test-execution-info :test ert-test :result (make-ert-test-aborted-with-non-local-exit) :exit-continuation (lambda () (return-from error nil)))) (should-form-accu (list))) (unwind-protect (let ((ert--should-execution-observer (lambda (form-description) (push form-description should-form-accu))) (message-log-max t) (ert--running-tests (cons ert-test ert--running-tests))) (ert--run-test-internal info)) (let ((result (ert--test-execution-info-result info))) (setf (ert-test-result-messages result) (with-current-buffer (get-buffer-create "*Messages*") (buffer-substring begin-marker (point-max)))) (ert--force-message-log-buffer-truncation) (setq should-form-accu (nreverse should-form-accu)) (setf (ert-test-result-should-forms result) should-form-accu) (setf (ert-test-most-recent-result ert-test) result)))) (set-marker begin-marker nil)))) (ert-test-most-recent-result ert-test)) (defun ert-running-test () "Return the top-level test currently executing." (car (last ert--running-tests))) ;;; Test selectors. (defun ert-test-result-type-p (result result-type) "Return non-nil if RESULT matches type RESULT-TYPE. Valid result types: nil -- Never matches. t -- Always matches. :failed, :passed -- Matches corresponding results. \(and TYPES...\) -- Matches if all TYPES match. \(or TYPES...\) -- Matches if some TYPES match. \(not TYPE\) -- Matches if TYPE does not match. \(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. (etypecase result-type ((member nil) nil) ((member t) t) ((member :failed) (ert-test-failed-p result)) ((member :passed) (ert-test-passed-p result)) (cons (destructuring-bind (operator &rest operands) result-type (ecase operator (and (case (length operands) (0 t) (t (and (ert-test-result-type-p result (first operands)) (ert-test-result-type-p result `(and ,@(rest operands))))))) (or (case (length operands) (0 nil) (t (or (ert-test-result-type-p result (first operands)) (ert-test-result-type-p result `(or ,@(rest operands))))))) (not (assert (eql (length operands) 1)) (not (ert-test-result-type-p result (first operands)))) (satisfies (assert (eql (length operands) 1)) (funcall (first operands) result))))))) (defun ert-test-result-expected-p (test result) "Return non-nil if TEST's expected result type matches RESULT." (ert-test-result-type-p result (ert-test-expected-result-type test))) (defun ert-select-tests (selector universe) "Return the tests that match SELECTOR. UNIVERSE specifies the set of tests to select from; it should be a list of tests, or t, which refers to all tests named by symbols in `obarray'. Returns the set of tests as a list. Valid selectors: nil -- Selects the empty set. t -- Selects UNIVERSE. :new -- Selects all tests that have not been run yet. :failed, :passed -- Select tests according to their most recent result. :expected, :unexpected -- Select tests according to their most recent result. a string -- Selects all tests that have a name that matches the string, a regexp. a test -- Selects that test. a symbol -- Selects the test that the symbol names, errors if none. \(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. \(eql TEST\) -- Selects TEST, a test or a symbol naming a test. \(and SELECTORS...\) -- Selects the tests that match all SELECTORS. \(or SELECTORS...\) -- Selects the tests that match any SELECTOR. \(not SELECTOR\) -- Selects all tests that do not match SELECTOR. \(tag TAG) -- Selects all tests that have TAG on their tags list. \(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. Only selectors that require a superset of tests, such as (satisfies ...), strings, :new, etc. make use of UNIVERSE. Selectors that do not, such as \(member ...\), just return the set implied by them without checking whether it is really contained in UNIVERSE." ;; This code needs to match the etypecase in ;; `ert-insert-human-readable-selector'. (etypecase selector ((member nil) nil) ((member t) (etypecase universe (list universe) ((member t) (ert-select-tests "" universe)))) ((member :new) (ert-select-tests `(satisfies ,(lambda (test) (null (ert-test-most-recent-result test)))) universe)) ((member :failed) (ert-select-tests `(satisfies ,(lambda (test) (ert-test-result-type-p (ert-test-most-recent-result test) ':failed))) universe)) ((member :passed) (ert-select-tests `(satisfies ,(lambda (test) (ert-test-result-type-p (ert-test-most-recent-result test) ':passed))) universe)) ((member :expected) (ert-select-tests `(satisfies ,(lambda (test) (ert-test-result-expected-p test (ert-test-most-recent-result test)))) universe)) ((member :unexpected) (ert-select-tests `(not :expected) universe)) (string (etypecase universe ((member t) (mapcar #'ert-get-test (apropos-internal selector #'ert-test-boundp))) (list (ert--remove-if-not (lambda (test) (and (ert-test-name test) (string-match selector (ert-test-name test)))) universe)))) (ert-test (list selector)) (symbol (assert (ert-test-boundp selector)) (list (ert-get-test selector))) (cons (destructuring-bind (operator &rest operands) selector (ecase operator (member (mapcar (lambda (purported-test) (etypecase purported-test (symbol (assert (ert-test-boundp purported-test)) (ert-get-test purported-test)) (ert-test purported-test))) operands)) (eql (assert (eql (length operands) 1)) (ert-select-tests `(member ,@operands) universe)) (and ;; Do these definitions of AND, NOT and OR satisfy de ;; Morgan's laws? Should they? (case (length operands) (0 (ert-select-tests 't universe)) (t (ert-select-tests `(and ,@(rest operands)) (ert-select-tests (first operands) universe))))) (not (assert (eql (length operands) 1)) (let ((all-tests (ert-select-tests 't universe))) (ert--set-difference all-tests (ert-select-tests (first operands) all-tests)))) (or (case (length operands) (0 (ert-select-tests 'nil universe)) (t (ert--union (ert-select-tests (first operands) universe) (ert-select-tests `(or ,@(rest operands)) universe))))) (tag (assert (eql (length operands) 1)) (let ((tag (first operands))) (ert-select-tests `(satisfies ,(lambda (test) (member tag (ert-test-tags test)))) universe))) (satisfies (assert (eql (length operands) 1)) (ert--remove-if-not (first operands) (ert-select-tests 't universe)))))))) (defun ert--insert-human-readable-selector (selector) "Insert a human-readable presentation of SELECTOR into the current buffer." ;; This is needed to avoid printing the (huge) contents of the ;; `backtrace' slot of the result objects in the ;; `most-recent-result' slots of test case objects in (eql ...) or ;; (member ...) selectors. (labels ((rec (selector) ;; This code needs to match the etypecase in `ert-select-tests'. (etypecase selector ((or (member nil t :new :failed :passed :expected :unexpected) string symbol) selector) (ert-test (if (ert-test-name selector) (make-symbol (format "<%S>" (ert-test-name selector))) (make-symbol ""))) (cons (destructuring-bind (operator &rest operands) selector (ecase operator ((member eql and not or) `(,operator ,@(mapcar #'rec operands))) ((member tag satisfies) selector))))))) (insert (format "%S" (rec selector))))) ;;; Facilities for running a whole set of tests. ;; The data structure that contains the set of tests being executed ;; during one particular test run, their results, the state of the ;; execution, and some statistics. ;; ;; The data about results and expected results of tests may seem ;; redundant here, since the test objects also carry such information. ;; However, the information in the test objects may be more recent, it ;; may correspond to a different test run. We need the information ;; that corresponds to this run in order to be able to update the ;; statistics correctly when a test is re-run interactively and has a ;; different result than before. (defstruct ert--stats (selector (assert nil)) ;; The tests, in order. (tests (assert nil) :type vector) ;; A map of test names (or the test objects themselves for unnamed ;; tests) to indices into the `tests' vector. (test-map (assert nil) :type hash-table) ;; The results of the tests during this run, in order. (test-results (assert nil) :type vector) ;; The start times of the tests, in order, as reported by ;; `current-time'. (test-start-times (assert nil) :type vector) ;; The end times of the tests, in order, as reported by ;; `current-time'. (test-end-times (assert nil) :type vector) (passed-expected 0) (passed-unexpected 0) (failed-expected 0) (failed-unexpected 0) (start-time nil) (end-time nil) (aborted-p nil) (current-test nil) ;; The time at or after which the next redisplay should occur, as a ;; float. (next-redisplay 0.0)) (defun ert-stats-completed-expected (stats) "Return the number of tests in STATS that had expected results." (+ (ert--stats-passed-expected stats) (ert--stats-failed-expected stats))) (defun ert-stats-completed-unexpected (stats) "Return the number of tests in STATS that had unexpected results." (+ (ert--stats-passed-unexpected stats) (ert--stats-failed-unexpected stats))) (defun ert-stats-completed (stats) "Number of tests in STATS that have run so far." (+ (ert-stats-completed-expected stats) (ert-stats-completed-unexpected stats))) (defun ert-stats-total (stats) "Number of tests in STATS, regardless of whether they have run yet." (length (ert--stats-tests stats))) ;; The stats object of the current run, dynamically bound. This is ;; used for the mode line progress indicator. (defvar ert--current-run-stats nil) (defun ert--stats-test-key (test) "Return the key used for TEST in the test map of ert--stats objects. Returns the name of TEST if it has one, or TEST itself otherwise." (or (ert-test-name test) test)) (defun ert--stats-set-test-and-result (stats pos test result) "Change STATS by replacing the test at position POS with TEST and RESULT. Also changes the counters in STATS to match." (let* ((tests (ert--stats-tests stats)) (results (ert--stats-test-results stats)) (old-test (aref tests pos)) (map (ert--stats-test-map stats))) (flet ((update (d) (if (ert-test-result-expected-p (aref tests pos) (aref results pos)) (etypecase (aref results pos) (ert-test-passed (incf (ert--stats-passed-expected stats) d)) (ert-test-failed (incf (ert--stats-failed-expected stats) d)) (null) (ert-test-aborted-with-non-local-exit)) (etypecase (aref results pos) (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) (null) (ert-test-aborted-with-non-local-exit))))) ;; Adjust counters to remove the result that is currently in stats. (update -1) ;; Put new test and result into stats. (setf (aref tests pos) test (aref results pos) result) (remhash (ert--stats-test-key old-test) map) (setf (gethash (ert--stats-test-key test) map) pos) ;; Adjust counters to match new result. (update +1) nil))) (defun ert--make-stats (tests selector) "Create a new `ert--stats' object for running TESTS. SELECTOR is the selector that was used to select TESTS." (setq tests (ert--coerce-to-vector tests)) (let ((map (make-hash-table :size (length tests)))) (loop for i from 0 for test across tests for key = (ert--stats-test-key test) do (assert (not (gethash key map))) (setf (gethash key map) i)) (make-ert--stats :selector selector :tests tests :test-map map :test-results (make-vector (length tests) nil) :test-start-times (make-vector (length tests) nil) :test-end-times (make-vector (length tests) nil)))) (defun ert-run-or-rerun-test (stats test listener) ;; checkdoc-order: nil "Run the single test TEST and record the result using STATS and LISTENER." (let ((ert--current-run-stats stats) (pos (ert--stats-test-pos stats test))) (ert--stats-set-test-and-result stats pos test nil) ;; Call listener after setting/before resetting ;; (ert--stats-current-test stats); the listener might refresh the ;; mode line display, and if the value is not set yet/any more ;; during this refresh, the mode line will flicker unnecessarily. (setf (ert--stats-current-test stats) test) (funcall listener 'test-started stats test) (setf (ert-test-most-recent-result test) nil) (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) (unwind-protect (ert-run-test test) (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) (let ((result (ert-test-most-recent-result test))) (ert--stats-set-test-and-result stats pos test result) (funcall listener 'test-ended stats test result)) (setf (ert--stats-current-test stats) nil)))) (defun ert-run-tests (selector listener) "Run the tests specified by SELECTOR, sending progress updates to LISTENER." (let* ((tests (ert-select-tests selector t)) (stats (ert--make-stats tests selector))) (setf (ert--stats-start-time stats) (current-time)) (funcall listener 'run-started stats) (let ((abortedp t)) (unwind-protect (let ((ert--current-run-stats stats)) (force-mode-line-update) (unwind-protect (progn (loop for test in tests do (ert-run-or-rerun-test stats test listener)) (setq abortedp nil)) (setf (ert--stats-aborted-p stats) abortedp) (setf (ert--stats-end-time stats) (current-time)) (funcall listener 'run-ended stats abortedp))) (force-mode-line-update)) stats))) (defun ert--stats-test-pos (stats test) ;; checkdoc-order: nil "Return the position (index) of TEST in the run represented by STATS." (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) ;;; Formatting functions shared across UIs. (defun ert--format-time-iso8601 (time) "Format TIME in the variant of ISO 8601 used for timestamps in ERT." (format-time-string "%Y-%m-%d %T%z" time)) (defun ert-char-for-test-result (result expectedp) "Return a character that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." (let ((s (etypecase result (ert-test-passed ".P") (ert-test-failed "fF") (null "--") (ert-test-aborted-with-non-local-exit "aA")))) (elt s (if expectedp 0 1)))) (defun ert-string-for-test-result (result expectedp) "Return a string that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." (let ((s (etypecase result (ert-test-passed '("passed" "PASSED")) (ert-test-failed '("failed" "FAILED")) (null '("unknown" "UNKNOWN")) (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) (elt s (if expectedp 0 1)))) (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." (let ((begin (point))) (pp object (current-buffer)) (unless (bolp) (insert "\n")) (save-excursion (goto-char begin) (indent-sexp)))) (defun ert--insert-infos (result) "Insert `ert-info' infos from RESULT into current buffer. RESULT must be an `ert-test-result-with-condition'." (check-type result ert-test-result-with-condition) (dolist (info (ert-test-result-with-condition-infos result)) (destructuring-bind (prefix . message) info (let ((begin (point)) (indentation (make-string (+ (length prefix) 4) ?\s)) (end nil)) (unwind-protect (progn (insert message "\n") (setq end (copy-marker (point))) (goto-char begin) (insert " " prefix) (forward-line 1) (while (< (point) end) (insert indentation) (forward-line 1))) (when end (set-marker end nil))))))) ;;; Running tests in batch mode. (defvar ert-batch-backtrace-right-margin 70 "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") ;;;###autoload (defun ert-run-tests-batch (&optional selector) "Run the tests specified by SELECTOR, printing results to the terminal. SELECTOR works as described in `ert-select-tests', except if SELECTOR is nil, in which case all tests rather than none will be run; this makes the command line \"emacs -batch -l my-tests.el -f ert-run-tests-batch-and-exit\" useful. Returns the stats object." (unless selector (setq selector 't)) (ert-run-tests selector (lambda (event-type &rest event-args) (ecase event-type (run-started (destructuring-bind (stats) event-args (message "Running %s tests (%s)" (length (ert--stats-tests stats)) (ert--format-time-iso8601 (ert--stats-start-time stats))))) (run-ended (destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) (expected-failures (ert--stats-failed-expected stats))) (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" (if (not abortedp) "" "Aborted: ") (ert-stats-total stats) (ert-stats-completed-expected stats) (if (zerop unexpected) "" (format ", %s unexpected" unexpected)) (ert--format-time-iso8601 (ert--stats-end-time stats)) (if (zerop expected-failures) "" (format "\n%s expected failures" expected-failures))) (unless (zerop unexpected) (message "%s unexpected results:" unexpected) (loop for test across (ert--stats-tests stats) for result = (ert-test-most-recent-result test) do (when (not (ert-test-result-expected-p test result)) (message "%9s %S" (ert-string-for-test-result result nil) (ert-test-name test)))) (message "%s" ""))))) (test-started ) (test-ended (destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) (etypecase result (ert-test-passed (message "Test %S passed unexpectedly" (ert-test-name test))) (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer (ert--print-backtrace (ert-test-result-with-condition-backtrace result)) (goto-char (point-min)) (while (not (eobp)) (let ((start (point)) (end (progn (end-of-line) (point)))) (setq end (min end (+ start ert-batch-backtrace-right-margin))) (message "%s" (buffer-substring-no-properties start end))) (forward-line 1))) (with-temp-buffer (ert--insert-infos result) (insert " ") (let ((print-escape-newlines t) (print-level 5) (print-length 10)) (let ((begin (point))) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result)))) (goto-char (1- (point-max))) (assert (looking-at "\n")) (delete-char 1) (message "Test %S condition:" (ert-test-name test)) (message "%s" (buffer-string)))) (ert-test-aborted-with-non-local-exit (message "Test %S aborted with non-local exit" (ert-test-name test))))) (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) (format-string (concat "%9s %" (prin1-to-string (length max)) "s/" max " %S"))) (message format-string (ert-string-for-test-result result (ert-test-result-expected-p test result)) (1+ (ert--stats-test-pos stats test)) (ert-test-name test))))))))) ;;;###autoload (defun ert-run-tests-batch-and-exit (&optional selector) "Like `ert-run-tests-batch', but exits Emacs when done. The exit status will be 0 if all test results were as expected, 1 on unexpected results, or 2 if the framework detected an error outside of the tests (e.g. invalid SELECTOR or bug in the code that runs the tests)." (unwind-protect (let ((stats (ert-run-tests-batch selector))) (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) (unwind-protect (progn (message "Error running tests") (backtrace)) (kill-emacs 2)))) ;;; Utility functions for load/unload actions. (defun ert--activate-font-lock-keywords () "Activate font-lock keywords for some of ERT's symbols." (font-lock-add-keywords nil '(("(\\(\\\\s *\\(\\sw+\\)?" (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t))))) (defun* ert--remove-from-list (list-var element &key key test) "Remove ELEMENT from the value of LIST-VAR if present. This can be used as an inverse of `add-to-list'." (unless key (setq key #'identity)) (unless test (setq test #'equal)) (setf (symbol-value list-var) (ert--remove* element (symbol-value list-var) :key key :test test))) ;;; Some basic interactive functions. (defun ert-read-test-name (prompt &optional default history add-default-to-prompt) "Read the name of a test and return it as a symbol. Prompt with PROMPT. If DEFAULT is a valid test name, use it as a default. HISTORY is the history to use; see `completing-read'. If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to include the default, if any. Signals an error if no test name was read." (etypecase default (string (let ((symbol (intern-soft default))) (unless (and symbol (ert-test-boundp symbol)) (setq default nil)))) (symbol (setq default (if (ert-test-boundp default) (symbol-name default) nil))) (ert-test (setq default (ert-test-name default)))) (when add-default-to-prompt (setq prompt (if (null default) (format "%s: " prompt) (format "%s (default %s): " prompt default)))) (let ((input (completing-read prompt obarray #'ert-test-boundp t nil history default nil))) ;; completing-read returns an empty string if default was nil and ;; the user just hit enter. (let ((sym (intern-soft input))) (if (ert-test-boundp sym) sym (error "Input does not name a test"))))) (defun ert-read-test-name-at-point (prompt) "Read the name of a test and return it as a symbol. As a default, use the symbol at point, or the test at point if in the ERT results buffer. Prompt with PROMPT, augmented with the default (if any)." (ert-read-test-name prompt (ert-test-at-point) nil t)) (defun ert-find-test-other-window (test-name) "Find, in another window, the definition of TEST-NAME." (interactive (list (ert-read-test-name-at-point "Find test definition: "))) (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) (defun ert-delete-test (test-name) "Make the test TEST-NAME unbound. Nothing more than an interactive interface to `ert-make-test-unbound'." (interactive (list (ert-read-test-name-at-point "Delete test"))) (ert-make-test-unbound test-name)) (defun ert-delete-all-tests () "Make all symbols in `obarray' name no test." (interactive) (when (interactive-p) (unless (y-or-n-p "Delete all tests? ") (error "Aborted"))) ;; We can't use `ert-select-tests' here since that gives us only ;; test objects, and going from them back to the test name symbols ;; can fail if the `ert-test' defstruct has been redefined. (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) t) ;;; Display of test progress and results. ;; An entry in the results buffer ewoc. There is one entry per test. (defstruct ert--ewoc-entry (test (assert nil)) ;; If the result of this test was expected, its ewoc entry is hidden ;; initially. (hidden-p (assert nil)) ;; An ewoc entry may be collapsed to hide details such as the error ;; condition. ;; ;; I'm not sure the ability to expand and collapse entries is still ;; a useful feature. (expanded-p t) ;; By default, the ewoc entry presents the error condition with ;; certain limits on how much to print (`print-level', ;; `print-length'). The user can interactively switch to a set of ;; higher limits. (extended-printer-limits-p nil)) ;; Variables local to the results buffer. ;; The ewoc. (defvar ert--results-ewoc) ;; The stats object. (defvar ert--results-stats) ;; A string with one character per test. Each character represents ;; the result of the corresponding test. The string is displayed near ;; the top of the buffer and serves as a progress bar. (defvar ert--results-progress-bar-string) ;; The position where the progress bar button begins. (defvar ert--results-progress-bar-button-begin) ;; The test result listener that updates the buffer when tests are run. (defvar ert--results-listener) (defun ert-insert-test-name-button (test-name) "Insert a button that links to TEST-NAME." (insert-text-button (format "%S" test-name) :type 'ert--test-name-button 'ert-test-name test-name)) (defun ert--results-format-expected-unexpected (expected unexpected) "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." (if (zerop unexpected) (format "%s" expected) (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) (defun ert--results-update-ewoc-hf (ewoc stats) "Update the header and footer of EWOC to show certain information from STATS. Also sets `ert--results-progress-bar-button-begin'." (let ((run-count (ert-stats-completed stats)) (results-buffer (current-buffer)) ;; Need to save buffer-local value. (font-lock font-lock-mode)) (ewoc-set-hf ewoc ;; header (with-temp-buffer (insert "Selector: ") (ert--insert-human-readable-selector (ert--stats-selector stats)) (insert "\n") (insert (format (concat "Passed: %s\n" "Failed: %s\n" "Total: %s/%s\n\n") (ert--results-format-expected-unexpected (ert--stats-passed-expected stats) (ert--stats-passed-unexpected stats)) (ert--results-format-expected-unexpected (ert--stats-failed-expected stats) (ert--stats-failed-unexpected stats)) run-count (ert-stats-total stats))) (insert (format "Started at: %s\n" (ert--format-time-iso8601 (ert--stats-start-time stats)))) ;; FIXME: This is ugly. Need to properly define invariants of ;; the `stats' data structure. (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) ((ert--stats-current-test stats) 'running) ((ert--stats-end-time stats) 'finished) (t 'preparing)))) (ecase state (preparing (insert "")) (aborted (cond ((ert--stats-current-test stats) (insert "Aborted during test: ") (ert-insert-test-name-button (ert-test-name (ert--stats-current-test stats)))) (t (insert "Aborted.")))) (running (assert (ert--stats-current-test stats)) (insert "Running test: ") (ert-insert-test-name-button (ert-test-name (ert--stats-current-test stats)))) (finished (assert (not (ert--stats-current-test stats))) (insert "Finished."))) (insert "\n") (if (ert--stats-end-time stats) (insert (format "%s%s\n" (if (ert--stats-aborted-p stats) "Aborted at: " "Finished at: ") (ert--format-time-iso8601 (ert--stats-end-time stats)))) (insert "\n")) (insert "\n")) (let ((progress-bar-string (with-current-buffer results-buffer ert--results-progress-bar-string))) (let ((progress-bar-button-begin (insert-text-button progress-bar-string :type 'ert--results-progress-bar-button 'face (or (and font-lock (ert-face-for-stats stats)) 'button)))) ;; The header gets copied verbatim to the results buffer, ;; and all positions remain the same, so ;; `progress-bar-button-begin' will be the right position ;; even in the results buffer. (with-current-buffer results-buffer (set (make-local-variable 'ert--results-progress-bar-button-begin) progress-bar-button-begin)))) (insert "\n\n") (buffer-string)) ;; footer ;; ;; We actually want an empty footer, but that would trigger a bug ;; in ewoc, sometimes clearing the entire buffer. (It's possible ;; that this bug has been fixed since this has been tested; we ;; should test it again.) "\n"))) (defvar ert-test-run-redisplay-interval-secs .1 "How many seconds ERT should wait between redisplays while running tests. While running tests, ERT shows the current progress, and this variable determines how frequently the progress display is updated.") (defun ert--results-update-stats-display (ewoc stats) "Update EWOC and the mode line to show data from STATS." ;; TODO(ohler): investigate using `make-progress-reporter'. (ert--results-update-ewoc-hf ewoc stats) (force-mode-line-update) (redisplay t) (setf (ert--stats-next-redisplay stats) (+ (float-time) ert-test-run-redisplay-interval-secs))) (defun ert--results-update-stats-display-maybe (ewoc stats) "Call `ert--results-update-stats-display' if not called recently. EWOC and STATS are arguments for `ert--results-update-stats-display'." (when (>= (float-time) (ert--stats-next-redisplay stats)) (ert--results-update-stats-display ewoc stats))) (defun ert--tests-running-mode-line-indicator () "Return a string for the mode line that shows the test run progress." (let* ((stats ert--current-run-stats) (tests-total (ert-stats-total stats)) (tests-completed (ert-stats-completed stats))) (if (>= tests-completed tests-total) (format " ERT(%s/%s,finished)" tests-completed tests-total) (format " ERT(%s/%s):%s" (1+ tests-completed) tests-total (if (null (ert--stats-current-test stats)) "?" (format "%S" (ert-test-name (ert--stats-current-test stats)))))))) (defun ert--make-xrefs-region (begin end) "Attach cross-references to function names between BEGIN and END. BEGIN and END specify a region in the current buffer." (save-excursion (save-restriction (narrow-to-region begin (point)) ;; Inhibit optimization in `debugger-make-xrefs' that would ;; sometimes insert unrelated backtrace info into our buffer. (let ((debugger-previous-backtrace nil)) (debugger-make-xrefs))))) (defun ert--string-first-line (s) "Return the first line of S, or S if it contains no newlines. The return value does not include the line terminator." (substring s 0 (ert--string-position ?\n s))) (defun ert-face-for-test-result (expectedp) "Return a face that shows whether a test result was expected or unexpected. If EXPECTEDP is nil, returns the face for unexpected results; if non-nil, returns the face for expected results.." (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) (defun ert-face-for-stats (stats) "Return a face that represents STATS." (cond ((ert--stats-aborted-p stats) 'nil) ((plusp (ert-stats-completed-unexpected stats)) (ert-face-for-test-result nil)) ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) (ert-face-for-test-result t)) (t 'nil))) (defun ert--print-test-for-ewoc (entry) "The ewoc print function for ewoc test entries. ENTRY is the entry to print." (let* ((test (ert--ewoc-entry-test entry)) (stats ert--results-stats) (result (let ((pos (ert--stats-test-pos stats test))) (assert pos) (aref (ert--stats-test-results stats) pos))) (hiddenp (ert--ewoc-entry-hidden-p entry)) (expandedp (ert--ewoc-entry-expanded-p entry)) (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p entry))) (cond (hiddenp) (t (let ((expectedp (ert-test-result-expected-p test result))) (insert-text-button (format "%c" (ert-char-for-test-result result expectedp)) :type 'ert--results-expand-collapse-button 'face (or (and font-lock-mode (ert-face-for-test-result expectedp)) 'button))) (insert " ") (ert-insert-test-name-button (ert-test-name test)) (insert "\n") (when (and expandedp (not (eql result 'nil))) (when (ert-test-documentation test) (insert " " (propertize (ert--string-first-line (ert-test-documentation test)) 'font-lock-face 'font-lock-doc-face) "\n")) (etypecase result (ert-test-passed (if (ert-test-result-expected-p test result) (insert " passed\n") (insert " passed unexpectedly\n")) (insert "")) (ert-test-result-with-condition (ert--insert-infos result) (let ((print-escape-newlines t) (print-level (if extended-printer-limits-p 12 6)) (print-length (if extended-printer-limits-p 100 10))) (insert " ") (let ((begin (point))) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result)) (ert--make-xrefs-region begin (point))))) (ert-test-aborted-with-non-local-exit (insert " aborted\n"))) (insert "\n"))))) nil) (defun ert--results-font-lock-function (enabledp) "Redraw the ERT results buffer after font-lock-mode was switched on or off. ENABLEDP is true if font-lock-mode is switched on, false otherwise." (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) (ewoc-refresh ert--results-ewoc) (font-lock-default-function enabledp)) (defun ert--setup-results-buffer (stats listener buffer-name) "Set up a test results buffer. STATS is the stats object; LISTENER is the results listener; BUFFER-NAME, if non-nil, is the buffer name to use." (unless buffer-name (setq buffer-name "*ert*")) (let ((buffer (get-buffer-create buffer-name))) (with-current-buffer buffer (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-results-mode) ;; Erase buffer again in case switching out of the previous ;; mode inserted anything. (This happens e.g. when switching ;; from ert-results-mode to ert-results-mode when ;; font-lock-mode turns itself off in change-major-mode-hook.) (erase-buffer) (set (make-local-variable 'font-lock-function) 'ert--results-font-lock-function) (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) (set (make-local-variable 'ert--results-ewoc) ewoc) (set (make-local-variable 'ert--results-stats) stats) (set (make-local-variable 'ert--results-progress-bar-string) (make-string (ert-stats-total stats) (ert-char-for-test-result nil t))) (set (make-local-variable 'ert--results-listener) listener) (loop for test across (ert--stats-tests stats) do (ewoc-enter-last ewoc (make-ert--ewoc-entry :test test :hidden-p t))) (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) (goto-char (1- (point-max))) buffer))))) (defvar ert--selector-history nil "List of recent test selectors read from terminal.") ;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? ;; They are needed only for our automated self-tests at the moment. ;; Or should there be some other mechanism? ;;;###autoload (defun ert-run-tests-interactively (selector &optional output-buffer-name message-fn) "Run the tests specified by SELECTOR and display the results in a buffer. SELECTOR works as described in `ert-select-tests'. OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they are used for automated self-tests and specify which buffer to use and how to display message." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is ;; not compiled, and `first' is not ;; defined without cl. (car ert--selector-history) "t"))) (read-from-minibuffer (if (null default) "Run tests: " (format "Run tests (default %s): " default)) nil nil t 'ert--selector-history default nil)) nil)) (unless message-fn (setq message-fn 'message)) (lexical-let ((output-buffer-name output-buffer-name) buffer listener (message-fn message-fn)) (setq listener (lambda (event-type &rest event-args) (ecase event-type (run-started (destructuring-bind (stats) event-args (setq buffer (ert--setup-results-buffer stats listener output-buffer-name)) (pop-to-buffer buffer))) (run-ended (destructuring-bind (stats abortedp) event-args (funcall message-fn "%sRan %s tests, %s results were as expected%s" (if (not abortedp) "" "Aborted: ") (ert-stats-total stats) (ert-stats-completed-expected stats) (let ((unexpected (ert-stats-completed-unexpected stats))) (if (zerop unexpected) "" (format ", %s unexpected" unexpected)))) (ert--results-update-stats-display (with-current-buffer buffer ert--results-ewoc) stats))) (test-started (destructuring-bind (stats test) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) (node (ewoc-nth ewoc pos))) (assert node) (setf (ert--ewoc-entry-test (ewoc-data node)) test) (aset ert--results-progress-bar-string pos (ert-char-for-test-result nil t)) (ert--results-update-stats-display-maybe ewoc stats) (ewoc-invalidate ewoc node))))) (test-ended (destructuring-bind (stats test result) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) (node (ewoc-nth ewoc pos))) (when (ert--ewoc-entry-hidden-p (ewoc-data node)) (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) (ert-test-result-expected-p test result))) (aset ert--results-progress-bar-string pos (ert-char-for-test-result result (ert-test-result-expected-p test result))) (ert--results-update-stats-display-maybe ewoc stats) (ewoc-invalidate ewoc node)))))))) (ert-run-tests selector listener))) ;;;###autoload (defalias 'ert 'ert-run-tests-interactively) ;;; Simple view mode for auxiliary information like stack traces or ;;; messages. Mainly binds "q" for quit. (define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" "Major mode for viewing auxiliary information in ERT.") (loop for (key binding) in '(("q" quit-window) ) do (define-key ert-simple-view-mode-map key binding)) ;;; Commands and button actions for the results buffer. (define-derived-mode ert-results-mode fundamental-mode "ERT-Results" "Major mode for viewing results of ERT test runs.") (loop for (key binding) in '(;; Stuff that's not in the menu. ("\t" forward-button) ([backtab] backward-button) ("j" ert-results-jump-between-summary-and-result) ("q" quit-window) ("L" ert-results-toggle-printer-limits-for-test-at-point) ("n" ert-results-next-test) ("p" ert-results-previous-test) ;; Stuff that is in the menu. ("R" ert-results-rerun-all-tests) ("r" ert-results-rerun-test-at-point) ("d" ert-results-rerun-test-at-point-debugging-errors) ("." ert-results-find-test-at-point-other-window) ("b" ert-results-pop-to-backtrace-for-test-at-point) ("m" ert-results-pop-to-messages-for-test-at-point) ("l" ert-results-pop-to-should-forms-for-test-at-point) ("h" ert-results-describe-test-at-point) ("D" ert-delete-test) ("T" ert-results-pop-to-timings) ) do (define-key ert-results-mode-map key binding)) (easy-menu-define ert-results-mode-menu ert-results-mode-map "Menu for `ert-results-mode'." '("ERT Results" ["Re-run all tests" ert-results-rerun-all-tests] "--" ["Re-run test" ert-results-rerun-test-at-point] ["Debug test" ert-results-rerun-test-at-point-debugging-errors] ["Show test definition" ert-results-find-test-at-point-other-window] "--" ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] ["Show messages" ert-results-pop-to-messages-for-test-at-point] ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] ["Describe test" ert-results-describe-test-at-point] "--" ["Delete test" ert-delete-test] "--" ["Show execution time of each test" ert-results-pop-to-timings] )) (define-button-type 'ert--results-progress-bar-button 'action #'ert--results-progress-bar-button-action 'help-echo "mouse-2, RET: Reveal test result") (define-button-type 'ert--test-name-button 'action #'ert--test-name-button-action 'help-echo "mouse-2, RET: Find test definition") (define-button-type 'ert--results-expand-collapse-button 'action #'ert--results-expand-collapse-button-action 'help-echo "mouse-2, RET: Expand/collapse test result") (defun ert--results-test-node-or-null-at-point () "If point is on a valid ewoc node, return it; return nil otherwise. To be used in the ERT results buffer." (let* ((ewoc ert--results-ewoc) (node (ewoc-locate ewoc))) ;; `ewoc-locate' will return an arbitrary node when point is on ;; header or footer, or when all nodes are invisible. So we need ;; to validate its return value here. ;; ;; Update: I'm seeing nil being returned in some cases now, ;; perhaps this has been changed? (if (and node (>= (point) (ewoc-location node)) (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) node nil))) (defun ert--results-test-node-at-point () "If point is on a valid ewoc node, return it; signal an error otherwise. To be used in the ERT results buffer." (or (ert--results-test-node-or-null-at-point) (error "No test at point"))) (defun ert-results-next-test () "Move point to the next test. To be used in the ERT results buffer." (interactive) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next "No tests below")) (defun ert-results-previous-test () "Move point to the previous test. To be used in the ERT results buffer." (interactive) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev "No tests above")) (defun ert--results-move (node ewoc-fn error-message) "Move point from NODE to the previous or next node. EWOC-FN specifies the direction and should be either `ewoc-prev' or `ewoc-next'. If there are no more nodes in that direction, an error is signalled with the message ERROR-MESSAGE." (loop (setq node (funcall ewoc-fn ert--results-ewoc node)) (when (null node) (error "%s" error-message)) (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) (goto-char (ewoc-location node)) (return)))) (defun ert--results-expand-collapse-button-action (button) "Expand or collapse the test node BUTTON belongs to." (let* ((ewoc ert--results-ewoc) (node (save-excursion (goto-char (ert--button-action-position)) (ert--results-test-node-at-point))) (entry (ewoc-data node))) (setf (ert--ewoc-entry-expanded-p entry) (not (ert--ewoc-entry-expanded-p entry))) (ewoc-invalidate ewoc node))) (defun ert-results-find-test-at-point-other-window () "Find the definition of the test at point in another window. To be used in the ERT results buffer." (interactive) (let ((name (ert-test-at-point))) (unless name (error "No test at point")) (ert-find-test-other-window name))) (defun ert--test-name-button-action (button) "Find the definition of the test BUTTON belongs to, in another window." (let ((name (button-get button 'ert-test-name))) (ert-find-test-other-window name))) (defun ert--ewoc-position (ewoc node) ;; checkdoc-order: nil "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." (loop for i from 0 for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) do (when (eql node node-here) (return i)) finally (return nil))) (defun ert-results-jump-between-summary-and-result () "Jump back and forth between the test run summary and individual test results. From an ewoc node, jumps to the character that represents the same test in the progress bar, and vice versa. To be used in the ERT results buffer." ;; Maybe this command isn't actually needed much, but if it is, it ;; seems like an indication that the UI design is not optimal. If ;; jumping back and forth between a summary at the top of the buffer ;; and the error log in the remainder of the buffer is useful, then ;; the summary apparently needs to be easily accessible from the ;; error log, and perhaps it would be better to have it in a ;; separate buffer to keep it visible. (interactive) (let ((ewoc ert--results-ewoc) (progress-bar-begin ert--results-progress-bar-button-begin)) (cond ((ert--results-test-node-or-null-at-point) (let* ((node (ert--results-test-node-at-point)) (pos (ert--ewoc-position ewoc node))) (goto-char (+ progress-bar-begin pos)))) ((and (<= progress-bar-begin (point)) (< (point) (button-end (button-at progress-bar-begin)))) (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) (entry (ewoc-data node))) (when (ert--ewoc-entry-hidden-p entry) (setf (ert--ewoc-entry-hidden-p entry) nil) (ewoc-invalidate ewoc node)) (ewoc-goto-node ewoc node))) (t (goto-char progress-bar-begin))))) (defun ert-test-at-point () "Return the name of the test at point as a symbol, or nil if none." (or (and (eql major-mode 'ert-results-mode) (let ((test (ert--results-test-at-point-no-redefinition))) (and test (ert-test-name test)))) (let* ((thing (thing-at-point 'symbol)) (sym (intern-soft thing))) (and (ert-test-boundp sym) sym)))) (defun ert--results-test-at-point-no-redefinition () "Return the test at point, or nil. To be used in the ERT results buffer." (assert (eql major-mode 'ert-results-mode)) (if (ert--results-test-node-or-null-at-point) (let* ((node (ert--results-test-node-at-point)) (test (ert--ewoc-entry-test (ewoc-data node)))) test) (let ((progress-bar-begin ert--results-progress-bar-button-begin)) (when (and (<= progress-bar-begin (point)) (< (point) (button-end (button-at progress-bar-begin)))) (let* ((test-index (- (point) progress-bar-begin)) (test (aref (ert--stats-tests ert--results-stats) test-index))) test))))) (defun ert--results-test-at-point-allow-redefinition () "Look up the test at point, and check whether it has been redefined. To be used in the ERT results buffer. Returns a list of two elements: the test (or nil) and a symbol specifying whether the test has been redefined. If a new test has been defined with the same name as the test at point, replaces the test at point with the new test, and returns the new test and the symbol `redefined'. If the test has been deleted, returns the old test and the symbol `deleted'. If the test is still current, returns the test and the symbol nil. If there is no test at point, returns a list with two nils." (let ((test (ert--results-test-at-point-no-redefinition))) (cond ((null test) `(nil nil)) ((null (ert-test-name test)) `(,test nil)) (t (let* ((name (ert-test-name test)) (new-test (and (ert-test-boundp name) (ert-get-test name)))) (cond ((eql test new-test) `(,test nil)) ((null new-test) `(,test deleted)) (t (ert--results-update-after-test-redefinition (ert--stats-test-pos ert--results-stats test) new-test) `(,new-test redefined)))))))) (defun ert--results-update-after-test-redefinition (pos new-test) "Update results buffer after the test at pos POS has been redefined. Also updates the stats object. NEW-TEST is the new test definition." (let* ((stats ert--results-stats) (ewoc ert--results-ewoc) (node (ewoc-nth ewoc pos)) (entry (ewoc-data node))) (ert--stats-set-test-and-result stats pos new-test nil) (setf (ert--ewoc-entry-test entry) new-test (aref ert--results-progress-bar-string pos) (ert-char-for-test-result nil t)) (ewoc-invalidate ewoc node)) nil) (defun ert--button-action-position () "The buffer position where the last button action was triggered." (cond ((integerp last-command-event) (point)) ((eventp last-command-event) (posn-point (event-start last-command-event))) (t (assert nil)))) (defun ert--results-progress-bar-button-action (button) "Jump to details for the test represented by the character clicked in BUTTON." (goto-char (ert--button-action-position)) (ert-results-jump-between-summary-and-result)) (defun ert-results-rerun-all-tests () "Re-run all tests, using the same selector. To be used in the ERT results buffer." (interactive) (assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) (ert-run-tests-interactively selector (buffer-name)))) (defun ert-results-rerun-test-at-point () "Re-run the test at point. To be used in the ERT results buffer." (interactive) (destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) (error "No test at point")) (let* ((stats ert--results-stats) (progress-message (format "Running %stest %S" (ecase redefinition-state ((nil) "") (redefined "new definition of ") (deleted "deleted ")) (ert-test-name test)))) ;; Need to save and restore point manually here: When point is on ;; the first visible ewoc entry while the header is updated, point ;; moves to the top of the buffer. This is undesirable, and a ;; simple `save-excursion' doesn't prevent it. (let ((point (point))) (unwind-protect (unwind-protect (progn (message "%s..." progress-message) (ert-run-or-rerun-test stats test ert--results-listener)) (ert--results-update-stats-display ert--results-ewoc stats) (message "%s...%s" progress-message (let ((result (ert-test-most-recent-result test))) (ert-string-for-test-result result (ert-test-result-expected-p test result))))) (goto-char point)))))) (defun ert-results-rerun-test-at-point-debugging-errors () "Re-run the test at point with `ert-debug-on-error' bound to t. To be used in the ERT results buffer." (interactive) (let ((ert-debug-on-error t)) (ert-results-rerun-test-at-point))) (defun ert-results-pop-to-backtrace-for-test-at-point () "Display the backtrace for the test at point. To be used in the ERT results buffer." (interactive) (let* ((test (ert--results-test-at-point-no-redefinition)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) (etypecase result (ert-test-passed (error "Test passed, no backtrace available")) (ert-test-result-with-condition (let ((backtrace (ert-test-result-with-condition-backtrace result)) (buffer (get-buffer-create "*ERT Backtrace*"))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) ;; Use unibyte because `debugger-setup-buffer' also does so. (set-buffer-multibyte nil) (setq truncate-lines t) (ert--print-backtrace backtrace) (debugger-make-xrefs) (goto-char (point-min)) (insert "Backtrace for test `") (ert-insert-test-name-button (ert-test-name test)) (insert "':\n"))))))) (defun ert-results-pop-to-messages-for-test-at-point () "Display the part of the *Messages* buffer generated during the test at point. To be used in the ERT results buffer." (interactive) (let* ((test (ert--results-test-at-point-no-redefinition)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) (let ((buffer (get-buffer-create "*ERT Messages*"))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) (insert (ert-test-result-messages result)) (goto-char (point-min)) (insert "Messages for test `") (ert-insert-test-name-button (ert-test-name test)) (insert "':\n"))))) (defun ert-results-pop-to-should-forms-for-test-at-point () "Display the list of `should' forms executed during the test at point. To be used in the ERT results buffer." (interactive) (let* ((test (ert--results-test-at-point-no-redefinition)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) (let ((buffer (get-buffer-create "*ERT list of should forms*"))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) (if (null (ert-test-result-should-forms result)) (insert "\n(No should forms during this test.)\n") (loop for form-description in (ert-test-result-should-forms result) for i from 1 do (insert "\n") (insert (format "%s: " i)) (let ((begin (point))) (ert--pp-with-indentation-and-newline form-description) (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) (insert "`should' forms executed during test `") (ert-insert-test-name-button (ert-test-name test)) (insert "':\n") (insert "\n") (insert (concat "(Values are shallow copies and may have " "looked different during the test if they\n" "have been modified destructively.)\n")) (forward-line 1))))) (defun ert-results-toggle-printer-limits-for-test-at-point () "Toggle how much of the condition to print for the test at point. To be used in the ERT results buffer." (interactive) (let* ((ewoc ert--results-ewoc) (node (ert--results-test-node-at-point)) (entry (ewoc-data node))) (setf (ert--ewoc-entry-extended-printer-limits-p entry) (not (ert--ewoc-entry-extended-printer-limits-p entry))) (ewoc-invalidate ewoc node))) (defun ert-results-pop-to-timings () "Display test timings for the last run. To be used in the ERT results buffer." (interactive) (let* ((stats ert--results-stats) (start-times (ert--stats-test-start-times stats)) (end-times (ert--stats-test-end-times stats)) (buffer (get-buffer-create "*ERT timings*")) (data (loop for test across (ert--stats-tests stats) for start-time across (ert--stats-test-start-times stats) for end-time across (ert--stats-test-end-times stats) collect (list test (float-time (subtract-time end-time start-time)))))) (setq data (sort data (lambda (a b) (> (second a) (second b))))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) (if (null data) (insert "(No data)\n") (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) (loop for (test time) in data for cumul-time = time then (+ cumul-time time) for i from 1 do (let ((begin (point))) (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) (ert-insert-test-name-button (ert-test-name test)) (insert "\n")))) (goto-char (point-min)) (insert "Tests by run time (seconds):\n\n") (forward-line 1)))) ;;;###autoload (defun ert-describe-test (test-or-test-name) "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." (interactive (list (ert-read-test-name-at-point "Describe test"))) (when (< emacs-major-version 24) (error "Requires Emacs 24")) (let (test-name test-definition) (etypecase test-or-test-name (symbol (setq test-name test-or-test-name test-definition (ert-get-test test-or-test-name))) (ert-test (setq test-name (ert-test-name test-or-test-name) test-definition test-or-test-name))) (help-setup-xref (list #'ert-describe-test test-or-test-name) (called-interactively-p 'interactive)) (save-excursion (with-help-window (help-buffer) (with-current-buffer (help-buffer) (insert (if test-name (format "%S" test-name) "")) (insert " is a test") (let ((file-name (and test-name (symbol-file test-name 'ert-deftest)))) (when file-name (insert " defined in `" (file-name-nondirectory file-name) "'") (save-excursion (re-search-backward "`\\([^`']+\\)'" nil t) (help-xref-button 1 'help-function-def test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) (insert "\n\n") (unless (and (ert-test-boundp test-name) (eql (ert-get-test test-name) test-definition)) (let ((begin (point))) (insert "Note: This test has been redefined or deleted, " "this documentation refers to an old definition.") (fill-region-as-paragraph begin (point))) (insert "\n\n")) (insert (or (ert-test-documentation test-definition) "It is not documented.") "\n"))))))) (defun ert-results-describe-test-at-point () "Display the documentation of the test at point. To be used in the ERT results buffer." (interactive) (ert-describe-test (ert--results-test-at-point-no-redefinition))) ;;; Actions on load/unload. (add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) (add-to-list 'minor-mode-alist '(ert--current-run-stats (:eval (ert--tests-running-mode-line-indicator)))) (add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) (defun ert--unload-function () "Unload function to undo the side-effects of loading ert.el." (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) (ert--remove-from-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) nil) (defvar ert-unload-hook '()) (add-hook 'ert-unload-hook 'ert--unload-function) (provide 'ert) ;;; ert.el ends here slime-2.20/lib/ert.el000066400000000000000000003166131315100173500144360ustar00rootroot00000000000000;;; ert.el --- Emacs Lisp Regression Testing ;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc. ;; Author: Christian M. Ohler ;; Keywords: lisp, tools ;; This file is NOT part of GNU Emacs. ;; 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 3 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, see `http://www.gnu.org/licenses/'. ;;; Commentary: ;; ERT is a tool for automated testing in Emacs Lisp. Its main ;; features are facilities for defining and running test cases and ;; reporting the results as well as for debugging test failures ;; interactively. ;; ;; The main entry points are `ert-deftest', which is similar to ;; `defun' but defines a test, and `ert-run-tests-interactively', ;; which runs tests and offers an interactive interface for inspecting ;; results and debugging. There is also ;; `ert-run-tests-batch-and-exit' for non-interactive use. ;; ;; The body of `ert-deftest' forms resembles a function body, but the ;; additional operators `should', `should-not' and `should-error' are ;; available. `should' is similar to cl's `assert', but signals a ;; different error when its condition is violated that is caught and ;; processed by ERT. In addition, it analyzes its argument form and ;; records information that helps debugging (`assert' tries to do ;; something similar when its second argument SHOW-ARGS is true, but ;; `should' is more sophisticated). For information on `should-not' ;; and `should-error', see their docstrings. ;; ;; See ERT's info manual as well as the docstrings for more details. ;; To compile the manual, run `makeinfo ert.texinfo' in the ERT ;; directory, then C-u M-x info ert.info in Emacs to view it. ;; ;; To see some examples of tests written in ERT, see its self-tests in ;; ert-tests.el. Some of these are tricky due to the bootstrapping ;; problem of writing tests for a testing tool, others test simple ;; functions and are straightforward. ;;; Code: (eval-when-compile (require 'cl)) (require 'button) (require 'debug) (require 'easymenu) (require 'ewoc) (require 'find-func) (require 'help) ;;; UI customization options. (defgroup ert () "ERT, the Emacs Lisp regression testing tool." :prefix "ert-" :group 'lisp) (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) :background "green3")) "Face used for expected results in the ERT results buffer." :group 'ert) (defface ert-test-result-unexpected '((((class color) (background light)) :background "red1") (((class color) (background dark)) :background "red3")) "Face used for unexpected results in the ERT results buffer." :group 'ert) ;;; Copies/reimplementations of cl functions. (defun ert--cl-do-remf (plist tag) "Copy of `cl-do-remf'. Modify PLIST by removing TAG." (let ((p (cdr plist))) (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) (defun ert--remprop (sym tag) "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." (let ((plist (symbol-plist sym))) (if (and plist (eq tag (car plist))) (progn (setplist sym (cdr (cdr plist))) t) (ert--cl-do-remf plist tag)))) (defun ert--remove-if-not (ert-pred ert-list) "A reimplementation of `remove-if-not'. ERT-PRED is a predicate, ERT-LIST is the input list." (loop for ert-x in ert-list if (funcall ert-pred ert-x) collect ert-x)) (defun ert--intersection (a b) "A reimplementation of `intersection'. Intersect the sets A and B. Elements are compared using `eql'." (loop for x in a if (memql x b) collect x)) (defun ert--set-difference (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eql'." (loop for x in a unless (memql x b) collect x)) (defun ert--set-difference-eq (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eq'." (loop for x in a unless (memq x b) collect x)) (defun ert--union (a b) "A reimplementation of `union'. Compute the union of the sets A and B. Elements are compared using `eql'." (append a (ert--set-difference b a))) (eval-and-compile (defvar ert--gensym-counter 0)) (eval-and-compile (defun ert--gensym (&optional prefix) "Only allows string PREFIX, not compatible with CL." (unless prefix (setq prefix "G")) (make-symbol (format "%s%s" prefix (prog1 ert--gensym-counter (incf ert--gensym-counter)))))) (defun ert--coerce-to-vector (x) "Coerce X to a vector." (when (char-table-p x) (error "Not supported")) (if (vectorp x) x (vconcat x))) (defun* ert--remove* (x list &key key test) "Does not support all the keywords of remove*." (unless key (setq key #'identity)) (unless test (setq test #'eql)) (loop for y in list unless (funcall test x (funcall key y)) collect y)) (defun ert--string-position (c s) "Return the position of the first occurrence of C in S, or nil if none." (loop for i from 0 for x across s when (eql x c) return i)) (defun ert--mismatch (a b) "Return index of first element that differs between A and B. Like `mismatch'. Uses `equal' for comparison." (cond ((or (listp a) (listp b)) (ert--mismatch (ert--coerce-to-vector a) (ert--coerce-to-vector b))) ((> (length a) (length b)) (ert--mismatch b a)) (t (let ((la (length a)) (lb (length b))) (assert (arrayp a) t) (assert (arrayp b) t) (assert (<= la lb) t) (loop for i below la when (not (equal (aref a i) (aref b i))) return i finally (return (if (/= la lb) la (assert (equal a b) t) nil))))))) (defun ert--subseq (seq start &optional end) "Return a subsequence of SEQ from START to END." (when (char-table-p seq) (error "Not supported")) (let ((vector (substring (ert--coerce-to-vector seq) start end))) (etypecase seq (vector vector) (string (concat vector)) (list (append vector nil)) (bool-vector (loop with result = (make-bool-vector (length vector) nil) for i below (length vector) do (setf (aref result i) (aref vector i)) finally (return result))) (char-table (assert nil))))) (defun ert-equal-including-properties (a b) "Return t if A and B have similar structure and contents. This is like `equal-including-properties' except that it compares the property values of text properties structurally (by recursing) rather than with `eq'. Perhaps this is what `equal-including-properties' should do in the first place; see Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; This implementation is inefficient. Rather than making it ;; efficient, let's hope bug 6581 gets fixed so that we can delete ;; it altogether. (not (ert--explain-not-equal-including-properties a b))) ;;; Defining and locating tests. ;; The data structure that represents a test case. (defstruct ert-test (name nil) (documentation nil) (body (assert nil)) (most-recent-result nil) (expected-result-type ':passed) (tags '())) (defun ert-test-boundp (symbol) "Return non-nil if SYMBOL names a test." (and (get symbol 'ert--test) t)) (defun ert-get-test (symbol) "If SYMBOL names a test, return that. Signal an error otherwise." (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) (get symbol 'ert--test)) (defun ert-set-test (symbol definition) "Make SYMBOL name the test DEFINITION, and return DEFINITION." (when (eq symbol 'nil) ;; We disallow nil since `ert-test-at-point' and related functions ;; want to return a test name, but also need an out-of-band value ;; on failure. Nil is the most natural out-of-band value; using 0 ;; or "" or signalling an error would be too awkward. ;; ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) (put symbol 'ert--test definition) definition) (defun ert-make-test-unbound (symbol) "Make SYMBOL name no test. Return SYMBOL." (ert--remprop symbol 'ert--test) symbol) (defun ert--parse-keys-and-body (keys-and-body) "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. KEYS-AND-BODY should have the form of a property list, with the exception that only keywords are permitted as keys and that the tail -- the body -- is a list of forms that does not start with a keyword. Returns a two-element list containing the keys-and-values plist and the body." (let ((extracted-key-accu '()) (remaining keys-and-body)) (while (and (consp remaining) (keywordp (first remaining))) (let ((keyword (pop remaining))) (unless (consp remaining) (error "Value expected after keyword %S in %S" keyword keys-and-body)) (when (assoc keyword extracted-key-accu) (warn "Keyword %S appears more than once in %S" keyword keys-and-body)) (push (cons keyword (pop remaining)) extracted-key-accu))) (setq extracted-key-accu (nreverse extracted-key-accu)) (list (loop for (key . value) in extracted-key-accu collect key collect value) remaining))) ;;;###autoload (defmacro* ert-deftest (name () &body docstring-keys-and-body) "Define NAME (a symbol) as a test. BODY is evaluated as a `progn' when the test is run. It should signal a condition on failure or just return if the test passes. `should', `should-not' and `should-error' are useful for assertions in BODY. Use `ert' to run tests interactively. Tests that are expected to fail can be marked as such using :expected-result. See `ert-test-result-type-p' for a description of valid values for RESULT-TYPE. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ \[:tags '(TAG...)] BODY...)" (declare (debug (&define :name test name sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 3) (indent 2)) (let ((documentation nil) (documentation-supplied-p nil)) (when (stringp (first docstring-keys-and-body)) (setq documentation (pop docstring-keys-and-body) documentation-supplied-p t)) (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) (tags nil tags-supplied-p)) body) (ert--parse-keys-and-body docstring-keys-and-body) `(progn (ert-set-test ',name (make-ert-test :name ',name ,@(when documentation-supplied-p `(:documentation ,documentation)) ,@(when expected-result-supplied-p `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) :body (lambda () ,@body))) ;; This hack allows `symbol-file' to associate `ert-deftest' ;; forms with files, and therefore enables `find-function' to ;; work with tests. However, it leads to warnings in ;; `unload-feature', which doesn't know how to undefine tests ;; and has no mechanism for extension. (push '(ert-deftest . ,name) current-load-list) ',name)))) ;; We use these `put' forms in addition to the (declare (indent)) in ;; the defmacro form since the `declare' alone does not lead to ;; correct indentation before the .el/.elc file is loaded. ;; Autoloading these `put' forms solves this. ;;;###autoload (progn ;; TODO(ohler): Figure out what these mean and make sure they are correct. (put 'ert-deftest 'lisp-indent-function 2) (put 'ert-info 'lisp-indent-function 1)) (defvar ert--find-test-regexp (concat "^\\s-*(ert-deftest" find-function-space-re "%s\\(\\s-\\|$\\)") "The regexp the `find-function' mechanisms use for finding test definitions.") (put 'ert-test-failed 'error-conditions '(error ert-test-failed)) (put 'ert-test-failed 'error-message "Test failed") (defun ert-pass () "Terminate the current test and mark it passed. Does not return." (throw 'ert--pass nil)) (defun ert-fail (data) "Terminate the current test and mark it failed. Does not return. DATA is displayed to the user and should state the reason of the failure." (signal 'ert-test-failed (list data))) ;;; The `should' macros. (defvar ert--should-execution-observer nil) (defun ert--signal-should-execution (form-description) "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." (when ert--should-execution-observer (funcall ert--should-execution-observer form-description))) (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) (let ((definition (indirect-function thing t))) (and (subrp definition) (eql (cdr (subr-arity definition)) 'unevalled))))) (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form ;; If `cl-macroexpand' isn't bound, the code that we're ;; compiling doesn't depend on cl and thus doesn't need an ;; environment arg for `macroexpand'. (if (fboundp 'cl-macroexpand) ;; Suppress warning about run-time call to cl funtion: we ;; only call it if it's fboundp. (with-no-warnings (cl-macroexpand form (and (boundp 'cl-macro-environment) cl-macro-environment))) (macroexpand form)))) (cond ((or (atom form) (ert--special-operator-p (car form))) (let ((value (ert--gensym "value-"))) `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) ,(funcall inner-expander `(setq ,value ,form) `(list ',whole :form ',form :value ,value) value) ,value))) (t (let ((fn-name (car form)) (arg-forms (cdr form))) (assert (or (symbolp fn-name) (and (consp fn-name) (eql (car fn-name) 'lambda) (listp (cdr fn-name))))) (let ((fn (ert--gensym "fn-")) (args (ert--gensym "args-")) (value (ert--gensym "value-")) (default-value (ert--gensym "ert-form-evaluation-aborted-"))) `(let ((,fn (function ,fn-name)) (,args (list ,@arg-forms))) (let ((,value ',default-value)) ,(funcall inner-expander `(setq ,value (apply ,fn ,args)) `(nconc (list ',whole) (list :form `(,,fn ,@,args)) (unless (eql ,value ',default-value) (list :value ,value)) (let ((-explainer- (and (symbolp ',fn-name) (get ',fn-name 'ert-explainer)))) (when -explainer- (list :explanation (apply -explainer- ,args))))) value) ,value)))))))) (defun ert--expand-should (whole form inner-expander) "Helper function for the `should' macro and its variants. Analyzes FORM and returns an expression that has the same semantics under evaluation but records additional debugging information. INNER-EXPANDER should be a function and is called with two arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is an expression that returns a description of FORM. INNER-EXPANDER should return code that calls INNER-FORM and performs the checks and error signalling specific to the particular variant of `should'. The code that INNER-EXPANDER returns must not call FORM-DESCRIPTION-FORM before it has called INNER-FORM." (lexical-let ((inner-expander inner-expander)) (ert--expand-should-1 whole form (lambda (inner-form form-description-form value-var) (let ((form-description (ert--gensym "form-description-"))) `(let (,form-description) ,(funcall inner-expander `(unwind-protect ,inner-form (setq ,form-description ,form-description-form) (ert--signal-should-execution ,form-description)) `,form-description value-var))))))) (defmacro* should (form) "Evaluate FORM. If it returns nil, abort the current test as failed. Returns the value of FORM." (ert--expand-should `(should ,form) form (lambda (inner-form form-description-form value-var) `(unless ,inner-form (ert-fail ,form-description-form))))) (defmacro* should-not (form) "Evaluate FORM. If it returns non-nil, abort the current test as failed. Returns nil." (ert--expand-should `(should-not ,form) form (lambda (inner-form form-description-form value-var) `(unless (not ,inner-form) (ert-fail ,form-description-form))))) (defun ert--should-error-handle-error (form-description-fn condition type exclude-subtypes) "Helper function for `should-error'. Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, and aborts the current test as failed if it doesn't." (let ((signalled-conditions (get (car condition) 'error-conditions)) (handled-conditions (etypecase type (list type) (symbol (list type))))) (assert signalled-conditions) (unless (ert--intersection signalled-conditions handled-conditions) (ert-fail (append (funcall form-description-fn) (list :condition condition :fail-reason (concat "the error signalled did not" " have the expected type"))))) (when exclude-subtypes (unless (member (car condition) handled-conditions) (ert-fail (append (funcall form-description-fn) (list :condition condition :fail-reason (concat "the error signalled was a subtype" " of the expected type")))))))) ;; FIXME: The expansion will evaluate the keyword args (if any) in ;; nonstandard order. (defmacro* should-error (form &rest keys &key type exclude-subtypes) "Evaluate FORM and check that it signals an error. The error signalled needs to match TYPE. TYPE should be a list of condition names. (It can also be a non-nil symbol, which is equivalent to a singleton list containing that symbol.) If EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its condition names is an element of TYPE. If EXCLUDE-SUBTYPES is non-nil, the error matches TYPE if it is an element of TYPE. If the error matches, returns (ERROR-SYMBOL . DATA) from the error. If not, or if no error was signalled, abort the test as failed." (unless type (setq type ''error)) (ert--expand-should `(should-error ,form ,@keys) form (lambda (inner-form form-description-form value-var) (let ((errorp (ert--gensym "errorp")) (form-description-fn (ert--gensym "form-description-fn-"))) `(let ((,errorp nil) (,form-description-fn (lambda () ,form-description-form))) (condition-case -condition- ,inner-form ;; We can't use ,type here because we want to evaluate it. (error (setq ,errorp t) (ert--should-error-handle-error ,form-description-fn -condition- ,type ,exclude-subtypes) (setq ,value-var -condition-))) (unless ,errorp (ert-fail (append (funcall ,form-description-fn) (list :fail-reason "did not signal an error"))))))))) ;;; Explanation of `should' failures. ;; TODO(ohler): Rework explanations so that they are displayed in a ;; similar way to `ert-info' messages; in particular, allow text ;; buttons in explanations that give more detail or open an ediff ;; buffer. Perhaps explanations should be reported through `ert-info' ;; rather than as part of the condition. (defun ert--proper-list-p (x) "Return non-nil if X is a proper list, nil otherwise." (loop for firstp = t then nil for fast = x then (cddr fast) for slow = x then (cdr slow) do (when (null fast) (return t)) (when (not (consp fast)) (return nil)) (when (null (cdr fast)) (return t)) (when (not (consp (cdr fast))) (return nil)) (when (and (not firstp) (eq fast slow)) (return nil)))) (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-not-equal'." (typecase x (fixnum (list x (format "#x%x" x) (format "?%c" x))) (t x))) (defun ert--explain-not-equal (a b) "Explainer function for `equal'. Returns a programmer-readable explanation of why A and B are not `equal', or nil if they are." (if (not (equal (type-of a) (type-of b))) `(different-types ,a ,b) (etypecase a (cons (let ((a-proper-p (ert--proper-list-p a)) (b-proper-p (ert--proper-list-p b))) (if (not (eql (not a-proper-p) (not b-proper-p))) `(one-list-proper-one-improper ,a ,b) (if a-proper-p (if (not (equal (length a) (length b))) `(proper-lists-of-different-length ,(length a) ,(length b) ,a ,b first-mismatch-at ,(ert--mismatch a b)) (loop for i from 0 for ai in a for bi in b for xi = (ert--explain-not-equal ai bi) do (when xi (return `(list-elt ,i ,xi))) finally (assert (equal a b) t))) (let ((car-x (ert--explain-not-equal (car a) (car b)))) (if car-x `(car ,car-x) (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) (if cdr-x `(cdr ,cdr-x) (assert (equal a b) t) nil)))))))) (array (if (not (equal (length a) (length b))) `(arrays-of-different-length ,(length a) ,(length b) ,a ,b ,@(unless (char-table-p a) `(first-mismatch-at ,(ert--mismatch a b)))) (loop for i from 0 for ai across a for bi across b for xi = (ert--explain-not-equal ai bi) do (when xi (return `(array-elt ,i ,xi))) finally (assert (equal a b) t)))) (atom (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) `(different-atoms ,(ert--explain-format-atom a) ,(ert--explain-format-atom b))) nil))))) (put 'equal 'ert-explainer 'ert--explain-not-equal) (defun ert--significant-plist-keys (plist) "Return the keys of PLIST that have non-null values, in order." (assert (zerop (mod (length plist) 2)) t) (loop for (key value . rest) on plist by #'cddr unless (or (null value) (memq key accu)) collect key into accu finally (return accu))) (defun ert--plist-difference-explanation (a b) "Return a programmer-readable explanation of why A and B are different plists. Returns nil if they are equivalent, i.e., have the same value for each key, where absent values are treated as nil. The order of key/value pairs in each list does not matter." (assert (zerop (mod (length a) 2)) t) (assert (zerop (mod (length b) 2)) t) ;; Normalizing the plists would be another way to do this but it ;; requires a total ordering on all lisp objects (since any object ;; is valid as a text property key). Perhaps defining such an ;; ordering is useful in other contexts, too, but it's a lot of ;; work, so let's punt on it for now. (let* ((keys-a (ert--significant-plist-keys a)) (keys-b (ert--significant-plist-keys b)) (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) (flet ((explain-with-key (key) (let ((value-a (plist-get a key)) (value-b (plist-get b key))) (assert (not (equal value-a value-b)) t) `(different-properties-for-key ,key ,(ert--explain-not-equal-including-properties value-a value-b))))) (cond (keys-in-a-not-in-b (explain-with-key (first keys-in-a-not-in-b))) (keys-in-b-not-in-a (explain-with-key (first keys-in-b-not-in-a))) (t (loop for key in keys-a when (not (equal (plist-get a key) (plist-get b key))) return (explain-with-key key))))))) (defun ert--abbreviate-string (s len suffixp) "Shorten string S to at most LEN chars. If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." (let ((n (length s))) (cond ((< n len) s) (suffixp (substring s (- n len))) (t (substring s 0 len))))) (defun ert--explain-not-equal-including-properties (a b) "Explainer function for `ert-equal-including-properties'. Returns a programmer-readable explanation of why A and B are not `ert-equal-including-properties', or nil if they are." (if (not (equal a b)) (ert--explain-not-equal a b) (assert (stringp a) t) (assert (stringp b) t) (assert (eql (length a) (length b)) t) (loop for i from 0 to (length a) for props-a = (text-properties-at i a) for props-b = (text-properties-at i b) for difference = (ert--plist-difference-explanation props-a props-b) do (when difference (return `(char ,i ,(substring-no-properties a i (1+ i)) ,difference context-before ,(ert--abbreviate-string (substring-no-properties a 0 i) 10 t) context-after ,(ert--abbreviate-string (substring-no-properties a (1+ i)) 10 nil)))) ;; TODO(ohler): Get `equal-including-properties' fixed in ;; Emacs, delete `ert-equal-including-properties', and ;; re-enable this assertion. ;;finally (assert (equal-including-properties a b) t) ))) (put 'ert-equal-including-properties 'ert-explainer 'ert--explain-not-equal-including-properties) ;;; Implementation of `ert-info'. ;; TODO(ohler): The name `info' clashes with ;; `ert--test-execution-info'. One or both should be renamed. (defvar ert--infos '() "The stack of `ert-info' infos that currently apply. Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") (defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) &body body) "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. To be used within ERT tests. MESSAGE-FORM should evaluate to a string that will be displayed together with the test result if the test fails. PREFIX-FORM should evaluate to a string as well and is displayed in front of the value of MESSAGE-FORM." (declare (debug ((form &rest [sexp form]) body)) (indent 1)) `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) ,@body)) ;;; Facilities for running a single test. (defvar ert-debug-on-error nil "Non-nil means enter debugger when a test fails or terminates with an error.") ;; The data structures that represent the result of running a test. (defstruct ert-test-result (messages nil) (should-forms nil) ) (defstruct (ert-test-passed (:include ert-test-result))) (defstruct (ert-test-result-with-condition (:include ert-test-result)) (condition (assert nil)) (backtrace (assert nil)) (infos (assert nil))) (defstruct (ert-test-quit (:include ert-test-result-with-condition))) (defstruct (ert-test-failed (:include ert-test-result-with-condition))) (defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) (defun ert--record-backtrace () "Record the current backtrace (as a list) and return it." ;; Since the backtrace is stored in the result object, result ;; objects must only be printed with appropriate limits ;; (`print-level' and `print-length') in place. For interactive ;; use, the cost of ensuring this possibly outweighs the advantage ;; of storing the backtrace for ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we ;; already have `ert-results-rerun-test-debugging-errors-at-point'. ;; For batch use, however, printing the backtrace may be useful. (loop ;; 6 is the number of frames our own debugger adds (when ;; compiled; more when interpreted). FIXME: Need to describe a ;; procedure for determining this constant. for i from 6 for frame = (backtrace-frame i) while frame collect frame)) (defun ert--print-backtrace (backtrace) "Format the backtrace BACKTRACE to the current buffer." ;; This is essentially a reimplementation of Fbacktrace ;; (src/eval.c), but for a saved backtrace, not the current one. (let ((print-escape-newlines t) (print-level 8) (print-length 50)) (dolist (frame backtrace) (ecase (first frame) ((nil) ;; Special operator. (destructuring-bind (special-operator &rest arg-forms) (cdr frame) (insert (format " %S\n" (list* special-operator arg-forms))))) ((t) ;; Function call. (destructuring-bind (fn &rest args) (cdr frame) (insert (format " %S(" fn)) (loop for firstp = t then nil for arg in args do (unless firstp (insert " ")) (insert (format "%S" arg))) (insert ")\n"))))))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. (defstruct ert--test-execution-info (test (assert nil)) (result (assert nil)) ;; A thunk that may be called when RESULT has been set to its final ;; value and test execution should be terminated. Should not ;; return. (exit-continuation (assert nil)) ;; The binding of `debugger' outside of the execution of the test. next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the ;; execution of the current test. We store it to avoid being ;; affected by any new bindings the test itself may establish. (I ;; don't remember whether this feature is important.) ert-debug-on-error) (defun ert--run-test-debugger (info debugger-args) "During a test run, `debugger' is bound to a closure that calls this function. This function records failures and errors and either terminates the test silently or calls the interactive debugger, as appropriate. INFO is the ert--test-execution-info corresponding to this test run. DEBUGGER-ARGS are the arguments to `debugger'." (destructuring-bind (first-debugger-arg &rest more-debugger-args) debugger-args (ecase first-debugger-arg ((lambda debug t exit nil) (apply (ert--test-execution-info-next-debugger info) debugger-args)) (error (let* ((condition (first more-debugger-args)) (type (case (car condition) ((quit) 'quit) (otherwise 'failed))) (backtrace (ert--record-backtrace)) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) (ecase type (quit (make-ert-test-quit :condition condition :backtrace backtrace :infos infos)) (failed (make-ert-test-failed :condition condition :backtrace backtrace :infos infos)))) ;; Work around Emacs' heuristic (in eval.c) for detecting ;; errors in the debugger. (incf num-nonmacro-input-events) ;; FIXME: We should probably implement more fine-grained ;; control a la non-t `debug-on-error' here. (cond ((ert--test-execution-info-ert-debug-on-error info) (apply (ert--test-execution-info-next-debugger info) debugger-args)) (t)) (funcall (ert--test-execution-info-exit-continuation info))))))) (defun ert--run-test-internal (ert-test-execution-info) "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." (lexical-let ((info ert-test-execution-info)) (setf (ert--test-execution-info-next-debugger info) debugger (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) (catch 'ert--pass ;; For now, each test gets its own temp buffer and its own ;; window excursion, just to be safe. If this turns out to be ;; too expensive, we can remove it. (with-temp-buffer (save-window-excursion (let ((debugger (lambda (&rest debugger-args) (ert--run-test-debugger info debugger-args))) (debug-on-error t) (debug-on-quit t) ;; FIXME: Do we need to store the old binding of this ;; and consider it in `ert--run-test-debugger'? (debug-ignored-errors nil) (ert--infos '())) (funcall (ert-test-body (ert--test-execution-info-test info)))))) (ert-pass)) (setf (ert--test-execution-info-result info) (make-ert-test-passed))) nil) (defun ert--force-message-log-buffer-truncation () "Immediately truncate *Messages* buffer according to `message-log-max'. This can be useful after reducing the value of `message-log-max'." (with-current-buffer (get-buffer-create "*Messages*") ;; This is a reimplementation of this part of message_dolog() in xdisp.c: ;; if (NATNUMP (Vmessage_log_max)) ;; { ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, ;; -XFASTINT (Vmessage_log_max) - 1, 0); ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); ;; } (when (and (integerp message-log-max) (>= message-log-max 0)) (let ((begin (point-min)) (end (save-excursion (goto-char (point-max)) (forward-line (- message-log-max)) (point)))) (delete-region begin end))))) (defvar ert--running-tests nil "List of tests that are currently in execution. This list is empty while no test is running, has one element while a test is running, two elements while a test run from inside a test is running, etc. The list is in order of nesting, innermost test first. The elements are of type `ert-test'.") (defun ert-run-test (ert-test) "Run ERT-TEST. Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (setf (ert-test-most-recent-result ert-test) nil) (block error (lexical-let ((begin-marker (with-current-buffer (get-buffer-create "*Messages*") (set-marker (make-marker) (point-max))))) (unwind-protect (lexical-let ((info (make-ert--test-execution-info :test ert-test :result (make-ert-test-aborted-with-non-local-exit) :exit-continuation (lambda () (return-from error nil)))) (should-form-accu (list))) (unwind-protect (let ((ert--should-execution-observer (lambda (form-description) (push form-description should-form-accu))) (message-log-max t) (ert--running-tests (cons ert-test ert--running-tests))) (ert--run-test-internal info)) (let ((result (ert--test-execution-info-result info))) (setf (ert-test-result-messages result) (with-current-buffer (get-buffer-create "*Messages*") (buffer-substring begin-marker (point-max)))) (ert--force-message-log-buffer-truncation) (setq should-form-accu (nreverse should-form-accu)) (setf (ert-test-result-should-forms result) should-form-accu) (setf (ert-test-most-recent-result ert-test) result)))) (set-marker begin-marker nil)))) (ert-test-most-recent-result ert-test)) (defun ert-running-test () "Return the top-level test currently executing." (car (last ert--running-tests))) ;;; Test selectors. (defun ert-test-result-type-p (result result-type) "Return non-nil if RESULT matches type RESULT-TYPE. Valid result types: nil -- Never matches. t -- Always matches. :failed, :passed -- Matches corresponding results. \(and TYPES...\) -- Matches if all TYPES match. \(or TYPES...\) -- Matches if some TYPES match. \(not TYPE\) -- Matches if TYPE does not match. \(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. (etypecase result-type ((member nil) nil) ((member t) t) ((member :failed) (ert-test-failed-p result)) ((member :passed) (ert-test-passed-p result)) (cons (destructuring-bind (operator &rest operands) result-type (ecase operator (and (case (length operands) (0 t) (t (and (ert-test-result-type-p result (first operands)) (ert-test-result-type-p result `(and ,@(rest operands))))))) (or (case (length operands) (0 nil) (t (or (ert-test-result-type-p result (first operands)) (ert-test-result-type-p result `(or ,@(rest operands))))))) (not (assert (eql (length operands) 1)) (not (ert-test-result-type-p result (first operands)))) (satisfies (assert (eql (length operands) 1)) (funcall (first operands) result))))))) (defun ert-test-result-expected-p (test result) "Return non-nil if TEST's expected result type matches RESULT." (ert-test-result-type-p result (ert-test-expected-result-type test))) (defun ert-select-tests (selector universe) "Return the tests that match SELECTOR. UNIVERSE specifies the set of tests to select from; it should be a list of tests, or t, which refers to all tests named by symbols in `obarray'. Returns the set of tests as a list. Valid selectors: nil -- Selects the empty set. t -- Selects UNIVERSE. :new -- Selects all tests that have not been run yet. :failed, :passed -- Select tests according to their most recent result. :expected, :unexpected -- Select tests according to their most recent result. a string -- Selects all tests that have a name that matches the string, a regexp. a test -- Selects that test. a symbol -- Selects the test that the symbol names, errors if none. \(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. \(eql TEST\) -- Selects TEST, a test or a symbol naming a test. \(and SELECTORS...\) -- Selects the tests that match all SELECTORS. \(or SELECTORS...\) -- Selects the tests that match any SELECTOR. \(not SELECTOR\) -- Selects all tests that do not match SELECTOR. \(tag TAG) -- Selects all tests that have TAG on their tags list. \(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. Only selectors that require a superset of tests, such as (satisfies ...), strings, :new, etc. make use of UNIVERSE. Selectors that do not, such as \(member ...\), just return the set implied by them without checking whether it is really contained in UNIVERSE." ;; This code needs to match the etypecase in ;; `ert-insert-human-readable-selector'. (etypecase selector ((member nil) nil) ((member t) (etypecase universe (list universe) ((member t) (ert-select-tests "" universe)))) ((member :new) (ert-select-tests `(satisfies ,(lambda (test) (null (ert-test-most-recent-result test)))) universe)) ((member :failed) (ert-select-tests `(satisfies ,(lambda (test) (ert-test-result-type-p (ert-test-most-recent-result test) ':failed))) universe)) ((member :passed) (ert-select-tests `(satisfies ,(lambda (test) (ert-test-result-type-p (ert-test-most-recent-result test) ':passed))) universe)) ((member :expected) (ert-select-tests `(satisfies ,(lambda (test) (ert-test-result-expected-p test (ert-test-most-recent-result test)))) universe)) ((member :unexpected) (ert-select-tests `(not :expected) universe)) (string (etypecase universe ((member t) (mapcar #'ert-get-test (apropos-internal selector #'ert-test-boundp))) (list (ert--remove-if-not (lambda (test) (and (ert-test-name test) (string-match selector (ert-test-name test)))) universe)))) (ert-test (list selector)) (symbol (assert (ert-test-boundp selector)) (list (ert-get-test selector))) (cons (destructuring-bind (operator &rest operands) selector (ecase operator (member (mapcar (lambda (purported-test) (etypecase purported-test (symbol (assert (ert-test-boundp purported-test)) (ert-get-test purported-test)) (ert-test purported-test))) operands)) (eql (assert (eql (length operands) 1)) (ert-select-tests `(member ,@operands) universe)) (and ;; Do these definitions of AND, NOT and OR satisfy de ;; Morgan's laws? Should they? (case (length operands) (0 (ert-select-tests 't universe)) (t (ert-select-tests `(and ,@(rest operands)) (ert-select-tests (first operands) universe))))) (not (assert (eql (length operands) 1)) (let ((all-tests (ert-select-tests 't universe))) (ert--set-difference all-tests (ert-select-tests (first operands) all-tests)))) (or (case (length operands) (0 (ert-select-tests 'nil universe)) (t (ert--union (ert-select-tests (first operands) universe) (ert-select-tests `(or ,@(rest operands)) universe))))) (tag (assert (eql (length operands) 1)) (let ((tag (first operands))) (ert-select-tests `(satisfies ,(lambda (test) (member tag (ert-test-tags test)))) universe))) (satisfies (assert (eql (length operands) 1)) (ert--remove-if-not (first operands) (ert-select-tests 't universe)))))))) (defun ert--insert-human-readable-selector (selector) "Insert a human-readable presentation of SELECTOR into the current buffer." ;; This is needed to avoid printing the (huge) contents of the ;; `backtrace' slot of the result objects in the ;; `most-recent-result' slots of test case objects in (eql ...) or ;; (member ...) selectors. (labels ((rec (selector) ;; This code needs to match the etypecase in `ert-select-tests'. (etypecase selector ((or (member nil t :new :failed :passed :expected :unexpected) string symbol) selector) (ert-test (if (ert-test-name selector) (make-symbol (format "<%S>" (ert-test-name selector))) (make-symbol ""))) (cons (destructuring-bind (operator &rest operands) selector (ecase operator ((member eql and not or) `(,operator ,@(mapcar #'rec operands))) ((member tag satisfies) selector))))))) (insert (format "%S" (rec selector))))) ;;; Facilities for running a whole set of tests. ;; The data structure that contains the set of tests being executed ;; during one particular test run, their results, the state of the ;; execution, and some statistics. ;; ;; The data about results and expected results of tests may seem ;; redundant here, since the test objects also carry such information. ;; However, the information in the test objects may be more recent, it ;; may correspond to a different test run. We need the information ;; that corresponds to this run in order to be able to update the ;; statistics correctly when a test is re-run interactively and has a ;; different result than before. (defstruct ert--stats (selector (assert nil)) ;; The tests, in order. (tests (assert nil) :type vector) ;; A map of test names (or the test objects themselves for unnamed ;; tests) to indices into the `tests' vector. (test-map (assert nil) :type hash-table) ;; The results of the tests during this run, in order. (test-results (assert nil) :type vector) ;; The start times of the tests, in order, as reported by ;; `current-time'. (test-start-times (assert nil) :type vector) ;; The end times of the tests, in order, as reported by ;; `current-time'. (test-end-times (assert nil) :type vector) (passed-expected 0) (passed-unexpected 0) (failed-expected 0) (failed-unexpected 0) (start-time nil) (end-time nil) (aborted-p nil) (current-test nil) ;; The time at or after which the next redisplay should occur, as a ;; float. (next-redisplay 0.0)) (defun ert-stats-completed-expected (stats) "Return the number of tests in STATS that had expected results." (+ (ert--stats-passed-expected stats) (ert--stats-failed-expected stats))) (defun ert-stats-completed-unexpected (stats) "Return the number of tests in STATS that had unexpected results." (+ (ert--stats-passed-unexpected stats) (ert--stats-failed-unexpected stats))) (defun ert-stats-completed (stats) "Number of tests in STATS that have run so far." (+ (ert-stats-completed-expected stats) (ert-stats-completed-unexpected stats))) (defun ert-stats-total (stats) "Number of tests in STATS, regardless of whether they have run yet." (length (ert--stats-tests stats))) ;; The stats object of the current run, dynamically bound. This is ;; used for the mode line progress indicator. (defvar ert--current-run-stats nil) (defun ert--stats-test-key (test) "Return the key used for TEST in the test map of ert--stats objects. Returns the name of TEST if it has one, or TEST itself otherwise." (or (ert-test-name test) test)) (defun ert--stats-set-test-and-result (stats pos test result) "Change STATS by replacing the test at position POS with TEST and RESULT. Also changes the counters in STATS to match." (let* ((tests (ert--stats-tests stats)) (results (ert--stats-test-results stats)) (old-test (aref tests pos)) (map (ert--stats-test-map stats))) (flet ((update (d) (if (ert-test-result-expected-p (aref tests pos) (aref results pos)) (etypecase (aref results pos) (ert-test-passed (incf (ert--stats-passed-expected stats) d)) (ert-test-failed (incf (ert--stats-failed-expected stats) d)) (null) (ert-test-aborted-with-non-local-exit)) (etypecase (aref results pos) (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) (null) (ert-test-aborted-with-non-local-exit))))) ;; Adjust counters to remove the result that is currently in stats. (update -1) ;; Put new test and result into stats. (setf (aref tests pos) test (aref results pos) result) (remhash (ert--stats-test-key old-test) map) (setf (gethash (ert--stats-test-key test) map) pos) ;; Adjust counters to match new result. (update +1) nil))) (defun ert--make-stats (tests selector) "Create a new `ert--stats' object for running TESTS. SELECTOR is the selector that was used to select TESTS." (setq tests (ert--coerce-to-vector tests)) (let ((map (make-hash-table :size (length tests)))) (loop for i from 0 for test across tests for key = (ert--stats-test-key test) do (assert (not (gethash key map))) (setf (gethash key map) i)) (make-ert--stats :selector selector :tests tests :test-map map :test-results (make-vector (length tests) nil) :test-start-times (make-vector (length tests) nil) :test-end-times (make-vector (length tests) nil)))) (defun ert-run-or-rerun-test (stats test listener) ;; checkdoc-order: nil "Run the single test TEST and record the result using STATS and LISTENER." (let ((ert--current-run-stats stats) (pos (ert--stats-test-pos stats test))) (ert--stats-set-test-and-result stats pos test nil) ;; Call listener after setting/before resetting ;; (ert--stats-current-test stats); the listener might refresh the ;; mode line display, and if the value is not set yet/any more ;; during this refresh, the mode line will flicker unnecessarily. (setf (ert--stats-current-test stats) test) (funcall listener 'test-started stats test) (setf (ert-test-most-recent-result test) nil) (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) (unwind-protect (ert-run-test test) (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) (let ((result (ert-test-most-recent-result test))) (ert--stats-set-test-and-result stats pos test result) (funcall listener 'test-ended stats test result)) (setf (ert--stats-current-test stats) nil)))) (defun ert-run-tests (selector listener) "Run the tests specified by SELECTOR, sending progress updates to LISTENER." (let* ((tests (ert-select-tests selector t)) (stats (ert--make-stats tests selector))) (setf (ert--stats-start-time stats) (current-time)) (funcall listener 'run-started stats) (let ((abortedp t)) (unwind-protect (let ((ert--current-run-stats stats)) (force-mode-line-update) (unwind-protect (progn (loop for test in tests do (ert-run-or-rerun-test stats test listener)) (setq abortedp nil)) (setf (ert--stats-aborted-p stats) abortedp) (setf (ert--stats-end-time stats) (current-time)) (funcall listener 'run-ended stats abortedp))) (force-mode-line-update)) stats))) (defun ert--stats-test-pos (stats test) ;; checkdoc-order: nil "Return the position (index) of TEST in the run represented by STATS." (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) ;;; Formatting functions shared across UIs. (defun ert--format-time-iso8601 (time) "Format TIME in the variant of ISO 8601 used for timestamps in ERT." (format-time-string "%Y-%m-%d %T%z" time)) (defun ert-char-for-test-result (result expectedp) "Return a character that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." (let ((s (etypecase result (ert-test-passed ".P") (ert-test-failed "fF") (null "--") (ert-test-aborted-with-non-local-exit "aA")))) (elt s (if expectedp 0 1)))) (defun ert-string-for-test-result (result expectedp) "Return a string that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." (let ((s (etypecase result (ert-test-passed '("passed" "PASSED")) (ert-test-failed '("failed" "FAILED")) (null '("unknown" "UNKNOWN")) (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) (elt s (if expectedp 0 1)))) (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." (let ((begin (point))) (pp object (current-buffer)) (unless (bolp) (insert "\n")) (save-excursion (goto-char begin) (indent-sexp)))) (defun ert--insert-infos (result) "Insert `ert-info' infos from RESULT into current buffer. RESULT must be an `ert-test-result-with-condition'." (check-type result ert-test-result-with-condition) (dolist (info (ert-test-result-with-condition-infos result)) (destructuring-bind (prefix . message) info (let ((begin (point)) (indentation (make-string (+ (length prefix) 4) ?\s)) (end nil)) (unwind-protect (progn (insert message "\n") (setq end (copy-marker (point))) (goto-char begin) (insert " " prefix) (forward-line 1) (while (< (point) end) (insert indentation) (forward-line 1))) (when end (set-marker end nil))))))) ;;; Running tests in batch mode. (defvar ert-batch-backtrace-right-margin 70 "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") ;;;###autoload (defun ert-run-tests-batch (&optional selector) "Run the tests specified by SELECTOR, printing results to the terminal. SELECTOR works as described in `ert-select-tests', except if SELECTOR is nil, in which case all tests rather than none will be run; this makes the command line \"emacs -batch -l my-tests.el -f ert-run-tests-batch-and-exit\" useful. Returns the stats object." (unless selector (setq selector 't)) (ert-run-tests selector (lambda (event-type &rest event-args) (ecase event-type (run-started (destructuring-bind (stats) event-args (message "Running %s tests (%s)" (length (ert--stats-tests stats)) (ert--format-time-iso8601 (ert--stats-start-time stats))))) (run-ended (destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) (expected-failures (ert--stats-failed-expected stats))) (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" (if (not abortedp) "" "Aborted: ") (ert-stats-total stats) (ert-stats-completed-expected stats) (if (zerop unexpected) "" (format ", %s unexpected" unexpected)) (ert--format-time-iso8601 (ert--stats-end-time stats)) (if (zerop expected-failures) "" (format "\n%s expected failures" expected-failures))) (unless (zerop unexpected) (message "%s unexpected results:" unexpected) (loop for test across (ert--stats-tests stats) for result = (ert-test-most-recent-result test) do (when (not (ert-test-result-expected-p test result)) (message "%9s %S" (ert-string-for-test-result result nil) (ert-test-name test)))) (message "%s" ""))))) (test-started ) (test-ended (destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) (etypecase result (ert-test-passed (message "Test %S passed unexpectedly" (ert-test-name test))) (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer (ert--print-backtrace (ert-test-result-with-condition-backtrace result)) (goto-char (point-min)) (while (not (eobp)) (let ((start (point)) (end (progn (end-of-line) (point)))) (setq end (min end (+ start ert-batch-backtrace-right-margin))) (message "%s" (buffer-substring-no-properties start end))) (forward-line 1))) (with-temp-buffer (ert--insert-infos result) (insert " ") (let ((print-escape-newlines t) (print-level 5) (print-length 10)) (let ((begin (point))) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result)))) (goto-char (1- (point-max))) (assert (looking-at "\n")) (delete-char 1) (message "Test %S condition:" (ert-test-name test)) (message "%s" (buffer-string)))) (ert-test-aborted-with-non-local-exit (message "Test %S aborted with non-local exit" (ert-test-name test))))) (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) (format-string (concat "%9s %" (prin1-to-string (length max)) "s/" max " %S"))) (message format-string (ert-string-for-test-result result (ert-test-result-expected-p test result)) (1+ (ert--stats-test-pos stats test)) (ert-test-name test))))))))) ;;;###autoload (defun ert-run-tests-batch-and-exit (&optional selector) "Like `ert-run-tests-batch', but exits Emacs when done. The exit status will be 0 if all test results were as expected, 1 on unexpected results, or 2 if the framework detected an error outside of the tests (e.g. invalid SELECTOR or bug in the code that runs the tests)." (unwind-protect (let ((stats (ert-run-tests-batch selector))) (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) (unwind-protect (progn (message "Error running tests") (backtrace)) (kill-emacs 2)))) ;;; Utility functions for load/unload actions. (defun ert--activate-font-lock-keywords () "Activate font-lock keywords for some of ERT's symbols." (font-lock-add-keywords nil '(("(\\(\\\\s *\\(\\sw+\\)?" (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t))))) (defun* ert--remove-from-list (list-var element &key key test) "Remove ELEMENT from the value of LIST-VAR if present. This can be used as an inverse of `add-to-list'." (unless key (setq key #'identity)) (unless test (setq test #'equal)) (setf (symbol-value list-var) (ert--remove* element (symbol-value list-var) :key key :test test))) ;;; Some basic interactive functions. (defun ert-read-test-name (prompt &optional default history add-default-to-prompt) "Read the name of a test and return it as a symbol. Prompt with PROMPT. If DEFAULT is a valid test name, use it as a default. HISTORY is the history to use; see `completing-read'. If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to include the default, if any. Signals an error if no test name was read." (etypecase default (string (let ((symbol (intern-soft default))) (unless (and symbol (ert-test-boundp symbol)) (setq default nil)))) (symbol (setq default (if (ert-test-boundp default) (symbol-name default) nil))) (ert-test (setq default (ert-test-name default)))) (when add-default-to-prompt (setq prompt (if (null default) (format "%s: " prompt) (format "%s (default %s): " prompt default)))) (let ((input (completing-read prompt obarray #'ert-test-boundp t nil history default nil))) ;; completing-read returns an empty string if default was nil and ;; the user just hit enter. (let ((sym (intern-soft input))) (if (ert-test-boundp sym) sym (error "Input does not name a test"))))) (defun ert-read-test-name-at-point (prompt) "Read the name of a test and return it as a symbol. As a default, use the symbol at point, or the test at point if in the ERT results buffer. Prompt with PROMPT, augmented with the default (if any)." (ert-read-test-name prompt (ert-test-at-point) nil t)) (defun ert-find-test-other-window (test-name) "Find, in another window, the definition of TEST-NAME." (interactive (list (ert-read-test-name-at-point "Find test definition: "))) (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) (defun ert-delete-test (test-name) "Make the test TEST-NAME unbound. Nothing more than an interactive interface to `ert-make-test-unbound'." (interactive (list (ert-read-test-name-at-point "Delete test"))) (ert-make-test-unbound test-name)) (defun ert-delete-all-tests () "Make all symbols in `obarray' name no test." (interactive) (when (interactive-p) (unless (y-or-n-p "Delete all tests? ") (error "Aborted"))) ;; We can't use `ert-select-tests' here since that gives us only ;; test objects, and going from them back to the test name symbols ;; can fail if the `ert-test' defstruct has been redefined. (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) t) ;;; Display of test progress and results. ;; An entry in the results buffer ewoc. There is one entry per test. (defstruct ert--ewoc-entry (test (assert nil)) ;; If the result of this test was expected, its ewoc entry is hidden ;; initially. (hidden-p (assert nil)) ;; An ewoc entry may be collapsed to hide details such as the error ;; condition. ;; ;; I'm not sure the ability to expand and collapse entries is still ;; a useful feature. (expanded-p t) ;; By default, the ewoc entry presents the error condition with ;; certain limits on how much to print (`print-level', ;; `print-length'). The user can interactively switch to a set of ;; higher limits. (extended-printer-limits-p nil)) ;; Variables local to the results buffer. ;; The ewoc. (defvar ert--results-ewoc) ;; The stats object. (defvar ert--results-stats) ;; A string with one character per test. Each character represents ;; the result of the corresponding test. The string is displayed near ;; the top of the buffer and serves as a progress bar. (defvar ert--results-progress-bar-string) ;; The position where the progress bar button begins. (defvar ert--results-progress-bar-button-begin) ;; The test result listener that updates the buffer when tests are run. (defvar ert--results-listener) (defun ert-insert-test-name-button (test-name) "Insert a button that links to TEST-NAME." (insert-text-button (format "%S" test-name) :type 'ert--test-name-button 'ert-test-name test-name)) (defun ert--results-format-expected-unexpected (expected unexpected) "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." (if (zerop unexpected) (format "%s" expected) (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) (defun ert--results-update-ewoc-hf (ewoc stats) "Update the header and footer of EWOC to show certain information from STATS. Also sets `ert--results-progress-bar-button-begin'." (let ((run-count (ert-stats-completed stats)) (results-buffer (current-buffer)) ;; Need to save buffer-local value. (font-lock font-lock-mode)) (ewoc-set-hf ewoc ;; header (with-temp-buffer (insert "Selector: ") (ert--insert-human-readable-selector (ert--stats-selector stats)) (insert "\n") (insert (format (concat "Passed: %s\n" "Failed: %s\n" "Total: %s/%s\n\n") (ert--results-format-expected-unexpected (ert--stats-passed-expected stats) (ert--stats-passed-unexpected stats)) (ert--results-format-expected-unexpected (ert--stats-failed-expected stats) (ert--stats-failed-unexpected stats)) run-count (ert-stats-total stats))) (insert (format "Started at: %s\n" (ert--format-time-iso8601 (ert--stats-start-time stats)))) ;; FIXME: This is ugly. Need to properly define invariants of ;; the `stats' data structure. (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) ((ert--stats-current-test stats) 'running) ((ert--stats-end-time stats) 'finished) (t 'preparing)))) (ecase state (preparing (insert "")) (aborted (cond ((ert--stats-current-test stats) (insert "Aborted during test: ") (ert-insert-test-name-button (ert-test-name (ert--stats-current-test stats)))) (t (insert "Aborted.")))) (running (assert (ert--stats-current-test stats)) (insert "Running test: ") (ert-insert-test-name-button (ert-test-name (ert--stats-current-test stats)))) (finished (assert (not (ert--stats-current-test stats))) (insert "Finished."))) (insert "\n") (if (ert--stats-end-time stats) (insert (format "%s%s\n" (if (ert--stats-aborted-p stats) "Aborted at: " "Finished at: ") (ert--format-time-iso8601 (ert--stats-end-time stats)))) (insert "\n")) (insert "\n")) (let ((progress-bar-string (with-current-buffer results-buffer ert--results-progress-bar-string))) (let ((progress-bar-button-begin (insert-text-button progress-bar-string :type 'ert--results-progress-bar-button 'face (or (and font-lock (ert-face-for-stats stats)) 'button)))) ;; The header gets copied verbatim to the results buffer, ;; and all positions remain the same, so ;; `progress-bar-button-begin' will be the right position ;; even in the results buffer. (with-current-buffer results-buffer (set (make-local-variable 'ert--results-progress-bar-button-begin) progress-bar-button-begin)))) (insert "\n\n") (buffer-string)) ;; footer ;; ;; We actually want an empty footer, but that would trigger a bug ;; in ewoc, sometimes clearing the entire buffer. (It's possible ;; that this bug has been fixed since this has been tested; we ;; should test it again.) "\n"))) (defvar ert-test-run-redisplay-interval-secs .1 "How many seconds ERT should wait between redisplays while running tests. While running tests, ERT shows the current progress, and this variable determines how frequently the progress display is updated.") (defun ert--results-update-stats-display (ewoc stats) "Update EWOC and the mode line to show data from STATS." ;; TODO(ohler): investigate using `make-progress-reporter'. (ert--results-update-ewoc-hf ewoc stats) (force-mode-line-update) (redisplay t) (setf (ert--stats-next-redisplay stats) (+ (float-time) ert-test-run-redisplay-interval-secs))) (defun ert--results-update-stats-display-maybe (ewoc stats) "Call `ert--results-update-stats-display' if not called recently. EWOC and STATS are arguments for `ert--results-update-stats-display'." (when (>= (float-time) (ert--stats-next-redisplay stats)) (ert--results-update-stats-display ewoc stats))) (defun ert--tests-running-mode-line-indicator () "Return a string for the mode line that shows the test run progress." (let* ((stats ert--current-run-stats) (tests-total (ert-stats-total stats)) (tests-completed (ert-stats-completed stats))) (if (>= tests-completed tests-total) (format " ERT(%s/%s,finished)" tests-completed tests-total) (format " ERT(%s/%s):%s" (1+ tests-completed) tests-total (if (null (ert--stats-current-test stats)) "?" (format "%S" (ert-test-name (ert--stats-current-test stats)))))))) (defun ert--make-xrefs-region (begin end) "Attach cross-references to function names between BEGIN and END. BEGIN and END specify a region in the current buffer." (save-excursion (save-restriction (narrow-to-region begin (point)) ;; Inhibit optimization in `debugger-make-xrefs' that would ;; sometimes insert unrelated backtrace info into our buffer. (let ((debugger-previous-backtrace nil)) (debugger-make-xrefs))))) (defun ert--string-first-line (s) "Return the first line of S, or S if it contains no newlines. The return value does not include the line terminator." (substring s 0 (ert--string-position ?\n s))) (defun ert-face-for-test-result (expectedp) "Return a face that shows whether a test result was expected or unexpected. If EXPECTEDP is nil, returns the face for unexpected results; if non-nil, returns the face for expected results.." (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) (defun ert-face-for-stats (stats) "Return a face that represents STATS." (cond ((ert--stats-aborted-p stats) 'nil) ((plusp (ert-stats-completed-unexpected stats)) (ert-face-for-test-result nil)) ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) (ert-face-for-test-result t)) (t 'nil))) (defun ert--print-test-for-ewoc (entry) "The ewoc print function for ewoc test entries. ENTRY is the entry to print." (let* ((test (ert--ewoc-entry-test entry)) (stats ert--results-stats) (result (let ((pos (ert--stats-test-pos stats test))) (assert pos) (aref (ert--stats-test-results stats) pos))) (hiddenp (ert--ewoc-entry-hidden-p entry)) (expandedp (ert--ewoc-entry-expanded-p entry)) (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p entry))) (cond (hiddenp) (t (let ((expectedp (ert-test-result-expected-p test result))) (insert-text-button (format "%c" (ert-char-for-test-result result expectedp)) :type 'ert--results-expand-collapse-button 'face (or (and font-lock-mode (ert-face-for-test-result expectedp)) 'button))) (insert " ") (ert-insert-test-name-button (ert-test-name test)) (insert "\n") (when (and expandedp (not (eql result 'nil))) (when (ert-test-documentation test) (insert " " (propertize (ert--string-first-line (ert-test-documentation test)) 'font-lock-face 'font-lock-doc-face) "\n")) (etypecase result (ert-test-passed (if (ert-test-result-expected-p test result) (insert " passed\n") (insert " passed unexpectedly\n")) (insert "")) (ert-test-result-with-condition (ert--insert-infos result) (let ((print-escape-newlines t) (print-level (if extended-printer-limits-p 12 6)) (print-length (if extended-printer-limits-p 100 10))) (insert " ") (let ((begin (point))) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result)) (ert--make-xrefs-region begin (point))))) (ert-test-aborted-with-non-local-exit (insert " aborted\n"))) (insert "\n"))))) nil) (defun ert--results-font-lock-function (enabledp) "Redraw the ERT results buffer after font-lock-mode was switched on or off. ENABLEDP is true if font-lock-mode is switched on, false otherwise." (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) (ewoc-refresh ert--results-ewoc) (font-lock-default-function enabledp)) (defun ert--setup-results-buffer (stats listener buffer-name) "Set up a test results buffer. STATS is the stats object; LISTENER is the results listener; BUFFER-NAME, if non-nil, is the buffer name to use." (unless buffer-name (setq buffer-name "*ert*")) (let ((buffer (get-buffer-create buffer-name))) (with-current-buffer buffer (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-results-mode) ;; Erase buffer again in case switching out of the previous ;; mode inserted anything. (This happens e.g. when switching ;; from ert-results-mode to ert-results-mode when ;; font-lock-mode turns itself off in change-major-mode-hook.) (erase-buffer) (set (make-local-variable 'font-lock-function) 'ert--results-font-lock-function) (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) (set (make-local-variable 'ert--results-ewoc) ewoc) (set (make-local-variable 'ert--results-stats) stats) (set (make-local-variable 'ert--results-progress-bar-string) (make-string (ert-stats-total stats) (ert-char-for-test-result nil t))) (set (make-local-variable 'ert--results-listener) listener) (loop for test across (ert--stats-tests stats) do (ewoc-enter-last ewoc (make-ert--ewoc-entry :test test :hidden-p t))) (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) (goto-char (1- (point-max))) buffer))))) (defvar ert--selector-history nil "List of recent test selectors read from terminal.") ;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? ;; They are needed only for our automated self-tests at the moment. ;; Or should there be some other mechanism? ;;;###autoload (defun ert-run-tests-interactively (selector &optional output-buffer-name message-fn) "Run the tests specified by SELECTOR and display the results in a buffer. SELECTOR works as described in `ert-select-tests'. OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they are used for automated self-tests and specify which buffer to use and how to display message." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is ;; not compiled, and `first' is not ;; defined without cl. (car ert--selector-history) "t"))) (read-from-minibuffer (if (null default) "Run tests: " (format "Run tests (default %s): " default)) nil nil t 'ert--selector-history default nil)) nil)) (unless message-fn (setq message-fn 'message)) (lexical-let ((output-buffer-name output-buffer-name) buffer listener (message-fn message-fn)) (setq listener (lambda (event-type &rest event-args) (ecase event-type (run-started (destructuring-bind (stats) event-args (setq buffer (ert--setup-results-buffer stats listener output-buffer-name)) (pop-to-buffer buffer))) (run-ended (destructuring-bind (stats abortedp) event-args (funcall message-fn "%sRan %s tests, %s results were as expected%s" (if (not abortedp) "" "Aborted: ") (ert-stats-total stats) (ert-stats-completed-expected stats) (let ((unexpected (ert-stats-completed-unexpected stats))) (if (zerop unexpected) "" (format ", %s unexpected" unexpected)))) (ert--results-update-stats-display (with-current-buffer buffer ert--results-ewoc) stats))) (test-started (destructuring-bind (stats test) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) (node (ewoc-nth ewoc pos))) (assert node) (setf (ert--ewoc-entry-test (ewoc-data node)) test) (aset ert--results-progress-bar-string pos (ert-char-for-test-result nil t)) (ert--results-update-stats-display-maybe ewoc stats) (ewoc-invalidate ewoc node))))) (test-ended (destructuring-bind (stats test result) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) (node (ewoc-nth ewoc pos))) (when (ert--ewoc-entry-hidden-p (ewoc-data node)) (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) (ert-test-result-expected-p test result))) (aset ert--results-progress-bar-string pos (ert-char-for-test-result result (ert-test-result-expected-p test result))) (ert--results-update-stats-display-maybe ewoc stats) (ewoc-invalidate ewoc node)))))))) (ert-run-tests selector listener))) ;;;###autoload (defalias 'ert 'ert-run-tests-interactively) ;;; Simple view mode for auxiliary information like stack traces or ;;; messages. Mainly binds "q" for quit. (define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" "Major mode for viewing auxiliary information in ERT.") (loop for (key binding) in '(("q" quit-window) ) do (define-key ert-simple-view-mode-map key binding)) ;;; Commands and button actions for the results buffer. (define-derived-mode ert-results-mode fundamental-mode "ERT-Results" "Major mode for viewing results of ERT test runs.") (loop for (key binding) in '(;; Stuff that's not in the menu. ("\t" forward-button) ([backtab] backward-button) ("j" ert-results-jump-between-summary-and-result) ("q" quit-window) ("L" ert-results-toggle-printer-limits-for-test-at-point) ("n" ert-results-next-test) ("p" ert-results-previous-test) ;; Stuff that is in the menu. ("R" ert-results-rerun-all-tests) ("r" ert-results-rerun-test-at-point) ("d" ert-results-rerun-test-at-point-debugging-errors) ("." ert-results-find-test-at-point-other-window) ("b" ert-results-pop-to-backtrace-for-test-at-point) ("m" ert-results-pop-to-messages-for-test-at-point) ("l" ert-results-pop-to-should-forms-for-test-at-point) ("h" ert-results-describe-test-at-point) ("D" ert-delete-test) ("T" ert-results-pop-to-timings) ) do (define-key ert-results-mode-map key binding)) (easy-menu-define ert-results-mode-menu ert-results-mode-map "Menu for `ert-results-mode'." '("ERT Results" ["Re-run all tests" ert-results-rerun-all-tests] "--" ["Re-run test" ert-results-rerun-test-at-point] ["Debug test" ert-results-rerun-test-at-point-debugging-errors] ["Show test definition" ert-results-find-test-at-point-other-window] "--" ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] ["Show messages" ert-results-pop-to-messages-for-test-at-point] ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] ["Describe test" ert-results-describe-test-at-point] "--" ["Delete test" ert-delete-test] "--" ["Show execution time of each test" ert-results-pop-to-timings] )) (define-button-type 'ert--results-progress-bar-button 'action #'ert--results-progress-bar-button-action 'help-echo "mouse-2, RET: Reveal test result") (define-button-type 'ert--test-name-button 'action #'ert--test-name-button-action 'help-echo "mouse-2, RET: Find test definition") (define-button-type 'ert--results-expand-collapse-button 'action #'ert--results-expand-collapse-button-action 'help-echo "mouse-2, RET: Expand/collapse test result") (defun ert--results-test-node-or-null-at-point () "If point is on a valid ewoc node, return it; return nil otherwise. To be used in the ERT results buffer." (let* ((ewoc ert--results-ewoc) (node (ewoc-locate ewoc))) ;; `ewoc-locate' will return an arbitrary node when point is on ;; header or footer, or when all nodes are invisible. So we need ;; to validate its return value here. ;; ;; Update: I'm seeing nil being returned in some cases now, ;; perhaps this has been changed? (if (and node (>= (point) (ewoc-location node)) (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) node nil))) (defun ert--results-test-node-at-point () "If point is on a valid ewoc node, return it; signal an error otherwise. To be used in the ERT results buffer." (or (ert--results-test-node-or-null-at-point) (error "No test at point"))) (defun ert-results-next-test () "Move point to the next test. To be used in the ERT results buffer." (interactive) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next "No tests below")) (defun ert-results-previous-test () "Move point to the previous test. To be used in the ERT results buffer." (interactive) (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev "No tests above")) (defun ert--results-move (node ewoc-fn error-message) "Move point from NODE to the previous or next node. EWOC-FN specifies the direction and should be either `ewoc-prev' or `ewoc-next'. If there are no more nodes in that direction, an error is signalled with the message ERROR-MESSAGE." (loop (setq node (funcall ewoc-fn ert--results-ewoc node)) (when (null node) (error "%s" error-message)) (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) (goto-char (ewoc-location node)) (return)))) (defun ert--results-expand-collapse-button-action (button) "Expand or collapse the test node BUTTON belongs to." (let* ((ewoc ert--results-ewoc) (node (save-excursion (goto-char (ert--button-action-position)) (ert--results-test-node-at-point))) (entry (ewoc-data node))) (setf (ert--ewoc-entry-expanded-p entry) (not (ert--ewoc-entry-expanded-p entry))) (ewoc-invalidate ewoc node))) (defun ert-results-find-test-at-point-other-window () "Find the definition of the test at point in another window. To be used in the ERT results buffer." (interactive) (let ((name (ert-test-at-point))) (unless name (error "No test at point")) (ert-find-test-other-window name))) (defun ert--test-name-button-action (button) "Find the definition of the test BUTTON belongs to, in another window." (let ((name (button-get button 'ert-test-name))) (ert-find-test-other-window name))) (defun ert--ewoc-position (ewoc node) ;; checkdoc-order: nil "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." (loop for i from 0 for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) do (when (eql node node-here) (return i)) finally (return nil))) (defun ert-results-jump-between-summary-and-result () "Jump back and forth between the test run summary and individual test results. From an ewoc node, jumps to the character that represents the same test in the progress bar, and vice versa. To be used in the ERT results buffer." ;; Maybe this command isn't actually needed much, but if it is, it ;; seems like an indication that the UI design is not optimal. If ;; jumping back and forth between a summary at the top of the buffer ;; and the error log in the remainder of the buffer is useful, then ;; the summary apparently needs to be easily accessible from the ;; error log, and perhaps it would be better to have it in a ;; separate buffer to keep it visible. (interactive) (let ((ewoc ert--results-ewoc) (progress-bar-begin ert--results-progress-bar-button-begin)) (cond ((ert--results-test-node-or-null-at-point) (let* ((node (ert--results-test-node-at-point)) (pos (ert--ewoc-position ewoc node))) (goto-char (+ progress-bar-begin pos)))) ((and (<= progress-bar-begin (point)) (< (point) (button-end (button-at progress-bar-begin)))) (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) (entry (ewoc-data node))) (when (ert--ewoc-entry-hidden-p entry) (setf (ert--ewoc-entry-hidden-p entry) nil) (ewoc-invalidate ewoc node)) (ewoc-goto-node ewoc node))) (t (goto-char progress-bar-begin))))) (defun ert-test-at-point () "Return the name of the test at point as a symbol, or nil if none." (or (and (eql major-mode 'ert-results-mode) (let ((test (ert--results-test-at-point-no-redefinition))) (and test (ert-test-name test)))) (let* ((thing (thing-at-point 'symbol)) (sym (intern-soft thing))) (and (ert-test-boundp sym) sym)))) (defun ert--results-test-at-point-no-redefinition () "Return the test at point, or nil. To be used in the ERT results buffer." (assert (eql major-mode 'ert-results-mode)) (if (ert--results-test-node-or-null-at-point) (let* ((node (ert--results-test-node-at-point)) (test (ert--ewoc-entry-test (ewoc-data node)))) test) (let ((progress-bar-begin ert--results-progress-bar-button-begin)) (when (and (<= progress-bar-begin (point)) (< (point) (button-end (button-at progress-bar-begin)))) (let* ((test-index (- (point) progress-bar-begin)) (test (aref (ert--stats-tests ert--results-stats) test-index))) test))))) (defun ert--results-test-at-point-allow-redefinition () "Look up the test at point, and check whether it has been redefined. To be used in the ERT results buffer. Returns a list of two elements: the test (or nil) and a symbol specifying whether the test has been redefined. If a new test has been defined with the same name as the test at point, replaces the test at point with the new test, and returns the new test and the symbol `redefined'. If the test has been deleted, returns the old test and the symbol `deleted'. If the test is still current, returns the test and the symbol nil. If there is no test at point, returns a list with two nils." (let ((test (ert--results-test-at-point-no-redefinition))) (cond ((null test) `(nil nil)) ((null (ert-test-name test)) `(,test nil)) (t (let* ((name (ert-test-name test)) (new-test (and (ert-test-boundp name) (ert-get-test name)))) (cond ((eql test new-test) `(,test nil)) ((null new-test) `(,test deleted)) (t (ert--results-update-after-test-redefinition (ert--stats-test-pos ert--results-stats test) new-test) `(,new-test redefined)))))))) (defun ert--results-update-after-test-redefinition (pos new-test) "Update results buffer after the test at pos POS has been redefined. Also updates the stats object. NEW-TEST is the new test definition." (let* ((stats ert--results-stats) (ewoc ert--results-ewoc) (node (ewoc-nth ewoc pos)) (entry (ewoc-data node))) (ert--stats-set-test-and-result stats pos new-test nil) (setf (ert--ewoc-entry-test entry) new-test (aref ert--results-progress-bar-string pos) (ert-char-for-test-result nil t)) (ewoc-invalidate ewoc node)) nil) (defun ert--button-action-position () "The buffer position where the last button action was triggered." (cond ((integerp last-command-event) (point)) ((eventp last-command-event) (posn-point (event-start last-command-event))) (t (assert nil)))) (defun ert--results-progress-bar-button-action (button) "Jump to details for the test represented by the character clicked in BUTTON." (goto-char (ert--button-action-position)) (ert-results-jump-between-summary-and-result)) (defun ert-results-rerun-all-tests () "Re-run all tests, using the same selector. To be used in the ERT results buffer." (interactive) (assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) (ert-run-tests-interactively selector (buffer-name)))) (defun ert-results-rerun-test-at-point () "Re-run the test at point. To be used in the ERT results buffer." (interactive) (destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) (error "No test at point")) (let* ((stats ert--results-stats) (progress-message (format "Running %stest %S" (ecase redefinition-state ((nil) "") (redefined "new definition of ") (deleted "deleted ")) (ert-test-name test)))) ;; Need to save and restore point manually here: When point is on ;; the first visible ewoc entry while the header is updated, point ;; moves to the top of the buffer. This is undesirable, and a ;; simple `save-excursion' doesn't prevent it. (let ((point (point))) (unwind-protect (unwind-protect (progn (message "%s..." progress-message) (ert-run-or-rerun-test stats test ert--results-listener)) (ert--results-update-stats-display ert--results-ewoc stats) (message "%s...%s" progress-message (let ((result (ert-test-most-recent-result test))) (ert-string-for-test-result result (ert-test-result-expected-p test result))))) (goto-char point)))))) (defun ert-results-rerun-test-at-point-debugging-errors () "Re-run the test at point with `ert-debug-on-error' bound to t. To be used in the ERT results buffer." (interactive) (let ((ert-debug-on-error t)) (ert-results-rerun-test-at-point))) (defun ert-results-pop-to-backtrace-for-test-at-point () "Display the backtrace for the test at point. To be used in the ERT results buffer." (interactive) (let* ((test (ert--results-test-at-point-no-redefinition)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) (etypecase result (ert-test-passed (error "Test passed, no backtrace available")) (ert-test-result-with-condition (let ((backtrace (ert-test-result-with-condition-backtrace result)) (buffer (get-buffer-create "*ERT Backtrace*"))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) ;; Use unibyte because `debugger-setup-buffer' also does so. (set-buffer-multibyte nil) (setq truncate-lines t) (ert--print-backtrace backtrace) (debugger-make-xrefs) (goto-char (point-min)) (insert "Backtrace for test `") (ert-insert-test-name-button (ert-test-name test)) (insert "':\n"))))))) (defun ert-results-pop-to-messages-for-test-at-point () "Display the part of the *Messages* buffer generated during the test at point. To be used in the ERT results buffer." (interactive) (let* ((test (ert--results-test-at-point-no-redefinition)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) (let ((buffer (get-buffer-create "*ERT Messages*"))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) (insert (ert-test-result-messages result)) (goto-char (point-min)) (insert "Messages for test `") (ert-insert-test-name-button (ert-test-name test)) (insert "':\n"))))) (defun ert-results-pop-to-should-forms-for-test-at-point () "Display the list of `should' forms executed during the test at point. To be used in the ERT results buffer." (interactive) (let* ((test (ert--results-test-at-point-no-redefinition)) (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) (let ((buffer (get-buffer-create "*ERT list of should forms*"))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) (if (null (ert-test-result-should-forms result)) (insert "\n(No should forms during this test.)\n") (loop for form-description in (ert-test-result-should-forms result) for i from 1 do (insert "\n") (insert (format "%s: " i)) (let ((begin (point))) (ert--pp-with-indentation-and-newline form-description) (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) (insert "`should' forms executed during test `") (ert-insert-test-name-button (ert-test-name test)) (insert "':\n") (insert "\n") (insert (concat "(Values are shallow copies and may have " "looked different during the test if they\n" "have been modified destructively.)\n")) (forward-line 1))))) (defun ert-results-toggle-printer-limits-for-test-at-point () "Toggle how much of the condition to print for the test at point. To be used in the ERT results buffer." (interactive) (let* ((ewoc ert--results-ewoc) (node (ert--results-test-node-at-point)) (entry (ewoc-data node))) (setf (ert--ewoc-entry-extended-printer-limits-p entry) (not (ert--ewoc-entry-extended-printer-limits-p entry))) (ewoc-invalidate ewoc node))) (defun ert-results-pop-to-timings () "Display test timings for the last run. To be used in the ERT results buffer." (interactive) (let* ((stats ert--results-stats) (start-times (ert--stats-test-start-times stats)) (end-times (ert--stats-test-end-times stats)) (buffer (get-buffer-create "*ERT timings*")) (data (loop for test across (ert--stats-tests stats) for start-time across (ert--stats-test-start-times stats) for end-time across (ert--stats-test-end-times stats) collect (list test (float-time (subtract-time end-time start-time)))))) (setq data (sort data (lambda (a b) (> (second a) (second b))))) (pop-to-buffer buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) (if (null data) (insert "(No data)\n") (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) (loop for (test time) in data for cumul-time = time then (+ cumul-time time) for i from 1 do (let ((begin (point))) (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) (ert-insert-test-name-button (ert-test-name test)) (insert "\n")))) (goto-char (point-min)) (insert "Tests by run time (seconds):\n\n") (forward-line 1)))) ;;;###autoload (defun ert-describe-test (test-or-test-name) "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." (interactive (list (ert-read-test-name-at-point "Describe test"))) (when (< emacs-major-version 24) (error "Requires Emacs 24")) (let (test-name test-definition) (etypecase test-or-test-name (symbol (setq test-name test-or-test-name test-definition (ert-get-test test-or-test-name))) (ert-test (setq test-name (ert-test-name test-or-test-name) test-definition test-or-test-name))) (help-setup-xref (list #'ert-describe-test test-or-test-name) (called-interactively-p 'interactive)) (save-excursion (with-help-window (help-buffer) (with-current-buffer (help-buffer) (insert (if test-name (format "%S" test-name) "")) (insert " is a test") (let ((file-name (and test-name (symbol-file test-name 'ert-deftest)))) (when file-name (insert " defined in `" (file-name-nondirectory file-name) "'") (save-excursion (re-search-backward "`\\([^`']+\\)'" nil t) (help-xref-button 1 'help-function-def test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) (insert "\n\n") (unless (and (ert-test-boundp test-name) (eql (ert-get-test test-name) test-definition)) (let ((begin (point))) (insert "Note: This test has been redefined or deleted, " "this documentation refers to an old definition.") (fill-region-as-paragraph begin (point))) (insert "\n\n")) (insert (or (ert-test-documentation test-definition) "It is not documented.") "\n"))))))) (defun ert-results-describe-test-at-point () "Display the documentation of the test at point. To be used in the ERT results buffer." (interactive) (ert-describe-test (ert--results-test-at-point-no-redefinition))) ;;; Actions on load/unload. (add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) (add-to-list 'minor-mode-alist '(ert--current-run-stats (:eval (ert--tests-running-mode-line-indicator)))) (add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) (defun ert--unload-function () "Unload function to undo the side-effects of loading ert.el." (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) (ert--remove-from-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) nil) (defvar ert-unload-hook '()) (add-hook 'ert-unload-hook 'ert--unload-function) (provide 'ert) ;;; ert.el ends here slime-2.20/lib/hyperspec.el000066400000000000000000002702241315100173500156430ustar00rootroot00000000000000;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec ;; Copyright 1997 Naggum Software ;; Author: Erik Naggum ;; 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-lib nil t) (require 'cl-lib "lib/cl-lib") (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.") (defvar common-lisp-hyperspec--symbols (make-hash-table :test 'equal) "Map a symbol name to its list of relative URLs.") ;; Lookup NAME in 'common-lisp-hyperspec--symbols´ (defun common-lisp-hyperspec--find (name) "Get the relative url of a Common Lisp symbol NAME." (gethash name common-lisp-hyperspec--symbols)) (defun common-lisp-hyperspec--insert (name relative-url) "Insert CL symbol NAME and RELATIVE-URL into master table." (cl-pushnew relative-url (gethash name common-lisp-hyperspec--symbols) :test #'equal)) (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)) ;; Choose the symbol at point or read symbol-name from the minibuffer. (defun common-lisp-hyperspec-read-symbol-name (&optional symbol-at-point) (let* ((symbol-at-point (or symbol-at-point (thing-at-point 'symbol))) (stripped-symbol (and symbol-at-point (common-lisp-hyperspec--strip-cl-package (downcase symbol-at-point))))) (cond ((and stripped-symbol (common-lisp-hyperspec--find stripped-symbol)) stripped-symbol) (t (completing-read "Look up symbol in Common Lisp HyperSpec: " common-lisp-hyperspec--symbols nil t stripped-symbol 'common-lisp-hyperspec-history))))) ;; FIXME: is the (sleep-for 1.5) a actually needed? (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 (common-lisp-hyperspec-read-symbol-name))) (let ((name (common-lisp-hyperspec--strip-cl-package (downcase symbol-name)))) (cl-maplist (lambda (entry) (browse-url (concat common-lisp-hyperspec-root "Body/" (car entry))) (when (cdr entry) (sleep-for 1.5))) (or (common-lisp-hyperspec--find name) (error "The symbol `%s' is not defined in Common Lisp" symbol-name))))) ;;; 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 (defun common-lisp-hyperspec--get-one-line () (prog1 (cl-delete ?\n (thing-at-point 'line)) (forward-line))) (defun common-lisp-hyperspec--parse-map-file (file) (with-current-buffer (find-file-noselect file) (goto-char (point-min)) (let ((result '())) (while (< (point) (point-max)) (let* ((symbol-name (downcase (common-lisp-hyperspec--get-one-line))) (relative-url (common-lisp-hyperspec--get-one-line)) (file (file-name-nondirectory relative-url))) (push (list symbol-name file) result))) (reverse result)))) (mapc (lambda (entry) (common-lisp-hyperspec--insert (car entry) (cadr entry))) (if common-lisp-hyperspec-symbol-table (common-lisp-hyperspec--parse-map-file common-lisp-hyperspec-symbol-table) '(("&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")))) ;;; Added entries for reader macros. ;;; ;;; 20090302 Tobias C Rittweiler, and Stas Boukarev (defvar common-lisp-hyperspec--reader-macros (make-hash-table :test #'equal)) ;;; Data/Map_Sym.txt in does not contain entries for the reader ;;; macros. So we have to enumerate these explicitly. (mapc (lambda (entry) (puthash (car entry) (cadr entry) common-lisp-hyperspec--reader-macros)) '(("#" "02_dh.htm") ("##" "02_dhp.htm") ("#'" "02_dhb.htm") ("#(" "02_dhc.htm") ("#*" "02_dhd.htm") ("#:" "02_dhe.htm") ("#." "02_dhf.htm") ("#=" "02_dho.htm") ("#+" "02_dhq.htm") ("#-" "02_dhr.htm") ("#<" "02_dht.htm") ("#A" "02_dhl.htm") ("#B" "02_dhg.htm") ("#C" "02_dhk.htm") ("#O" "02_dhh.htm") ("#P" "02_dhn.htm") ("#R" "02_dhj.htm") ("#S" "02_dhm.htm") ("#X" "02_dhi.htm") ("#\\" "02_dha.htm") ("#|" "02_dhs.htm") ("\"" "02_de.htm") ("'" "02_dc.htm") ("`" "02_df.htm") ("," "02_dg.htm") ("(" "02_da.htm") (")" "02_db.htm") (";" "02_dd.htm"))) (defun common-lisp-hyperspec-lookup-reader-macro (macro) "Browse the CLHS entry for the reader-macro MACRO." (interactive (list (let ((completion-ignore-case t)) (completing-read "Look up reader-macro: " common-lisp-hyperspec--reader-macros nil t (common-lisp-hyperspec-reader-macro-at-point))))) (browse-url (concat common-lisp-hyperspec-root "Body/" (gethash macro common-lisp-hyperspec--reader-macros)))) (defun common-lisp-hyperspec-reader-macro-at-point () (let ((regexp "\\(#.?\\)\\|\\([\"',`';()]\\)")) (when (looking-back regexp nil t) (match-string-no-properties 0)))) ;;; FORMAT character lookup by Frode Vatvedt Fjeld 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.") (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)) (defvar common-lisp-hyperspec--format-characters (make-hash-table :test 'equal)) (defun common-lisp-hyperspec--read-format-character () (let ((char-at-point (ignore-errors (char-to-string (char-after (point)))))) (if (and char-at-point (gethash (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)))) (defun common-lisp-hyperspec-format (character-name) (interactive (list (common-lisp-hyperspec--read-format-character))) (cl-maplist (lambda (entry) (browse-url (common-lisp-hyperspec-section (car entry)))) (or (gethash character-name common-lisp-hyperspec--format-characters) (error "The symbol `%s' is not defined in Common Lisp" character-name)))) ;;; Previously there were entries for "C" and "C: Character", ;;; which unpleasingly crowded the completion buffer, so I made ;;; it show one entry ("C - Character") only. ;;; ;;; 20100131 Tobias C Rittweiler (defun common-lisp-hyperspec--insert-format-directive (char section &optional summary) (let* ((designator (if summary (format "%s - %s" char summary) char))) (cl-pushnew section (gethash designator common-lisp-hyperspec--format-characters) :test #'equal))) (mapc (lambda (entry) (cl-destructuring-bind (char section &optional summary) entry (common-lisp-hyperspec--insert-format-directive char section summary) (when (and (= 1 (length char)) (not (string-equal char (upcase char)))) (common-lisp-hyperspec--insert-format-directive (upcase char) section summary)))) '(("c" (22 3 1 1) "Character") ("%" (22 3 1 2) "Newline") ("&" (22 3 1 3) "Fresh-line") ("|" (22 3 1 4) "Page") ("~" (22 3 1 5) "Tilde") ("r" (22 3 2 1) "Radix") ("d" (22 3 2 2) "Decimal") ("b" (22 3 2 3) "Binary") ("o" (22 3 2 4) "Octal") ("x" (22 3 2 5) "Hexadecimal") ("f" (22 3 3 1) "Fixed-Format Floating-Point") ("e" (22 3 3 2) "Exponential Floating-Point") ("g" (22 3 3 3) "General Floating-Point") ("$" (22 3 3 4) "Monetary Floating-Point") ("a" (22 3 4 1) "Aesthetic") ("s" (22 3 4 2) "Standard") ("w" (22 3 4 3) "Write") ("_" (22 3 5 1) "Conditional Newline") ("<" (22 3 5 2) "Logical Block") ("i" (22 3 5 3) "Indent") ("/" (22 3 5 4) "Call Function") ("t" (22 3 6 1) "Tabulate") ("<" (22 3 6 2) "Justification") (">" (22 3 6 3) "End of Justification") ("*" (22 3 7 1) "Go-To") ("[" (22 3 7 2) "Conditional Expression") ("]" (22 3 7 3) "End of Conditional Expression") ("{" (22 3 7 4) "Iteration") ("}" (22 3 7 5) "End of Iteration") ("?" (22 3 7 6) "Recursive Processing") ("(" (22 3 8 1) "Case Conversion") (")" (22 3 8 2) "End of Case Conversion") ("p" (22 3 8 3) "Plural") (";" (22 3 9 1) "Clause Separator") ("^" (22 3 9 2) "Escape Upward") ("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)))) ;;;; Glossary (defvar common-lisp-hyperspec-glossary-function 'common-lisp-glossary-6.0 "Function that creates a URL for a glossary term.") (define-obsolete-variable-alias 'common-lisp-glossary-fun 'common-lisp-hyperspec-glossary-function) (defvar common-lisp-hyperspec--glossary-terms (make-hash-table :test #'equal) "Collection of glossary terms and relative URLs.") ;;; Functions ;;; The functions below are used to collect glossary terms and page anchors ;;; from CLHS. They are commented out because they are not needed unless the ;;; list of terms/anchors need to be updated. ;; (defun common-lisp-hyperspec-glossary-pages () ;; "List of CLHS glossary pages." ;; (mapcar (lambda (end) ;; (format "%sBody/26_glo_%s.htm" ;; common-lisp-hyperspec-root ;; end)) ;; (cons "9" (mapcar #'char-to-string ;; (number-sequence ?a ?z))))) ;; (defun common-lisp-hyperspec-glossary-download () ;; "Download CLHS glossary pages to temporary files and return a ;; list of file names." ;; (mapcar (lambda (url) ;; (url-file-local-copy url)) ;; (common-lisp-hyperspec-glossary-pages))) ;; (defun common-lisp-hyperspec-glossary-entries (file) ;; "Given a CLHS glossary file FILE, return a list of ;; term-anchor pairs. ;; Term is the glossary term and anchor is the term's anchor on the ;; page." ;; (let (entries) ;; (save-excursion ;; (set-buffer (find-file-noselect file)) ;; (goto-char (point-min)) ;; (while (search-forward-regexp "\\(.*?\\)" nil t) ;; (setq entries (cons (list (match-string-no-properties 2) ;; (match-string-no-properties 1)) ;; entries)))) ;; (sort entries (lambda (a b) ;; (string< (car a) (car b)))))) ;; ;; Add glossary terms by downloading and parsing glossary pages from CLHS ;; (mapc (lambda (entry) ;; (puthash (car entry) (cadr entry) ;; common-lisp-hyperspec--glossary-terms)) ;; (cl-reduce (lambda (a b) ;; (append a b)) ;; (mapcar #'common-lisp-hyperspec-glossary-entries ;; (common-lisp-hyperspec-glossary-download)))) ;; Add glossary entries to the master hash table (mapc (lambda (entry) (puthash (car entry) (cadr entry) common-lisp-hyperspec--glossary-terms)) '(("()" "OPCP") ("absolute" "absolute") ("access" "access") ("accessibility" "accessibility") ("accessible" "accessible") ("accessor" "accessor") ("active" "active") ("actual adjustability" "actual_adjustability") ("actual argument" "actual_argument") ("actual array element type" "actual_array_element_type") ("actual complex part type" "actual_complex_part_type") ("actual parameter" "actual_parameter") ("actually adjustable" "actually_adjustable") ("adjustability" "adjustability") ("adjustable" "adjustable") ("after method" "after_method") ("alist" "alist") ("alphabetic" "alphabetic") ("alphanumeric" "alphanumeric") ("ampersand" "ampersand") ("anonymous" "anonymous") ("apparently uninterned" "apparently_uninterned") ("applicable" "applicable") ("applicable handler" "applicable_handler") ("applicable method" "applicable_method") ("applicable restart" "applicable_restart") ("apply" "apply") ("argument" "argument") ("argument evaluation order" "argument_evaluation_order") ("argument precedence order" "argument_precedence_order") ("around method" "around_method") ("array" "array") ("array element type" "array_element_type") ("array total size" "array_total_size") ("assign" "assign") ("association list" "association_list") ("asterisk" "asterisk") ("at-sign" "at-sign") ("atom" "atom") ("atomic" "atomic") ("atomic type specifier" "atomic_type_specifier") ("attribute" "attribute") ("aux variable" "aux_variable") ("auxiliary method" "auxiliary_method") ("backquote" "backquote") ("backslash" "backslash") ("base character" "base_character") ("base string" "base_string") ("before method" "before_method") ("bidirectional" "bidirectional") ("binary" "binary") ("bind" "bind") ("binding" "binding") ("bit" "bit") ("bit array" "bit_array") ("bit vector" "bit_vector") ("bit-wise logical operation specifier" "bit-wise_logical_operation_specifier") ("block" "block") ("block tag" "block_tag") ("boa lambda list" "boa_lambda_list") ("body parameter" "body_parameter") ("boolean" "boolean") ("boolean equivalent" "boolean_equivalent") ("bound" "bound") ("bound declaration" "bound_declaration") ("bounded" "bounded") ("bounding index" "bounding_index") ("bounding index designator" "bounding_index_designator") ("break loop" "break_loop") ("broadcast stream" "broadcast_stream") ("built-in class" "built-in_class") ("built-in type" "built-in_type") ("byte" "byte") ("byte specifier" "byte_specifier") ("cadr" "cadr") ("call" "call") ("captured initialization form" "captured_initialization_form") ("car" "car") ("case" "case") ("case sensitivity mode" "case_sensitivity_mode") ("catch" "catch") ("catch tag" "catch_tag") ("cddr" "cddr") ("cdr" "cdr") ("cell" "cell") ("character" "character") ("character code" "character_code") ("character designator" "character_designator") ("circular" "circular") ("circular list" "circular_list") ("class" "class") ("class designator" "class_designator") ("class precedence list" "class_precedence_list") ("close" "close") ("closed" "closed") ("closure" "closure") ("coalesce" "coalesce") ("code" "code") ("coerce" "coerce") ("colon" "colon") ("comma" "comma") ("compilation" "compilation") ("compilation environment" "compilation_environment") ("compilation unit" "compilation_unit") ("compile" "compile") ("compile time" "compile_time") ("compile-time definition" "compile-time_definition") ("compiled code" "compiled_code") ("compiled file" "compiled_file") ("compiled function" "compiled_function") ("compiler" "compiler") ("compiler macro" "compiler_macro") ("compiler macro expansion" "compiler_macro_expansion") ("compiler macro form" "compiler_macro_form") ("compiler macro function" "compiler_macro_function") ("complex" "complex") ("complex float" "complex_float") ("complex part type" "complex_part_type") ("complex rational" "complex_rational") ("complex single float" "complex_single_float") ("composite stream" "composite_stream") ("compound form" "compound_form") ("compound type specifier" "compound_type_specifier") ("concatenated stream" "concatenated_stream") ("condition" "condition") ("condition designator" "condition_designator") ("condition handler" "condition_handler") ("condition reporter" "condition_reporter") ("conditional newline" "conditional_newline") ("conformance" "conformance") ("conforming code" "conforming_code") ("conforming implementation" "conforming_implementation") ("conforming processor" "conforming_processor") ("conforming program" "conforming_program") ("congruent" "congruent") ("cons" "cons") ("constant" "constant") ("constant form" "constant_form") ("constant object" "constant_object") ("constant variable" "constant_variable") ("constituent" "constituent") ("constituent trait" "constituent_trait") ("constructed stream" "constructed_stream") ("contagion" "contagion") ("continuable" "continuable") ("control form" "control_form") ("copy" "copy") ("correctable" "correctable") ("current input base" "current_input_base") ("current logical block" "current_logical_block") ("current output base" "current_output_base") ("current package" "current_package") ("current pprint dispatch table" "current_pprint_dispatch_table") ("current random state" "current_random_state") ("current readtable" "current_readtable") ("data type" "data_type") ("debug I/O" "debug_iSLo") ("debugger" "debugger") ("declaration" "declaration") ("declaration identifier" "declaration_identifier") ("declaration specifier" "declaration_specifier") ("declare" "declare") ("decline" "decline") ("decoded time" "decoded_time") ("default method" "default_method") ("defaulted initialization argument list" "defaulted_initialization_argument_list") ("define-method-combination arguments lambda list" "define-method-combination_arguments_lambda_list") ("define-modify-macro lambda list" "define-modify-macro_lambda_list") ("defined name" "defined_name") ("defining form" "defining_form") ("defsetf lambda list" "defsetf_lambda_list") ("deftype lambda list" "deftype_lambda_list") ("denormalized" "denormalized") ("derived type" "derived_type") ("derived type specifier" "derived_type_specifier") ("designator" "designator") ("destructive" "destructive") ("destructuring lambda list" "destructuring_lambda_list") ("different" "different") ("digit" "digit") ("dimension" "dimension") ("direct instance" "direct_instance") ("direct subclass" "direct_subclass") ("direct superclass" "direct_superclass") ("disestablish" "disestablish") ("disjoint" "disjoint") ("dispatching macro character" "dispatching_macro_character") ("displaced array" "displaced_array") ("distinct" "distinct") ("documentation string" "documentation_string") ("dot" "dot") ("dotted list" "dotted_list") ("dotted pair" "dotted_pair") ("double float" "double_float") ("double-quote" "double-quote") ("dynamic binding" "dynamic_binding") ("dynamic environment" "dynamic_environment") ("dynamic extent" "dynamic_extent") ("dynamic scope" "dynamic_scope") ("dynamic variable" "dynamic_variable") ("echo stream" "echo_stream") ("effective method" "effective_method") ("element" "element") ("element type" "element_type") ("em" "em") ("empty list" "empty_list") ("empty type" "empty_type") ("end of file" "end_of_file") ("environment" "environment") ("environment object" "environment_object") ("environment parameter" "environment_parameter") ("error" "error") ("error output" "error_output") ("escape" "escape") ("establish" "establish") ("evaluate" "evaluate") ("evaluation" "evaluation") ("evaluation environment" "evaluation_environment") ("execute" "execute") ("execution time" "execution_time") ("exhaustive partition" "exhaustive_partition") ("exhaustive union" "exhaustive_union") ("exit point" "exit_point") ("explicit return" "explicit_return") ("explicit use" "explicit_use") ("exponent marker" "exponent_marker") ("export" "export") ("exported" "exported") ("expressed adjustability" "expressed_adjustability") ("expressed array element type" "expressed_array_element_type") ("expressed complex part type" "expressed_complex_part_type") ("expression" "expression") ("expressly adjustable" "expressly_adjustable") ("extended character" "extended_character") ("extended function designator" "extended_function_designator") ("extended lambda list" "extended_lambda_list") ("extension" "extension") ("extent" "extent") ("external file format" "external_file_format") ("external file format designator" "external_file_format_designator") ("external symbol" "external_symbol") ("externalizable object" "externalizable_object") ("false" "false") ("fbound" "fbound") ("feature" "feature") ("feature expression" "feature_expression") ("features list" "features_list") ("file" "file") ("file compiler" "file_compiler") ("file position" "file_position") ("file position designator" "file_position_designator") ("file stream" "file_stream") ("file system" "file_system") ("filename" "filename") ("fill pointer" "fill_pointer") ("finite" "finite") ("fixnum" "fixnum") ("float" "float") ("for-value" "for-value") ("form" "form") ("formal argument" "formal_argument") ("formal parameter" "formal_parameter") ("format" "format") ("format argument" "format_argument") ("format control" "format_control") ("format directive" "format_directive") ("format string" "format_string") ("free declaration" "free_declaration") ("fresh" "fresh") ("freshline" "freshline") ("funbound" "funbound") ("function" "function") ("function block name" "function_block_name") ("function cell" "function_cell") ("function designator" "function_designator") ("function form" "function_form") ("function name" "function_name") ("functional evaluation" "functional_evaluation") ("functional value" "functional_value") ("further compilation" "further_compilation") ("general" "general") ("generalized boolean" "generalized_boolean") ("generalized instance" "generalized_instance") ("generalized reference" "generalized_reference") ("generalized synonym stream" "generalized_synonym_stream") ("generic function" "generic_function") ("generic function lambda list" "generic_function_lambda_list") ("gensym" "gensym") ("global declaration" "global_declaration") ("global environment" "global_environment") ("global variable" "global_variable") ("glyph" "glyph") ("go" "go") ("go point" "go_point") ("go tag" "go_tag") ("graphic" "graphic") ("handle" "handle") ("handler" "handler") ("hash table" "hash_table") ("home package" "home_package") ("I/O customization variable" "iSLo_customization_variable") ("identical" "identical") ("identifier" "identifier") ("immutable" "immutable") ("implementation" "implementation") ("implementation limit" "implementation_limit") ("implementation-defined" "implementation-defined") ("implementation-dependent" "implementation-dependent") ("implementation-independent" "implementation-independent") ("implicit block" "implicit_block") ("implicit compilation" "implicit_compilation") ("implicit progn" "implicit_progn") ("implicit tagbody" "implicit_tagbody") ("import" "import") ("improper list" "improper_list") ("inaccessible" "inaccessible") ("indefinite extent" "indefinite_extent") ("indefinite scope" "indefinite_scope") ("indicator" "indicator") ("indirect instance" "indirect_instance") ("inherit" "inherit") ("initial pprint dispatch table" "initial_pprint_dispatch_table") ("initial readtable" "initial_readtable") ("initialization argument list" "initialization_argument_list") ("initialization form" "initialization_form") ("input" "input") ("instance" "instance") ("integer" "integer") ("interactive stream" "interactive_stream") ("intern" "intern") ("internal symbol" "internal_symbol") ("internal time" "internal_time") ("internal time unit" "internal_time_unit") ("interned" "interned") ("interpreted function" "interpreted_function") ("interpreted implementation" "interpreted_implementation") ("interval designator" "interval_designator") ("invalid" "invalid") ("iteration form" "iteration_form") ("iteration variable" "iteration_variable") ("key" "key") ("keyword" "keyword") ("keyword parameter" "keyword_parameter") ("keyword/value pair" "keywordSLvalue_pair") ("Lisp image" "lisp_image") ("Lisp printer" "lisp_printer") ("Lisp read-eval-print loop" "lisp_read-eval-print_loop") ("Lisp reader" "lisp_reader") ("lambda combination" "lambda_combination") ("lambda expression" "lambda_expression") ("lambda form" "lambda_form") ("lambda list" "lambda_list") ("lambda list keyword" "lambda_list_keyword") ("lambda variable" "lambda_variable") ("leaf" "leaf") ("leap seconds" "leap_seconds") ("left-parenthesis" "left-parenthesis") ("length" "length") ("lexical binding" "lexical_binding") ("lexical closure" "lexical_closure") ("lexical environment" "lexical_environment") ("lexical scope" "lexical_scope") ("lexical variable" "lexical_variable") ("list" "list") ("list designator" "list_designator") ("list structure" "list_structure") ("literal" "literal") ("load" "load") ("load time" "load_time") ("load time value" "load_time_value") ("loader" "loader") ("local declaration" "local_declaration") ("local precedence order" "local_precedence_order") ("local slot" "local_slot") ("logical block" "logical_block") ("logical host" "logical_host") ("logical host designator" "logical_host_designator") ("logical pathname" "logical_pathname") ("long float" "long_float") ("loop keyword" "loop_keyword") ("lowercase" "lowercase") ("Metaobject Protocol" "metaobject_protocol") ("macro" "macro") ("macro character" "macro_character") ("macro expansion" "macro_expansion") ("macro form" "macro_form") ("macro function" "macro_function") ("macro lambda list" "macro_lambda_list") ("macro name" "macro_name") ("macroexpand hook" "macroexpand_hook") ("mapping" "mapping") ("metaclass" "metaclass") ("method" "method") ("method combination" "method_combination") ("method-defining form" "method-defining_form") ("method-defining operator" "method-defining_operator") ("minimal compilation" "minimal_compilation") ("modified lambda list" "modified_lambda_list") ("most recent" "most_recent") ("multiple escape" "multiple_escape") ("multiple values" "multiple_values") ("name" "name") ("named constant" "named_constant") ("namespace" "namespace") ("namestring" "namestring") ("newline" "newline") ("next method" "next_method") ("nickname" "nickname") ("nil" "nil") ("non-atomic" "non-atomic") ("non-constant variable" "non-constant_variable") ("non-correctable" "non-correctable") ("non-empty" "non-empty") ("non-generic function" "non-generic_function") ("non-graphic" "non-graphic") ("non-list" "non-list") ("non-local exit" "non-local_exit") ("non-nil" "non-nil") ("non-null lexical environment" "non-null_lexical_environment") ("non-simple" "non-simple") ("non-terminating" "non-terminating") ("non-top-level form" "non-top-level_form") ("normal return" "normal_return") ("normalized" "normalized") ("null" "null") ("null lexical environment" "null_lexical_environment") ("number" "number") ("numeric" "numeric") ("object" "object") ("object-traversing" "object-traversing") ("open" "open") ("operator" "operator") ("optimize quality" "optimize_quality") ("optional parameter" "optional_parameter") ("ordinary function" "ordinary_function") ("ordinary lambda list" "ordinary_lambda_list") ("otherwise inaccessible part" "otherwise_inaccessible_part") ("output" "output") ("package" "package") ("package cell" "package_cell") ("package designator" "package_designator") ("package marker" "package_marker") ("package prefix" "package_prefix") ("package registry" "package_registry") ("pairwise" "pairwise") ("parallel" "parallel") ("parameter" "parameter") ("parameter specializer" "parameter_specializer") ("parameter specializer name" "parameter_specializer_name") ("pathname" "pathname") ("pathname designator" "pathname_designator") ("physical pathname" "physical_pathname") ("place" "place") ("plist" "plist") ("portable" "portable") ("potential copy" "potential_copy") ("potential number" "potential_number") ("pprint dispatch table" "pprint_dispatch_table") ("predicate" "predicate") ("present" "present") ("pretty print" "pretty_print") ("pretty printer" "pretty_printer") ("pretty printing stream" "pretty_printing_stream") ("primary method" "primary_method") ("primary value" "primary_value") ("principal" "principal") ("print name" "print_name") ("printer control variable" "printer_control_variable") ("printer escaping" "printer_escaping") ("printing" "printing") ("process" "process") ("processor" "processor") ("proclaim" "proclaim") ("proclamation" "proclamation") ("prog tag" "prog_tag") ("program" "program") ("programmer" "programmer") ("programmer code" "programmer_code") ("proper list" "proper_list") ("proper name" "proper_name") ("proper sequence" "proper_sequence") ("proper subtype" "proper_subtype") ("property" "property") ("property indicator" "property_indicator") ("property list" "property_list") ("property value" "property_value") ("purports to conform" "purports_to_conform") ("qualified method" "qualified_method") ("qualifier" "qualifier") ("query I/O" "query_iSLo") ("quoted object" "quoted_object") ("radix" "radix") ("random state" "random_state") ("rank" "rank") ("ratio" "ratio") ("ratio marker" "ratio_marker") ("rational" "rational") ("read" "read") ("readably" "readably") ("reader" "reader") ("reader macro" "reader_macro") ("reader macro function" "reader_macro_function") ("readtable" "readtable") ("readtable case" "readtable_case") ("readtable designator" "readtable_designator") ("recognizable subtype" "recognizable_subtype") ("reference" "reference") ("registered package" "registered_package") ("relative" "relative") ("repertoire" "repertoire") ("report" "report") ("report message" "report_message") ("required parameter" "required_parameter") ("rest list" "rest_list") ("rest parameter" "rest_parameter") ("restart" "restart") ("restart designator" "restart_designator") ("restart function" "restart_function") ("return" "return") ("return value" "return_value") ("right-parenthesis" "right-parenthesis") ("run time" "run_time") ("run-time compiler" "run-time_compiler") ("run-time definition" "run-time_definition") ("run-time environment" "run-time_environment") ("safe" "safe") ("safe call" "safe_call") ("same" "same") ("satisfy the test" "satisfy_the_test") ("scope" "scope") ("script" "script") ("secondary value" "secondary_value") ("section" "section") ("self-evaluating object" "self-evaluating_object") ("semi-standard" "semi-standard") ("semicolon" "semicolon") ("sequence" "sequence") ("sequence function" "sequence_function") ("sequential" "sequential") ("sequentially" "sequentially") ("serious condition" "serious_condition") ("session" "session") ("set" "set") ("setf expander" "setf_expander") ("setf expansion" "setf_expansion") ("setf function" "setf_function") ("setf function name" "setf_function_name") ("shadow" "shadow") ("shadowing symbol" "shadowing_symbol") ("shadowing symbols list" "shadowing_symbols_list") ("shared slot" "shared_slot") ("sharpsign" "sharpsign") ("short float" "short_float") ("sign" "sign") ("signal" "signal") ("signature" "signature") ("similar" "similar") ("similarity" "similarity") ("simple" "simple") ("simple array" "simple_array") ("simple bit array" "simple_bit_array") ("simple bit vector" "simple_bit_vector") ("simple condition" "simple_condition") ("simple general vector" "simple_general_vector") ("simple string" "simple_string") ("simple vector" "simple_vector") ("single escape" "single_escape") ("single float" "single_float") ("single-quote" "single-quote") ("singleton" "singleton") ("situation" "situation") ("slash" "slash") ("slot" "slot") ("slot specifier" "slot_specifier") ("source code" "source_code") ("source file" "source_file") ("space" "space") ("special form" "special_form") ("special operator" "special_operator") ("special variable" "special_variable") ("specialize" "specialize") ("specialized" "specialized") ("specialized lambda list" "specialized_lambda_list") ("spreadable argument list designator" "spreadable_argument_list_designator") ("stack allocate" "stack_allocate") ("stack-allocated" "stack-allocated") ("standard character" "standard_character") ("standard class" "standard_class") ("standard generic function" "standard_generic_function") ("standard input" "standard_input") ("standard method combination" "standard_method_combination") ("standard object" "standard_object") ("standard output" "standard_output") ("standard pprint dispatch table" "standard_pprint_dispatch_table") ("standard readtable" "standard_readtable") ("standard syntax" "standard_syntax") ("standardized" "standardized") ("startup environment" "startup_environment") ("step" "step") ("stream" "stream") ("stream associated with a file" "stream_associated_with_a_file") ("stream designator" "stream_designator") ("stream element type" "stream_element_type") ("stream variable" "stream_variable") ("stream variable designator" "stream_variable_designator") ("string" "string") ("string designator" "string_designator") ("string equal" "string_equal") ("string stream" "string_stream") ("structure" "structure") ("structure class" "structure_class") ("structure name" "structure_name") ("style warning" "style_warning") ("subclass" "subclass") ("subexpression" "subexpression") ("subform" "subform") ("subrepertoire" "subrepertoire") ("subtype" "subtype") ("superclass" "superclass") ("supertype" "supertype") ("supplied-p parameter" "supplied-p_parameter") ("symbol" "symbol") ("symbol macro" "symbol_macro") ("synonym stream" "synonym_stream") ("synonym stream symbol" "synonym_stream_symbol") ("syntax type" "syntax_type") ("system class" "system_class") ("system code" "system_code") ("t" "t") ("tag" "tag") ("tail" "tail") ("target" "target") ("terminal I/O" "terminal_iSLo") ("terminating" "terminating") ("tertiary value" "tertiary_value") ("throw" "throw") ("tilde" "tilde") ("time" "time") ("time zone" "time_zone") ("token" "token") ("top level form" "top_level_form") ("trace output" "trace_output") ("tree" "tree") ("tree structure" "tree_structure") ("true" "true") ("truename" "truename") ("two-way stream" "two-way_stream") ("type" "type") ("type declaration" "type_declaration") ("type equivalent" "type_equivalent") ("type expand" "type_expand") ("type specifier" "type_specifier") ("unbound" "unbound") ("unbound variable" "unbound_variable") ("undefined function" "undefined_function") ("unintern" "unintern") ("uninterned" "uninterned") ("universal time" "universal_time") ("unqualified method" "unqualified_method") ("unregistered package" "unregistered_package") ("unsafe" "unsafe") ("unsafe call" "unsafe_call") ("upgrade" "upgrade") ("upgraded array element type" "upgraded_array_element_type") ("upgraded complex part type" "upgraded_complex_part_type") ("uppercase" "uppercase") ("use" "use") ("use list" "use_list") ("user" "user") ("valid array dimension" "valid_array_dimension") ("valid array index" "valid_array_index") ("valid array row-major index" "valid_array_row-major_index") ("valid fill pointer" "valid_fill_pointer") ("valid logical pathname host" "valid_logical_pathname_host") ("valid pathname device" "valid_pathname_device") ("valid pathname directory" "valid_pathname_directory") ("valid pathname host" "valid_pathname_host") ("valid pathname name" "valid_pathname_name") ("valid pathname type" "valid_pathname_type") ("valid pathname version" "valid_pathname_version") ("valid physical pathname host" "valid_physical_pathname_host") ("valid sequence index" "valid_sequence_index") ("value" "value") ("value cell" "value_cell") ("variable" "variable") ("vector" "vector") ("vertical-bar" "vertical-bar") ("whitespace" "whitespace") ("wild" "wild") ("write" "write") ("writer" "writer") ("yield" "yield"))) (defun common-lisp-hyperspec-glossary-term (term) "View the definition of TERM on the Common Lisp Hyperspec." (interactive (list (completing-read "Look up glossary term: " common-lisp-hyperspec--glossary-terms nil t))) (browse-url (funcall common-lisp-hyperspec-glossary-function term))) (defun common-lisp-glossary-6.0 (term) "Get a URL for a glossary term TERM." (let ((anchor (gethash term common-lisp-hyperspec--glossary-terms))) (if (not anchor) (message "Unknown glossary term: %s" term) (format "%sBody/26_glo_%s.htm#%s" common-lisp-hyperspec-root (let ((char (string-to-char term))) (if (and (<= ?a char) (<= char ?z)) (make-string 1 char) "9")) anchor)))) ;; Tianxiang Xiong 20151229 ;; Is this function necessary? The link does created does not work. (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))) ;;;; Issuex ;; FIXME: the issuex stuff is not used (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-hash-table :test 'equal)) (mapc (lambda (entry) (puthash (car entry) (cadr entry) common-lisp-hyperspec--issuex-symbols)) (if common-lisp-hyperspec-issuex-table (common-lisp-hyperspec--parse-map-file common-lisp-hyperspec-issuex-table) '(("&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 ((entry (gethash (downcase issue-name) common-lisp-hyperspec--issuex-symbols))) (concat common-lisp-hyperspec-root "Issues/" entry))) ;;; Added the following just to provide a common entry point according ;;; to the various 'hyperspec' implementations. ;;; ;;; 19990820 Marco Antoniotti (defalias 'hyperspec-lookup 'common-lisp-hyperspec) (defalias 'hyperspec-lookup-reader-macro 'common-lisp-hyperspec-lookup-reader-macro) (defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format) (provide 'hyperspec) ;;; hyperspec.el ends here slime-2.20/lib/macrostep.el000066400000000000000000001303011315100173500156250ustar00rootroot00000000000000;;; macrostep.el --- interactive macro expander ;; Copyright (C) 2012-2015 Jon Oddie ;; Author: joddie ;; Maintainer: joddie ;; Created: 16 January 2012 ;; Updated: 07 December 2015 ;; Version: 0.9 ;; Keywords: lisp, languages, macro, debugging ;; Url: https://github.com/joddie/macrostep ;; Package-Requires: ((cl-lib "0.5")) ;; This file is NOT part of GNU Emacs. ;; 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 3 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, see `http://www.gnu.org/licenses/'. ;;; Commentary: ;; `macrostep' is an Emacs minor mode for interactively stepping through ;; the expansion of macros in Emacs Lisp source code. It lets you see ;; exactly what happens at each step of the expansion process by ;; pretty-printing the expanded forms inline in the source buffer, which is ;; temporarily read-only while macro expansions are visible. You can ;; expand and collapse macro forms one step at a time, and evaluate or ;; instrument the expansions for debugging with Edebug as normal (but see ;; "Bugs and known limitations", below). Single-stepping through the ;; expansion is particularly useful for debugging macros that expand into ;; another macro form. These can be difficult to debug with Emacs' ;; built-in `macroexpand', which continues expansion until the top-level ;; form is no longer a macro call. ;; Both globally-visible macros as defined by `defmacro' and local macros ;; bound by `(cl-)macrolet' or another macro-defining form can be expanded. ;; Within macro expansions, calls to macros and compiler macros are ;; fontified specially: macro forms using `macrostep-macro-face', and ;; functions with compiler macros using `macrostep-compiler-macro-face'. ;; Uninterned symbols (gensyms) are fontified based on which step in the ;; expansion created them, to distinguish them both from normal symbols and ;; from other gensyms with the same print name. ;; As of version 0.9, it is also possible to extend `macrostep' to work ;; with other languages with macro systems in addition to Emacs Lisp. An ;; extension for Common Lisp (via SLIME) is in the works; contributions for ;; other languages are welcome. See "Extending macrostep" below for ;; details. ;; 1 Key-bindings and usage ;; ======================== ;; The standard keybindings in `macrostep-mode' are the following: ;; e, =, RET : expand the macro form following point one step ;; c, u, DEL : collapse the form following point ;; q, C-c C-c: collapse all expanded forms and exit macrostep-mode ;; n, TAB : jump to the next macro form in the expansion ;; p, M-TAB : jump to the previous macro form in the expansion ;; It's not very useful to enable and disable macrostep-mode directly. ;; Instead, bind `macrostep-expand' to a key in `emacs-lisp-mode-map', ;; for example C-c e: ;; ,---- ;; | (define-key emacs-lisp-mode-map (kbd "C-c e") 'macrostep-expand) ;; `---- ;; You can then enter macrostep-mode and expand a macro form completely ;; by typing `C-c e e e ...' as many times as necessary. ;; Exit macrostep-mode by typing `q' or `C-c C-c', or by successively ;; typing `c' to collapse all surrounding expansions. ;; 2 Customization options ;; ======================= ;; Type `M-x customize-group RET macrostep RET' to customize options and ;; faces. ;; To display macro expansions in a separate window, instead of inline in ;; the source buffer, customize `macrostep-expand-in-separate-buffer' to ;; `t'. The default is `nil'. Whichever default behavior is selected, ;; the alternative behavior can be obtained temporarily by giving a ;; prefix argument to `macrostep-expand'. ;; To have `macrostep' ignore compiler macros, customize ;; `macrostep-expand-compiler-macros' to `nil'. The default is `t'. ;; Customize the faces `macrostep-macro-face', ;; `macrostep-compiler-macro-face', and `macrostep-gensym-1' through ;; `macrostep-gensym-5' to alter the appearance of macro expansions. ;; 3 Locally-bound macros ;; ====================== ;; As of version 0.9, `macrostep' can expand calls to a locally-bound ;; macro, whether defined by a surrounding `(cl-)macrolet' form, or by ;; another macro-defining macro. In other words, it is possible to ;; expand the inner `local-macro' forms in both the following examples, ;; whether `local-macro' is defined by an enclosing `cl-macrolet' -- ;; ,---- ;; | (cl-macrolet ((local-macro (&rest args) ;; | `(expansion of ,args))) ;; | (local-macro (do-something))) ;; `---- ;; -- or by a macro which expands into `cl-macrolet', provided that its ;; definition of macro is evaluated prior to calling `macrostep-expand': ;; ,---- ;; | (defmacro with-local-macro (&rest body) ;; | `(cl-macrolet ((local-macro (&rest args) ;; | `(expansion of ,args))) ;; | ,@body)) ;; | ;; | (with-local-macro ;; | (local-macro (do something (else))) ;; `---- ;; See the `with-js' macro in Emacs's `js.el' for a real example of the ;; latter kind of macro. ;; Expansion of locally-bound macros is implemented by instrumenting ;; Emacs Lisp's macro-expander to capture the environment at point. A ;; similar trick is used to detect macro- and compiler-macro calls within ;; expanded text so that they can be fontified accurately. ;; 4 Expanding sub-forms ;; ===================== ;; By moving point around in the macro expansion using ;; `macrostep-next-macro' and `macrostep-prev-macro' (bound to the `n' ;; and `p' keys), it is possible to expand other macro calls within the ;; expansion before expanding the outermost form. This can sometimes be ;; useful, although it does not correspond to the real order of macro ;; expansion in Emacs Lisp, which proceeds by fully expanding the outer ;; form to a non-macro form before expanding sub-forms. ;; The main reason to expand sub-forms out of order is to help with ;; debugging macros which programmatically expand their arguments in ;; order to rewrite them. Expanding the arguments of such a macro lets ;; you visualise what the macro definition would compute via ;; `macroexpand-all'. ;; 5 Extending macrostep for other languages ;; ========================================= ;; Since version 0.9, it is possible to extend macrostep to work with ;; other languages besides Emacs Lisp. In typical Emacs fashion, this is ;; implemented by setting buffer-local variables to different function ;; values. Six buffer-local variables define the language-specific part ;; of the implementation: ;; - `macrostep-sexp-bounds-function' ;; - `macrostep-sexp-at-point-function' ;; - `macrostep-environment-at-point-function' ;; - `macrostep-expand-1-function' ;; - `macrostep-print-function' ;; - `macrostep-macro-form-p-function' ;; Typically, an implementation for another language would set these ;; variables in a major-mode hook. See the docstrings of each variable ;; for details on how each one is called and what it should return. At a ;; minimum, another language implementation needs to provide ;; `macrostep-sexp-at-point-function', `macrostep-expand-1-function', and ;; `macrostep-print-function'. Lisp-like languages may be able to reuse ;; the default `macrostep-sexp-bounds-function' if they provide another ;; implementation of `macrostep-macro-form-p-function'. Languages which ;; do not implement locally-defined macros can set ;; `macrostep-environment-at-point-function' to `ignore'. ;; Note that the core `macrostep' machinery only interprets the return ;; value of `macrostep-sexp-bounds-function', so implementations for ;; other languages can use any internal representations of code and ;; environments which is convenient. Although the terminology is ;; Lisp-specific, there is no reason that implementations could not be ;; provided for non-Lisp languages with macro systems, provided there is ;; some way of identifying macro calls and calling the compiler / ;; preprocessor to obtain their expansions. ;; 6 Bugs and known limitations ;; ============================ ;; You can evaluate and edebug macro-expanded forms and step through the ;; macro-expanded version, but the form that `eval-defun' and friends ;; read from the buffer won't have the uninterned symbols of the real ;; macro expansion. This will probably work OK with CL-style gensyms, ;; but may cause problems with `make-symbol' symbols if they have the ;; same print name as another symbol in the expansion. It's possible that ;; using `print-circle' and `print-gensym' could get around this. ;; Please send other bug reports and feature requests to the author. ;; 7 Acknowledgements ;; ================== ;; Thanks to: ;; - John Wiegley for fixing a bug with the face definitions under Emacs ;; 24 & for plugging macrostep in his [EmacsConf presentation]! ;; - George Kettleborough for bug reports, and patches to highlight the ;; expanded region and properly handle backquotes. ;; - Nic Ferrier for suggesting support for local definitions within ;; macrolet forms ;; - Luís Oliveira for suggesting and implementing SLIME support ;; `macrostep' was originally inspired by J. V. Toups's 'Deep Emacs Lisp' ;; articles ([part 1], [part 2], [screencast]). ;; [EmacsConf presentation] http://youtu.be/RvPFZL6NJNQ ;; [part 1] ;; http://dorophone.blogspot.co.uk/2011/04/deep-emacs-part-1.html ;; [part 2] ;; http://dorophone.blogspot.co.uk/2011/04/deep-emacs-lisp-part-2.html ;; [screencast] ;; http://dorophone.blogspot.co.uk/2011/05/monadic-parser-combinators-in-elisp.html ;; 8 Changelog ;; =========== ;; - v0.9, 2015-10-01: ;; - separate into Elisp-specific and generic components ;; - highlight and expand compiler macros ;; - improve local macro expansion and macro form identification by ;; instrumenting `macroexpand(-all)' ;; - v0.8, 2014-05-29: fix a bug with printing the first element of lists ;; - v0.7, 2014-05-11: expand locally-defined macros within ;; `(cl-)macrolet' forms ;; - v0.6, 2013-05-04: better handling of quote and backquote ;; - v0.5, 2013-04-16: highlight region, maintain cleaner buffer state ;; - v0.4, 2013-04-07: only enter macrostep-mode on successful ;; macro-expansion ;; - v0.3, 2012-10-30: print dotted lists correctly. autoload ;; definitions. ;;; Code: (require 'pp) (require 'ring) (eval-and-compile (require 'cl-lib nil t) (require 'cl-lib "lib/cl-lib")) ;;; Constants and dynamically bound variables (defvar macrostep-overlays nil "List of all macro stepper overlays in the current buffer.") (make-variable-buffer-local 'macrostep-overlays) (defvar macrostep-gensym-depth nil "Number of macro expansion levels that have introduced gensyms so far.") (make-variable-buffer-local 'macrostep-gensym-depth) (defvar macrostep-gensyms-this-level nil "t if gensyms have been encountered during current level of macro expansion.") (make-variable-buffer-local 'macrostep-gensyms-this-level) (defvar macrostep-saved-undo-list nil "Saved value of buffer-undo-list upon entering macrostep mode.") (make-variable-buffer-local 'macrostep-saved-undo-list) (defvar macrostep-saved-read-only nil "Saved value of buffer-read-only upon entering macrostep mode.") (make-variable-buffer-local 'macrostep-saved-read-only) (defvar macrostep-expansion-buffer nil "Non-nil if the current buffer is a macro-expansion buffer.") (make-variable-buffer-local 'macrostep-expansion-buffer) (defvar macrostep-outer-environment nil "Outermost macro-expansion environment to use in a dedicated macro-expansion buffers. This variable is used to save information about any enclosing `cl-macrolet' context when a macro form is expanded in a separate buffer.") (make-variable-buffer-local 'macrostep-outer-environment) ;;; Customization options and faces (defgroup macrostep nil "Interactive macro stepper for Emacs Lisp." :group 'lisp :link '(emacs-commentary-link :tag "commentary" "macrostep.el") :link '(emacs-library-link :tag "lisp file" "macrostep.el") :link '(url-link :tag "web page" "https://github.com/joddie/macrostep")) (defface macrostep-gensym-1 '((((min-colors 16581375)) :foreground "#8080c0" :box t :bold t) (((min-colors 8)) :background "cyan") (t :inverse-video t)) "Face for gensyms created in the first level of macro expansion." :group 'macrostep) (defface macrostep-gensym-2 '((((min-colors 16581375)) :foreground "#8fbc8f" :box t :bold t) (((min-colors 8)) :background "#00cd00") (t :inverse-video t)) "Face for gensyms created in the second level of macro expansion." :group 'macrostep) (defface macrostep-gensym-3 '((((min-colors 16581375)) :foreground "#daa520" :box t :bold t) (((min-colors 8)) :background "yellow") (t :inverse-video t)) "Face for gensyms created in the third level of macro expansion." :group 'macrostep) (defface macrostep-gensym-4 '((((min-colors 16581375)) :foreground "#cd5c5c" :box t :bold t) (((min-colors 8)) :background "red") (t :inverse-video t)) "Face for gensyms created in the fourth level of macro expansion." :group 'macrostep) (defface macrostep-gensym-5 '((((min-colors 16581375)) :foreground "#da70d6" :box t :bold t) (((min-colors 8)) :background "magenta") (t :inverse-video t)) "Face for gensyms created in the fifth level of macro expansion." :group 'macrostep) (defface macrostep-expansion-highlight-face '((((min-colors 16581375) (background light)) :background "#eee8d5") (((min-colors 16581375) (background dark)) :background "#222222")) "Face for macro-expansion highlight." :group 'macrostep) (defface macrostep-macro-face '((t :underline t)) "Face for macros in macro-expanded code." :group 'macrostep) (defface macrostep-compiler-macro-face '((t :slant italic)) "Face for compiler macros in macro-expanded code." :group 'macrostep) (defcustom macrostep-expand-in-separate-buffer nil "When non-nil, show expansions in a separate buffer instead of inline." :group 'macrostep :type 'boolean) (defcustom macrostep-expand-compiler-macros t "When non-nil, expand compiler macros as well as `defmacro' and `macrolet' macros." :group 'macrostep :type 'boolean) ;; Need the following for making the ring of faces (defun macrostep-make-ring (&rest items) "Make a ring containing all of ITEMS with no empty slots." (let ((ring (make-ring (length items)))) (mapc (lambda (item) (ring-insert ring item)) (reverse items)) ring)) (defvar macrostep-gensym-faces (macrostep-make-ring 'macrostep-gensym-1 'macrostep-gensym-2 'macrostep-gensym-3 'macrostep-gensym-4 'macrostep-gensym-5) "Ring of all macrostepper faces for fontifying gensyms.") ;; Other modes can enable macrostep by redefining these functions to ;; language-specific versions. (defvar macrostep-sexp-bounds-function #'macrostep-sexp-bounds "Function to return the bounds of the macro form nearest point. It will be called with no arguments and should return a cons of buffer positions, (START . END). It should use `save-excursion' to avoid changing the position of point. The default value, `macrostep-sexp-bounds', implements this for Emacs Lisp, and may be suitable for other Lisp-like languages.") (make-variable-buffer-local 'macrostep-sexp-bounds-function) (defvar macrostep-sexp-at-point-function #'macrostep-sexp-at-point "Function to return the macro form at point for expansion. It will be called with two arguments, the values of START and END returned by `macrostep-sexp-bounds-function', and with point positioned at START. It should return a value suitable for passing as the first argument to `macrostep-expand-1-function'. The default value, `macrostep-sexp-at-point', implements this for Emacs Lisp, and may be suitable for other Lisp-like languages.") (make-variable-buffer-local 'macrostep-sexp-at-point-function) (defvar macrostep-environment-at-point-function #'macrostep-environment-at-point "Function to return the local macro-expansion environment at point. It will be called with no arguments, and should return a value suitable for passing as the second argument to `macrostep-expand-1-function'. The default value, `macrostep-environment-at-point', is specific to Emacs Lisp. For languages which do not implement local macro-expansion environments, this should be set to `ignore' or `(lambda () nil)'.") (make-variable-buffer-local 'macrostep-environment-at-point-function) (defvar macrostep-expand-1-function #'macrostep-expand-1 "Function to perform one step of macro-expansion. It will be called with two arguments, FORM and ENVIRONMENT, the return values of `macrostep-sexp-at-point-function' and `macrostep-environment-at-point-function' respectively. It should return the result of expanding FORM by one step as a value which is suitable for passing as the argument to `macrostep-print-function'. The default value, `macrostep-expand-1', is specific to Emacs Lisp.") (make-variable-buffer-local 'macrostep-expand-1-function) (defvar macrostep-print-function #'macrostep-pp "Function to pretty-print macro expansions. It will be called with two arguments, FORM and ENVIRONMENT, the return values of `macrostep-sexp-at-point-function' and `macrostep-environment-at-point-function' respectively. It should insert a pretty-printed representation at point in the current buffer, leaving point just after the inserted representation, without altering any other text in the current buffer. The default value, `macrostep-pp', is specific to Emacs Lisp.") (make-variable-buffer-local 'macrostep-print-function) (defvar macrostep-macro-form-p-function #'macrostep-macro-form-p "Function to check whether a form is a macro call. It will be called with two arguments, FORM and ENVIRONMENT -- the return values of `macrostep-sexp-at-point-function' and `macrostep-environment-at-point-function' respectively -- and should return non-nil if FORM would undergo macro-expansion in ENVIRONMENT. This is called only from `macrostep-sexp-bounds', so it need not be provided if a different value is used for `macrostep-sexp-bounds-function'. The default value, `macrostep-macro-form-p', is specific to Emacs Lisp.") (make-variable-buffer-local 'macrostep-macro-form-p-function) ;;; Define keymap and minor mode (defvar macrostep-keymap (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") 'macrostep-expand) (define-key map "=" 'macrostep-expand) (define-key map "e" 'macrostep-expand) (define-key map (kbd "DEL") 'macrostep-collapse) (define-key map "u" 'macrostep-collapse) (define-key map "c" 'macrostep-collapse) (define-key map (kbd "TAB") 'macrostep-next-macro) (define-key map "n" 'macrostep-next-macro) (define-key map (kbd "M-TAB") 'macrostep-prev-macro) (define-key map "p" 'macrostep-prev-macro) (define-key map "q" 'macrostep-collapse-all) (define-key map (kbd "C-c C-c") 'macrostep-collapse-all) map) "Keymap for `macrostep-mode'.") ;;;###autoload (define-minor-mode macrostep-mode "Minor mode for inline expansion of macros in Emacs Lisp source buffers. \\Progressively expand macro forms with \\[macrostep-expand], collapse them with \\[macrostep-collapse], and move back and forth with \\[macrostep-next-macro] and \\[macrostep-prev-macro]. Use \\[macrostep-collapse-all] or collapse all visible expansions to quit and return to normal editing. \\{macrostep-keymap}" nil " Macro-Stepper" :keymap macrostep-keymap :group macrostep (if macrostep-mode (progn ;; Disable recording of undo information (setq macrostep-saved-undo-list buffer-undo-list buffer-undo-list t) ;; Remember whether buffer was read-only (setq macrostep-saved-read-only buffer-read-only buffer-read-only t) ;; Set up post-command hook to bail out on leaving read-only (add-hook 'post-command-hook 'macrostep-command-hook nil t) (message (substitute-command-keys "\\Entering macro stepper mode. Use \\[macrostep-expand] to expand, \\[macrostep-collapse] to collapse, \\[macrostep-collapse-all] to exit."))) ;; Exiting mode (if macrostep-expansion-buffer ;; Kill dedicated expansion buffers (quit-window t) ;; Collapse any remaining overlays (when macrostep-overlays (macrostep-collapse-all)) ;; Restore undo info & read-only state (setq buffer-undo-list macrostep-saved-undo-list buffer-read-only macrostep-saved-read-only macrostep-saved-undo-list nil) ;; Remove our post-command hook (remove-hook 'post-command-hook 'macrostep-command-hook t)))) ;; Post-command hook: bail out of macrostep-mode if the user types C-x ;; C-q to make the buffer writable again. (defun macrostep-command-hook () (if (not buffer-read-only) (macrostep-mode 0))) ;;; Interactive functions ;;;###autoload (defun macrostep-expand (&optional toggle-separate-buffer) "Expand the macro form following point by one step. Enters `macrostep-mode' if it is not already active, making the buffer temporarily read-only. If macrostep-mode is active and the form following point is not a macro form, search forward in the buffer and expand the next macro form found, if any. With a prefix argument, the expansion is displayed in a separate buffer instead of inline in the current buffer. Setting `macrostep-expand-in-separate-buffer' to non-nil swaps these two behaviors." (interactive "P") (cl-destructuring-bind (start . end) (funcall macrostep-sexp-bounds-function) (goto-char start) (let* ((sexp (funcall macrostep-sexp-at-point-function start end)) (end (copy-marker end)) (text (buffer-substring start end)) (env (funcall macrostep-environment-at-point-function)) (expansion (funcall macrostep-expand-1-function sexp env))) ;; Create a dedicated macro-expansion buffer and copy the text to ;; be expanded into it, if required (let ((separate-buffer-p (if toggle-separate-buffer (not macrostep-expand-in-separate-buffer) macrostep-expand-in-separate-buffer))) (when (and separate-buffer-p (not macrostep-expansion-buffer)) (let ((mode major-mode) (buffer (get-buffer-create (generate-new-buffer-name "*macro expansion*")))) (set-buffer buffer) (funcall mode) (setq macrostep-expansion-buffer t) (setq macrostep-outer-environment env) (save-excursion (setq start (point)) (insert text) (setq end (point-marker))) (pop-to-buffer buffer)))) (unless macrostep-mode (macrostep-mode t)) (let ((existing-overlay (macrostep-overlay-at-point)) (macrostep-gensym-depth macrostep-gensym-depth) (macrostep-gensyms-this-level nil) priority) (if existing-overlay (progn ; Expanding part of a previous macro-expansion (setq priority (1+ (overlay-get existing-overlay 'priority))) (setq macrostep-gensym-depth (overlay-get existing-overlay 'macrostep-gensym-depth))) ;; Expanding source buffer text (setq priority 1) (setq macrostep-gensym-depth -1)) (with-silent-modifications (atomic-change-group (let ((inhibit-read-only t)) (save-excursion ;; Insert expansion (funcall macrostep-print-function expansion env) ;; Delete the original form (macrostep-collapse-overlays-in (point) end) (delete-region (point) end) ;; Create a new overlay (let ((overlay (make-overlay start (if (looking-at "\n") (1+ (point)) (point))))) (unless macrostep-expansion-buffer ;; Highlight the overlay in original source buffers only (overlay-put overlay 'face 'macrostep-expansion-highlight-face)) (overlay-put overlay 'priority priority) (overlay-put overlay 'macrostep-original-text text) (overlay-put overlay 'macrostep-gensym-depth macrostep-gensym-depth) (push overlay macrostep-overlays)))))))))) (defun macrostep-collapse () "Collapse the innermost macro expansion near point to its source text. If no more macro expansions are visible after this, exit `macrostep-mode'." (interactive) (let ((overlay (macrostep-overlay-at-point))) (when (not overlay) (error "No macro expansion at point")) (let ((inhibit-read-only t)) (with-silent-modifications (atomic-change-group (macrostep-collapse-overlay overlay))))) (if (not macrostep-overlays) (macrostep-mode 0))) (defun macrostep-collapse-all () "Collapse all visible macro expansions and exit `macrostep-mode'." (interactive) (let ((inhibit-read-only t)) (with-silent-modifications (dolist (overlay macrostep-overlays) (let ((outermost (= (overlay-get overlay 'priority) 1))) ;; We only need restore the original text for the outermost ;; overlays (macrostep-collapse-overlay overlay (not outermost)))))) (setq macrostep-overlays nil) (macrostep-mode 0)) (defun macrostep-next-macro () "Move point forward to the next macro form in macro-expanded text." (interactive) (let* ((start (if (get-text-property (point) 'macrostep-macro-start) (1+ (point)) (point))) (next (next-single-property-change start 'macrostep-macro-start))) (if next (goto-char next) (error "No more macro forms found")))) (defun macrostep-prev-macro () "Move point back to the previous macro form in macro-expanded text." (interactive) (let (prev) (save-excursion (while (progn (setq prev (previous-single-property-change (point) 'macrostep-macro-start)) (if (or (not prev) (get-text-property (1- prev) 'macrostep-macro-start)) nil (prog1 t (goto-char prev)))))) (if prev (goto-char (1- prev)) (error "No previous macro form found")))) ;;; Utility functions (not language-specific) (defun macrostep-overlay-at-point () "Return the innermost macro stepper overlay at point." (let ((result (get-char-property-and-overlay (point) 'macrostep-original-text))) (cdr result))) (defun macrostep-collapse-overlay (overlay &optional no-restore-p) "Collapse a macro-expansion overlay and restore the unexpanded source text. As a minor optimization, does not restore the original source text if NO-RESTORE-P is non-nil. This is safe to do when collapsing all the sub-expansions of an outer overlay, since the outer overlay will restore the original source itself. Also removes the overlay from `macrostep-overlays'." (with-current-buffer (overlay-buffer overlay) ;; If we're cleaning up we don't need to bother restoring text ;; or checking for inner overlays to delete (unless no-restore-p (let* ((start (overlay-start overlay)) (end (overlay-end overlay)) (text (overlay-get overlay 'macrostep-original-text)) (sexp-end (copy-marker (if (equal (char-before end) ?\n) (1- end) end)))) (macrostep-collapse-overlays-in start end) (goto-char (overlay-start overlay)) (save-excursion (insert text) (delete-region (point) sexp-end)))) ;; Remove overlay from the list and delete it (setq macrostep-overlays (delq overlay macrostep-overlays)) (delete-overlay overlay))) (defun macrostep-collapse-overlays-in (start end) "Collapse all macrostepper overlays that are strictly between START and END. Will not collapse overlays that begin at START and end at END." (dolist (ol (overlays-in start end)) (if (and (> (overlay-start ol) start) (< (overlay-end ol) end) (overlay-get ol 'macrostep-original-text)) (macrostep-collapse-overlay ol t)))) ;;; Emacs Lisp implementation (defun macrostep-sexp-bounds () "Find the bounds of the macro form nearest point. If point is not before an open-paren, moves up to the nearest enclosing list. If the form at point is not a macro call, attempts to move forward to the next macro form as determined by `macrostep-macro-form-p-function'. Returns a cons of buffer positions, (START . END)." (save-excursion (if (not (looking-at "[(`]")) (backward-up-list 1)) (if (equal (char-before) ?`) (backward-char)) (let ((sexp (funcall macrostep-sexp-at-point-function)) (env (funcall macrostep-environment-at-point-function))) ;; If this isn't a macro form, try to find the next one in the buffer (unless (funcall macrostep-macro-form-p-function sexp env) (condition-case nil (macrostep-next-macro) (error (if (consp sexp) (error "(%s ...) is not a macro form" (car sexp)) (error "Text at point is not a macro form.")))))) (cons (point) (scan-sexps (point) 1)))) (defun macrostep-sexp-at-point (&rest ignore) "Return the sexp near point for purposes of macro-stepper expansion. If the sexp near point is part of a macro expansion, returns the saved text of the macro expansion, and does not read from the buffer. This preserves uninterned symbols in the macro expansion, so that they can be fontified consistently. (See `macrostep-print-sexp'.)" (or (get-text-property (point) 'macrostep-expanded-text) (sexp-at-point))) (defun macrostep-macro-form-p (form environment) "Return non-nil if FORM would be evaluated via macro expansion. If FORM is an invocation of a macro defined by `defmacro' or an enclosing `cl-macrolet' form, return the symbol `macro'. If `macrostep-expand-compiler-macros' is non-nil and FORM is a call to a function with a compiler macro, return the symbol `compiler-macro'. Otherwise, return nil." (car (macrostep--macro-form-info form environment t))) (defun macrostep--macro-form-info (form environment &optional inhibit-autoload) "Return information about macro definitions that apply to FORM. If no macros are involved in the evaluation of FORM within ENVIRONMENT, returns nil. Otherwise, returns a cons (TYPE . DEFINITION). If FORM would be evaluated by a macro defined by `defmacro', `cl-macrolet', etc., TYPE is the symbol `macro' and DEFINITION is the macro definition, as a function. If `macrostep-expand-compiler-macros' is non-nil and FORM would be compiled using a compiler macro, TYPE is the symbol `compmiler-macro' and DEFINITION is the function that implements the compiler macro. If FORM is an invocation of an autoloaded macro, the behavior depends on the value of INHIBIT-AUTOLOAD. If INHIBIT-AUTOLOAD is nil, the file containing the macro definition will be loaded using `load-library' and the macro definition returned as normal. If INHIBIT-AUTOLOAD is non-nil, no files will be loaded, and the value of DEFINITION in the result will be nil." (if (not (and (consp form) (symbolp (car form)))) `(nil . nil) (let* ((head (car form)) (local-definition (assoc-default head environment #'eq))) (if local-definition `(macro . ,local-definition) (let ((compiler-macro-definition (and macrostep-expand-compiler-macros (or (get head 'compiler-macro) (get head 'cl-compiler-macro))))) (if (and compiler-macro-definition (not (eq form (apply compiler-macro-definition form (cdr form))))) `(compiler-macro . ,compiler-macro-definition) (condition-case nil (let ((fun (indirect-function head))) (cl-case (car-safe fun) ((macro) `(macro . ,(cdr fun))) ((autoload) (when (eq (nth 4 fun) 'macro) (if inhibit-autoload `(macro . nil) (load-library (nth 1 fun)) (macrostep--macro-form-info form nil)))) (t `(nil . nil)))) (void-function nil)))))))) (defun macrostep-expand-1 (form environment) "Return result of macro-expanding the top level of FORM by exactly one step. Unlike `macroexpand', this function does not continue macro expansion until a non-macro-call results." (cl-destructuring-bind (type . definition) (macrostep--macro-form-info form environment) (cl-ecase type ((nil) form) ((macro) (apply definition (cdr form))) ((compiler-macro) (let ((expansion (apply definition form (cdr form)))) (if (equal form expansion) (error "Form left unchanged by compiler macro") expansion)))))) (put 'macrostep-grab-environment-failed 'error-conditions '(macrostep-grab-environment-failed error)) (defun macrostep-environment-at-point () "Return the local macro-expansion environment at point, if any. The local environment includes macros declared by any `macrolet' or `cl-macrolet' forms surrounding point, as well as by any macro forms which expand into a `macrolet'. The return value is an alist of elements (NAME . FUNCTION), where NAME is the symbol locally bound to the macro and FUNCTION is the lambda expression that returns its expansion." ;; If point is on a macro form within an expansion inserted by ;; `macrostep-print-sexp', a local environment may have been ;; previously saved as a text property. (let ((saved-environment (get-text-property (point) 'macrostep-environment))) (if saved-environment saved-environment ;; Otherwise, we (ab)use the macro-expander to return the ;; environment at point. If point is not at an evaluated ;; position in the containing form, ;; `macrostep-environment-at-point-1' will raise an error, and ;; we back up progressively through the containing forms until ;; it succeeds. (save-excursion (catch 'done (while t (condition-case nil (throw 'done (macrostep-environment-at-point-1)) (macrostep-grab-environment-failed (condition-case nil (backward-sexp) (scan-error (backward-up-list))))))))))) (defun macrostep-environment-at-point-1 () "Attempt to extract the macro environment that would be active at point. If point is not at an evaluated position within the containing form, raise an error." ;; Macro environments are extracted using Emacs Lisp's builtin ;; macro-expansion machinery. The form containing point is copied ;; to a temporary buffer, and a call to ;; `--macrostep-grab-environment--' is inserted at point. This ;; altered form is then fully macro-expanded, in an environment ;; where `--macrostep-grab-environment--' is defined as a macro ;; which throws the environment to a uniquely-generated tag. (let* ((point-at-top-level (save-excursion (while (ignore-errors (backward-up-list) t)) (point))) (enclosing-form (buffer-substring point-at-top-level (scan-sexps point-at-top-level 1))) (position (- (point) point-at-top-level)) (tag (make-symbol "macrostep-grab-environment-tag")) (grab-environment '--macrostep-grab-environment--)) (if (= position 0) nil (with-temp-buffer (emacs-lisp-mode) (insert enclosing-form) (goto-char (+ (point-min) position)) (prin1 `(,grab-environment) (current-buffer)) (let ((form (read (copy-marker (point-min))))) (catch tag (cl-letf (((symbol-function #'message) (symbol-function #'format))) (with-no-warnings (ignore-errors (macroexpand-all `(cl-macrolet ((,grab-environment (&environment env) (throw ',tag env))) ,form))))) (signal 'macrostep-grab-environment-failed nil))))))) (defun macrostep-collect-macro-forms (form &optional environment) "Identify sub-forms of FORM which undergo macro-expansion. FORM is an Emacs Lisp form. ENVIRONMENT is a local environment of macro definitions. The return value is a list of two elements, (MACRO-FORM-ALIST COMPILER-MACRO-FORMS). MACRO-FORM-ALIST is an alist of elements of the form (SUBFORM . ENVIRONMENT), where SUBFORM is a form which undergoes macro-expansion in the course of expanding FORM, and ENVIRONMENT is the local macro environment in force when it is expanded. COMPILER-MACRO-FORMS is a list of subforms which would be compiled using a compiler macro. Since there is no standard way to provide a local compiler-macro definition in Emacs Lisp, no corresponding local environments are collected for these. Forms and environments are extracted from FORM by instrumenting Emacs's builtin `macroexpand' function and calling `macroexpand-all'." (let ((real-macroexpand (indirect-function #'macroexpand)) (macro-form-alist '()) (compiler-macro-forms '())) (cl-letf (((symbol-function #'macroexpand) (lambda (form environment &rest args) (let ((expansion (apply real-macroexpand form environment args))) (cond ((not (eq expansion form)) (setq macro-form-alist (cons (cons form environment) macro-form-alist))) ((and (consp form) (symbolp (car form)) macrostep-expand-compiler-macros (not (eq form (cl-compiler-macroexpand form)))) (setq compiler-macro-forms (cons form compiler-macro-forms)))) expansion)))) (ignore-errors (macroexpand-all form environment))) (list macro-form-alist compiler-macro-forms))) (defvar macrostep-collected-macro-form-alist nil "An alist of macro forms and environments. Controls the printing of sub-forms in `macrostep-print-sexp'.") (defvar macrostep-collected-compiler-macro-forms nil "A list of compiler-macro forms to be highlighted in `macrostep-print-sexp'.") (defun macrostep-pp (sexp environment) "Pretty-print SEXP, fontifying macro forms and uninterned symbols." (cl-destructuring-bind (macrostep-collected-macro-form-alist macrostep-collected-compiler-macro-forms) (macrostep-collect-macro-forms sexp environment) (let ((print-quoted t)) (macrostep-print-sexp sexp) ;; Point is now after the expanded form; pretty-print it (save-restriction (narrow-to-region (scan-sexps (point) -1) (point)) (save-excursion (pp-buffer) ;; Remove the extra newline inserted by pp-buffer (goto-char (point-max)) (delete-region (point) (save-excursion (skip-chars-backward " \t\n") (point)))) ;; Indent the newly-inserted form in context (widen) (save-excursion (backward-sexp) (indent-sexp)))))) ;; This must be defined before `macrostep-print-sexp': (defmacro macrostep-propertize (form &rest plist) "Evaluate FORM, applying syntax properties in PLIST to any inserted text." (declare (indent 1) (debug (&rest form))) (let ((start (make-symbol "start"))) `(let ((,start (point))) (prog1 ,form ,@(cl-loop for (key value) on plist by #'cddr collect `(put-text-property ,start (point) ,key ,value)))))) (defun macrostep-print-sexp (sexp) "Insert SEXP like `print', fontifying macro forms and uninterned symbols. Fontifies uninterned symbols and macro forms using `font-lock-face' property, and saves the actual text of SEXP's sub-forms as the `macrostep-expanded-text' text property so that any uninterned symbols can be reused in macro expansions of the sub-forms. See also `macrostep-sexp-at-point'. Macro and compiler-macro forms within SEXP are identified by comparison with the `macrostep-collected-macro-form-alist' and `macrostep-collected-compiler-macro-forms' variables, which should be dynamically let-bound around calls to this function." (cond ((symbolp sexp) ;; Fontify gensyms (if (not (eq sexp (intern-soft (symbol-name sexp)))) (macrostep-propertize (prin1 sexp (current-buffer)) 'font-lock-face (macrostep-get-gensym-face sexp)) ;; Print other symbols as normal (prin1 sexp (current-buffer)))) ((listp sexp) ;; Print quoted and quasiquoted forms nicely. (let ((head (car sexp))) (cond ((and (eq head 'quote) ; quote (= (length sexp) 2)) (insert "'") (macrostep-print-sexp (cadr sexp))) ((and (eq head '\`) ; backquote (= (length sexp) 2)) (if (assq sexp macrostep-collected-macro-form-alist) (macrostep-propertize (insert "`") 'macrostep-expanded-text sexp 'macrostep-macro-start t 'font-lock-face 'macrostep-macro-face) (insert "`")) (macrostep-print-sexp (cadr sexp))) ((and (memq head '(\, \,@)) ; unquote (= (length sexp) 2)) (princ head (current-buffer)) (macrostep-print-sexp (cadr sexp))) (t ; other list form (cl-destructuring-bind (macro? . environment) (or (assq sexp macrostep-collected-macro-form-alist) '(nil . nil)) (let ((compiler-macro? (memq sexp macrostep-collected-compiler-macro-forms))) (if (or macro? compiler-macro?) (progn ;; Save the real expansion as a text property on the ;; opening paren (macrostep-propertize (insert "(") 'macrostep-macro-start t 'macrostep-expanded-text sexp 'macrostep-environment environment) ;; Fontify the head of the macro (macrostep-propertize (macrostep-print-sexp head) 'font-lock-face (if macro? 'macrostep-macro-face 'macrostep-compiler-macro-face))) ;; Not a macro form (insert "(") (macrostep-print-sexp head)))) ;; Print remaining list elements (setq sexp (cdr sexp)) (when sexp (insert " ")) (while sexp (if (listp sexp) (progn (macrostep-print-sexp (car sexp)) (when (cdr sexp) (insert " ")) (setq sexp (cdr sexp))) ;; Print tail of dotted list (insert ". ") (macrostep-print-sexp sexp) (setq sexp nil))) (insert ")"))))) ;; Print everything except symbols and lists as normal (t (prin1 sexp (current-buffer))))) (defun macrostep-get-gensym-face (symbol) "Return the face to use in fontifying SYMBOL in printed macro expansions. All symbols introduced in the same level of macro expansion are fontified using the same face (modulo the number of faces; see `macrostep-gensym-faces')." (or (get symbol 'macrostep-gensym-face) (progn (if (not macrostep-gensyms-this-level) (setq macrostep-gensym-depth (1+ macrostep-gensym-depth) macrostep-gensyms-this-level t)) (let ((face (ring-ref macrostep-gensym-faces macrostep-gensym-depth))) (put symbol 'macrostep-gensym-face face) face)))) (provide 'macrostep) ;;; macrostep.el ends here slime-2.20/metering.lisp000066400000000000000000001467151315100173500152630ustar00rootroot00000000000000;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.; -*- ;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz ;;; **************************************************************** ;;; 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. ;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. ;;; 07-Aug-12 heller Break lines at 80 columns ;;; ;;; ******************************** ;;; 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 ;;; (swank-monitor:with-monitoring (names*) () ;;; your-forms*) ;;; or ;;; (swank-monitor: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 SWANK-MONITOR::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 "SWANK-MONITOR" (: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 "SWANK-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) #+openmcl (progn (deftype time-type () 'unsigned-byte) (deftype consing-type () 'unsigned-byte)) (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))) #-(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 swank-monitor::*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* slime-2.20/nregex.lisp000066400000000000000000000473601315100173500147350ustar00rootroot00000000000000;;; ;;; This code was written by: ;;; ;;; Lawrence E. Freil ;;; 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 &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 [ :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) slime-2.20/packages.lisp000066400000000000000000000125371315100173500152210ustar00rootroot00000000000000(defpackage swank/backend (:use cl) (:nicknames swank-backend) (:export *debug-swank-backend* *log-output* sldb-condition compiler-condition original-condition message source-context condition severity with-compilation-hooks make-location location location-p location-buffer location-position location-hints position-p position-pos print-output-to-string quit-lisp references unbound-slot-filler declaration-arglist type-specifier-arglist with-struct when-let defimplementation converting-errors-to-error-location make-error-location deinit-log-output ;; interrupt macro for the backend *pending-slime-interrupts* check-slime-interrupts *interrupt-queued-handler* ;; inspector related symbols emacs-inspect label-value-line label-value-line* boolean-to-feature-expression with-symbol choose-symbol ;; package helper for backend import-to-swank-mop import-swank-mop-symbols ;; default-directory set-default-directory frame-source-location restart-frame gdb-initial-commands sldb-break-on-return buffer-first-change profiled-functions unprofile-all profile-report profile-reset profile-package with-collected-macro-forms)) (defpackage swank/rpc (:use :cl) (:export read-message read-packet swank-reader-error swank-reader-error.packet swank-reader-error.cause write-message)) (defpackage swank/match (:use cl) (:export match)) ;; FIXME: rename to sawnk/mop (defpackage swank-mop (:use) (:export ;; classes standard-generic-function standard-slot-definition standard-method standard-class eql-specializer eql-specializer-object ;; standard-class readers class-default-initargs class-direct-default-initargs class-direct-slots class-direct-subclasses class-direct-superclasses class-finalized-p class-name class-precedence-list class-prototype class-slots specializer-direct-methods ;; generic function readers generic-function-argument-precedence-order generic-function-declarations generic-function-lambda-list generic-function-methods generic-function-method-class generic-function-method-combination generic-function-name ;; method readers method-generic-function method-function method-lambda-list method-specializers method-qualifiers ;; slot readers slot-definition-allocation slot-definition-documentation slot-definition-initargs slot-definition-initform slot-definition-initfunction slot-definition-name slot-definition-type slot-definition-readers slot-definition-writers slot-boundp-using-class slot-value-using-class slot-makunbound-using-class ;; generic function protocol compute-applicable-methods-using-classes finalize-inheritance)) (defpackage swank (:use cl swank/backend swank/match swank/rpc) (:export #:startup-multiprocessing #:start-server #:create-server #:stop-server #:restart-server #:ed-in-emacs #:inspect-in-emacs #:print-indentation-lossage #:invoke-slime-debugger #:swank-debugger-hook #:emacs-inspect ;;#:inspect-slot-for-emacs ;; These are user-configurable variables: #:*communication-style* #:*dont-close* #:*fasl-pathname-function* #:*log-events* #:*use-dedicated-output-stream* #:*dedicated-output-stream-port* #:*configure-emacs-indentation* #:*readtable-alist* #:*globally-redirect-io* #:*global-debugger* #:*sldb-quit-restart* #:*backtrace-printer-bindings* #:*default-worker-thread-bindings* #:*macroexpand-printer-bindings* #:*swank-pprint-bindings* #:*record-repl-results* #:*inspector-verbose* ;; This is SETFable. #:debug-on-swank-error ;; These are re-exported directly from the backend: #:buffer-first-change #:frame-source-location #:gdb-initial-commands #:restart-frame #:sldb-step #:sldb-break #:sldb-break-on-return #:profiled-functions #:profile-report #:profile-reset #:unprofile-all #:profile-package #:default-directory #:set-default-directory #:quit-lisp #:eval-for-emacs #:eval-in-emacs #:y-or-n-p-in-emacs #:*find-definitions-right-trim* #:*find-definitions-left-trim* #:*after-toggle-trace-hook* #:unredable-result #:unredable-result-p #:unredable-result-string #:parse-string #:from-string #:to-string #:*swank-debugger-condition*)) slime-2.20/sbcl-pprint-patch.lisp000066400000000000000000000276541315100173500170030ustar00rootroot00000000000000;; 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))) slime-2.20/slime-autoloads.el000066400000000000000000000024111315100173500161640ustar00rootroot00000000000000;;; 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. ;; ;; JT@14/01/09: FIXME: This file should be auto-generated with autoload cookies. ;;; 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 'slime-selector "slime" "Select a new by type, indicated by a single character." t) (autoload 'hyperspec-lookup "lib/hyperspec" nil t) (autoload 'slime-lisp-mode-hook "slime") (autoload 'slime-scheme-mode-hook "slime") (defvar slime-contribs nil "A list of contrib packages to load with SLIME.") (autoload 'slime-setup "slime" "Setup some SLIME contribs.") (define-obsolete-variable-alias 'slime-setup-contribs 'slime-contribs "2.3.2") (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook) (provide 'slime-autoloads) ;;; slime-autoloads.el ends here ;; Local Variables: ;; no-byte-compile: t ;; End: slime-2.20/slime-tests.el000066400000000000000000001557531315100173500153550ustar00rootroot00000000000000;;; slime-tests.el --- Automated tests for slime.el ;; ;;;; License ;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller ;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller ;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler ;; Copyright (C) 2013 ;; ;; For a detailed list of contributors, see the manual. ;; ;; 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. ;;;; Tests (require 'slime) (require 'ert nil t) (require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23 (require 'cl-lib) (require 'bytecomp) ; byte-compile-current-file (eval-when-compile (require 'cl)) ; lexical-let (defun slime-shuffle-list (list) (let* ((len (length list)) (taken (make-vector len nil)) (result (make-vector len nil))) (dolist (e list) (while (let ((i (random len))) (cond ((aref taken i)) (t (aset taken i t) (aset result i e) nil))))) (append result '()))) (defun slime-batch-test (&optional test-name randomize) "Run the test suite in batch-mode. Exits Emacs when finished. The exit code is the number of failed tests." (interactive) (let ((ert-debug-on-error nil) (timeout 30) (slime-background-message-function #'ignore)) (slime) ;; Block until we are up and running. (lexical-let (timed-out) (run-with-timer timeout nil (lambda () (setq timed-out t))) (while (not (slime-connected-p)) (sit-for 1) (when timed-out (when noninteractive (kill-emacs 252))))) (slime-sync-to-top-level 5) (let* ((selector (if randomize `(member ,@(slime-shuffle-list (ert-select-tests (or test-name t) t))) (or test-name t))) (ert-fun (if noninteractive 'ert-run-tests-batch 'ert))) (let ((stats (funcall ert-fun selector))) (if noninteractive (kill-emacs (ert-stats-completed-unexpected stats))))))) (defun slime-skip-test (message) ;; ERT for Emacs 23 and earlier doesn't have `ert-skip' (if (fboundp 'ert-skip) (ert-skip message) (message (concat "SKIPPING: " message)) (ert-pass))) (defun slime-tests--undefine-all () (dolist (test (ert-select-tests t t)) (let* ((sym (ert-test-name test))) (cl-assert (eq (get sym 'ert--test) test)) (cl-remprop sym 'ert--test)))) (slime-tests--undefine-all) (eval-and-compile (defun slime-tests-auto-tags () (append '(slime) (let ((file-name (or load-file-name byte-compile-current-file))) (if (and file-name (string-match "contrib/test/slime-\\(.*\\)\.elc?$" file-name)) (list 'contrib (intern (match-string 1 file-name))) '(core))))) (defmacro define-slime-ert-test (name &rest args) "Like `ert-deftest', but set tags automatically. Also don't error if `ert.el' is missing." (if (not (featurep 'ert)) (warn "No ert.el found: not defining test %s" name) (let* ((docstring (and (stringp (second args)) (second args))) (args (if docstring (cddr args) (cdr args))) (tags (slime-tests-auto-tags))) `(ert-deftest ,name () ,(or docstring "No docstring for this test.") :tags ',tags ,@args)))) (defun slime-test-ert-test-for (name input i doc body fails-for style fname) `(define-slime-ert-test ,(intern (format "%s-%d" name i)) () ,(format "For input %s, %s" (truncate-string-to-width (format "%s" input) 15 nil nil 'ellipsis) (replace-regexp-in-string "^.??\\(\\w+\\)" (lambda (s) (downcase s)) doc t)) ,@(if fails-for `(:expected-result '(satisfies (lambda (result) (ert-test-result-type-p result (if (member (slime-lisp-implementation-name) ',fails-for) :failed :passed)))))) ,@(when style `((let ((style (slime-communication-style))) (when (not (member style ',style)) (slime-skip-test (format "test not applicable for style %s" style)))))) (apply #',fname ',input)))) (defmacro def-slime-test (name args doc inputs &rest body) "Define a test case. NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test. OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*) 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)." (declare (debug (&define name sexp sexp sexp &rest def-form))) (if (not (featurep 'ert)) (warn "No ert.el found: not defining test %s" name) `(progn ,@(cl-destructuring-bind (name &rest options) (if (listp name) name (list name)) (let ((fname (intern (format "slime-test-%s" name)))) (cons `(defun ,fname ,args (slime-sync-to-top-level 0.3) ,@body (slime-sync-to-top-level 0.3)) (cl-loop for input in (eval inputs) for i from 1 with fails-for = (cdr (assoc :fails-for options)) with style = (cdr (assoc :style options)) collect (slime-test-ert-test-for name input i doc body fails-for style fname)))))))) (put 'def-slime-test 'lisp-indent-function 4) (defmacro slime-check (check &rest body) (declare (indent defun)) `(unless (progn ,@body) (ert-fail ,(cl-etypecase check (cons `(concat "Ooops, " ,(cons 'format check))) (string `(concat "Check failed: " ,check)) (symbol `(concat "Check failed: " ,(symbol-name check))))))) ;;;;; Test case definitions (defun slime-check-top-level () ;(&optional _test-name) (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)) (let ((now (current-time))) (message "waiting for condition: %s [%s.%06d]" name (format-time-string "%H:%M:%S" now) (third now))) (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 (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 (let ((sldb (sldb-get-default-buffer))) (if sldb (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))) (if test (should (funcall test expected actual)) (should (equal expected actual)))) (defun sldb-level () (let ((sldb (sldb-get-default-buffer))) (if sldb (with-current-buffer sldb sldb-level)))) (defun slime-sldb-level= (level) (equal level (sldb-level))) (eval-when-compile (defvar slime-test-symbols '(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar") ("|asdf||foo||bar|") ("\\#") ("\\(setf\\ car\\)")))) (defun slime-check-symbol-at-point (prefix symbol suffix) ;; We test that `slime-symbol-at-point' works at every ;; character of the symbol name. (with-temp-buffer (lisp-mode) (insert prefix) (let ((start (point))) (insert symbol suffix) (dotimes (i (length symbol)) (goto-char (+ start i)) (slime-test-expect (format "Check `%s' (at %d)..." (buffer-string) (point)) symbol (slime-symbol-at-point) #'equal))))) (def-slime-test symbol-at-point.2 (sym) "fancy symbol-name _not_ at BOB/EOB" slime-test-symbols (slime-check-symbol-at-point "(foo " sym " bar)")) (def-slime-test symbol-at-point.3 (sym) "fancy symbol-name with leading ," (remove-if (lambda (s) (eq (aref (car s) 0) ?@)) slime-test-symbols) (slime-check-symbol-at-point "," sym "")) (def-slime-test symbol-at-point.4 (sym) "fancy symbol-name with leading ,@" slime-test-symbols (slime-check-symbol-at-point ",@" sym "")) (def-slime-test symbol-at-point.5 (sym) "fancy symbol-name with leading `" slime-test-symbols (slime-check-symbol-at-point "`" sym "")) (def-slime-test symbol-at-point.6 (sym) "fancy symbol-name wrapped in ()" slime-test-symbols (slime-check-symbol-at-point "(" sym ")")) (def-slime-test symbol-at-point.7 (sym) "fancy symbol-name wrapped in #< {DEADBEEF}>" slime-test-symbols (slime-check-symbol-at-point "#<" sym " {DEADBEEF}>")) ;;(def-slime-test symbol-at-point.8 (sym) ;; "fancy symbol-name wrapped in #<>" ;; slime-test-symbols ;; (slime-check-symbol-at-point "#<" sym ">")) (def-slime-test symbol-at-point.9 (sym) "fancy symbol-name wrapped in #| ... |#" slime-test-symbols (slime-check-symbol-at-point "#|\n" sym "\n|#")) (def-slime-test symbol-at-point.10 (sym) "fancy symbol-name after #| )))(( |# (1)" slime-test-symbols (slime-check-symbol-at-point "#| )))(( #|\n" sym "")) (def-slime-test symbol-at-point.11 (sym) "fancy symbol-name after #| )))(( |# (2)" slime-test-symbols (slime-check-symbol-at-point "#| )))(( #|" sym "")) (def-slime-test symbol-at-point.12 (sym) "fancy symbol-name wrapped in \"...\"" slime-test-symbols (slime-check-symbol-at-point "\"\n" sym "\"\n")) (def-slime-test symbol-at-point.13 (sym) "fancy symbol-name wrapped in \" )))(( \" (1)" slime-test-symbols (slime-check-symbol-at-point "\" )))(( \"\n" sym "")) (def-slime-test symbol-at-point.14 (sym) "fancy symbol-name wrapped in \" )))(( \" (1)" slime-test-symbols (slime-check-symbol-at-point "\" )))(( \"" sym "")) (def-slime-test symbol-at-point.15 (sym) "symbol-at-point after #." slime-test-symbols (slime-check-symbol-at-point "#." sym "")) (def-slime-test symbol-at-point.16 (sym) "symbol-at-point after #+" slime-test-symbols (slime-check-symbol-at-point "#+" sym "")) (def-slime-test sexp-at-point.1 (string) "symbol-at-point after #'" '(("foo") ("#:foo") ("#'foo") ("#'(lambda (x) x)") ("()")) (with-temp-buffer (lisp-mode) (insert string) (goto-char (point-min)) (slime-test-expect (format "Check sexp `%s' (at %d)..." (buffer-string) (point)) string (slime-sexp-at-point) #'equal))) (def-slime-test narrowing () "Check that narrowing is properly sustained." '() (slime-check-top-level) (let ((random-buffer-name (symbol-name (cl-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-popup-buffer (random-buffer-name) (slime-check ("Checking that we're in Slime's temp buffer `%s'" random-buffer-name) (equal (buffer-name (current-buffer)) random-buffer-name))) (with-current-buffer random-buffer-name ;; Notice that we cannot quit the buffer within the extent ;; of slime-with-output-to-temp-buffer. (quit-window t)) (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. %S" 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)) (defun slime-test--display-region-eval-arg (line window-height) (cl-etypecase line (number line) (cons (slime-dcase line ((+h line) (+ (slime-test--display-region-eval-arg line window-height) window-height)) ((-h line) (- (slime-test--display-region-eval-arg line window-height) window-height)))))) (defun slime-test--display-region-line-to-position (line window-height) (let ((line (slime-test--display-region-eval-arg line window-height))) (save-excursion (goto-char (point-min)) (forward-line (1- line)) (line-beginning-position)))) (def-slime-test display-region (start end pos window-start expected-window-start expected-point) "Test `slime-display-region'." ;; numbers are actually lines numbers '(;; region visible, point in region (2 4 3 1 1 3) ;; region visible, point visible but ouside region (2 4 5 1 1 5) ;; end not visible, point at start (2 (+h 2) 2 1 2 2) ;; start not visible, point at start ((+h 2) (+h 500) (+h 2) 1 (+h 2) (+h 2)) ;; start not visible, point after end ((+h 2) (+h 500) (+h 6) 1 (+h 2) (+h 6)) ;; end - start should be visible, point after end ((+h 2) (+h 7) (+h 10) 1 (-h (+h 7)) (+h 6)) ;; region is window-height + 1 and ends with newline ((+h -2) (+h (+h -3)) (+h -2) 1 (+h -3) (+h -2)) (2 (+h 1) 3 1 1 3) (2 (+h 0) 3 1 1 3) (2 (+h -1) 3 1 1 3) ;; start and end are the beginning (1 1 1 1 1 1) ;; (1 (+h 1) (+h 22) (+h 20) 1 (+h 0)) ) (when noninteractive (slime-skip-test "Can't test slime-display-region in batch mode")) (with-temp-buffer (dotimes (i 1000) (insert (format "%09d\n" i))) (let* ((win (display-buffer (current-buffer) t)) (wh (window-text-height win))) (cl-macrolet ((l2p (l) `(slime-test--display-region-line-to-position ,l wh))) (select-window win) (set-window-start win (l2p window-start)) (redisplay) (goto-char (l2p pos)) (cl-assert (= (l2p window-start) (window-start win))) (cl-assert (= (point) (l2p pos))) (slime--display-region (l2p start) (l2p end)) (redisplay) (cl-assert (= (l2p expected-window-start) (window-start))) (cl-assert (= (l2p expected-point) (point))) )))) (def-slime-test find-definition (name buffer-package snippet) "Find the definition of a function or macro in swank.lisp." '(("start-server" "SWANK" "(defun start-server ") ("swank::start-server" "CL-USER" "(defun start-server ") ("swank:start-server" "CL-USER" "(defun start-server ") ("swank::connection" "CL-USER" "(defstruct (connection") ("swank::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*") ) (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 ("Looking at '%s'." snippet) (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 (find-definition.2 (:fails-for "allegro" "lispworks")) (buffer-content buffer-package snippet) "Check that we're able to find definitions even when confronted with nasty #.-fu." '(("#.(prog1 nil (defvar *foobar* 42)) (defun .foo. (x) (+ x #.*foobar*)) #.(prog1 nil (makunbound '*foobar*)) " "SWANK" "[ \t]*(defun .foo. " ) ("#.(prog1 nil (defvar *foobar* 42)) ;; some comment (defun .foo. (x) (+ x #.*foobar*)) #.(prog1 nil (makunbound '*foobar*)) " "SWANK" "[ \t]*(defun .foo. " ) ("(in-package swank) (eval-when (:compile-toplevel) (defparameter *bar* 456)) (eval-when (:load-toplevel :execute) (makunbound '*bar*)) (defun bar () #.*bar*) (defun .foo. () 123)" "SWANK" "[ \t]*(defun .foo. () 123)")) (let ((slime-buffer-package buffer-package)) (with-temp-buffer (insert buffer-content) (slime-check-top-level) (slime-eval `(swank:compile-string-for-emacs ,buffer-content ,(buffer-name) '((:position 0) (:line 1 1)) ,nil ,nil)) (let ((bufname (buffer-name))) (slime-edit-definition ".foo.") (slime-check ("Definition of `.foo.' is in buffer `%s'." bufname) (string= (buffer-name) bufname)) (slime-check "Definition now at point." (looking-at snippet)))))) (def-slime-test (find-definition.3 (:fails-for "abcl" "allegro" "clisp" "lispworks" "sbcl" "ecl")) (name source regexp) "Extra tests for defstruct." '(("swank::foo-struct" "(progn (defun foo-fun ()) (defstruct (foo-struct (:constructor nil) (:predicate nil))) )" "(defstruct (foo-struct")) (switch-to-buffer "*scratch*") (with-temp-buffer (insert source) (let ((slime-buffer-package "SWANK")) (slime-eval `(swank:compile-string-for-emacs ,source ,(buffer-name) '((:position 0) (:line 1 1)) ,nil ,nil))) (let ((temp-buffer (current-buffer))) (with-current-buffer "*scratch*" (slime-edit-definition name) (slime-check ("Definition of %S is in buffer `%s'." name temp-buffer) (eq (current-buffer) temp-buffer)) (slime-check "Definition now at point." (looking-at regexp))) ))) (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:foobar" ()) ("swank::compile-file" ("swank::compile-file" "swank::compile-file-for-emacs" "swank::compile-file-if-needed" "swank::compile-file-output" "swank::compile-file-pathname")) ("cl:m-v-l" ())) (let ((completions (slime-simple-completions prefix))) (slime-test-expect "Completion set" expected-completions completions))) (def-slime-test read-from-minibuffer (input-keys expected-result) "Test `slime-read-from-minibuffer' with INPUT-KEYS as events." '(("( r e v e TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET" "(reverse '(1 2 3))") ("( c l : c o n TAB s t a n t l TAB SPC 4 2 ) RET" "(cl:constantly 42)")) (when noninteractive (slime-skip-test "Can't use unread-command-events in batch mode")) (let ((keys (eval `(kbd ,input-keys)))) ; kbd is a macro in Emacs 23 (setq unread-command-events (listify-key-sequence keys))) (let ((actual-result (slime-read-from-minibuffer "Test: "))) (accept-process-output) ; run idle timers (slime-test-expect "Completed string" expected-result actual-result))) (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::compute-backtrace" "(swank::compute-backtrace start end)") ("swank::emacs-connected" "(swank::emacs-connected)") ("swank::compile-string-for-emacs" "(swank::compile-string-for-emacs \ string buffer position filename policy)") ("swank::connection.socket-io" "(swank::connection.socket-io \ \\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))") ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)") ("cl:class-name" "(cl:class-name \\(class\\|object\\|instance\\|structure\\))")) (let ((arglist (slime-eval `(swank:operator-arglist ,function-name "swank")))) (slime-test-expect "Argument list is as expected" expected-arglist (and arglist (downcase arglist)) (lambda (pattern arglist) (and arglist (string-match pattern arglist)))))) (defun slime-test--compile-defun (program subform) (slime-check-top-level) (with-temp-buffer (lisp-mode) (insert program) (let ((font-lock-verbose nil)) (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 (compile-defun (:fails-for "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 () \"\\\" 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-test--compile-defun program subform)) ;; This test ideally would be collapsed into the previous ;; compile-defun test, but only 1 case fails for ccl--and that's here (def-slime-test (compile-defun-with-reader-conditionals (:fails-for "allegro" "lispworks" "clisp" "ccl")) (program subform) "Compile PROGRAM containing errors. Confirm that SUBFORM is correctly located." '(("(defun foo () #+#.'(:and) (/ 1 0))" (/ 1 0))) (slime-test--compile-defun program subform)) ;; SBCL used to pass this one but since they changed the ;; backquote/unquote reader it fails. (def-slime-test (compile-defun-with-backquote (:fails-for "allegro" "lispworks" "clisp" "sbcl")) (program subform) "Compile PROGRAM containing errors. Confirm that SUBFORM is correctly located." '(("(defun cl-user::foo () (list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3 ,(cl-user::bar))))" (cl-user::bar))) (slime-test--compile-defun program subform)) (def-slime-test (compile-file (:fails-for "allegro" "clisp")) (string) "Insert STRING in a file, and compile it." `((,(pp-to-string '(defun foo () nil)))) (let ((filename "/tmp/slime-tmp-file.lisp")) (with-temp-file filename (insert string)) (let ((cell (cons nil nil))) (slime-eval-async `(swank:compile-file-for-emacs ,filename nil) (slime-rcurry (lambda (result cell) (setcar cell t) (setcdr cell result)) cell)) (slime-wait-condition "Compilation finished" (lambda () (car cell)) 0.5) (let ((result (cdr cell))) (slime-check "Compilation successfull" (eq (slime-compilation-result.successp result) t)))))) (def-slime-test utf-8-source (input output) "Source code containing utf-8 should work" (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206") ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046) ;; 'utf-8) (string (decode-coding-string bytes 'utf-8-unix))) (assert (equal bytes (encode-coding-string string 'utf-8-unix))) (list (concat "(defun cl-user::foo () \"" string "\")") string))) (slime-eval `(cl:eval (cl:read-from-string ,input))) (slime-test-expect "Eval result correct" output (slime-eval '(cl-user::foo))) (let ((cell (cons nil nil))) (let ((hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell))) (add-hook 'slime-compilation-finished-hook hook) (unwind-protect (progn (slime-compile-string input 0) (slime-wait-condition "Compilation finished" (lambda () (car cell)) 0.5) (slime-test-expect "Compile-string result correct" output (slime-eval '(cl-user::foo)))) (remove-hook 'slime-compilation-finished-hook hook)) (let ((filename "/tmp/slime-tmp-file.lisp")) (setcar cell nil) (add-hook 'slime-compilation-finished-hook hook) (unwind-protect (with-temp-buffer (when (fboundp 'set-buffer-multibyte) (set-buffer-multibyte t)) (setq buffer-file-coding-system 'utf-8-unix) (setq buffer-file-name filename) (insert ";; -*- coding: utf-8-unix -*- \n") (insert input) (let ((coding-system-for-write 'utf-8-unix)) (write-region nil nil filename nil t)) (let ((slime-load-failed-fasl 'always)) (slime-compile-and-load-file) (slime-wait-condition "Compilation finished" (lambda () (car cell)) 0.5)) (slime-test-expect "Compile-file result correct" output (slime-eval '(cl-user::foo)))) (remove-hook 'slime-compilation-finished-hook hook) (ignore-errors (delete-file filename))))))) (def-slime-test async-eval-debugging (depth) "Test recursive debugging of asynchronous evaluation requests." '((1) (2) (3)) (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 '(error)))))))) (let ((sldb-hook (cons debug-hook sldb-hook))) (slime-eval-async '(error)) (slime-sync-to-top-level 5) (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)) (cl-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") (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) (accept-process-output)) (slime-sync-to-top-level 5) (slime-check-top-level) (unless noninteractive (let ((message (current-message))) (slime-check "Minibuffer contains: \"3\"" (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) (def-slime-test report-condition-with-circular-list (format-control format-argument) "Test conditions involving circular lists." '(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))") ("~a" "(let ((x (cons nil nil))) (setf (car x) x))") ("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\ (setf (cdr x) x))")) (slime-check-top-level) (lexical-let ((done nil)) (let ((sldb-hook (lambda () (sldb-continue) (setq done t)))) (slime-interactive-eval (format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))" format-control format-argument)) (while (not done) (accept-process-output)) (slime-sync-to-top-level 5) (slime-check-top-level) (unless noninteractive (let ((message (current-message))) (slime-check "Minibuffer contains: \"3\"" (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) (def-slime-test interrupt-bubbling-idiot () "Test interrupting a loop that sends a lot of output to Emacs." '(()) (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 (interrupt-encode-message (:style :sigio)) () "Test interrupt processing during swank::encode-message" '(()) (slime-eval-async '(cl:loop :for i :from 0 :do (swank::background-message "foo ~d" i))) (sleep-for 1) (slime-eval-async '(cl:/ 1 0)) (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 inspector (exp) "Test basic inspector workingness." '(((let ((h (make-hash-table))) (loop for i below 10 do (setf (gethash i h) i)) h)) ((make-array 10)) ((make-list 10)) ('cons) (#'cons)) (slime-inspect (prin1-to-string exp)) (cl-assert (not (slime-inspector-visible-p))) (slime-wait-condition "Inspector visible" #'slime-inspector-visible-p 5) (with-current-buffer (window-buffer (selected-window)) (slime-inspector-quit)) (slime-wait-condition "Inspector closed" (lambda () (not (slime-inspector-visible-p))) 5) (slime-sync-to-top-level 1)) (defun slime-buffer-visible-p (name) (let ((buffer (window-buffer (selected-window)))) (string-match name (buffer-name buffer)))) (defun slime-inspector-visible-p () (slime-buffer-visible-p (slime-buffer-name :inspector))) (defun slime-execute-as-command (name) "Execute `name' as if it was done by the user through the Command Loop. Similiar to `call-interactively' but also pushes on the buffer's undo-list." (undo-boundary) (call-interactively name)) (def-slime-test macroexpand (macro-defs bufcontent expansion1 search-str expansion2) "foo" '((("(defmacro qwertz (&body body) `(list :qwertz ',body))" "(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))") "(yxcv :A :B :C)" "(list :yxcv (qwertz :a :b :c))" "(qwertz" "(list :yxcv (list :qwertz '(:a :b :c)))")) (slime-check-top-level) (setq slime-buffer-package ":swank") (with-temp-buffer (lisp-mode) (dolist (def macro-defs) (slime-compile-string def 0) (slime-sync-to-top-level 5)) (insert bufcontent) (goto-char (point-min)) (slime-execute-as-command 'slime-macroexpand-1) (slime-wait-condition "Macroexpansion buffer visible" (lambda () (slime-buffer-visible-p (slime-buffer-name :macroexpansion))) 5) (with-current-buffer (get-buffer (slime-buffer-name :macroexpansion)) (slime-test-expect "Initial macroexpansion is correct" expansion1 (downcase (buffer-string)) #'slime-test-macroexpansion=) (search-forward search-str) (backward-up-list) (slime-execute-as-command 'slime-macroexpand-1-inplace) (slime-sync-to-top-level 3) (slime-test-expect "In-place macroexpansion is correct" expansion2 (downcase (buffer-string)) #'slime-test-macroexpansion=) (slime-execute-as-command 'slime-macroexpand-undo) (slime-test-expect "Expansion after undo is correct" expansion1 (downcase (buffer-string)) #'slime-test-macroexpansion=))) (setq slime-buffer-package ":cl-user")) (defun slime-test-macroexpansion= (string1 string2) (let ((string1 (replace-regexp-in-string " *\n *" " " string1)) (string2 (replace-regexp-in-string " *\n *" " " string2))) (equal string1 string2))) (def-slime-test indentation (buffer-content point-markers) "Check indentation update to work correctly." '((" \(in-package :swank) \(defmacro with-lolipop (&body body) `(progn ,@body)) \(defmacro lolipop (&body body) `(progn ,@body)) \(with-lolipop 1 2 42) \(lolipop 1 2 23) " ("23" "42"))) (with-temp-buffer (lisp-mode) (slime-lisp-mode-hook) (insert buffer-content) (slime-compile-region (point-min) (point-max)) (slime-sync-to-top-level 3) (slime-update-indentation) (slime-sync-to-top-level 3) (dolist (marker point-markers) (search-backward marker) (beginning-of-defun) (indent-sexp)) (slime-test-expect "Correct buffer content" buffer-content (substring-no-properties (buffer-string))))) (def-slime-test break (times exp) "Test whether BREAK invokes SLDB." (let ((exp1 '(break))) `((1 ,exp1) (2 ,exp1) (3 ,exp1))) (accept-process-output nil 0.2) (slime-check-top-level) (slime-eval-async `(cl:eval (cl:read-from-string ,(prin1-to-string `(dotimes (i ,times) (unless (= i 0) (swank::sleep-for 1)) ,exp))))) (dotimes (_i times) (slime-wait-condition "Debugger visible" (lambda () (and (slime-sldb-level= 1) (get-buffer-window (sldb-get-default-buffer)))) 3) (with-current-buffer (sldb-get-default-buffer) (sldb-continue)) (slime-wait-condition "sldb closed" (lambda () (not (sldb-get-default-buffer))) 0.5)) (slime-sync-to-top-level 1)) (def-slime-test (break2 (:fails-for "cmucl" "allegro")) (times exp) "Backends should arguably make sure that BREAK does not depend on *DEBUGGER-HOOK*." (let ((exp2 '(block outta (let ((*debugger-hook* (lambda (c h) (return-from outta 42)))) (break))))) `((1 ,exp2) (2 ,exp2) (3 ,exp2))) (slime-test-break times exp)) (def-slime-test locally-bound-debugger-hook () "Test that binding *DEBUGGER-HOOK* locally works properly." '(()) (accept-process-output nil 1) (slime-check-top-level) (slime-compile-string (prin1-to-string `(defun cl-user::quux () (block outta (let ((*debugger-hook* (lambda (c hook) (declare (ignore c hook)) (return-from outta 42)))) (error "FOO"))))) 0) (slime-sync-to-top-level 2) (slime-eval-async '(cl-user::quux)) ;; FIXME: slime-wait-condition returns immediately if the test returns true (slime-wait-condition "Checking that Debugger does not popup" (lambda () (not (sldb-get-default-buffer))) 3) (slime-sync-to-top-level 5)) (def-slime-test end-of-file (expr) "Signalling END-OF-FILE should invoke the debugger." '(((cl:error 'cl:end-of-file)) ((cl:read-from-string ""))) (let ((value (slime-eval `(cl:let ((condition nil)) (cl:with-simple-restart (cl:continue "continue") (cl:let ((cl:*debugger-hook* (cl:lambda (c h) (cl:setq condition c) (cl:continue)))) ,expr)) (cl:if (cl:typep condition 'cl:end-of-file) t))))) (slime-test-expect "Debugger invoked" t value))) (def-slime-test interrupt-at-toplevel () "Let's see what happens if we send a user interrupt at toplevel." '(()) (slime-check-top-level) (unless (and (eq (slime-communication-style) :spawn) (not (featurep 'slime-repl))) (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-debugger (interrupts continues) "Let's see what happens if we interrupt the debugger. INTERRUPTS ... number of nested interrupts CONTINUES ... how often the continue restart should be invoked" '((1 0) (2 1) (4 2)) (slime-check "No debugger" (not (sldb-get-default-buffer))) (when (and (eq (slime-communication-style) :spawn) (not (featurep 'slime-repl))) (slime-eval-async '(swank::without-slime-interrupts (swank::receive))) (sit-for 0.2)) (dotimes (i interrupts) (slime-interrupt) (let ((level (1+ i))) (slime-wait-condition (format "Debug level %d reachend" level) (lambda () (equal (sldb-level) level)) 2))) (dotimes (i continues) (with-current-buffer (sldb-get-default-buffer) (sldb-continue)) (let ((level (- interrupts (1+ i)))) (slime-wait-condition (format "Return to debug level %d" level) (lambda () (equal (sldb-level) level)) 2))) (with-current-buffer (sldb-get-default-buffer) (sldb-quit)) (slime-sync-to-top-level 1)) (def-slime-test flow-control (n delay interrupts) "Let Lisp produce output faster than Emacs can consume it." `((400 0.03 3)) (when noninteractive (slime-skip-test "test is currently unstable")) (slime-check "No debugger" (not (sldb-get-default-buffer))) (slime-eval-async `(swank:flow-control-test ,n ,delay)) (sleep-for 0.2) (dotimes (_i interrupts) (slime-interrupt) (slime-wait-condition "In debugger" (lambda () (slime-sldb-level= 1)) 5) (slime-check "In debugger" (slime-sldb-level= 1)) (with-current-buffer (sldb-get-default-buffer) (sldb-continue)) (slime-wait-condition "No debugger" (lambda () (slime-sldb-level= nil)) 3) (slime-check "Debugger closed" (slime-sldb-level= nil))) (slime-sync-to-top-level 8)) (def-slime-test sbcl-world-lock (n delay) "Print something from *MACROEXPAND-HOOK*. In SBCL, the compiler grabs a lock which can be problematic because no method dispatch code can be generated for other threads. This test will fail more likely before dispatch caches are warmed up." '((10 0.03) ;;((cl:+ swank::send-counter-limit 10) 0.03) ) (slime-test-expect "no error" 123 (slime-eval `(cl:let ((cl:*macroexpand-hook* (cl:lambda (fun form env) (swank:flow-control-test ,n ,delay) (cl:funcall fun form env)))) (cl:eval '(cl:macrolet ((foo () 123)) (foo))))))) (def-slime-test (disconnect-one-connection (:style :spawn)) () "`slime-disconnect' should disconnect only the current connection" '(()) (let ((connection-count (length slime-net-processes)) (old-connection slime-default-connection) (slime-connected-hook nil)) (unwind-protect (let ((slime-dispatching-connection (slime-connect "localhost" ;; Here we assume that the request will ;; be evaluated in its own thread. (slime-eval `(swank:create-server :port 0 ; use random port :style :spawn :dont-close nil))))) (slime-sync-to-top-level 3) (slime-disconnect) (slime-test-expect "Number of connections must remane the same" connection-count (length slime-net-processes))) (slime-select-connection old-connection)))) (def-slime-test disconnect-and-reconnect () "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") (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) (p p)) (setq hook (lambda () (slime-test-expect "We are connected again" p (slime-inferior-process)) (remove-hook 'slime-connected-hook hook))) (add-hook 'slime-connected-hook hook) (slime-wait-condition "Lisp restarted" (lambda () (not (member hook slime-connected-hook))) 5)))) ;;;; SLIME-loading tests that launch separate Emacsen ;;;; (cl-defun slime-test-recipe-test-for (&key preflight takeoff landing) (let ((success nil) (test-file (make-temp-file "slime-recipe-" nil ".el")) (test-forms `((require 'cl) (labels ((die (reason &optional more) (princ reason) (terpri) (and more (pp more)) (kill-emacs 254))) (condition-case err (progn ,@preflight) (error (die "Unexpected error running preflight forms" err))) (add-hook 'slime-connected-hook #'(lambda () (condition-case err (progn ,@landing (kill-emacs 0)) (error (die "Unexpected error running landing forms" err)))) t) (condition-case err (progn ,@takeoff ,(when (null landing) '(kill-emacs 0))) (error (die "Unexpected error running takeoff forms" err))) (with-timeout (20 (die "Timeout waiting for recipe test to finish." takeoff)) (while t (sit-for 1))))))) (unwind-protect (progn (with-temp-buffer (mapc #'insert (mapcar #'pp-to-string test-forms)) (write-file test-file)) (with-temp-buffer (let ((retval (call-process (concat invocation-directory invocation-name) nil (list t nil) nil "-Q" "--batch" "-l" test-file))) (unless (= 0 retval) (ert-fail (buffer-substring (+ (goto-char (point-min)) (skip-chars-forward " \t\n")) (+ (goto-char (point-max)) (skip-chars-backward " \t\n"))))))) (setq success t)) (if success (delete-file test-file) (message "Test failed: keeping %s for inspection" test-file))))) (define-slime-ert-test readme-recipe () "Test the README.md's autoload recipe." (slime-test-recipe-test-for :preflight `((add-to-list 'load-path ,slime-path) (require 'slime-autoloads) (setq inferior-lisp-program ,inferior-lisp-program) (setq slime-contribs '(slime-fancy))) :takeoff `((call-interactively 'slime)) :landing `((unless (and (featurep 'slime-repl) (find 'swank-repl slime-required-modules)) (die "slime-repl not loaded properly")) (with-current-buffer (slime-repl-buffer) (unless (and (string-match "^; +SLIME" (buffer-string)) (string-match "CL-USER> *$" (buffer-string))) (die "REPL prompt not properly setup" (buffer-substring-no-properties (point-min) (point-max)))))))) (define-slime-ert-test traditional-recipe () "Test the README.md's traditional recipe." (slime-test-recipe-test-for :preflight `((add-to-list 'load-path ,slime-path) (require 'slime) (setq inferior-lisp-program ,inferior-lisp-program) (slime-setup '(slime-fancy))) :takeoff `((call-interactively 'slime)) :landing `((unless (and (featurep 'slime-repl) (find 'swank-repl slime-required-modules)) (die "slime-repl not loaded properly")) (with-current-buffer (slime-repl-buffer) (unless (and (string-match "^; +SLIME" (buffer-string)) (string-match "CL-USER> *$" (buffer-string))) (die "REPL prompt not properly setup" (buffer-substring-no-properties (point-min) (point-max)))))))) (define-slime-ert-test readme-recipe-autoload-on-lisp-visit () "Test more autoload bits in README.md's installation recipe." (slime-test-recipe-test-for :preflight `((add-to-list 'load-path ,slime-path) (require 'slime-autoloads)) :takeoff `((if (featurep 'slime) (die "Didn't expect SLIME to be loaded so early!")) (find-file ,(make-temp-file "slime-lisp-source-file" nil ".lisp")) (unless (featurep 'slime) (die "Expected SLIME to be fully loaded by now"))))) (defun slime-test-eval-now (string) (second (slime-eval `(swank:eval-and-grab-output ,string)))) (def-slime-test (slime-recompile-all-xrefs (:fails-for "cmucl")) () "Test recompilation of all references within an xref buffer." '(()) (let* ((cell (cons nil nil)) (hook (slime-curry (lambda (cell &rest _) (setcar cell t)) cell)) (filename (make-temp-file "slime-recompile-all-xrefs" nil ".lisp"))) (add-hook 'slime-compilation-finished-hook hook) (unwind-protect (with-temp-file filename (set-visited-file-name filename) (slime-test-eval-now "(defparameter swank::*.var.* nil)") (insert "(in-package :swank) (defun .fn1. ()) (defun .fn2. () (.fn1.) #.*.var.*) (defun .fn3. () (.fn1.) #.*.var.*)") (save-buffer) (slime-compile-and-load-file) (slime-wait-condition "Compilation finished" (lambda () (car cell)) 0.5) (slime-test-eval-now "(setq *.var.* t)") (setcar cell nil) (slime-xref :calls ".fn1." (lambda (&rest args) (apply #'slime-show-xrefs args) (setcar cell t))) (slime-wait-condition "Xrefs computed and displayed" (lambda () (car cell)) 0.5) (setcar cell nil) (with-current-buffer slime-xref-last-buffer (slime-recompile-all-xrefs) (slime-wait-condition "Compilation finished" (lambda () (car cell)) 0.5)) (should (cl-equalp (list (slime-test-eval-now "(.fn2.)") (slime-test-eval-now "(.fn3.)")) '("T" "T")))) (remove-hook 'slime-compilation-finished-hook hook) (when slime-xref-last-buffer (kill-buffer slime-xref-last-buffer))))) (provide 'slime-tests) slime-2.20/slime.el000066400000000000000000010574531315100173500142140ustar00rootroot00000000000000;;; slime.el --- Superior Lisp Interaction Mode for Emacs -*-lexical-binding:t-*- ;; URL: https://github.com/slime/slime ;; Package-Requires: ((cl-lib "0.5") (macrostep "0.9")) ;; Keywords: languages, lisp, slime ;; Version: 2.20 ;;;; License and Commentary ;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller ;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller ;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler ;; ;; For a detailed list of contributors, see the manual. ;; ;; 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: ;; SLIME is the ``Superior Lisp Interaction Mode for Emacs.'' ;; ;; SLIME extends Emacs with support for interactive programming in ;; Common Lisp. The features are centered around slime-mode, an Emacs ;; minor-mode that complements the standard lisp-mode. While lisp-mode ;; supports editing Lisp source files, slime-mode adds support for ;; interacting with a running Common Lisp process for compilation, ;; debugging, documentation lookup, and so on. ;; ;; The 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 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 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. ;;; Code: ;;;; Dependencies and setup (eval-and-compile (require 'cl-lib nil t) ;; For emacs 23, look for bundled version (require 'cl-lib "lib/cl-lib")) (eval-when-compile (require 'cl)) ; defsetf, lexical-let (eval-and-compile (if (< emacs-major-version 23) (error "Slime requires an Emacs version of 23, or above"))) (require 'hyperspec "lib/hyperspec") (require 'thingatpt) (require 'comint) (require 'pp) (require 'easymenu) (require 'outline) (require 'arc-mode) (require 'etags) (require 'compile) (eval-when-compile (require 'apropos) (require 'gud) (require 'lisp-mnt)) (declare-function lm-version "lisp-mnt") (defvar slime-path nil "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.") (setq slime-path (file-name-directory load-file-name)) (defvar slime-version nil "The version of SLIME that you're using.") (setq slime-version (eval-when-compile (lm-version (cl-find "slime.el" (remove nil (list load-file-name (when (boundp 'byte-compile-current-file) byte-compile-current-file))) :key #'file-name-nondirectory :test #'string-equal)))) (defvar slime-lisp-modes '(lisp-mode)) (defvar slime-contribs nil "A list of contrib packages to load with SLIME.") (define-obsolete-variable-alias 'slime-setup-contribs 'slime-contribs "2.3.2") (defun slime-setup (&optional contribs) "Setup Emacs so that lisp-mode buffers always use SLIME. CONTRIBS is a list of contrib packages to load. If `nil', use `slime-contribs'. " (interactive) (when (member 'lisp-mode slime-lisp-modes) (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) (when contribs (setq slime-contribs contribs)) (slime--setup-contribs)) (defvar slime-required-modules '()) (defun slime--setup-contribs () "Load and initialize contribs." (dolist (c slime-contribs) (unless (featurep c) (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)) (defvar slime-protocol-version nil) (setq slime-protocol-version slime-version) ;;;; 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-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-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) (defcustom slime-lisp-host "127.0.0.1" "The default hostname (or IP address) to connect to." :type 'string :group 'slime-lisp) (defcustom slime-port 4005 "Port to use as the default for `slime-connect'." :type 'integer :group 'slime-lisp) (defvar slime-connect-host-history (list slime-lisp-host)) (defvar slime-connect-port-history (list (prin1-to-string slime-port))) (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))) (when (and probe (if (fboundp 'check-coding-system) (ignore-errors (check-coding-system (car probe))) (eq (car probe) 'binary))) probe))) (defcustom slime-net-coding-system (car (cl-find-if 'slime-find-coding-system slime-net-valid-coding-systems :key 'car)) "Coding system used for network connections. See also `slime-net-valid-coding-systems'." :type (cons 'choice (mapcar (lambda (x) (list 'const (car x))) slime-net-valid-coding-systems)) :group 'slime-lisp) ;;;;; slime-mode (defgroup slime-mode nil "Settings for slime-mode Lisp source buffers." :prefix "slime-" :group 'slime) (defcustom slime-find-definitions-function 'slime-find-definitions-rpc "Function to find definitions for a name. The function is called with the definition name, a string, as its argument." :type 'function :group 'slime-mode :options '(slime-find-definitions-rpc slime-etags-definitions (lambda (name) (append (slime-find-definitions-rpc name) (slime-etags-definitions name))) (lambda (name) (or (slime-find-definitions-rpc name) (and tags-table-list (slime-etags-definitions name)))))) ;; FIXME: remove one day (defcustom slime-complete-symbol-function 'nil "Obsolete. Use `slime-completion-at-point-functions' instead." :group 'slime-mode :type '(choice (const :tag "Compound" slime-complete-symbol*) (const :tag "Fuzzy" slime-fuzzy-complete-symbol))) (make-obsolete-variable 'slime-complete-symbol-function 'slime-completion-at-point-functions "2015-10-18") (defcustom slime-completion-at-point-functions '(slime-filename-completion slime-simple-completion-at-point) "List of functions to perform completion. Works like `completion-at-point-functions'. `slime--completion-at-point' uses this variable." :group 'slime-mode) ;;;;; slime-mode-faces (defgroup slime-mode-faces nil "Faces in slime-mode source code buffers." :prefix "slime-" :group 'slime-mode) (defface slime-error-face `((((class color) (background light)) (:underline "red")) (((class color) (background dark)) (:underline "red")) (t (:underline t))) "Face for errors from the compiler." :group 'slime-mode-faces) (defface slime-warning-face `((((class color) (background light)) (:underline "orange")) (((class color) (background dark)) (:underline "coral")) (t (:underline t))) "Face for warnings from the compiler." :group 'slime-mode-faces) (defface slime-style-warning-face `((((class color) (background light)) (:underline "brown")) (((class color) (background dark)) (:underline "gold")) (t (:underline t))) "Face for style-warnings from the compiler." :group 'slime-mode-faces) (defface slime-note-face `((((class color) (background light)) (:underline "brown4")) (((class color) (background dark)) (:underline "light goldenrod")) (t (:underline t))) "Face for notes from the compiler." :group 'slime-mode-faces) (defface slime-highlight-face '((t (:inherit highlight :underline nil))) "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 ,@(cl-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" '(:inherit font-lock-warning-face)) (section "the labels of major sections in the debugger buffer" '(:inherit header-line)) (frame-label "backtrace frame numbers" '(:inherit shadow)) (restart-type "restart names." '(: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") (restartable-frame-line "frames which are surely restartable" '(:foreground "lime green")) (non-restartable-frame-line "frames which are surely not restartable") (detailed-frame-line "function names and arguments in a detailed (expanded) frame") (local-name "local variable names" '(:inherit font-lock-variable-name-face)) (local-value "local variable values") (catch-tag "catch tags" '(:inherit highlight))) ;;;; Minor modes ;;;;; slime-mode (defvar slime-mode-indirect-map (make-sparse-keymap) "Empty keymap which has `slime-mode-map' as it's parent. This is a hack so that we can reinitilize the real slime-mode-map more easily. See `slime-init-keymaps'.") (defvar slime-buffer-connection) (defvar slime-dispatching-connection) (defvar slime-current-thread) (defun slime--on () (slime-setup-completion)) (defun slime--off () (remove-hook 'completion-at-point-functions #'slime--completion-at-point t)) (define-minor-mode slime-mode "\\\ 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}" :keymap slime-mode-indirect-map :lighter (:eval (slime-modeline-string)) (cond (slime-mode (slime--on)) (t (slime--off)))) ;;;;;; Modeline (defun slime-modeline-string () "Return the string to display in the modeline. \"Slime\" only appears if we aren't connected. If connected, include package-name, connection-name, and possibly some state information." (let ((conn (slime-current-connection))) ;; Bail out early in case there's no connection, so we won't ;; implicitly invoke `slime-connection' which may query the user. (if (not conn) (and slime-mode " Slime") (let ((local (eq conn slime-buffer-connection)) (pkg (slime-current-package))) (concat " " (if local "{" "[") (if pkg (slime-pretty-package-name pkg) "?") " " ;; ignore errors for closed connections (ignore-errors (slime-connection-name conn)) (slime-modeline-state-string conn) (if local "}" "]")))))) (defun slime-pretty-package-name (name) "Return a pretty version of a package name NAME." (cond ((string-match "^#?:\\(.*\\)$" name) (match-string 1 name)) ((string-match "^\"\\(.*\\)\"$" name) (match-string 1 name)) (t name))) (defun slime-modeline-state-string (conn) "Return a string possibly describing CONN's state." (cond ((not (eq (process-status conn) 'open)) (format " %s" (process-status conn))) ((let ((pending (length (slime-rex-continuations conn))) (sldbs (length (sldb-buffers conn)))) (cond ((and (zerop sldbs) (zerop pending)) nil) ((zerop sldbs) (format " %s" pending)) (t (format " %s/%s" pending sldbs))))))) (defun slime--recompute-modelines () (force-mode-line-update t)) ;;;;; Key bindings (defvar slime-parent-map nil "Parent keymap for shared between all Slime related modes.") (defvar slime-parent-bindings '(("\M-." slime-edit-definition) ("\M-," slime-pop-find-definition-stack) ("\M-_" slime-edit-uses) ; for German layout ("\M-?" slime-edit-uses) ; for USian layout ("\C-x4." slime-edit-definition-other-window) ("\C-x5." slime-edit-definition-other-frame) ("\C-x\C-e" slime-eval-last-expression) ("\C-\M-x" slime-eval-defun) ;; Include PREFIX keys... ("\C-c" slime-prefix-map))) (defvar slime-prefix-map nil "Keymap for commands prefixed with `slime-prefix-key'.") (defvar slime-prefix-bindings '(("\C-r" slime-eval-region) (":" slime-interactive-eval) ("\C-e" slime-interactive-eval) ("E" slime-edit-value) ("\C-l" slime-load-file) ("\C-b" slime-interrupt) ("\M-d" slime-disassemble-symbol) ("\C-t" slime-toggle-trace-fdefinition) ("I" slime-inspect) ("\C-xt" slime-list-threads) ("\C-xn" slime-next-connection) ("\C-xp" slime-prev-connection) ("\C-xc" slime-list-connections) ("<" slime-list-callers) (">" slime-list-callees) ;; Include DOC keys... ("\C-d" slime-doc-map) ;; Include XREF WHO-FOO keys... ("\C-w" slime-who-map) )) (defvar slime-editing-map nil "These keys are useful for buffers where the user can insert and edit s-exprs, e.g. for source buffers and the REPL.") (defvar slime-editing-keys `(;; Arglist display & completion (" " slime-space) ;; Evaluating ;;("\C-x\M-e" slime-eval-last-expression-display-output :inferior t) ("\C-c\C-p" slime-pprint-eval-last-expression) ;; Macroexpand ("\C-c\C-m" slime-expand-1) ("\C-c\M-m" slime-macroexpand-all) ;; Misc ("\C-c\C-u" slime-undefine-function) (,(kbd "C-M-.") slime-next-location) (,(kbd "C-M-,") slime-previous-location) ;; Obsolete, redundant bindings ("\C-c\C-i" completion-at-point) ;;("\M-*" pop-tag-mark) ; almost to clever )) (defvar slime-mode-map nil "Keymap for slime-mode.") (defvar slime-keys '( ;; Compiler notes ("\M-p" slime-previous-note) ("\M-n" slime-next-note) ("\C-c\M-c" slime-remove-notes) ("\C-c\C-k" slime-compile-and-load-file) ("\C-c\M-k" slime-compile-file) ("\C-c\C-c" slime-compile-defun))) (defun slime-nop () "The null command. Used to shadow currently-unused keybindings." (interactive) (call-interactively 'undefined)) (defvar slime-doc-map nil "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-documentation-lookup) (?~ common-lisp-hyperspec-format) (?g common-lisp-hyperspec-glossary-term) (?# common-lisp-hyperspec-lookup-reader-macro))) (defvar slime-who-map nil "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))) (defun slime-init-keymaps () "(Re)initialize the keymaps for `slime-mode'." (interactive) (slime-init-keymap 'slime-doc-map t t slime-doc-bindings) (slime-init-keymap 'slime-who-map t t slime-who-bindings) (slime-init-keymap 'slime-prefix-map t nil slime-prefix-bindings) (slime-init-keymap 'slime-parent-map nil nil slime-parent-bindings) (slime-init-keymap 'slime-editing-map nil nil slime-editing-keys) (set-keymap-parent slime-editing-map slime-parent-map) (slime-init-keymap 'slime-mode-map nil nil slime-keys) (set-keymap-parent slime-mode-map slime-editing-map) (set-keymap-parent slime-mode-indirect-map slime-mode-map)) (defun slime-init-keymap (keymap-name prefixp bothp bindings) (set keymap-name (make-sparse-keymap)) (when prefixp (define-prefix-command keymap-name)) (slime-bind-keys (eval keymap-name) bothp bindings)) (defun slime-bind-keys (keymap bothp bindings) "Add BINDINGS to KEYMAP. If BOTHP is true also add bindings with control modifier." (cl-loop for (key command) in bindings do (cond (bothp (define-key keymap `[,key] command) (unless (equal key ?h) ; But don't bind C-h (define-key keymap `[(control ,key)] command))) (t (define-key keymap key command))))) (slime-init-keymaps) (define-minor-mode slime-editing-mode "Minor mode which makes slime-editing-map available. \\{slime-editing-map}" nil nil slime-editing-map) ;;;; 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 slime-dcase (value &rest patterns) (declare (indent 1)) "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 (cl-gensym "op-")) (operands (cl-gensym "rand-")) (tmp (cl-gensym "tmp-"))) `(let* ((,tmp ,value) (,operator (car ,tmp)) (,operands (cdr ,tmp))) (cl-case ,operator ,@(mapcar (lambda (clause) (if (eq (car clause) t) `(t ,@(cdr clause)) (cl-destructuring-bind ((op &rest rands) &rest body) clause `(,op (cl-destructuring-bind ,rands ,operands . ,(or body '((ignore)) ; suppress some warnings )))))) patterns) ,@(if (eq (caar (last patterns)) t) '() `((t (error "slime-dcase failed: %S" ,tmp)))))))) (defmacro slime-define-keys (keymap &rest key-command) "Define keys in KEYMAP. Each KEY-COMMAND is a list of (KEY COMMAND)." (declare (indent 1)) `(progn . ,(mapcar (lambda (k-c) `(define-key ,keymap . ,k-c)) key-command))) (cl-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)" (declare (indent 2)) (let ((struct-var (cl-gensym "struct")) (reader (lambda (slot) (intern (concat (symbol-name conc-name) (symbol-name slot)))))) `(let ((,struct-var ,struct)) (cl-symbol-macrolet ,(mapcar (lambda (slot) (cl-etypecase slot (symbol `(,slot (,(funcall reader slot) ,struct-var))) (cons `(,(cl-first slot) (,(funcall reader (cl-second slot)) ,struct-var))))) slots) . ,body)))) ;;;;; Very-commonly-used functions (defvar slime-message-function 'message) ;; Interface (defun slime-buffer-name (type &optional hidden) (cl-assert (keywordp type)) (concat (if hidden " " "") (format "*slime-%s*" (substring (symbol-name type) 1)))) ;; 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)) (defun slime-display-warning (message &rest args) (display-warning '(slime warning) (apply #'format message args))) (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 (cl-position ?\n string) most-positive-fixnum) (1- (window-width (minibuffer-window)))))) ;; 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." (cond ((or current-prefix-arg query (not (slime-symbol-at-point))) (slime-read-from-minibuffer prompt (slime-symbol-at-point))) (t (slime-symbol-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." (declare (indent 1) (debug (sexp &rest form))) (let ((start (cl-gensym))) `(let ((,start (point))) (prog1 (progn ,@body) (add-text-properties ,start (point) ,props))))) (defun slime-add-face (face string) (declare (indent 1)) (add-text-properties 0 (length string) (list 'face face) string) string) ;; 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." (declare (indent 1)) (let ((start (cl-gensym)) (l (cl-gensym))) `(let ((,start (point)) (,l ,(or level '(current-column)))) (prog1 (progn ,@body) (slime-indent-rigidly ,start (point) ,l))))) (defun slime-indent-rigidly (start end column) ;; Similar to `indent-rigidly' but doesn't inherit text props. (let ((indent (make-string column ?\ ))) (save-excursion (goto-char end) (beginning-of-line) (while (and (<= start (point)) (progn (insert-before-markers indent) (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-property-bounds (prop) "Return two the positions of the previous and next changes to PROP. PROP is the name of a text property." (cl-assert (get-text-property (point) prop)) (let ((end (next-single-char-property-change (point) prop))) (list (previous-single-char-property-change end prop) end))) (defun slime-curry (fun &rest args) "Partially apply FUN to ARGS. The result is a new function. This idiom is preferred over `lexical-let'." `(lambda (&rest more) (apply ',fun (append ',args more)))) (defun slime-rcurry (fun &rest args) "Like `slime-curry' but ARGS on the right are applied." `(lambda (&rest more) (apply ',fun (append more ',args)))) ;;;;; Temporary popup buffers ;; keep compiler quiet (defvar slime-buffer-package) (defvar slime-buffer-connection) ;; Interface (cl-defmacro slime-with-popup-buffer ((name &key package connection select mode) &body body) "Similar to `with-output-to-temp-buffer'. Bind standard-output and initialize some buffer-local variables. Restore window configuration when closed. NAME is the name of the buffer to be created. PACKAGE is the value `slime-buffer-package'. CONNECTION is the value for `slime-buffer-connection', if nil, no explicit connection is associated with the buffer. If t, the current connection is taken. MODE is the name of a major mode which will be enabled. " (declare (indent 1)) (let ((package-sym (cl-gensym "package-")) (connection-sym (cl-gensym "connection-"))) `(let ((,package-sym ,(if (eq package t) `(slime-current-package) package)) (,connection-sym ,(if (eq connection t) `(slime-current-connection) connection))) (with-current-buffer (get-buffer-create ,name) (let ((inhibit-read-only t) (standard-output (current-buffer))) (erase-buffer) (funcall (or ,mode 'fundamental-mode)) (setq slime-buffer-package ,package-sym slime-buffer-connection ,connection-sym) (set-syntax-table lisp-mode-syntax-table) ,@body (slime-popup-buffer-mode 1) (funcall (if ,select 'pop-to-buffer 'display-buffer) (current-buffer)) (current-buffer)))))) (defvar slime-popup-buffer-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "q") 'quit-window) ;;("\C-c\C-z" . slime-switch-to-output-buffer) (define-key map (kbd "M-.") 'slime-edit-definition) map)) (define-minor-mode slime-popup-buffer-mode "Mode for displaying read only stuff" nil nil nil (setq buffer-read-only t)) (add-to-list 'minor-mode-alist `(slime-popup-buffer-mode (:eval (unless slime-mode (slime-modeline-string))))) (set-keymap-parent slime-popup-buffer-mode-map slime-parent-map) ;;;;; 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. (defvar slime-to-lisp-filename-function #'convert-standard-filename "Function to translate Emacs filenames to CL namestrings.") (defvar slime-from-lisp-filename-function #'identity "Function to translate CL namestrings to Emacs filenames.") (defun slime-to-lisp-filename (filename) "Translate the string FILENAME to a Lisp filename." (funcall slime-to-lisp-filename-function filename)) (defun slime-from-lisp-filename (filename) "Translate the Lisp filename FILENAME to an Emacs filename." (funcall slime-from-lisp-filename-function filename)) ;;;; 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 KEYWORD-ARGS) ...) NAME is a symbol for the implementation. PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. For KEYWORD-ARGS see `slime-start'. 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'") ;; dummy definitions for the compiler (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) (slime-setup) (let ((inferior-lisp-program (or command inferior-lisp-program)) (slime-net-coding-system (or coding-system slime-net-coding-system))) (slime-start* (cond ((and command (symbolp command)) (slime-lisp-options command)) (t (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 (cl-destructuring-bind (program &rest program-args) (split-string-and-unquote (read-shell-command "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)) (cl-assert (or (not name) table)) (cond (table (slime-lookup-lisp-implementation slime-lisp-implementations (or name slime-default-lisp (car (car table))))) (t (cl-destructuring-bind (program &rest args) (split-string inferior-lisp-program) (list :program program :program-args args)))))) (defun slime-lookup-lisp-implementation (table name) (let ((arguments (cl-rest (assoc name table)))) (unless arguments (error "Could not find lisp implementation with the name '%S'" name)) (when (and (= (length arguments) 1) (functionp (cl-first arguments))) (setf arguments (funcall (cl-first arguments)))) (cl-destructuring-bind ((prog &rest args) &rest keys) arguments (cl-list* :name name :program prog :program-args args keys)))) (cl-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 env) "Start a Lisp process and connect to it. This function is intended for programmatic use if `slime' is not flexible enough. PROGRAM and PROGRAM-ARGS are the filename and argument strings for the subprocess. 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 ENV environment variables for the subprocess (see `process-environment'). INIT-FUNCTION function to call right after the connection is established. BUFFER the name of the buffer to use for the subprocess. NAME a symbol to describe the Lisp implementation DIRECTORY change to this directory before starting the process. " (let ((args (list :program program :program-args program-args :buffer buffer :coding-system coding-system :init init :name name :init-function init-function :env env))) (slime-check-coding-system coding-system) (when (slime-bytecode-stale-p) (slime-urge-bytecode-recompile)) (let ((proc (slime-maybe-start-lisp program program-args env 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 interactive-p) "Connect to a running Swank server. Return the connection." (interactive (list (read-from-minibuffer "Host: " (cl-first slime-connect-host-history) nil nil '(slime-connect-host-history . 1)) (string-to-number (read-from-minibuffer "Port: " (cl-first slime-connect-port-history) nil nil '(slime-connect-port-history . 1))) nil t)) (slime-setup) (when (and interactive-p slime-net-processes (y-or-n-p "Close old connections first? ")) (slime-disconnect-all)) (message "Connecting to Swank on port %S.." port) (let* ((process (slime-net-connect host port)) (slime-dispatching-connection process)) (slime-setup-connection process))) ;; FIXME: seems redundant (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 (cl-copy-list options) :init-function init)))) ;;;;; 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." (let ((libfile (locate-library "slime"))) (when libfile (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." (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." (when (y-or-n-p "slime.elc is older than source. Recompile first? ") (slime-recompile-bytecode))) (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 env directory buffer) "Return a new or existing inferior lisp process." (cond ((not (comint-check-proc buffer)) (slime-start-lisp program program-args env directory buffer)) ((slime-reinitialize-inferior-lisp-p program program-args env buffer) (let ((conn (cl-find (get-buffer-process buffer) slime-net-processes :key #'slime-inferior-process))) (when conn (slime-net-close conn))) (get-buffer-process buffer)) (t (slime-start-lisp program program-args env directory (generate-new-buffer-name buffer))))) (defun slime-reinitialize-inferior-lisp-p (program program-args env 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) (equal (plist-get args :env) env) (not (y-or-n-p "Create an additional *inferior-lisp*? "))))) (defvar slime-inferior-process-start-hook nil "Hook called whenever a new process gets started.") (defun slime-start-lisp (program program-args env 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) (let ((process-environment (append env process-environment)) (process-connection-type nil)) (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) (run-hooks 'slime-inferior-process-start-hook) 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)) (defvar slime-inferior-lisp-args nil "A buffer local variable in the inferior proccess. See `slime-start'.") (defun slime-start-swank-server (process args) "Start a Swank server on the inferior lisp." (cl-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) "Return the initial process arguments. See `slime-start'." (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)))) ;; Return a single form to avoid problems with buffered input. (format "%S\n\n" `(progn (load ,(slime-to-lisp-filename (expand-file-name loader)) :verbose t) (funcall (read-from-string "swank-loader:init")) (funcall (read-from-string "swank:start-server") ,(slime-to-lisp-filename port-filename)))))) (defun slime-swank-port-file () "Filename where the SWANK server writes its TCP port number." (expand-file-name (format "slime.%S" (emacs-pid)) (slime-temp-directory))) (defun slime-temp-directory () (cond ((fboundp 'temp-directory) (temp-directory)) ((boundp 'temporary-file-directory) temporary-file-directory) (t "/tmp/"))) (defun slime-delete-swank-port-file (&optional quiet) (condition-case data (delete-file (slime-swank-port-file)) (error (cl-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) (slime-attempt-connection inferior-process nil 1)) (defun slime-attempt-connection (process retries attempt) ;; A small one-state machine to attempt a connection with ;; timer-based retries. (slime-cancel-connect-retry-timer) (let ((file (slime-swank-port-file))) (unless (active-minibuffer-window) (message "Polling %S .. %d (Abort with `M-x slime-abort-connection'.)" file attempt)) (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 "Gave up connecting to Swank after %d attempts." attempt)) ((eq (process-status process) 'exit) (message "Failed to connect to Swank: inferior process exited.")) (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))) (cl-assert (not slime-connect-retry-timer)) (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) ((debug 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)))) (cl-assert (integerp port)) port)))) (defun slime-toggle-debug-on-swank-error () (interactive) (if (slime-eval `(swank:toggle-debug-on-swank-error)) (message "Debug on SWANK error enabled.") (message "Debug on SWANK error disabled."))) ;;; 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!" "Are we consing yet?" ,(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 6-byte 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 () "Find the magic secret from the user's home directory. Return 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-send-secret (proc) (let ((secret (slime-secret))) (when secret (let* ((payload (encode-coding-string secret 'utf-8-unix)) (string (concat (slime-net-encode-length (length payload)) payload))) (process-send-string proc string))))) (defun slime-net-connect (host port) "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) (set-process-coding-system proc 'binary 'binary)) (slime-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) (set (make-local-variable 'kill-buffer-query-functions) nil)) 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 (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 (cl-second props) (boundp 'default-enable-multibyte-characters)) (cl-assert default-enable-multibyte-characters)) t)) (defun slime-coding-system-mulibyte-p (coding-system) (cl-second (slime-find-coding-system coding-system))) (defun slime-coding-system-cl-name (coding-system) (cl-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* ((payload (encode-coding-string (concat (slime-prin1-to-string sexp) "\n") 'utf-8-unix)) (string (concat (slime-net-encode-length (length payload)) payload))) (slime-log-event sexp) (process-send-string proc string))) (defun slime-safe-encoding-p (coding-system string) "Return true iff CODING-SYSTEM can safely encode STRING." (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)) ;;; 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-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-run-when-idle (function &rest args) "Call FUNCTION as soon as Emacs is idle." (apply #'run-at-time 0 nil function args)) (defun slime-handle-net-read-error (error) (let ((packet (buffer-string))) (slime-with-popup-buffer ((slime-buffer-name :error)) (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) (goto-char (point-min))) (cond ((y-or-n-p "Skip this packet? ") `(:emacs-skipped-packet ,packet)) (t (when (y-or-n-p "Enter debugger instead? ") (debug 'error error)) (signal (car error) (cdr error)))))) (defun slime-net-read-or-lose (process) (condition-case error (slime-net-read) (error (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 (+ (point) 6)) (end (+ start length))) (cl-assert (cl-plusp length)) (prog1 (save-restriction (narrow-to-region start end) (condition-case error (progn (decode-coding-region start end 'utf-8-unix) (setq end (point-max)) (read (current-buffer))) (error (slime-handle-net-read-error error)))) (delete-region (point-min) end)))) (defun slime-net-decode-length () (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16)) (defun slime-net-encode-length (n) (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." (let (print-escape-nonascii print-escape-newlines print-length print-level) (prin1-to-string sexp))) ;;;; 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) (or (slime-auto-select-connection) (error "No default connection selected."))) ((not conn) (or (slime-auto-start) (error "Not connected."))) ((not (eq (process-status conn) 'open)) (error "Connection closed.")) (t conn)))) (define-obsolete-variable-alias 'slime-auto-connect 'slime-auto-start "2.5") (defcustom slime-auto-start 'never "Controls auto connection when information from lisp process is needed. This doesn't mean it will connect right after Slime is loaded." :group 'slime-mode :type '(choice (const never) (const always) (const ask))) (defun slime-auto-start () (cond ((or (eq slime-auto-start 'always) (and (eq slime-auto-start 'ask) (y-or-n-p "No connection. Start Slime? "))) (save-window-excursion (slime) (while (not (slime-current-connection)) (sleep-for 1)) (slime-connection))) (t nil))) (defcustom slime-auto-select-connection 'ask "Controls auto selection after the default connection was closed." :group 'slime-mode :type '(choice (const never) (const always) (const ask))) (defun slime-auto-select-connection () (let* ((c0 (car slime-net-processes)) (c (cond ((eq slime-auto-select-connection 'always) c0) ((and (eq slime-auto-select-connection 'ask) (y-or-n-p (format "No default connection selected. %s %s? " "Switch to" (slime-connection-name c0)))) c0)))) (when c (slime-select-connection c) (message "Switching to connection: %s" (slime-connection-name c)) c))) (defun slime-select-connection (process) "Make PROCESS the default connection." (setq slime-default-connection process)) (defvar slime-cycle-connections-hook nil) (defun slime-cycle-connections-within (connections) (let* ((tail (or (cdr (member (slime-current-connection) connections)) connections)) ; loop around to the beginning (next (car tail))) (slime-select-connection next) (run-hooks 'slime-cycle-connections-hook) (message "Lisp: %s %s" (slime-connection-name next) (process-contact next)))) (defun slime-next-connection () "Change current slime connection, cycling through all connections." (interactive) (slime-cycle-connections-within (reverse slime-net-processes))) (define-obsolete-function-alias 'slime-cycle-connections 'slime-next-connection "2.13") (defun slime-prev-connection () "Change current slime connection, cycling through all connections. Goes in reverse order, relative to `slime-next-connection'." (interactive) (slime-cycle-connections-within slime-net-processes)) (cl-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))" (declare (indent 1)) `(with-current-buffer (process-buffer (or ,process (slime-connection) (error "No connection"))) ,@body)) ;;; 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'." (declare (indent 2)) (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)))) '(\, varname)))) (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-modules '() "The strings of Lisp's *MODULES*.") (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-lisp-implementation-program nil "The argv[0] of the process running 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.") (slime-def-connection-var slime-connection-coding-systems nil "Coding systems supported by 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) (cl-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. (let ((slime-current-thread t)) (slime-eval-async '(swank:connection-info) (slime-curry #'slime-set-connection-info proc)))) (defun slime-set-connection-info (connection info) "Initialize CONNECTION with INFO received from Lisp." (let ((slime-dispatching-connection connection) (slime-current-thread t)) (cl-destructuring-bind (&key pid style lisp-implementation machine features version modules encoding &allow-other-keys) info (slime-check-version version connection) (setf (slime-pid) pid (slime-communication-style) style (slime-lisp-features) features (slime-lisp-modules) modules) (cl-destructuring-bind (&key type name version program) lisp-implementation (setf (slime-lisp-implementation-type) type (slime-lisp-implementation-version) version (slime-lisp-implementation-name) name (slime-lisp-implementation-program) program (slime-connection-name) (slime-generate-connection-name name))) (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine (setf (slime-machine-instance) instance)) (cl-destructuring-bind (&key coding-systems) encoding (setf (slime-connection-coding-systems) coding-systems))) (let ((args (let ((p (slime-inferior-process))) (if p (slime-inferior-lisp-args p))))) (let ((name (plist-get args ':name))) (when name (unless (string= (slime-lisp-implementation-name) name) (setf (slime-connection-name) (slime-generate-connection-name (symbol-name name)))))) (slime-load-contribs) (run-hooks 'slime-connected-hook) (let ((fun (plist-get args ':init-function))) (when fun (funcall fun)))) (message "Connected. %s" (slime-random-words-of-encouragement)))) (defun slime-check-version (version conn) (or (equal version slime-protocol-version) (equal slime-protocol-version 'ignore) (y-or-n-p (format "Versions differ: %s (slime) vs. %s (swank). Continue? " slime-protocol-version version)) (slime-net-close conn) (top-level))) (defun slime-generate-connection-name (lisp-name) (cl-loop for i from 1 for name = lisp-name then (format "%s<%d>" lisp-name i) while (cl-find name slime-net-processes :key #'slime-connection-name :test #'equal) finally (cl-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 () "Close the current connection." (interactive) (slime-net-close (slime-connection))) (defun slime-disconnect-all () "Disconnect all connections." (interactive) (mapc #'slime-net-close slime-net-processes)) (defun slime-connection-port (connection) "Return the remote port number of CONNECTION." (cadr (process-contact connection))) (defun slime-process (&optional connection) "Return the Lisp process for CONNECTION (default `slime-connection'). 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)))) (cl-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 (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 (cl-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. (cl-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 `slime-dcase'. The result of the evaluation of SEXP is dispatched on CLAUSES. The result is either a sexp of the form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed asynchronously. Note: don't use backquote syntax for SEXP, because various Emacs versions cannot deal with that." (declare (indent 2)) (let ((result (cl-gensym))) `(lexical-let ,(cl-loop for var in saved-vars collect (cl-etypecase var (symbol (list var var)) (cons var))) (slime-dispatch-event (list :emacs-rex ,sexp ,package ,thread (lambda (,result) (slime-dcase ,result ,@continuations))))))) ;;; 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." (or slime-buffer-package (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)) (make-variable-buffer-local (defvar slime-package-cache nil "Cons of the form (buffer-modified-tick . package)")) ;; 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\\>[ \t']*" "\\([^)]+\\)[ \t]*)"))) (save-excursion (when (or (re-search-backward regexp nil t) (re-search-forward regexp nil t)) (match-string-no-properties 2))))) ;;; 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 (cl-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 "Reply to canceled synchronous eval request tag=%S sexp=%S" tag sexp)) (throw tag (list #'identity value))) ((:abort _condition) (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")) (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." (declare (indent 1)) (slime-rex (cont (buffer (current-buffer))) (sexp (or package (slime-current-package))) ((:ok result) (when cont (set-buffer buffer) (funcall cont result))) ((:abort condition) (message "Evaluation aborted on %s." condition))) ;; Guard against arbitrary return values which once upon a time ;; showed up in the minibuffer spuriously (due to a bug in ;; slime-autodoc.) If this ever happens again, returning the ;; following will make debugging much easier: :slime-eval-async) ;;; 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]")))) ;; UNUSED (defun slime-debugged-connection-p (conn) ;; This previously was (AND (SLDB-DEBUGGED-CONTINUATIONS CONN) T), ;; but an SLDB buffer may exist without having continuations ;; attached to it, e.g. the one resulting from `slime-interrupt'. (cl-loop for b in (sldb-buffers) thereis (with-current-buffer b (eq slime-buffer-connection conn)))) (defun slime-busy-p (&optional conn) "True if Lisp has outstanding requests. Debugged requests are ignored." (let ((debugged (sldb-debugged-continuations (or conn (slime-connection))))) (cl-remove-if (lambda (id) (memq id debugged)) (slime-rex-continuations) :key #'car))) (defun slime-sync () "Block until the most recent request has finished." (when (slime-rex-continuations) (let ((tag (caar (slime-rex-continuations)))) (while (cl-find tag (slime-rex-continuations) :key #'car) (accept-process-output nil 0.1))))) (defun slime-ping () "Check that communication works." (interactive) (message "%s" (slime-eval "PONG"))) ;;;;; Protocol event handler (cl-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) (slime-dcase event ((:emacs-rex form package thread continuation) (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) (slime-display-oneliner "; pipelined request... %S" form)) (let ((id (cl-incf (slime-continuation-counter)))) (slime-send `(:emacs-rex ,form ,package ,thread ,id)) (push (cons id continuation) (slime-rex-continuations)) (slime--recompute-modelines))) ((:return value id) (let ((rec (assq id (slime-rex-continuations)))) (cond (rec (setf (slime-rex-continuations) (remove rec (slime-rex-continuations))) (slime--recompute-modelines) (funcall (cdr rec) value)) (t (error "Unexpected reply: %S %S" id value))))) ((:debug-activate thread level &optional select) (cl-assert thread) (sldb-activate thread level select)) ((:debug thread level condition restarts frames conts) (cl-assert thread) (sldb-setup thread level condition restarts frames conts)) ((:debug-return thread level stepping) (cl-assert thread) (sldb-exit thread level stepping)) ((:emacs-interrupt thread) (slime-send `(:emacs-interrupt ,thread))) ((:channel-send id msg) (slime-channel-send (or (slime-find-channel id) (error "Invalid channel id: %S %S" id msg)) msg)) ((:emacs-channel-send id msg) (slime-send `(:emacs-channel-send ,id ,msg))) ((:read-from-minibuffer thread tag prompt initial-value) (slime-read-from-minibuffer-for-swank thread tag prompt initial-value)) ((:y-or-n-p thread tag question) (slime-y-or-n-p thread tag question)) ((:emacs-return-string thread tag string) (slime-send `(:emacs-return-string ,thread ,tag ,string))) ((:new-features features) (setf (slime-lisp-features) features)) ((:indentation-update info) (slime-handle-indentation-update info)) ((:eval-no-wait form) (slime-check-eval-in-emacs-enabled) (eval (read form))) ((: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 thread tag) (let ((hook (when (and thread tag) (slime-curry #'slime-send `(:emacs-return ,thread ,tag nil))))) (slime-open-inspector what nil hook))) ((:background-message message) (slime-background-message "%s" message)) ((:debug-condition thread message) (cl-assert thread) (message "%s" message)) ((:ping thread tag) (slime-send `(:emacs-pong ,thread ,tag))) ((:reader-error packet condition) (slime-with-popup-buffer ((slime-buffer-name :error)) (princ (format "Invalid protocol message:\n%s\n\n%s" condition packet)) (goto-char (point-min))) (error "Invalid protocol message")) ((:invalid-rpc id message) (setf (slime-rex-continuations) (cl-remove id (slime-rex-continuations) :key #'car)) (error "Invalid rpc: %s" message)) ((:emacs-skipped-packet _pkg)) ((:test-delay seconds) ; for testing only (sit-for seconds)))))) (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 and erase connection buffer." (interactive) (setf (slime-rex-continuations) '()) (mapc #'kill-buffer (sldb-buffers)) (slime-with-connection-buffer () (erase-buffer))) (defun slime-send-sigint () (interactive) (signal-process (slime-pid) 'SIGINT)) ;;;;; Channels ;;; A channel implements a set of operations. Those operations can be ;;; invoked by sending messages to the channel. Channels are used for ;;; protocols which can't be expressed naturally with RPCs, e.g. for ;;; streaming data over the wire. ;;; ;;; A channel can be "remote" or "local". Remote channels are ;;; represented by integers. Local channels are structures. Messages ;;; sent to a closed (remote) channel are ignored. (slime-def-connection-var slime-channels '() "Alist of the form (ID . CHANNEL).") (slime-def-connection-var slime-channels-counter 0 "Channel serial number counter.") (cl-defstruct (slime-channel (:conc-name slime-channel.) (:constructor slime-make-channel% (operations name id plist))) operations name id plist) (defun slime-make-channel (operations &optional name) (let* ((id (cl-incf (slime-channels-counter))) (ch (slime-make-channel% operations name id nil))) (push (cons id ch) (slime-channels)) ch)) (defun slime-close-channel (channel) (setf (slime-channel.operations channel) 'closed-channel) (let ((probe (assq (slime-channel.id channel) (slime-channels)))) (cond (probe (setf (slime-channels) (delete probe (slime-channels)))) (t (error "Invalid channel: %s" channel))))) (defun slime-find-channel (id) (cdr (assq id (slime-channels)))) (defun slime-channel-send (channel message) (apply (or (gethash (car message) (slime-channel.operations channel)) (error "Unsupported operation: %S %S" message channel)) channel (cdr message))) (defun slime-channel-put (channel prop value) (setf (slime-channel.plist channel) (plist-put (slime-channel.plist channel) prop value))) (defun slime-channel-get (channel prop) (plist-get (slime-channel.plist channel) prop)) (eval-and-compile (defun slime-channel-method-table-name (type) (intern (format "slime-%s-channel-methods" type)))) (defmacro slime-define-channel-type (name) (declare (indent defun)) (let ((tab (slime-channel-method-table-name name))) `(progn (defvar ,tab) (setq ,tab (make-hash-table :size 10))))) (defmacro slime-define-channel-method (type method args &rest body) (declare (indent 3) (debug (&define name sexp lambda-list def-body))) `(puthash ',method (lambda (self . ,args) . ,body) ,(slime-channel-method-table-name type))) (defun slime-send-to-remote-channel (channel-id msg) (slime-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) ;;;;; 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-buffer-name :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 () "Return or create the event log buffer." (or (get-buffer slime-event-buffer-name) (let ((buffer (get-buffer-create slime-event-buffer-name))) (with-current-buffer buffer (buffer-disable-undo) (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))) ;;;;; Cleanup after a quit (defun slime-restart-inferior-lisp () "Kill and restart the Lisp subprocess." (interactive) (cl-assert (slime-inferior-process) () "No inferior lisp process") (slime-quit-lisp-internal (slime-connection) 'slime-restart-sentinel t)) (defun slime-restart-sentinel (process _message) "Restart the inferior lisp process. Also rearrange windows." (cl-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) (plist-get args :env) nil buffer))) (slime-net-close process) (slime-inferior-connect new-proc args) (switch-to-buffer buffer) (goto-char (point-max)))) ;;;; Compilation and the creation of compiler-note annotations (defvar slime-highlight-compiler-notes t "*When non-nil annotate buffers with compilation notes etc.") (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.") ;; FIXME: remove some of the options (defcustom slime-compilation-finished-hook 'slime-maybe-show-compilation-log "Hook called with a list of compiler notes after a compilation." :group 'slime-mode :type 'hook :options '(slime-maybe-show-compilation-log slime-create-compilation-log slime-show-compilation-log slime-maybe-list-compiler-notes slime-list-compiler-notes slime-maybe-show-xrefs-for-notes slime-goto-first-note)) ;; FIXME: I doubt that anybody uses this directly and it seems to be ;; only an ugly way to pass arguments. (defvar slime-compilation-policy nil "When non-nil compile with these optimization settings.") (defun slime-compute-policy (arg) "Return the policy for the prefix argument ARG." (let ((between (lambda (min n max) (cond ((< n min) min) ((> n max) max) (t n))))) (let ((n (prefix-numeric-value arg))) (cond ((not arg) slime-compilation-policy) ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) ((eq arg '-) `((cl:speed . 3))) (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) (cl-defstruct (slime-compilation-result (:type list) (:conc-name slime-compilation-result.) (:constructor nil) (:copier nil)) tag notes successp duration loadp faslfile) (defvar slime-last-compilation-result nil "The result of the most recently issued compilation.") (defun slime-compiler-notes () "Return all compiler notes, warnings, and errors." (slime-compilation-result.notes slime-last-compilation-result)) (defun slime-compile-and-load-file (&optional policy) "Compile and load the buffer's file and highlight compiler notes. With (positive) prefix argument the file is compiled with maximal debug settings (`C-u'). With negative prefix argument it is compiled for speed (`M--'). If a numeric argument is passed set debug or speed settings to it depending on its sign. 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 "P") (slime-compile-file t (slime-compute-policy policy))) (defcustom slime-compile-file-options '() "Plist of additional options that C-c C-k should pass to Lisp. Currently only :fasl-directory is supported." :group 'slime-lisp :type '(plist :key-type symbol :value-type (file :must-match t))) (defun slime-compile-file (&optional load policy) "Compile current buffer's file and highlight resulting compiler notes. See `slime-compile-and-load-file' for further details." (interactive) (unless buffer-file-name (error "Buffer %s is not associated with a file." (buffer-name))) (check-parens) (slime--maybe-save-buffer) (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max)) (let ((file (slime-to-lisp-filename (buffer-file-name))) (options (slime-simplify-plist `(,@slime-compile-file-options :policy ,policy)))) (slime-eval-async `(swank:compile-file-for-emacs ,file ,(if load t nil) . ,(slime-hack-quotes options)) #'slime-compilation-finished) (message "Compiling %s..." file))) ;; FIXME: compilation-save-buffers-predicate was introduced in 24.1 (defun slime--maybe-save-buffer () (let ((slime--this-buffer (current-buffer))) (save-some-buffers (not compilation-ask-about-save) (lambda () (eq (current-buffer) slime--this-buffer))))) (defun slime-hack-quotes (arglist) ;; eval is the wrong primitive, we really want funcall (cl-loop for arg in arglist collect `(quote ,arg))) (defun slime-simplify-plist (plist) (cl-loop for (key val) on plist by #'cddr append (cond ((null val) '()) (t (list key val))))) (defun slime-compile-defun (&optional raw-prefix-arg) "Compile the current toplevel form. With (positive) prefix argument the form is compiled with maximal debug settings (`C-u'). With negative prefix argument it is compiled for speed (`M--'). If a numeric argument is passed set debug or speed settings to it depending on its sign." (interactive "P") (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) (if (use-region-p) (slime-compile-region (region-beginning) (region-end)) (apply #'slime-compile-region (slime-region-for-defun-at-point))))) (defun slime-compile-region (start end) "Compile the region." (interactive "r") ;; Check connection before running hooks things like ;; slime-flash-region don't make much sense if there's no connection (slime-connection) (slime-flash-region start end) (run-hook-with-args 'slime-before-compile-functions start end) (slime-compile-string (buffer-substring-no-properties start end) start)) (defun slime-flash-region (start end &optional timeout) "Temporarily highlight region from START to END." (let ((overlay (make-overlay start end))) (overlay-put overlay 'face 'secondary-selection) (run-with-timer (or timeout 0.2) nil 'delete-overlay overlay))) (defun slime-compile-string (string start-offset) (let* ((line (save-excursion (goto-char start-offset) (list (line-number-at-pos) (1+ (current-column))))) (position `((:position ,start-offset) (:line ,@line)))) (slime-eval-async `(swank:compile-string-for-emacs ,string ,(buffer-name) ',position ,(if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name))) ',slime-compilation-policy) #'slime-compilation-finished))) (defcustom slime-load-failed-fasl 'ask "Which action to take when COMPILE-FILE set FAILURE-P to T. NEVER doesn't load the fasl ALWAYS loads the fasl ASK asks the user." :type '(choice (const never) (const always) (const ask))) (defun slime-load-failed-fasl-p () (cl-ecase slime-load-failed-fasl (never nil) (always t) (ask (y-or-n-p "Compilation failed. Load fasl file anyway? ")))) (defun slime-compilation-finished (result) (with-struct (slime-compilation-result. notes duration successp loadp faslfile) result (setf slime-last-compilation-result result) (slime-show-note-counts notes duration (cond ((not loadp) successp) (t (and faslfile successp)))) (when slime-highlight-compiler-notes (slime-highlight-notes notes)) (run-hook-with-args 'slime-compilation-finished-hook notes) (when (and loadp faslfile (or successp (slime-load-failed-fasl-p))) (slime-eval-async `(swank:load-file ,faslfile))))) (defun slime-show-note-counts (notes secs successp) (message (concat (cond (successp "Compilation finished") (t (slime-add-face 'font-lock-warning-face "Compilation failed"))) (if (null notes) ". (No warnings)" ": ") (mapconcat (lambda (messages) (cl-destructuring-bind (sev . notes) messages (let ((len (length notes))) (format "%d %s%s" len (slime-severity-label sev) (if (= len 1) "" "s"))))) (sort (slime-alistify notes #'slime-note.severity #'eq) (lambda (x y) (slime-severity< (car y) (car x)))) " ") (if secs (format " [%.2f secs]" secs))))) (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)))))) (defvar slime-note-overlays '() "List of overlays created by `slime-make-note-overlay'") (defun slime-remove-old-overlays () "Delete the existing note overlays." (mapc #'delete-overlay slime-note-overlays) (setq slime-note-overlays '())) (defun slime-filter-buffers (predicate) "Return a list of where PREDICATE returns true. PREDICATE is executed in the buffer to test." (cl-remove-if-not (lambda (%buffer) (with-current-buffer %buffer (funcall predicate))) (buffer-list))) ;;;;; Recompilation. ;; FIXME: This whole idea is questionable since it depends so ;; crucially on precise source-locs. (defun slime-recompile-location (location) (save-excursion (slime-goto-source-location location) (slime-compile-defun))) (defun slime-recompile-locations (locations cont) (slime-eval-async `(swank:compile-multiple-strings-for-emacs ',(cl-loop for loc in locations collect (save-excursion (slime-goto-source-location loc) (cl-destructuring-bind (start end) (slime-region-for-defun-at-point) (list (buffer-substring-no-properties start end) (buffer-name) (slime-current-package) start (if (buffer-file-name) (slime-to-lisp-filename (buffer-file-name)) nil))))) ',slime-compilation-policy) cont)) ;;;;; 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 (cl-reduce #'slime-most-severe notes :key #'slime-note.severity)) (new-message (mapconcat #'slime-note.message notes "\n"))) (let ((new-note (cl-copy-list (car notes)))) (setf (cl-getf new-note :message) new-message) (setf (cl-getf new-note :severity) new-severity) new-note))) (defun slime-notes-in-same-location-p (a b) (equal (slime-note.location a) (slime-note.location b))) ;;;;; Compiler notes list (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-xrefs-for-notes (notes) (let ((xrefs)) (dolist (note notes) (let* ((location (cl-getf note :location)) (fn (cadr (assq :file (cdr location)))) (file (assoc fn xrefs)) (node (list (format "%s: %s" (cl-getf note :severity) (slime-one-line-ify (cl-getf note :message))) location))) (when fn (if file (push node (cdr file)) (setf xrefs (cl-acons fn (list node) xrefs)))))) xrefs)) (defun slime-maybe-show-xrefs-for-notes (notes) "Show the compiler notes NOTES if they come from more than one file." (let ((xrefs (slime-xrefs-for-notes notes))) (when (slime-length> xrefs 1) ; >1 file (slime-show-xrefs xrefs 'definition "Compiler notes" (slime-current-package))))) (defun slime-note-has-location-p (note) (not (eq ':error (car (slime-note.location note))))) (defun slime-redefinition-note-p (note) (eq (slime-note.severity note) :redefinition)) (defun slime-create-compilation-log (notes) "Create a buffer for `next-error' to use." (with-current-buffer (get-buffer-create (slime-buffer-name :compilation)) (let ((inhibit-read-only t)) (erase-buffer)) (slime-insert-compilation-log notes) (compilation-mode))) (defun slime-maybe-show-compilation-log (notes) "Display the log on failed compilations or if NOTES is non-nil." (slime-create-compilation-log notes) (with-struct (slime-compilation-result. notes duration successp) slime-last-compilation-result (unless successp (with-current-buffer (slime-buffer-name :compilation) (let ((inhibit-read-only t)) (goto-char (point-max)) (insert "Compilation " (if successp "succeeded." "failed.")) (goto-char (point-min)) (display-buffer (current-buffer))))))) (defun slime-show-compilation-log (notes) "Create and display the compilation log buffer." (interactive (list (slime-compiler-notes))) (slime-with-popup-buffer ((slime-buffer-name :compilation) :mode 'compilation-mode) (slime-insert-compilation-log notes))) (defun slime-insert-compilation-log (notes) "Insert NOTES in format suitable for `compilation-mode'." (cl-destructuring-bind (grouped-notes canonicalized-locs-table) (slime-group-and-sort-notes notes) (with-temp-message "Preparing compilation log..." (let ((inhibit-read-only t) (inhibit-modification-hooks t)) ; inefficient font-lock-hook (insert (format "cd %s\n%d compiler notes:\n\n" default-directory (length notes))) (dolist (notes grouped-notes) (let ((loc (gethash (cl-first notes) canonicalized-locs-table)) (start (point))) (insert (slime-canonicalized-location-to-string loc) ":") (slime-insert-note-group notes) (insert "\n") (slime-make-note-overlay (cl-first notes) start (1- (point)))))) (set (make-local-variable 'compilation-skip-threshold) 0) (setq next-error-last-buffer (current-buffer))))) (defun slime-insert-note-group (notes) "Insert a group of compiler messages." (insert "\n") (dolist (note notes) (insert " " (slime-severity-label (slime-note.severity note)) ": ") (let ((start (point))) (insert (slime-note.message note)) (let ((ctx (slime-note.source-context note))) (if ctx (insert "\n" ctx))) (slime-indent-block start 4)) (insert "\n"))) (defun slime-indent-block (start column) "If the region back to START isn't a one-liner indent it." (when (< start (line-beginning-position)) (save-excursion (goto-char start) (insert "\n")) (slime-indent-rigidly start (point) column))) (defun slime-canonicalized-location (location) "Return a list (FILE LINE COLUMN) for slime-location LOCATION. This is quite an expensive operation so use carefully." (save-excursion (slime-goto-location-buffer (slime-location.buffer location)) (save-excursion (slime-goto-source-location location) (list (or (buffer-file-name) (buffer-name)) (save-restriction (widen) (line-number-at-pos)) (1+ (current-column)))))) (defun slime-canonicalized-location-to-string (loc) (if loc (cl-destructuring-bind (filename line col) loc (format "%s:%d:%d" (cond ((not filename) "") ((let ((rel (file-relative-name filename))) (if (< (length rel) (length filename)) rel))) (t filename)) line col)) (format "Unknown location"))) (defun slime-goto-note-in-compilation-log (note) "Find `note' in the compilation log and display it." (with-current-buffer (get-buffer (slime-buffer-name :compilation)) (let ((pos (save-excursion (goto-char (point-min)) (cl-loop for overlay = (slime-find-next-note) while overlay for other-note = (overlay-get overlay 'slime-note) when (slime-notes-in-same-location-p note other-note) return (overlay-start overlay))))) (when pos (slime--display-position pos nil 0))))) (defun slime-group-and-sort-notes (notes) "First sort, then group NOTES according to their canonicalized locs." (let ((locs (make-hash-table :test #'eq))) (mapc (lambda (note) (let ((loc (slime-note.location note))) (when (slime-location-p loc) (puthash note (slime-canonicalized-location loc) locs)))) notes) (list (slime-group-similar (lambda (n1 n2) (equal (gethash n1 locs nil) (gethash n2 locs t))) (let* ((bottom most-negative-fixnum) (+default+ (list "" bottom bottom))) (sort notes (lambda (n1 n2) (cl-destructuring-bind ((filename1 line1 col1) (filename2 line2 col2)) (list (gethash n1 locs +default+) (gethash n2 locs +default+)) (cond ((string-lessp filename1 filename2) t) ((string-lessp filename2 filename1) nil) ((< line1 line2) t) ((> line1 line2) nil) (t (< col1 col2)))))))) locs))) (defun slime-note.severity (note) (plist-get note :severity)) (defun slime-note.message (note) (plist-get note :message)) (defun slime-note.source-context (note) (plist-get note :source-context)) (defun slime-note.location (note) (plist-get note :location)) (defun slime-severity-label (severity) (cl-subseq (symbol-name severity) 1)) ;;;;; 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." (cl-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-make-note-overlay (note start end) (let ((overlay (make-overlay start end))) (overlay-put overlay 'slime-note note) (push overlay slime-note-overlays) overlay)) (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 (slime-make-note-overlay note start end))) (cl-macrolet ((putp (name value) `(overlay-put overlay ,name ,value))) (putp 'face (slime-severity-face severity)) (putp 'severity severity) (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." (cl-macrolet ((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 (slime-dcase location ((:error _)) ; do nothing ((:location file pos _hints) (cond ((eq (car file) ':source-form) nil) ((eq (slime-note.severity note) :read-error) (slime-choose-overlay-for-read-error location)) ((equal pos '(:eof)) (cl-values (1- (point-max)) (point-max))) (t (slime-choose-overlay-for-sexp location)))))))) (defun slime-choose-overlay-for-read-error (location) (let ((pos (slime-location-offset location))) (save-excursion (goto-char pos) (cond ((slime-symbol-at-point) ;; package not found, &c. (cl-values (slime-symbol-start-pos) (slime-symbol-end-pos))) (t (cl-values pos (1+ pos))))))) (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)) (cl-values start (point)) (cl-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)))) (defvar slime-severity-face-plist '(:error slime-error-face :read-error slime-error-face :warning slime-warning-face :redefinition slime-style-warning-face :style-warning slime-style-warning-face :note slime-note-face)) (defun slime-severity-face (severity) "Return the name of the font-lock face representing SEVERITY." (or (plist-get slime-severity-face-plist severity) (error "No face for: %S" severity))) (defvar slime-severity-order '(:note :style-warning :redefinition :warning :error :read-error)) (defun slime-severity< (sev1 sev2) "Return true if SEV1 is less severe than SEV2." (< (cl-position sev1 slime-severity-order) (cl-position sev2 slime-severity-order))) (defun slime-most-severe (sev1 sev2) "Return the most servere of two conditions." (if (slime-severity< sev1 sev2) sev2 sev1)) ;; 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)) (let ((source-path (cdr source-path))) (when 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 (cl-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))))) ;; FIXME: really fix this mess ;; FIXME: the check shouln't be done here anyway but by M-. itself. (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 (split-string (file-name-directory target-filename) "/" t)) (buffer-dirs (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. (cl-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 (let ((concat-dirs (lambda (dirs) (apply #'concat (mapcar #'file-name-as-directory dirs)))) (pos (cl-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 ; PUSH reversed for us! (funcall concat-dirs target-suffix-dirs)) (buffer-root (funcall concat-dirs (reverse (nthcdr pos buffer-dirs*))))) (cl-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)) (let ((base-dirs (split-string base-dirname "/" t)) (contrast-dirs (split-string contrast-dirname "/" t))) (with-temp-buffer (cl-loop initially (insert (slime-filesystem-toplevel-directory)) for base-dir in base-dirs do (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) (cond ((not pos) (slime-insert-propertized '(face highlight) base-dir) (insert "/")) (t (insert (file-name-as-directory 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 (cl-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) (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-check-location-filename-sanity (filename) (when slime-warn-when-possibly-tricked-by-M-. (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) (let ((target-filename (truename-safe filename)) (buffer-filename (truename-safe (buffer-file-name)))) (when (and target-filename buffer-filename) (slime-maybe-warn-for-different-source-root target-filename buffer-filename)))))) (defun slime-check-location-buffer-name-sanity (buffer-name) (slime-check-location-filename-sanity (buffer-file-name (get-buffer buffer-name)))) (defun slime-goto-location-buffer (buffer) (slime-dcase buffer ((:file filename) (let ((filename (slime-from-lisp-filename filename))) (slime-check-location-filename-sanity filename) (set-buffer (or (get-file-buffer filename) (let ((find-file-suppress-same-file-warnings t)) (find-file-noselect filename)))))) ((:buffer buffer-name) (slime-check-location-buffer-name-sanity buffer-name) (set-buffer buffer-name)) ((:buffer-and-file buffer filename) (slime-goto-location-buffer (if (get-buffer buffer) (list :buffer buffer) (list :file filename)))) ((:source-form string) (set-buffer (get-buffer-create (slime-buffer-name :source))) (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) (slime-dcase position ((:position pos) (goto-char 1) (forward-char (- (1- pos) (slime-eol-conversion-fixup (1- pos))))) ((:offset start offset) (goto-char start) (forward-char offset)) ((:line start &optional column) (goto-char (point-min)) (beginning-of-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))) (goto-char (point-min)) (when (or (re-search-forward (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" (regexp-quote 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)))) ((:eof) (goto-char (point-max))))) (defun slime-eol-conversion-fixup (n) ;; Return the number of \r\n eol markers that we need to cross when ;; moving N chars forward. N is the number of chars but \r\n are ;; counted as 2 separate chars. (cl-case (coding-system-eol-type buffer-file-coding-system) ((1) (save-excursion (cl-do ((pos (+ (point) n)) (count 0 (1+ count))) ((>= (point) pos) (1- count)) (forward-line) (cl-decf pos)))) (t 0))) (defun slime-search-method-location (name specializers qualifiers) ;; Look for a sequence of words (def 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" (cl-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]")) (case-fold-search 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-search-edit-path (edit-path) "Move to EDIT-PATH starting at the current toplevel form." (when edit-path (unless (and (= (current-column) 0) (looking-at "(")) (beginning-of-defun)) (slime-forward-source-path edit-path))) (defun slime-goto-source-location (location &optional noerror) "Move to the source location LOCATION. Several kinds of locations are supported: ::= (:location ) | (:error ) ::= (:file ) | (:buffer ) | (:buffer-and-file ) | (:source-form ) | (:zip ) ::= (:position ) ; 1 based (for files) | (:offset ) ; start+offset (for C-c C-c) | (:line []) | (:function-name ) | (:source-path ) | (:method . )" (slime-dcase location ((:location buffer _position _hints) (slime-goto-location-buffer buffer) (let ((pos (slime-location-offset location))) (cond ((and (<= (point-min) pos) (<= pos (point-max)))) (widen-automatically (widen)) (t (error "Location is outside accessible part of buffer"))) (goto-char pos))) ((:error message) (if noerror (slime-message "%s" message) (error "%s" message))))) (defun slime-location-offset (location) "Return the position, as character number, of LOCATION." (save-restriction (widen) (condition-case nil (slime-goto-location-position (slime-location.position location)) (error (goto-char 0))) (cl-destructuring-bind (&key snippet edit-path call-site align) (slime-location.hints location) (when snippet (slime-isearch snippet)) (when edit-path (slime-search-edit-path edit-path)) (when call-site (slime-search-call-site call-site)) (when align (slime-forward-sexp) (beginning-of-sexp))) (point))) ;;;;; 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 "") (cl-loop for i from 1 to (length string) while (funcall search-fn (substring string 0 i) nil t) for match-data = (match-data) do (cl-case search-fn (search-forward (goto-char (match-beginning 0))) (search-backward (goto-char (1+ (match-end 0))))) finally (cl-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 (defun slime-next-note () "Go to and describe the next compiler note in the buffer." (interactive) (let ((here (point)) (note (slime-find-next-note))) (if note (slime-show-note note) (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)) (note (slime-find-previous-note))) (if note (slime-show-note note) (goto-char here) (message "No previous note.")))) (defun slime-goto-first-note (&rest _) "Go to the first note in the buffer." (let ((point (point))) (goto-char (point-min)) (cond ((slime-find-next-note) (slime-show-note (slime-note-at-point))) (t (goto-char point))))) (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) (if (get-buffer-window (slime-buffer-name :compilation) t) (slime-goto-note-in-compilation-log (overlay-get overlay 'slime-note)) (let ((message (get-char-property (point) 'help-echo))) (slime-message "%s" (if (zerop (length message)) "\"\"" message))))) ;; FIXME: could probably use flash region (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 with a timer." (run-with-timer 0.2 nil #'overlay-put overlay 'face (overlay-get overlay 'face)) (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." (cl-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-note)) (defun slime-note-overlays-at-point () "Return a list of all note overlays that are under the point." (cl-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 the note overlay if such a position is found, otherwise nil." (slime-search-property 'slime-note nil #'slime-note-at-point)) (defun slime-find-previous-note () "Go to the next position with the `slime-note' text property. Retuns the note overlay if such a position is found, otherwise nil." (slime-search-property 'slime-note t #'slime-note-at-point)) ;;;; 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) (slime-echo-arglist)) (put 'slime-space 'delete-selection t) ; for delete-section-mode & CUA (defun slime-echo-arglist () (when (slime-background-activities-enabled-p) (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)))))))) (defvar slime-operator-before-point-function 'slime-lisp-operator-before-point) (defun slime-operator-before-point () (funcall slime-operator-before-point-function)) (defun slime-lisp-operator-before-point () (ignore-errors (save-excursion (backward-up-list 1) (down-list 1) (slime-symbol-at-point)))) ;;;; Completion ;; FIXME: use this in Emacs 24 ;;(define-obsolete-function-alias slime-complete-symbol completion-at-point) (defalias 'slime-complete-symbol #'completion-at-point) (make-obsolete 'slime-complete-symbol #'completion-at-point "2015-10-17") ;; This is the function that we add to ;; `completion-at-point-functions'. For backward-compatibilty we look ;; at `slime-complete-symbol-function' first. The indirection through ;; `slime-completion-at-point-functions' is used so that users don't ;; have to set `completion-at-point-functions' in every slime-like ;; buffer. (defun slime--completion-at-point () (cond (slime-complete-symbol-function slime-complete-symbol-function) (t (run-hook-with-args-until-success 'slime-completion-at-point-functions)))) (defun slime-setup-completion () (add-hook 'completion-at-point-functions #'slime--completion-at-point nil t)) (defun slime-simple-completion-at-point () "Complete the symbol at point. Perform completion similar to `elisp-completion-at-point'." (let* ((end (point)) (beg (slime-symbol-start-pos))) (list beg end (completion-table-dynamic #'slime-simple-completions)))) (defun slime-filename-completion () "If point is at a string starting with \", complete it as filename. Return nil if point is not at filename." (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" (max (point-min) (- (point) 1000)) t)) (let ((comint-completion-addsuffix '("/" . "\""))) (comint-filename-completion)))) ;; FIXME: for backward compatibility. Remove it one day ;; together with slime-complete-symbol-function. (defun slime-simple-complete-symbol () (let ((completion-at-point-functions '(slime-maybe-complete-as-filename slime-simple-completion-at-point))) (completion-at-point))) ;; NOTE: the original idea was to bind this to TAB but that no longer ;; works as `completion-at-point' sets a transient keymap that ;; overrides TAB. So this is rather useless now. (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)) (completion-at-point)) ((memq (char-before) '(?\t ?\ )) (slime-echo-arglist)))))) (make-obsolete 'slime-indent-and-complete-symbol "Set tab-always-indent to 'complete." "2015-10-18") (defvar slime-minibuffer-map (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) (define-key map "\t" #'completion-at-point) (define-key map "\M-\t" #'completion-at-point) map) "Minibuffer keymap used for reading CL expressions.") (defvar slime-minibuffer-history '() "History list of expressions read from the minibuffer.") (defun slime-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) (slime-setup-completion))) minibuffer-setup-hook)) (defun slime-read-from-minibuffer (prompt &optional initial-value history) "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 (slime-minibuffer-setup-hook))) (read-from-minibuffer prompt initial-value slime-minibuffer-map nil (or history 'slime-minibuffer-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) (cl-destructuring-bind (completions _partial) (let ((slime-current-thread t)) (slime-eval `(swank:simple-completions ,(substring-no-properties prefix) ',(slime-current-package)))) completions)) ;;;; Edit definition (defun slime-push-definition-stack () "Add point to find-tag-marker-ring." (require 'etags) (ring-insert find-tag-marker-ring (point-marker))) (defun slime-pop-find-definition-stack () "Pop the edit-definition stack and goto the location." (interactive) (pop-tag-mark)) (cl-defstruct (slime-xref (:conc-name slime-xref.) (:type list)) dspec location) (cl-defstruct (slime-location (:conc-name slime-location.) (:type list) (:constructor nil) (:copier nil)) tag buffer position hints) (defun slime-location-p (o) (and (consp o) (eq (car o) :location))) (defun slime-xref-has-location-p (xref) (slime-location-p (slime-xref.location xref))) (defun make-slime-buffer-location (buffer-name position &optional hints) `(:location (:buffer ,buffer-name) (:position ,position) ,(when hints `(:hints ,hints)))) (defun make-slime-file-location (file-name position &optional hints) `(:location (:file ,file-name) (:position ,position) ,(when hints `(:hints ,hints)))) ;;; The hooks are tried in order until one succeeds, otherwise the ;;; default implementation involving `slime-find-definitions-function' ;;; is used. The hooks are called with the same arguments as ;;; `slime-edit-definition'. (defvar slime-edit-definition-hooks) (defun slime-edit-definition (&optional name 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 (or (and (not current-prefix-arg) (slime-symbol-at-point)) (slime-read-symbol-name "Edit Definition of: ")))) ;; The hooks might search for a name in a different manner, so don't ;; ask the user if it's missing before the hooks are run (or (run-hook-with-args-until-success 'slime-edit-definition-hooks name where) (slime-edit-definition-cont (slime-find-definitions name) name where))) (defun slime-edit-definition-cont (xrefs name where) (cl-destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs) (cond ((null xrefs) (error "No known definition for: %s (in %s)" name (slime-current-package))) (1loc (slime-push-definition-stack) (slime-pop-to-location (slime-xref.location (car xrefs)) where)) ((slime-length= xrefs 1) ; ((:error "...")) (error "%s" (cadr (slime-xref.location (car xrefs))))) (t (slime-push-definition-stack) (slime-show-xrefs file-alist 'definition name (slime-current-package)))))) (defvar slime-edit-uses-xrefs '(:calls :macroexpands :binds :references :sets :specializes)) ;;; FIXME. TODO: Would be nice to group the symbols (in each ;;; type-group) by their home-package. (defun slime-edit-uses (symbol) "Lookup all the uses of SYMBOL." (interactive (list (slime-read-symbol-name "Edit Uses of: "))) (slime-xrefs slime-edit-uses-xrefs symbol (lambda (xrefs type symbol package) (cond ((null xrefs) (message "No xref information found for %s." symbol)) ((and (slime-length= xrefs 1) ; one group (slime-length= (cdar xrefs) 1)) ; one ref in group (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) (slime-push-definition-stack) (slime-pop-to-location loc))) (t (slime-push-definition-stack) (slime-show-xref-buffer xrefs type symbol package)))))) (defun slime-analyze-xrefs (xrefs) "Find common filenames in XREFS. Return a list (SINGLE-LOCATION FILE-ALIST). SINGLE-LOCATION is true if all xrefs point to the same location. FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." (list (and xrefs (let ((loc (slime-xref.location (car xrefs)))) (and (slime-location-p loc) (cl-every (lambda (x) (equal (slime-xref.location x) loc)) (cdr xrefs))))) (slime-alistify xrefs #'slime-xref-group #'equal))) (defun slime-xref-group (xref) (cond ((slime-xref-has-location-p xref) (slime-dcase (slime-location.buffer (slime-xref.location xref)) ((:file filename) filename) ((:buffer bufname) (let ((buffer (get-buffer bufname))) (if buffer (format "%S" buffer) ; "#" (format "%s (previously existing buffer)" bufname)))) ((:buffer-and-file _buffer filename) filename) ((:source-form _) "(S-Exp)") ((:zip _zip entry) entry))) (t "(No location)"))) (defun slime-pop-to-location (location &optional where) (slime-goto-source-location location) (cl-ecase where ((nil) (switch-to-buffer (current-buffer))) (window (pop-to-buffer (current-buffer) t)) (frame (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t))))) (defun slime-postprocess-xref (original-xref) "Process (for normalization purposes) an Xref comming directly from SWANK before the rest of Slime sees it. In particular, convert ETAGS based xrefs to actual file+position based locations." (if (not (slime-xref-has-location-p original-xref)) (list original-xref) (let ((loc (slime-xref.location original-xref))) (slime-dcase (slime-location.buffer loc) ((:etags-file tags-file) (slime-dcase (slime-location.position loc) ((:tag &rest tags) (visit-tags-table tags-file) (mapcar (lambda (xref) (let ((old-dspec (slime-xref.dspec original-xref)) (new-dspec (slime-xref.dspec xref))) (setf (slime-xref.dspec xref) (format "%s: %s" old-dspec new-dspec)) xref)) (cl-mapcan #'slime-etags-definitions tags))))) (t (list original-xref)))))) (defun slime-postprocess-xrefs (xrefs) (cl-mapcan #'slime-postprocess-xref xrefs)) (defun slime-find-definitions (name) "Find definitions for NAME." (slime-postprocess-xrefs (funcall slime-find-definitions-function name))) (defun slime-find-definitions-rpc (name) (slime-eval `(swank:find-definitions-for-emacs ,name))) (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 ((xrefs (slime-etags-definitions name))) (cond (xrefs (message "Using tag file...") (slime-edit-definition-cont xrefs name nil)) (t (error "No known definition for: %s" name))))) (defun slime-etags-to-locations (name) "Search for definitions matching `name' in the currently active tags table. Return a possibly empty list of slime-locations." (let ((locs '())) (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) (cl-destructuring-bind (hint line &rest pos) (etags-snarf-tag) (unless (eq hint t) ; hint==t if we are in a filename line (push `(:location (:file ,(expand-file-name (file-of-tag))) (:line ,line) (:snippet ,hint)) locs)))))) (nreverse locs)))) (defun slime-etags-definitions (name) "Search definitions matching NAME in the tags file. The result is a (possibly empty) list of definitions." (mapcar (lambda (loc) (make-slime-xref :dspec (cl-second (slime-location.hints loc)) :location loc)) (slime-etags-to-locations name))) ;;;;; 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-lisp-readable-p (x) (or (stringp x) (memq x '(nil t)) (integerp x) (keywordp x) (and (consp x) (let ((l x)) (while (consp l) (slime-lisp-readable-p (car x)) (setq l (cdr l))) (slime-lisp-readable-p l))))) (defun slime-eval-for-lisp (thread tag form-string) (let ((ok nil) (value nil) (error nil) (c (slime-connection))) (unwind-protect (condition-case err (progn (slime-check-eval-in-emacs-enabled) (setq value (eval (read form-string))) (setq ok t)) ((debug error) (setq error err))) (let ((result (cond ((and ok (not (slime-lisp-readable-p value))) `(:unreadable ,(slime-prin1-to-string value))) (ok `(:ok ,value)) (error `(:error ,(symbol-name (car error)) . ,(mapcar #'slime-prin1-to-string (cdr error)))) (t `(: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 (concat "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 FILENAME &key LINE COLUMN POSITION), A function name (:function-name STRING) nil. This is for use in the implementation of COMMON-LISP:ED." (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)) (when what (slime-dcase what ((:filename file &key line column position bytep) (find-file (slime-from-lisp-filename file)) (when line (slime-goto-line line)) (when column (move-to-column column)) (when position (goto-char (if bytep (byte-to-position position) position)))) ((:function-name name) (slime-edit-definition name))))) (defun slime-goto-line (line-number) "Move to line LINE-NUMBER (1-based). This is similar to `goto-line' but without pushing the mark and the display stuff that we neither need nor want." (cl-assert (= (buffer-size) (- (point-max) (point-min))) () "slime-goto-line in narrowed buffer") (goto-char (point-min)) (forward-line (1- line-number))) (defun slime-y-or-n-p (thread tag question) (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question)))) (defun slime-read-from-minibuffer-for-swank (thread tag prompt initial-value) (let ((answer (condition-case nil (slime-read-from-minibuffer prompt initial-value) (quit nil)))) (slime-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) ;;;; 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: "))) (cl-case current-prefix-arg ((nil) (slime-eval-with-transcript `(swank:interactive-eval ,string))) ((-) (slime-eval-save string)) (t (slime-eval-print string)))) (defvar slime-transcript-start-hook nil "Hook run before start an evalution.") (defvar slime-transcript-stop-hook nil "Hook run after finishing a evalution.") (defun slime-display-eval-result (value) (slime-message "%s" value)) (defun slime-eval-with-transcript (form) "Eval FORM in Lisp. Display output, if any." (run-hooks 'slime-transcript-start-hook) (slime-rex () (form) ((:ok value) (run-hooks 'slime-transcript-stop-hook) (slime-display-eval-result value)) ((:abort condition) (run-hooks 'slime-transcript-stop-hook) (message "Evaluation aborted on %s." condition)))) (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) (lambda (result) (cl-destructuring-bind (output value) result (push-mark) (insert output value))))) (defun slime-eval-save (string) "Evaluate STRING in Lisp and save the result in the kill ring." (slime-eval-async `(swank:eval-and-grab-output ,string) (lambda (result) (cl-destructuring-bind (output value) result (let ((string (concat output value))) (kill-new string) (message "Evaluation finished; pushed result to kill ring.")))))) (defun slime-eval-describe (form) "Evaluate FORM in Lisp and display the result in a new buffer." (slime-eval-async form (slime-rcurry #'slime-show-description (slime-current-package)))) (defvar slime-description-autofocus nil "If non-nil select description windows on display.") (defun slime-show-description (string package) ;; So we can have one description buffer open per connection. Useful ;; for comparing the output of DISASSEMBLE across implementations. ;; FIXME: could easily be achieved with M-x rename-buffer (let ((bufname (slime-buffer-name :description))) (slime-with-popup-buffer (bufname :package package :connection t :select slime-description-autofocus) (princ string) (goto-char (point-min))))) (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-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-pprint-eval-region (start end) "Evaluate region; pprint the value in a buffer." (interactive "r") (slime-eval-describe `(swank:pprint-eval ,(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)) ;;;; Edit Lisp value ;;; (defun slime-edit-value (form-string) "\\\ 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-Value" '(("\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))) (buffer (slime-with-popup-buffer (name :package package :connection t :select t :mode 'lisp-mode) (slime-popup-buffer-mode -1) ; don't want binding of 'q' (slime-mode 1) (slime-edit-value-mode 1) (setq slime-edit-form-string form-string) (insert current-value) (current-buffer)))) (with-current-buffer buffer (setq buffer-read-only nil) (message "Type C-c C-c when done")))) (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 (quit-window t)))))))) ;;;; Tracing (defun slime-untrace-all () "Untrace all functions." (interactive) (slime-eval `(swank:untrace-all))) (defun slime-toggle-trace-fdefinition (spec) "Toggle trace." (interactive (list (slime-read-from-minibuffer "(Un)trace: " (slime-symbol-at-point)))) (message "%s" (slime-eval `(swank:swank-toggle-trace ,spec)))) (defun slime-disassemble-symbol (symbol-name) "Display the disassembly for SYMBOL-NAME." (interactive (list (slime-read-symbol-name "Disassemble: "))) (slime-eval-describe `(swank:disassemble-form ,(concat "'" 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-unintern-symbol (symbol-name package) "Unintern the symbol given with SYMBOL-NAME PACKAGE." (interactive (list (slime-read-symbol-name "Unintern symbol: " t) (slime-read-package-name "from package: " (slime-current-package)))) (slime-eval-async `(swank:unintern-symbol ,symbol-name ,package) (lambda (result) (message "%s" result)))) (defun slime-delete-package (package-name) "Delete the package with name PACKAGE-NAME." (interactive (list (slime-read-package-name "Delete package: " (slime-current-package)))) (slime-eval-async `(cl:delete-package (swank::guess-package ,package-name)))) (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)))) (defvar slime-change-directory-hooks nil "Hook run by `slime-change-directory'. The functions are called with the new (absolute) directory.") (defun slime-change-directory (directory) "Make DIRECTORY become Lisp's current directory. Return whatever swank:set-default-directory returns." (let ((dir (expand-file-name directory))) (prog1 (slime-eval `(swank:set-default-directory ,(slime-to-lisp-filename dir))) (slime-with-connection-buffer nil (cd-absolute dir)) (run-hook-with-args 'slime-change-directory-hooks dir)))) (defun slime-cd (directory) "Make DIRECTORY become Lisp's current directory. Return whatever swank:set-default-directory returns." (interactive (list (read-directory-name "Directory: " nil nil t))) (message "default-directory: %s" (slime-change-directory directory))) (defun slime-pwd () "Show Lisp's default directory." (interactive) (message "Directory %s" (slime-eval `(swank:default-directory)))) ;;;; Profiling (defun slime-toggle-profile-fdefinition (fname-string) "Toggle profiling for FNAME-STRING." (interactive (list (slime-read-from-minibuffer "(Un)Profile: " (slime-symbol-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:swank-profile-package ,package ,callers ,methods) (lambda (r) (message "%s" r)))) (defun slime-profile-by-substring (substring &optional package) "Profile all functions which names contain SUBSTRING. If PACKAGE is NIL, then search in all packages." (interactive (list (slime-read-from-minibuffer "Profile by matching substring: " (slime-symbol-at-point)) (slime-read-package-name "Package (RET for all packages): "))) (let ((package (unless (equal package "") package))) (slime-eval-async `(swank:profile-by-substring ,substring ,package) (lambda (r) (message "%s" r)) ))) ;;;; Documentation (defvar slime-documentation-lookup-function 'slime-hyperspec-lookup) (defun slime-documentation-lookup () "Generalized documentation lookup. Defaults to hyperspec lookup." (interactive) (call-interactively slime-documentation-lookup-function)) (defun slime-hyperspec-lookup (symbol-name) "A wrapper for `hyperspec-lookup'" (interactive (list (common-lisp-hyperspec-read-symbol-name (slime-symbol-at-point)))) (hyperspec-lookup symbol-name)) (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))) (defun slime-describe-function (symbol-name) (interactive (list (slime-read-symbol-name "Describe symbol's function: "))) (when (not symbol-name) (error "No symbol given")) (slime-eval-describe `(swank:describe-function ,symbol-name))) (defface slime-apropos-symbol '((t (:inherit bold))) "Face for the symbol name in Apropos output." :group 'slime) (defface slime-apropos-label '((t (:inherit italic))) "Face for label (`Function', `Variable' ...) in Apropos output." :group 'slime) (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. With prefix arg, you're interactively asked for parameters of the search." (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) (slime-rcurry #'slime-show-apropos string buffer-package (slime-apropos-summary string case-sensitive-p package only-external-p))))) (defun slime-apropos-all () "Shortcut for (slime-apropos 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)) (autoload 'apropos-mode "apropos") (defun slime-show-apropos (plists string package summary) (if (null plists) (message "No apropos matches for %S" string) (slime-with-popup-buffer ((slime-buffer-name :apropos) :package package :connection t :mode 'apropos-mode) (if (boundp 'header-line-format) (setq header-line-format summary) (insert summary "\n\n")) (slime-set-truncate-lines) (slime-print-apropos plists) (set-syntax-table lisp-mode-syntax-table) (goto-char (point-min))))) (defvar slime-apropos-namespaces '((: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"))) (defun slime-print-apropos (plists) (dolist (plist plists) (let ((designator (plist-get plist :designator))) (cl-assert designator) (slime-insert-propertized `(face slime-apropos-symbol) designator)) (terpri) (cl-loop for (prop value) on plist by #'cddr unless (eq prop :designator) do (let ((namespace (cadr (or (assq prop slime-apropos-namespaces) (error "Unknown property: %S" prop)))) (start (point))) (princ " ") (slime-insert-propertized `(face slime-apropos-label) namespace) (princ ": ") (princ (cl-etypecase value (string value) ((member nil :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)))) (defun slime-info () "Open Slime manual" (interactive) (let ((file (expand-file-name "doc/slime.info" slime-path))) (if (file-exists-p file) (info file) (message "No slime.info, run `make slime.info' in %s" (expand-file-name "doc/" slime-path))))) ;;;; XREF: cross-referencing (defvar slime-xref-mode-map) (define-derived-mode slime-xref-mode lisp-mode "Xref" "slime-xref-mode: Major mode for cross-referencing. \\\ 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} \\{slime-popup-buffer-mode-map} " (slime-popup-buffer-mode) (setq font-lock-defaults nil) (setq delayed-mode-hooks nil) (slime-mode -1)) (slime-define-keys slime-xref-mode-map ((kbd "RET") 'slime-goto-xref) ((kbd "SPC") 'slime-goto-xref) ("v" 'slime-show-xref) ("n" 'slime-xref-next-line) ("p" 'slime-xref-prev-line) ("." 'slime-xref-next-line) ("," 'slime-xref-prev-line) ("\C-c\C-c" 'slime-recompile-xref) ("\C-c\C-k" 'slime-recompile-all-xrefs) ("\M-," 'slime-xref-retract) ([remap next-line] 'slime-xref-next-line) ([remap previous-line] 'slime-xref-prev-line) ) ;;;;; XREF results buffer and window management (cl-defmacro slime-with-xref-buffer ((_xref-type _symbol &optional package) &body body) "Execute BODY in a xref buffer, then show that buffer." (declare (indent 1)) `(slime-with-popup-buffer ((slime-buffer-name :xref) :package ,package :connection t :select t :mode 'slime-xref-mode) (slime-set-truncate-lines) ,@body)) (defun slime-insert-xrefs (xref-alist) "Insert XREF-ALIST in the current-buffer. XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). GROUP and LABEL are for decoration purposes. LOCATION is a source-location." (cl-loop for (group . refs) in xref-alist do (slime-insert-propertized '(face bold) group "\n") (cl-loop for (label location) in refs do (slime-insert-propertized (list 'slime-location location 'face 'font-lock-keyword-face) " " (slime-one-line-ify label) "\n"))) ;; Remove the final newline to prevent accidental window-scrolling (backward-delete-char 1)) (defun slime-xref-next-line () (interactive) (slime-xref-show-location (slime-search-property 'slime-location))) (defun slime-xref-prev-line () (interactive) (slime-xref-show-location (slime-search-property 'slime-location t))) (defun slime-xref-show-location (loc) (cl-ecase (car loc) (:location (slime-show-source-location loc nil 1)) (:error (message "%s" (cadr loc))) ((nil)))) (defvar slime-next-location-function nil "Function to call for going to the next location.") (defvar slime-previous-location-function nil "Function to call for going to the previous location.") (defvar slime-xref-last-buffer nil "The most recent XREF results buffer. This is used by `slime-goto-next-xref'") (defun slime-show-xref-buffer (xrefs _type _symbol package) (slime-with-xref-buffer (_type _symbol package) (slime-insert-xrefs xrefs) (setq slime-next-location-function 'slime-goto-next-xref) (setq slime-previous-location-function 'slime-goto-previous-xref) (setq slime-xref-last-buffer (current-buffer)) (goto-char (point-min)))) (defun slime-show-xrefs (xrefs type symbol package) "Show the results of an XREF query." (if (null xrefs) (message "No references found for %s." symbol) (slime-show-xref-buffer xrefs type symbol package))) ;;;;; 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)) ;; FIXME: whats the call (slime-postprocess-xrefs result) good for? (defun slime-xref (type symbol &optional continuation) "Make an XREF request to Lisp." (slime-eval-async `(swank:xref ',type ',symbol) (slime-rcurry (lambda (result type symbol package cont) (slime-check-xref-implemented type result) (let* ((_xrefs (slime-postprocess-xrefs result)) (file-alist (cadr (slime-analyze-xrefs result)))) (funcall (or cont 'slime-show-xrefs) file-alist type symbol package))) type symbol (slime-current-package) continuation))) (defun slime-check-xref-implemented (type xrefs) (when (eq xrefs :not-implemented) (error "%s is not implemented yet on %s." (slime-xref-type type) (slime-lisp-implementation-name)))) (defun slime-xref-type (type) (format "who-%s" (slime-cl-symbol-name type))) (defun slime-xrefs (types symbol &optional continuation) "Make multiple XREF requests at once." (slime-eval-async `(swank:xrefs ',types ',symbol) #'(lambda (result) (funcall (or continuation #'slime-show-xrefs) (cl-loop for (key . val) in result collect (cons (slime-xref-type key) val)) types symbol (slime-current-package))))) ;;;;; 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-xref-dspec-at-point () (save-excursion (beginning-of-line 1) (with-syntax-table lisp-mode-syntax-table (forward-sexp) ; skip initial whitespaces (backward-sexp) (slime-sexp-at-point)))) (defun slime-all-xrefs () (let ((xrefs nil)) (save-excursion (goto-char (point-min)) (while (zerop (forward-line 1)) (let ((loc (get-text-property (point) 'slime-location))) (when loc (let* ((dspec (slime-xref-dspec-at-point)) (xref (make-slime-xref :dspec dspec :location loc))) (push xref xrefs)))))) (nreverse xrefs))) (defun slime-goto-xref () "Goto the cross-referenced location at point." (interactive) (slime-show-xref) (quit-window)) (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 t 1))) (defun slime-goto-next-xref (&optional backward) "Goto the next cross-reference location." (if (not (buffer-live-p slime-xref-last-buffer)) (error "No XREF buffer alive.") (cl-destructuring-bind (location pos) (with-current-buffer slime-xref-last-buffer (list (slime-search-property 'slime-location backward) (point))) (cond ((slime-location-p location) (slime-pop-to-location location) ;; We do this here because changing the location can take ;; a while when Emacs needs to read a file from disk. (with-current-buffer slime-xref-last-buffer (goto-char pos) (slime-highlight-line 0.35))) ((null location) (message (if backward "No previous xref" "No next xref."))) (t ; error location (slime-goto-next-xref backward)))))) (defun slime-goto-previous-xref () "Goto the previous cross-reference location." (slime-goto-next-xref t)) (defun slime-search-property (prop &optional backward prop-value-fn) "Search the next text range where PROP is non-nil. Return the value of PROP. If BACKWARD is non-nil, search backward. If PROP-VALUE-FN is non-nil use it to extract PROP's value." (let ((next-candidate (if backward #'previous-single-char-property-change #'next-single-char-property-change)) (prop-value-fn (or prop-value-fn (lambda () (get-text-property (point) prop)))) (start (point)) (prop-value)) (while (progn (goto-char (funcall next-candidate (point) prop)) (not (or (setq prop-value (funcall prop-value-fn)) (eobp) (bobp))))) (cond (prop-value) (t (goto-char start) nil)))) (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-previous-location () "Go to the previous location, depending on context. When displaying XREF information, this goes to the previous reference." (interactive) (when (null slime-previous-location-function) (error "No context for finding locations.")) (funcall slime-previous-location-function)) (defun slime-recompile-xref (&optional raw-prefix-arg) (interactive "P") (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) (let ((location (slime-xref-location-at-point)) (dspec (slime-xref-dspec-at-point))) (slime-recompile-locations (list location) (slime-rcurry #'slime-xref-recompilation-cont (list dspec) (current-buffer)))))) (defun slime-recompile-all-xrefs (&optional raw-prefix-arg) (interactive "P") (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg))) (let ((dspecs) (locations)) (dolist (xref (slime-all-xrefs)) (when (slime-xref-has-location-p xref) (push (slime-xref.dspec xref) dspecs) (push (slime-xref.location xref) locations))) (slime-recompile-locations locations (slime-rcurry #'slime-xref-recompilation-cont dspecs (current-buffer)))))) (defun slime-xref-recompilation-cont (results dspecs buffer) ;; Extreme long-windedness to insert status of recompilation; ;; sometimes Elisp resembles more of an Ewwlisp. ;; FIXME: Should probably throw out the whole recompilation cruft ;; anyway. -- helmut ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt (with-current-buffer buffer (slime-compilation-finished (slime-aggregate-compilation-results results)) (save-excursion (slime-xref-insert-recompilation-flags dspecs (cl-loop for r in results collect (or (slime-compilation-result.successp r) (and (slime-compilation-result.notes r) :complained))))))) (defun slime-aggregate-compilation-results (results) `(:compilation-result ,(cl-reduce #'append (mapcar #'slime-compilation-result.notes results)) ,(cl-every #'slime-compilation-result.successp results) ,(cl-reduce #'+ (mapcar #'slime-compilation-result.duration results)))) (defun slime-xref-insert-recompilation-flags (dspecs compilation-results) (let* ((buffer-read-only nil) (max-column (slime-column-max))) (goto-char (point-min)) (cl-loop for dspec in dspecs for result in compilation-results do (save-excursion (cl-loop for dspec2 = (progn (search-forward dspec) (slime-xref-dspec-at-point)) until (equal dspec2 dspec)) (end-of-line) ; skip old status information. (insert-char ?\ (1+ (- max-column (current-column)))) (insert (format "[%s]" (cl-case result ((t) :success) ((nil) :failure) (t result)))))))) ;;;; Macroexpansion (define-minor-mode slime-macroexpansion-minor-mode "SLIME mode for macroexpansion" nil " Macroexpand" '(("g" . slime-macroexpand-again))) (cl-macrolet ((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 'slime-compiler-macroexpand-1 'slime-compiler-macroexpand-1-inplace) (remap 'slime-expand-1 'slime-expand-1-inplace) (remap 'advertised-undo 'slime-macroexpand-undo) (remap 'undo 'slime-macroexpand-undo)) (defun slime-macroexpand-undo (&optional arg) (interactive) ;; Emacs 22.x introduced `undo-only' which ;; works by binding `undo-no-redo' to t. We do ;; it this way so we don't break prior Emacs ;; versions. (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) (let ((inhibit-read-only t)) (when (fboundp 'slime-remove-edits) (slime-remove-edits (point-min) (point-max))) (undo-only arg)))) (defvar slime-eval-macroexpand-expression nil "Specifies the last macroexpansion preformed. This variable specifies both what was expanded and how.") (defun slime-eval-macroexpand (expander &optional string) (let ((string (or string (slime-sexp-at-point-or-error)))) (setq slime-eval-macroexpand-expression `(,expander ,string)) (slime-eval-async slime-eval-macroexpand-expression #'slime-initialize-macroexpansion-buffer))) (defun slime-macroexpand-again () "Reperform the last macroexpansion." (interactive) (slime-eval-async slime-eval-macroexpand-expression (slime-rcurry #'slime-initialize-macroexpansion-buffer (current-buffer)))) (defun slime-initialize-macroexpansion-buffer (expansion &optional buffer) (pop-to-buffer (or buffer (slime-create-macroexpansion-buffer))) (setq buffer-undo-list nil) ; Get rid of undo information from ; previous expansions. (let ((inhibit-read-only t) (buffer-undo-list t)) ; Make the initial insertion not be undoable. (erase-buffer) (insert expansion) (goto-char (point-min)) (font-lock-fontify-buffer))) (defun slime-create-macroexpansion-buffer () (let ((name (slime-buffer-name :macroexpansion))) (slime-with-popup-buffer (name :package t :connection t :mode 'lisp-mode) (slime-mode 1) (slime-macroexpansion-minor-mode 1) (setq font-lock-keywords-case-fold-search t) (current-buffer)))) (defun slime-eval-macroexpand-inplace (expander) "Substitute the sexp at point with its macroexpansion. NB: Does not affect slime-eval-macroexpand-expression" (interactive) (let* ((bounds (or (slime-bounds-of-sexp-at-point) (user-error "No sexp at point")))) (lexical-let* ((start (copy-marker (car bounds))) (end (copy-marker (cdr bounds))) (point (point)) (package (slime-current-package)) (buffer (current-buffer))) (slime-eval-async `(,expander ,(buffer-substring-no-properties start end)) (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) (slime-insert-indented expansion) (goto-char point)))))))) (defun slime-macroexpand-1 (&optional repeatedly) "Display the macro expansion of the form starting 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 starting at point." (interactive) (slime-eval-macroexpand 'swank:swank-macroexpand-all)) (defun slime-macroexpand-all-inplace () "Display the recursively macro expanded sexp starting at point." (interactive) (slime-eval-macroexpand-inplace 'swank:swank-macroexpand-all)) (defun slime-compiler-macroexpand-1 (&optional repeatedly) "Display the compiler-macro expansion of sexp starting at point." (interactive "P") (slime-eval-macroexpand (if repeatedly 'swank:swank-compiler-macroexpand 'swank:swank-compiler-macroexpand-1))) (defun slime-compiler-macroexpand-1-inplace (&optional repeatedly) "Display the compiler-macro expansion of sexp starting at point." (interactive "P") (slime-eval-macroexpand-inplace (if repeatedly 'swank:swank-compiler-macroexpand 'swank:swank-compiler-macroexpand-1))) (defun slime-expand-1 (&optional repeatedly) "Display the macro expansion of the form starting at point. The form is expanded with CL:MACROEXPAND-1 or, if a prefix argument is given, with CL:MACROEXPAND. If the form denotes a compiler macro, SWANK/BACKEND:COMPILER-MACROEXPAND or SWANK/BACKEND:COMPILER-MACROEXPAND-1 are used instead." (interactive "P") (slime-eval-macroexpand (if repeatedly 'swank:swank-expand 'swank:swank-expand-1))) (defun slime-expand-1-inplace (&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-inplace (if repeatedly 'swank:swank-expand 'swank:swank-expand-1))) (defun slime-format-string-expand (&optional string) "Expand the format-string at point and display it." (interactive (list (or (and (not current-prefix-arg) (slime-string-at-point)) (slime-read-from-minibuffer "Expand format: " (slime-string-at-point))))) (slime-eval-macroexpand 'swank:swank-format-string-expand string)) ;;;; 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 kill) "Quit lisp, kill the inferior process and associated buffers." (interactive "P") (slime-quit-lisp-internal (slime-connection) 'slime-quit-sentinel kill)) (defun slime-quit-lisp-internal (connection sentinel kill) (let ((slime-dispatching-connection connection)) (slime-eval-async '(swank:quit-lisp)) (let* ((process (slime-inferior-process connection))) (set-process-filter connection nil) (set-process-sentinel connection sentinel) (when (and kill process) (sleep-for 0.2) (unless (memq (process-status process) '(exit signal)) (kill-process process)))))) (defun slime-quit-sentinel (process _message) (cl-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."))) ;;;; Debugger (SLDB) (defvar sldb-hook nil "Hook run on entry to the debugger.") (defcustom sldb-initial-restart-limit 6 "Maximum number of restarts to display initially." :group 'slime-debugger :type 'integer) ;;;;; Local variables in the debugger buffer ;; Small helper. (defun slime-make-variables-buffer-local (&rest variables) (mapcar #'make-variable-buffer-local variables)) (slime-make-variables-buffer-local (defvar sldb-condition nil "A list (DESCRIPTION TYPE) describing the condition being debugged.") (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 first frame of the backtrace.") (defvar sldb-restart-list-start-marker nil "Marker placed at the first restart in the restart list.") (defvar sldb-continuations nil "List of ids for pending continuation.")) ;;;;; SLDB macros ;; some macros that we need to define before the first use (defmacro sldb-in-face (name string) "Return STRING propertised with face sldb-NAME-face." (declare (indent 1)) (let ((facename (intern (format "sldb-%s-face" (symbol-name name)))) (var (cl-gensym "string"))) `(let ((,var ,string)) (slime-add-face ',facename ,var) ,var))) ;;;;; 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 ;; # 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:\\ 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 \\[sldb-invoke-restart-by-name] - invoke restart by name Commands to navigate frames: \\[sldb-down] - down \\[sldb-up] - up \\[sldb-details-down] - down, with details \\[sldb-details-up] - up, with details \\[sldb-cycle] - cycle between restarts & backtrace \\[sldb-beginning-of-backtrace] - beginning of backtrace \\[sldb-end-of-backtrace] - end of backtrace Miscellaneous commands: \\[sldb-restart-frame] - restart frame \\[sldb-return-from-frame] - return from frame \\[sldb-step] - step \\[sldb-break-with-default-debugger] - switch to native debugger \\[sldb-break-with-system-debugger] - switch to system debugger (gdb) \\[slime-interactive-eval] - eval \\[sldb-inspect-condition] - inspect signalled condition 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))) (set-keymap-parent sldb-mode-map slime-parent-map) (slime-define-keys sldb-mode-map ((kbd "RET") 'sldb-default-action) ("\C-m" 'sldb-default-action) ([return] 'sldb-default-action) ([mouse-2] 'sldb-default-action/mouse) ([follow-link] 'mouse-face) ("\C-i" 'sldb-cycle) ("h" 'describe-mode) ("v" 'sldb-show-source) ("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) ("I" 'sldb-invoke-restart-by-name) ("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) ("A" 'sldb-break-with-system-debugger) ("B" 'sldb-break-with-default-debugger) ("P" 'sldb-print-condition) ("C" 'sldb-inspect-condition) (":" 'slime-interactive-eval) ("\C-c\C-c" 'sldb-recompile-frame-source)) ;; Keys 0-9 are shortcuts to invoke particular restarts. (dotimes (number 10) (let ((fname (intern (format "sldb-invoke-restart-%S" number))) (docstring (format "Invoke restart numbered %S." number))) (eval `(defun ,fname () ,docstring (interactive) (sldb-invoke-restart ,number))) (define-key sldb-mode-map (number-to-string number) fname))) ;;;;; SLDB buffer creation & update (defun sldb-buffers (&optional connection) "Return a list of all sldb buffers (belonging to CONNECTION.)" (if connection (slime-filter-buffers (lambda () (and (eq slime-buffer-connection connection) (eq major-mode 'sldb-mode)))) (slime-filter-buffers (lambda () (eq major-mode 'sldb-mode))))) (defun sldb-find-buffer (thread &optional connection) (let ((connection (or connection (slime-connection)))) (cl-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 chosen buffer the default connection's it if exists." (car (sldb-buffers slime-default-connection))) (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 all debugged continuations for CONNECTION across SLDB buffers." (cl-loop for b in (sldb-buffers) append (with-current-buffer b (and (eq slime-buffer-connection connection) sldb-continuations)))) (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 &optional PLIST) 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) (cl-assert (if (equal sldb-level level) (equal sldb-condition condition) t) () "Bug: sldb-level is equal but condition differs\n%s\n%s" sldb-condition condition) (unless (equal sldb-level level) (setq buffer-read-only nil) (sldb-mode) (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" (sldb-in-face section "Restarts:") "\n") (setq sldb-restart-list-start-marker (point-marker)) (sldb-insert-restarts restarts 0 sldb-initial-restart-limit) (insert "\n" (sldb-in-face section "Backtrace:") "\n") (setq sldb-backtrace-start-marker (point-marker)) (save-excursion (if frames (sldb-insert-frames (sldb-prune-initial-frames frames) t) (insert "[No backtrace]"))) (run-hooks 'sldb-hook) (set-syntax-table lisp-mode-syntax-table)) ;; FIXME: remove when dropping Emacs23 support (let ((saved (selected-window))) (pop-to-buffer (current-buffer)) (set-window-parameter (selected-window) 'sldb-restore saved)) (unless noninteractive ; needed for tests in batch-mode (slime--display-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 select) "Display the debugger buffer for THREAD. If LEVEL isn't the same as in the buffer reinitialize the buffer." (or (let ((buffer (sldb-find-buffer thread))) (when buffer (with-current-buffer buffer (when (equal sldb-level level) (when select (pop-to-buffer (current-buffer))) t)))) (sldb-reinitialize thread level))) (defun sldb-reinitialize (thread 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." (let ((sldb (sldb-find-buffer thread))) (when sldb (with-current-buffer sldb (cond (stepping (setq sldb-level nil) (run-with-timer 0.4 nil 'sldb-close-step-buffer sldb)) ((not (eq sldb (window-buffer (selected-window)))) ;; A different window selection means an indirect, ;; non-interactive exit, we just kill the sldb buffer. (kill-buffer)) (t ;; An interactive exit should restore configuration per ;; `quit-window's protocol. FIXME: remove ;; `previous-window' hack when dropping Emacs23 support (let ((previous-window (window-parameter (selected-window) 'sldb-restore))) (quit-window t) (if (and (not (>= emacs-major-version 24)) (window-live-p previous-window)) (select-window previous-window))))))))) (defun sldb-close-step-buffer (buffer) (when (buffer-live-p buffer) (with-current-buffer buffer (when (not sldb-level) (quit-window t))))) ;;;;;; SLDB buffer insertion (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." (cl-destructuring-bind (message type extras) condition (slime-insert-propertized '(sldb-default-action sldb-inspect-condition) (sldb-in-face topline message) "\n" (sldb-in-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) (slime-dcase 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 start count) "Insert RESTARTS and add the needed text props RESTARTS should be a list ((NAME DESCRIPTION) ...)." (let* ((len (length restarts)) (end (if count (min (+ start count) len) len))) (cl-loop for (name string) in (cl-subseq restarts start end) for number from start do (slime-insert-propertized `(,@nil restart ,number sldb-default-action sldb-invoke-restart mouse-face highlight) " " (sldb-in-face restart-number (number-to-string number)) ": [" (sldb-in-face restart-type name) "] " (sldb-in-face restart string)) (insert "\n")) (when (< end len) (let ((pos (point))) (slime-insert-propertized (list 'sldb-default-action (slime-rcurry #'sldb-insert-more-restarts restarts pos end)) " --more--\n"))))) (defun sldb-insert-more-restarts (restarts position start) (goto-char position) (let ((inhibit-read-only t)) (delete-region position (1+ (line-end-position))) (sldb-insert-restarts restarts start nil))) (defun sldb-frame.string (frame) (cl-destructuring-bind (_ str &optional _) frame str)) (defun sldb-frame.number (frame) (cl-destructuring-bind (n _ &optional _) frame n)) (defun sldb-frame.plist (frame) (cl-destructuring-bind (_ _ &optional plist) frame plist)) (defun sldb-frame-restartable-p (frame) (and (plist-get (sldb-frame.plist frame) :restartable) t)) (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 (cl-loop for frame in frames until (string-match rx (sldb-frame.string frame)) 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 (slime-insert-propertized `(,@nil sldb-default-action sldb-fetch-more-frames sldb-previous-frame-number ,(sldb-frame.number (cl-first (last frames))) point-entered sldb-fetch-more-frames start-open t face sldb-section-face mouse-face highlight) " --more--") (insert "\n"))) (defun sldb-compute-frame-face (frame) (if (sldb-frame-restartable-p frame) 'sldb-restartable-frame-line-face 'sldb-frame-line-face)) (defun sldb-insert-frame (frame &optional face) "Insert FRAME with FACE at point. If FACE is nil, `sldb-compute-frame-face' is used to determine the face." (setq face (or face (sldb-compute-frame-face frame))) (let ((number (sldb-frame.number frame)) (string (sldb-frame.string frame)) (props `(frame ,frame sldb-default-action sldb-toggle-details))) (slime-propertize-region props (slime-propertize-region '(mouse-face highlight) (insert " " (sldb-in-face frame-label (format "%2d:" number)) " ") (slime-insert-indented (slime-add-face face string))) (insert "\n")))) (defun sldb-fetch-more-frames (&rest _) "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))) ;; we may be called twice, PREV is nil the second time (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) (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 () (slime-property-bounds 'frame)) (defun sldb-forward-frame () (goto-char (next-single-char-property-change (point) 'frame))) (defun sldb-backward-frame () (when (> (point) sldb-backtrace-start-marker) (goto-char (previous-single-char-property-change (if (get-text-property (point) 'frame) (car (sldb-frame-region)) (point)) '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)) ;; Recenter to bottom of the window; -2 to account for the ;; empty last line displayed in sldb buffers. (recenter -2))) (defun sldb-beginning-of-backtrace () "Goto the first frame." (interactive) (goto-char sldb-backtrace-start-marker)) ;;;;;; SLDB recenter & redisplay ;; not sure yet, whether this is a good idea. ;; ;; jt: seconded. Only `sldb-show-frame-details' and ;; `sldb-hide-frame-details' use this. They could avoid it by not ;; removing and reinserting the frame's name line. (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") (cl-destructuring-bind (_mouse-1 (_w pos &rest ignore)) event (save-excursion (goto-char pos) (let ((fn (get-text-property (point) 'sldb-default-action))) (if fn (funcall fn)))))) (defun sldb-cycle () "Cycle between restart list and backtrace." (interactive) (let ((pt (point))) (cond ((< pt sldb-restart-list-start-marker) (goto-char sldb-restart-list-start-marker)) ((< pt sldb-backtrace-start-marker) (goto-char sldb-backtrace-start-marker)) (t (goto-char sldb-restart-list-start-marker))))) (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 (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) (slime-eval-async `(swank:frame-source-location ,frame-number) (lambda (source-location) (slime-dcase source-location ((:error message) (message "%s" message) (ding)) (t (slime-show-source-location source-location t nil)))))) (defun slime-show-source-location (source-location &optional highlight recenter-arg) "Go to SOURCE-LOCATION and display the buffer in the other window." (slime-goto-source-location source-location) ;; show the location, but don't hijack focus. (slime--display-position (point) t recenter-arg) (when highlight (slime-highlight-sexp))) (defun slime--display-position (pos other-window recenter-arg) (with-selected-window (display-buffer (current-buffer) other-window) (goto-char pos) (recenter recenter-arg))) ;; Set window-start so that the region from START to END becomes visible. ;; START is inclusive; END is exclusive. (defun slime--adjust-window-start (start end) (let* ((last (max start (1- end))) (window-height (window-text-height)) (region-height (count-screen-lines start last t))) ;; if needed, make the region visible (when (or (not (pos-visible-in-window-p start)) (not (pos-visible-in-window-p last))) (let* ((nlines (cond ((or (< start (window-start)) (>= region-height window-height)) 0) (t (- region-height))))) (goto-char start) (recenter nlines))) (cl-assert (pos-visible-in-window-p start)) (cl-assert (or (pos-visible-in-window-p last) (> region-height window-height))) (cl-assert (pos-visible-in-window-p (1- (window-end nil t)) nil t)))) ;; move POS to visible region (defun slime--adjust-window-point (pos) (cond ((pos-visible-in-window-p pos) (goto-char pos)) ((< pos (window-start)) (goto-char (window-start))) (t (goto-char (1- (window-end nil t))) (move-to-column 0))) (cl-assert (pos-visible-in-window-p (point) nil t))) (defun slime--display-region (start end) "Make the region from START to END visible. Minimize point motion." (cl-assert (<= start end)) (cl-assert (eq (window-buffer (selected-window)) (current-buffer))) (let ((pos (point))) (slime--adjust-window-start start end) (slime--adjust-window-point pos))) (defun slime-highlight-sexp (&optional start end) "Highlight the first sexp after point." (let ((start (or start (point))) (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) (slime-flash-region start end))) (defun slime-highlight-line (&optional timeout) (slime-flash-region (+ (line-beginning-position) (current-indentation)) (line-end-position) timeout)) ;;;;;; 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) (cl-assert (sldb-frame-number-at-point)) (let ((inhibit-read-only t) (inhibit-point-motion-hooks 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 (cl-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 (if (sldb-frame-restartable-p frame) 'sldb-restartable-frame-line-face ;; FIXME: can we somehow merge the two? 'sldb-detailed-frame-line-face)) (let ((indent1 " ") (indent2 " ")) (insert indent1 (sldb-in-face section (if locals "Locals:" "[No Locals]")) "\n") (sldb-insert-locals locals indent2 frame) (when catches (insert indent1 (sldb-in-face section "Catch-tags:") "\n") (dolist (tag catches) (slime-propertize-region `(catch-tag ,tag) (insert indent2 (sldb-in-face catch-tag (format "%s" tag)) "\n")))) (setq end (point))))) (slime--display-region (point) 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))) (cl-destructuring-bind (start end) (sldb-frame-region) (cl-list* start end frame (slime-eval `(swank:frame-locals-and-catch-tags ,num)))))) (defvar sldb-insert-frame-variable-value-function 'sldb-insert-frame-variable-value) (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." (cl-loop for i from 0 for var in vars do (cl-destructuring-bind (&key name id value) var (slime-propertize-region (list 'sldb-default-action 'sldb-inspect-var 'var i) (insert prefix (sldb-in-face local-name (concat name (if (zerop id) "" (format "#%d" id)))) " = ") (funcall sldb-insert-frame-variable-value-function value frame i) (insert "\n"))))) (defun sldb-insert-frame-variable-value (value _frame _index) (insert (sldb-in-face local-value value))) (defun sldb-hide-frame-details () ;; delete locals and catch tags, but keep the function name and args. (cl-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))))) ;;;;;; SLDB eval and inspect (defun sldb-eval-in-frame (frame string package) "Prompt for an expression and evaluate it in the selected frame." (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) (slime-eval-async `(swank:eval-string-in-frame ,string ,frame ,package) (if current-prefix-arg 'slime-write-string 'slime-display-eval-result))) (defun sldb-pprint-eval-in-frame (frame string package) "Prompt for an expression, evaluate in selected frame, pretty-print result." (interactive (sldb-read-form-for-frame "Eval in frame (%s)> ")) (slime-eval-async `(swank:pprint-eval-string-in-frame ,string ,frame ,package) (lambda (result) (slime-show-description result nil)))) (defun sldb-read-form-for-frame (fstring) (let* ((frame (sldb-frame-number-at-point)) (pkg (slime-eval `(swank:frame-package-name ,frame)))) (list frame (let ((slime-buffer-package pkg)) (slime-read-from-minibuffer (format fstring pkg))) pkg))) (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)) (defun sldb-print-condition () (interactive) (slime-eval-describe `(swank:sdlb-print-condition))) ;;;;;; 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) (cl-assert sldb-restarts () "sldb-quit called outside of sldb buffer") (slime-rex () ('(swank:throw-to-toplevel)) ((:ok x) (error "sldb-quit returned [%s]" x)) ((:abort _)))) (defun sldb-continue () "Invoke the \"continue\" restart." (interactive) (cl-assert sldb-restarts () "sldb-continue called outside of sldb buffer") (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 (index into `sldb-restarts') 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-invoke-restart-by-name (restart-name) (interactive (list (let ((completion-ignore-case t)) (completing-read "Restart: " sldb-restarts nil t "" 'sldb-invoke-restart-by-name)))) (sldb-invoke-restart (cl-position restart-name sldb-restarts :test 'string= :key 'first))) (defun sldb-break-with-default-debugger (&optional dont-unwind) "Enter default debugger." (interactive "P") (slime-rex () ((list 'swank:sldb-break-with-default-debugger (not (not dont-unwind))) nil slime-current-thread) ((:abort _)))) (defun sldb-break-with-system-debugger (&optional lightweight) "Enter system debugger (gdb)." (interactive "P") (slime-attach-gdb slime-buffer-connection lightweight)) (defun slime-attach-gdb (connection &optional lightweight) "Run `gud-gdb'on the connection with PID `pid'. If `lightweight' is given, do not send any request to the inferior Lisp (e.g. to obtain default gdb config) but only operate from the Emacs side; intended for cases where the Lisp is truly screwed up." (interactive (list (slime-read-connection "Attach gdb to: " (slime-connection)) "P")) (let ((pid (slime-pid connection)) (file (slime-lisp-implementation-program connection)) (commands (unless lightweight (let ((slime-dispatching-connection connection)) (slime-eval `(swank:gdb-initial-commands)))))) (gud-gdb (format "gdb -p %d %s" pid (or file ""))) (with-current-buffer gud-comint-buffer (dolist (cmd commands) ;; First wait until gdb was initialized, then wait until current ;; command was processed. (while (not (looking-back comint-prompt-regexp nil)) (sit-for 0.01)) ;; We do not use `gud-call' because we want the initial commands ;; to be displayed by the user so he knows what he's got. (insert cmd) (comint-send-input))))) (defun slime-read-connection (prompt &optional initial-value) "Read a connection from the minibuffer. Return the net process, or nil." (cl-assert (memq initial-value slime-net-processes)) (let* ((to-string (lambda (p) (format "%s (pid %d)" (slime-connection-name p) (slime-pid p)))) (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) slime-net-processes))) (cdr (assoc (completing-read prompt candidates nil t (funcall to-string initial-value)) candidates)))) (defun sldb-step () "Step to next basic-block boundary." (interactive) (let ((frame (sldb-frame-number-at-point))) (slime-eval-async `(swank:sldb-step ,frame)))) (defun sldb-next () "Step over call." (interactive) (let ((frame (sldb-frame-number-at-point))) (slime-eval-async `(swank:sldb-next ,frame)))) (defun sldb-out () "Resume stepping after returning from this function." (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 _))))) (defun slime-toggle-break-on-signals () "Toggle the value of *break-on-signals*." (interactive) (slime-eval-async `(swank:toggle-break-on-signals) (lambda (msg) (message "%s" msg)))) ;;;;;; SLDB recompilation commands (defun sldb-recompile-frame-source (&optional raw-prefix-arg) (interactive "P") (slime-eval-async `(swank:frame-source-location ,(sldb-frame-number-at-point)) (lexical-let ((policy (slime-compute-policy raw-prefix-arg))) (lambda (source-location) (slime-dcase source-location ((:error message) (message "%s" message) (ding)) (t (let ((slime-compilation-policy policy)) (slime-recompile-location source-location)))))))) ;;;; Thread control panel (defvar slime-threads-buffer-name (slime-buffer-name :threads)) (defvar slime-threads-buffer-timer nil) (defcustom slime-threads-update-interval nil "Interval at which the list of threads will be updated." :type '(choice (number :value 0.5) (const nil)) :group 'slime-ui) (defun slime-list-threads () "Display a list of threads." (interactive) (let ((name slime-threads-buffer-name)) (slime-with-popup-buffer (name :connection t :mode 'slime-thread-control-mode) (slime-update-threads-buffer) (goto-char (point-min)) (when slime-threads-update-interval (when slime-threads-buffer-timer (cancel-timer slime-threads-buffer-timer)) (setq slime-threads-buffer-timer (run-with-timer slime-threads-update-interval slime-threads-update-interval 'slime-update-threads-buffer)))))) (defun slime-quit-threads-buffer () (when slime-threads-buffer-timer (cancel-timer slime-threads-buffer-timer)) (quit-window t) (slime-eval-async `(swank:quit-thread-browser))) (defun slime-update-threads-buffer () (interactive) (with-current-buffer slime-threads-buffer-name (slime-eval-async '(swank:list-threads) 'slime-display-threads))) (defun slime-move-point (position) "Move point in the current buffer and in the window the buffer is displayed." (let ((window (get-buffer-window (current-buffer) t))) (goto-char position) (when window (set-window-point window position)))) (defun slime-display-threads (threads) (with-current-buffer slime-threads-buffer-name (let* ((inhibit-read-only t) (old-thread-id (get-text-property (point) 'thread-id)) (old-line (line-number-at-pos)) (old-column (current-column))) (erase-buffer) (slime-insert-threads threads) (let ((new-line (cl-position old-thread-id (cdr threads) :key #'car :test #'equal))) (goto-char (point-min)) (forward-line (or new-line old-line)) (move-to-column old-column) (slime-move-point (point)))))) (defun slime-transpose-lists (list-of-lists) (let ((ncols (length (car list-of-lists)))) (cl-loop for col-index below ncols collect (cl-loop for row in list-of-lists collect (elt row col-index))))) (defun slime-insert-table-row (line line-props col-props col-widths) (slime-propertize-region line-props (cl-loop for string in line for col-prop in col-props for width in col-widths do (slime-insert-propertized col-prop string) (insert-char ?\ (- width (length string)))))) (defun slime-insert-table (rows header row-properties column-properties) "Insert a \"table\" so that the columns are nicely aligned." (let* ((ncols (length header)) (lines (cons header rows)) (widths (cl-loop for columns in (slime-transpose-lists lines) collect (1+ (cl-loop for cell in columns maximize (length cell))))) (header-line (with-temp-buffer (slime-insert-table-row header nil (make-list ncols nil) widths) (buffer-string)))) (cond ((boundp 'header-line-format) (setq header-line-format header-line)) (t (insert header-line "\n"))) (cl-loop for line in rows for line-props in row-properties do (slime-insert-table-row line line-props column-properties widths) (insert "\n")))) (defvar slime-threads-table-properties '(nil (face bold))) (defun slime-insert-threads (threads) (let* ((labels (car threads)) (threads (cdr threads)) (header (cl-loop for label in labels collect (capitalize (substring (symbol-name label) 1)))) (rows (cl-loop for thread in threads collect (cl-loop for prop in thread collect (format "%s" prop)))) (line-props (cl-loop for (id) in threads for i from 0 collect `(thread-index ,i thread-id ,id))) (col-props (cl-loop for nil in labels for i from 0 collect (nth i slime-threads-table-properties)))) (slime-insert-table rows header line-props col-props))) ;;;;; Major mode (define-derived-mode slime-thread-control-mode fundamental-mode "Threads" "SLIME Thread Control Panel Mode. \\{slime-thread-control-mode-map} \\{slime-popup-buffer-mode-map}" (when slime-truncate-lines (set (make-local-variable 'truncate-lines) t)) (setq buffer-undo-list t)) (slime-define-keys slime-thread-control-mode-map ("a" 'slime-thread-attach) ("d" 'slime-thread-debug) ("g" 'slime-update-threads-buffer) ("k" 'slime-thread-kill) ("q" 'slime-quit-threads-buffer)) (defun slime-thread-kill () (interactive) (slime-eval `(cl:mapc 'swank:kill-nth-thread ',(slime-get-properties 'thread-index))) (call-interactively 'slime-update-threads-buffer)) (defun slime-get-region-properties (prop start end) (cl-loop for position = (if (get-text-property start prop) start (next-single-property-change start prop)) then (next-single-property-change position prop) while (<= position end) collect (get-text-property position prop))) (defun slime-get-properties (prop) (if (use-region-p) (slime-get-region-properties prop (region-beginning) (region-end)) (let ((value (get-text-property (point) prop))) (when value (list value))))) (defun slime-thread-attach () (interactive) (let ((id (get-text-property (point) 'thread-index)) (file (slime-swank-port-file))) (slime-eval-async `(swank:start-swank-server-in-thread ,id ,file))) (slime-read-port-and-connect nil)) (defun slime-thread-debug () (interactive) (let ((id (get-text-property (point) 'thread-index))) (slime-eval-async `(swank:debug-nth-thread ,id)))) ;;;;; Connection listing (define-derived-mode slime-connection-list-mode fundamental-mode "Slime-Connections" "SLIME Connection List Mode. \\{slime-connection-list-mode-map} \\{slime-popup-buffer-mode-map}" (when slime-truncate-lines (set (make-local-variable 'truncate-lines) t))) (slime-define-keys slime-connection-list-mode-map ("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-quit-connection-at-point (connection) (interactive (list (slime-connection-at-point))) (let ((slime-dispatching-connection connection) (end (time-add (current-time) (seconds-to-time 3)))) (slime-quit-lisp t) (while (memq connection slime-net-processes) (when (time-less-p end (current-time)) (message "Quit timeout expired. Disconnecting.") (delete-process connection)) (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)) (defvar slime-connections-buffer-name (slime-buffer-name :connections)) (defun slime-list-connections () "Display a list of all connections." (interactive) (slime-with-popup-buffer (slime-connections-buffer-name :mode 'slime-connection-list-mode) (slime-draw-connection-list))) (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-pos (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 '((t (:inherit font-lock-builtin-face))) "Face for things which can themselves be inspected." :group 'slime-inspector) (defface slime-inspector-action-face '((t (:inherit font-lock-warning-face))) "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 '()) (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" " \\{slime-inspector-mode-map} \\{slime-popup-buffer-mode-map}" (set-syntax-table lisp-mode-syntax-table) (slime-set-truncate-lines) (setq buffer-read-only t)) (defun slime-inspector-buffer () (or (get-buffer (slime-buffer-name :inspector)) (slime-with-popup-buffer ((slime-buffer-name :inspector) :mode 'slime-inspector-mode) (setq slime-inspector-mark-stack '()) (buffer-disable-undo) (current-buffer)))) (defmacro slime-inspector-fontify (face string) `(slime-add-face ',(intern (format "slime-inspector-%s-face" face)) ,string)) (defvar slime-inspector-insert-ispec-function 'slime-inspector-insert-ispec) (defun slime-open-inspector (inspected-parts &optional point hook) "Display INSPECTED-PARTS in a new inspector window. Optionally set point to POINT. If HOOK is provided, it is added to local KILL-BUFFER hooks for the inspector buffer." (with-current-buffer (slime-inspector-buffer) (when hook (add-hook 'kill-buffer-hook hook t t)) (setq slime-buffer-connection (slime-current-connection)) (let ((inhibit-read-only t)) (erase-buffer) (pop-to-buffer (current-buffer)) (cl-destructuring-bind (&key id title content) inspected-parts (cl-macrolet ((fontify (face string) `(slime-inspector-fontify ,face ,string))) (slime-propertize-region (list 'slime-part-number id 'mouse-face 'highlight 'face 'slime-inspector-value-face) (insert title)) (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" (fontify label "--------------------") "\n") (save-excursion (slime-inspector-insert-content content)) (when point (cl-check-type point cons) (ignore-errors (goto-char (point-min)) (forward-line (1- (car point))) (move-to-column (cdr point))))))))) (defvar slime-inspector-limit 500) (defun slime-inspector-insert-content (content) (slime-inspector-fetch-chunk content nil (lambda (chunk) (let ((inhibit-read-only t)) (slime-inspector-insert-chunk chunk t t))))) (defun slime-inspector-insert-chunk (chunk prev next) "Insert CHUNK at point. If PREV resp. NEXT are true insert more-buttons as needed." (cl-destructuring-bind (ispecs len start end) chunk (when (and prev (> start 0)) (slime-inspector-insert-more-button start t)) (mapc slime-inspector-insert-ispec-function ispecs) (when (and next (< end len)) (slime-inspector-insert-more-button end nil)))) (defun slime-inspector-insert-ispec (ispec) (if (stringp ispec) (insert ispec) (slime-dcase ispec ((:value string id) (slime-propertize-region (list 'slime-part-number id 'mouse-face 'highlight 'face 'slime-inspector-value-face) (insert string))) ((:label string) (insert (slime-inspector-fontify label string))) ((:action string id) (slime-insert-propertized (list 'slime-action-number id 'mouse-face 'highlight 'face 'slime-inspector-action-face) string))))) (defun slime-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. ;; FIXME: why would somebody narrow the buffer? (save-restriction (widen) (cons (line-number-at-pos) (current-column)))) (defun slime-inspector-property-at-point () (let* ((properties '(slime-part-number slime-range-button slime-action-number)) (find-property (lambda (point) (cl-loop for property in properties for value = (get-text-property point property) when value return (list property value))))) (or (funcall find-property (point)) (funcall find-property (1- (point)))))) (defun slime-inspector-operate-on-point () "Invoke the command for the text at point. 1. If point is on a value then recursivly call the inspector on that value. 2. If point is on an action then call that action. 3. If point is on a range-button fetch and insert the range." (interactive) (let ((opener (lexical-let ((point (slime-inspector-position))) (lambda (parts) (when parts (slime-open-inspector parts point))))) (new-opener (lambda (parts) (when parts (slime-open-inspector parts))))) (cl-destructuring-bind (&optional property value) (slime-inspector-property-at-point) (cl-case property (slime-part-number (slime-eval-async `(swank:inspect-nth-part ,value) new-opener) (push (slime-inspector-position) slime-inspector-mark-stack)) (slime-range-button (slime-inspector-fetch-more value)) (slime-action-number (slime-eval-async `(swank::inspector-call-nth-action ,value) opener)) (t (error "No object at point")))))) (defun slime-inspector-operate-on-click (event) "Move to events' position and operate the part." (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-range-button) (get-text-property point 'slime-action-number))) (goto-char point) (slime-inspector-operate-on-point)) (t (error "No clickable part here"))))) (defun slime-inspector-pop () "Reinspect the previous object." (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 () "Inspect the next object in the history." (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 () "Quit the inspector and kill the buffer." (interactive) (slime-eval-async `(swank:quit-inspector)) (quit-window t)) ;; FIXME: first return value is just point. ;; FIXME: could probably use slime-search-property. (defun slime-find-inspectable-object (direction limit) "Find the next/previous inspectable object. DIRECTION can be either 'next or 'prev. LIMIT is the maximum or minimum position in the current buffer. Return 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 (cl-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) (cl-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) (cl-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-eval (string) "Eval an expression in the context of the inspected object." (interactive (list (slime-read-from-minibuffer "Inspector eval: "))) (slime-eval-with-transcript `(swank:inspector-eval ,string))) (defun slime-inspector-history () "Show the previously inspected objects." (interactive) (slime-eval-describe `(swank:inspector-history))) (defun slime-inspector-show-source (part) (interactive (list (or (get-text-property (point) 'slime-part-number) (error "No part at point")))) (slime-eval-async `(swank:find-source-location-for-emacs '(:inspector ,part)) #'slime-show-source-location)) (defun slime-inspector-reinspect () (interactive) (slime-eval-async `(swank:inspector-reinspect) (lexical-let ((point (slime-inspector-position))) (lambda (parts) (slime-open-inspector parts point))))) (defun slime-inspector-toggle-verbose () (interactive) (slime-eval-async `(swank:inspector-toggle-verbose) (lexical-let ((point (slime-inspector-position))) (lambda (parts) (slime-open-inspector parts point))))) (defun slime-inspector-insert-more-button (index previous) (slime-insert-propertized (list 'slime-range-button (list index previous) 'mouse-face 'highlight 'face 'slime-inspector-action-face) (if previous " [--more--]\n" " [--more--]"))) (defun slime-inspector-fetch-all () "Fetch all inspector contents and go to the end." (interactive) (goto-char (1- (point-max))) (let ((button (get-text-property (point) 'slime-range-button))) (when button (let (slime-inspector-limit) (slime-inspector-fetch-more button))))) (defun slime-inspector-fetch-more (button) (cl-destructuring-bind (index prev) button (slime-inspector-fetch-chunk (list '() (1+ index) index index) prev (slime-rcurry (lambda (chunk prev) (let ((inhibit-read-only t)) (apply #'delete-region (slime-property-bounds 'slime-range-button)) (slime-inspector-insert-chunk chunk prev (not prev)))) prev)))) (defun slime-inspector-fetch-chunk (chunk prev cont) (slime-inspector-fetch chunk slime-inspector-limit prev cont)) (defun slime-inspector-fetch (chunk limit prev cont) (cl-destructuring-bind (from to) (slime-inspector-next-range chunk limit prev) (cond ((and from to) (slime-eval-async `(swank:inspector-range ,from ,to) (slime-rcurry (lambda (chunk2 chunk1 limit prev cont) (slime-inspector-fetch (slime-inspector-join-chunks chunk1 chunk2) limit prev cont)) chunk limit prev cont))) (t (funcall cont chunk))))) (defun slime-inspector-next-range (chunk limit prev) (cl-destructuring-bind (_ len start end) chunk (let ((count (- end start))) (cond ((and prev (< 0 start) (or (not limit) (< count limit))) (list (if limit (max (- end limit) 0) 0) start)) ((and (not prev) (< end len) (or (not limit) (< count limit))) (list end (if limit (+ start limit) most-positive-fixnum))) (t '(nil nil)))))) (defun slime-inspector-join-chunks (chunk1 chunk2) (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 (cl-destructuring-bind (i2 l2 s2 e2) chunk2 (cond ((= e1 s2) (list (append i1 i2) l2 s1 e2)) ((= e2 s1) (list (append i2 i1) l2 s2 e1)) (t (error "Invalid chunks")))))) (set-keymap-parent slime-inspector-mode-map slime-parent-map) (slime-define-keys slime-inspector-mode-map ([return] 'slime-inspector-operate-on-point) ("\C-m" 'slime-inspector-operate-on-point) ([mouse-1] 'slime-inspector-operate-on-click) ([mouse-2] 'slime-inspector-operate-on-click) ([mouse-6] 'slime-inspector-pop) ([mouse-7] 'slime-inspector-next) ("l" 'slime-inspector-pop) ("n" 'slime-inspector-next) (" " 'slime-inspector-next) ("d" 'slime-inspector-describe) ("p" 'slime-inspector-pprint) ("e" 'slime-inspector-eval) ("h" 'slime-inspector-history) ("g" 'slime-inspector-reinspect) ("v" 'slime-inspector-toggle-verbose) ("\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. ("." 'slime-inspector-show-source) (">" 'slime-inspector-fetch-all) ("q" 'slime-inspector-quit)) ;;;; 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.") (defvar slime-selector-other-window nil "If non-nil use switch-to-buffer-other-window.") (defun slime-selector (&optional other-window) "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* ((slime-selector-other-window other-window) (ch (save-window-excursion (select-window (minibuffer-window)) (read-char))) (method (cl-find ch slime-selector-methods :key #'car))) (cond (method (funcall (cl-third method))) (t (message "No method for character: ?\\%c" ch) (ding) (sleep-for 1) (discard-input) (slime-selector))))) (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." (let ((method `(lambda () (let ((buffer (progn ,@body))) (cond ((not (get-buffer buffer)) (message "No such buffer: %S" buffer) (ding)) ((get-buffer-window buffer) (select-window (get-buffer-window buffer))) (slime-selector-other-window (switch-to-buffer-other-window buffer)) (t (switch-to-buffer buffer))))))) `(setq slime-selector-methods (cl-sort (cons (list ,key ,description ,method) (cl-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") (cl-loop for (key line nil) in slime-selector-methods do (insert (format "%c:\t%s\n" key line))) (goto-char (point-min)) (help-mode) (display-buffer (current-buffer) t)) (slime-selector) (current-buffer)) (cl-pushnew (list ?4 "Select in other window" (lambda () (slime-selector t))) slime-selector-methods :key #'car) (def-slime-selector-method ?q "Abort." (top-level)) (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-buffer-name) (def-slime-selector-method ?n "Cycle to the next Lisp connection." (slime-next-connection) (concat "*slime-repl " (slime-connection-name (slime-current-connection)) "*")) (def-slime-selector-method ?p "Cycle to the previous Lisp connection." (slime-prev-connection) (concat "*slime-repl " (slime-connection-name (slime-current-connection)) "*")) (def-slime-selector-method ?t "SLIME threads buffer." (slime-list-threads) slime-threads-buffer-name) (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." (cl-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))) ;;;; 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-intern-indentation-spec (spec) (cond ((consp spec) (cons (slime-intern-indentation-spec (car spec)) (slime-intern-indentation-spec (cdr spec)))) ((stringp spec) (intern spec)) (t spec))) ;; FIXME: restore the old version without per-package ;; stuff. slime-indentation.el should be able tho disable the simple ;; version if needed. (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 (slime-intern-indentation-spec (cl-second info))) (packages (cl-third info))) (if (and (boundp 'common-lisp-system-indentation) (fboundp 'slime-update-system-indentation)) ;; A table provided by slime-cl-indent.el. (funcall #'slime-update-system-indentation symbol indent packages) ;; Does the symbol have an indentation value that we set? (when (equal (get symbol 'common-lisp-indent-function) (get symbol 'slime-indent)) (put symbol 'common-lisp-indent-function indent) (put symbol 'slime-indent indent))) (run-hook-with-args 'slime-indentation-update-hooks symbol indent packages)))) ;;;; Contrib modules (defun slime-require (module) (cl-pushnew module slime-required-modules) (when (slime-connected-p) (slime-load-contribs))) (defun slime-load-contribs () (let ((needed (cl-remove-if (lambda (s) (member (cl-subseq (symbol-name s) 1) (mapcar #'downcase (slime-lisp-modules)))) slime-required-modules))) (when needed ;; No asynchronous request because with :SPAWN that could result ;; in the attempt to load modules concurrently which may not be ;; supported by the host Lisp. (setf (slime-lisp-modules) (slime-eval `(swank:swank-require ',needed)))))) (cl-defstruct slime-contrib name slime-dependencies swank-dependencies enable disable authors license) (defun slime-contrib--enable-fun (name) (intern (concat (symbol-name name) "-init"))) (defun slime-contrib--disable-fun (name) (intern (concat (symbol-name name) "-unload"))) (defmacro define-slime-contrib (name _docstring &rest clauses) (declare (indent 1)) (cl-destructuring-bind (&key slime-dependencies swank-dependencies on-load on-unload authors license) (cl-loop for (key . value) in clauses append `(,key ,value)) `(progn ,@(mapcar (lambda (d) `(require ',d)) slime-dependencies) (defun ,(slime-contrib--enable-fun name) () (mapc #'funcall ',(mapcar #'slime-contrib--enable-fun slime-dependencies)) (mapc #'slime-require ',swank-dependencies) ,@on-load) (defun ,(slime-contrib--disable-fun name) () ,@on-unload (mapc #'funcall ',(mapcar #'slime-contrib--disable-fun slime-dependencies))) (put 'slime-contribs ',name (make-slime-contrib :name ',name :authors ',authors :license ',license :slime-dependencies ',slime-dependencies :swank-dependencies ',swank-dependencies :enable ',(slime-contrib--enable-fun name) :disable ',(slime-contrib--disable-fun name)))))) (defun slime-all-contribs () (cl-loop for (nil val) on (symbol-plist 'slime-contribs) by #'cddr when (slime-contrib-p val) collect val)) (defun slime-contrib-all-dependencies (contrib) "List all contribs recursively needed by CONTRIB, including self." (cons contrib (cl-mapcan #'slime-contrib-all-dependencies (slime-contrib-slime-dependencies (slime-find-contrib contrib))))) (defun slime-find-contrib (name) (get 'slime-contribs name)) (defun slime-read-contrib-name () (let ((names (cl-loop for c in (slime-all-contribs) collect (symbol-name (slime-contrib-name c))))) (intern (completing-read "Contrib: " names nil t)))) (defun slime-enable-contrib (name) (interactive (list (slime-read-contrib-name))) (let ((c (or (slime-find-contrib name) (error "Unknown contrib: %S" name)))) (funcall (slime-contrib-enable c)))) (defun slime-disable-contrib (name) (interactive (list (slime-read-contrib-name))) (let ((c (or (slime-find-contrib name) (error "Unknown contrib: %S" name)))) (funcall (slime-contrib-disable c)))) ;;;;; 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" completion-at-point ,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 ] [ "Eval Region And Pretty-Print" slime-pprint-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] [ "Profile by Substring" slime-profile-by-substring ,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 ] [ "Lookup Documentation..." slime-documentation-lookup t ] [ "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] ))) (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 ] "--" [ "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-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-documentation-lookup)) (:title "Completion" :map slime-mode-map :bindings (slime-indent-and-complete-symbol slime-fuzzy-complete-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-toggle-verbose "Toggle verbose mode") (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-buffer-name :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 (cl-getf mode :title)) (mode-map (cl-getf mode :map)) (mode-keys (cl-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) (cl-second func)) descriptions) (let ((all-bindings (where-is-internal (if (symbolp func) func (cl-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))) (cl-loop 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) "" key)) do (insert "\n") finally do (insert "\n"))))) (setq buffer-read-only t) (goto-char (point-min))) ;;;; Utilities (no not Paul Graham style) ;; XXX: unused function (defun slime-intersperse (element list) "Intersperse ELEMENT between each element of LIST." (if (null list) '() (cons (car list) (cl-mapcan (lambda (x) (list element x)) (cdr list))))) ;;; FIXME: this looks almost slime `slime-alistify', perhaps the two ;;; functions can be merged. (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))))) (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." (let ((alist '())) (dolist (e list) (let* ((k (funcall key e)) (probe (cl-assoc k alist :test test))) (if probe (push e (cdr probe)) (push (cons k (list e)) alist)))) ;; Put them back in order. (cl-loop for (key . value) in (reverse alist) collect (cons key (reverse value))))) ;;;;; Misc. (defun slime-length= (seq n) "Return (= (length SEQ) N)." (cl-etypecase seq (list (cond ((zerop n) (null seq)) ((let ((tail (nthcdr (1- n) seq))) (and tail (null (cdr tail))))))) (sequence (= (length seq) n)))) (defun slime-length> (seq n) "Return (> (length SEQ) N)." (cl-etypecase seq (list (nthcdr n seq)) (sequence (> (length seq) n)))) (defun slime-trim-whitespace (str) (let ((start (cl-position-if-not (lambda (x) (memq x '(?\t ?\n ?\s ?\r))) str)) (end (cl-position-if-not (lambda (x) (memq x '(?\t ?\n ?\s ?\r))) str :from-end t))) (if start (substring str start (1+ end)) ""))) ;;;;; 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)))))) (defun slime-column-max () (save-excursion (goto-char (point-min)) (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) until (= (point) (point-max)) maximizing column))) ;;;;; CL symbols vs. Elisp symbols. (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))) (defun slime-qualify-cl-symbol-name (symbol-or-name) "Return a package-qualified string for SYMBOL-OR-NAME. If SYMBOL-OR-NAME 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", or "\"CL-USER\"". (if package (slime-pretty-package-name package) "CL-USER")) (slime-cl-symbol-name s))))) ;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) (defmacro slime-point-moves-p (&rest body) "Execute BODY and return true if the current buffer's point moved." (declare (indent 0)) (let ((pointvar (cl-gensym "point-"))) `(let ((,pointvar (point))) (save-current-buffer ,@body) (/= ,pointvar (point))))) (defun slime-forward-sexp (&optional count) "Like `forward-sexp', but understands reader-conditionals (#- and #+), and skips comments." (dotimes (_i (or count 1)) (slime-forward-cruft) (forward-sexp))) (defconst slime-reader-conditionals-regexp ;; #!+, #!- are SBCL specific reader-conditional syntax. ;; We need this for the source files of SBCL itself. (regexp-opt '("#+" "#-" "#!+" "#!-"))) (defun slime-forward-reader-conditional () "Move past any reader conditional (#+ or #-) at point." (when (looking-at slime-reader-conditionals-regexp) (goto-char (match-end 0)) (let* ((plus-conditional-p (eq (char-before) ?+)) (result (slime-eval-feature-expression (condition-case e (read (current-buffer)) (invalid-read-syntax (signal 'slime-unknown-feature-expression (cdr e))))))) (unless (if plus-conditional-p result (not result)) ;; skip this sexp (slime-forward-sexp))))) (defun slime-forward-cruft () "Move forward over whitespace, comments, reader conditionals." (while (slime-point-moves-p (skip-chars-forward " \t\n") (forward-comment (buffer-size)) (inline (slime-forward-reader-conditional))))) (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))))) (put 'slime-incorrect-feature-expression 'error-conditions '(slime-incorrect-feature-expression error)) (put 'slime-unknown-feature-expression 'error-conditions '(slime-unknown-feature-expression slime-incorrect-feature-expression error)) ;; FIXME: let it crash ;; FIXME: the length=1 constraint is bogus (defun slime-eval-feature-expression (e) "Interpret a reader conditional expression." (cond ((symbolp e) (memq (slime-keywordify e) (slime-lisp-features))) ((and (consp e) (symbolp (car e))) (funcall (let ((head (slime-keywordify (car e)))) (cl-case head (:and #'cl-every) (:or #'cl-some) (:not (lexical-let ((feature-expression e)) (lambda (f l) (cond ((slime-length= l 0) t) ((slime-length= l 1) (not (apply f l))) (t (signal 'slime-incorrect-feature-expression feature-expression)))))) (t (signal 'slime-unknown-feature-expression head)))) #'slime-eval-feature-expression (cdr e))) (t (signal 'slime-incorrect-feature-expression e)))) ;;;;; 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 defun at point." (save-excursion (save-match-data (end-of-defun) (let ((end (point))) (beginning-of-defun) (list (point) end))))) (defun slime-beginning-of-symbol () "Move to the beginning of the CL-style symbol at point." (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" (when (> (point) 2000) (- (point) 2000)) t)) (re-search-forward "\\=#[-+.<|]" nil t) (when (and (looking-at "@") (eq (char-before) ?\,)) (forward-char))) (defun slime-end-of-symbol () "Move to the end of the CL-style symbol at point." (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) (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-bounds-of-symbol-at-point () "Return the bounds of the symbol around point. The returned bounds are either nil or non-empty." (let ((bounds (bounds-of-thing-at-point 'slime-symbol))) (if (and bounds (< (car bounds) (cdr bounds))) bounds))) (defun slime-symbol-at-point () "Return the name of the symbol at point, otherwise nil." ;; (thing-at-point 'symbol) returns "" in empty buffers (let ((bounds (slime-bounds-of-symbol-at-point))) (if bounds (buffer-substring-no-properties (car bounds) (cdr bounds))))) (defun slime-bounds-of-sexp-at-point () "Return the bounds sexp at point as a pair (or nil)." (or (slime-bounds-of-symbol-at-point) (and (equal (char-after) ?\() (member (char-before) '(?\' ?\, ?\@)) ;; hide stuff before ( to avoid quirks with '( etc. (save-restriction (narrow-to-region (point) (point-max)) (bounds-of-thing-at-point 'sexp))) (bounds-of-thing-at-point 'sexp))) (defun slime-sexp-at-point () "Return the sexp at point as a string, otherwise nil." (let ((bounds (slime-bounds-of-sexp-at-point))) (if bounds (buffer-substring-no-properties (car bounds) (cdr bounds))))) (defun slime-sexp-at-point-or-error () "Return the sexp at point as a string, othwise signal an error." (or (slime-sexp-at-point) (user-error "No expression at point"))) (defun slime-string-at-point () "Returns the string at point as a string, otherwise nil." (let ((sexp (slime-sexp-at-point))) (if (and sexp (eql (char-syntax (aref sexp 0)) ?\")) sexp nil))) (defun slime-string-at-point-or-error () "Return the sexp at point as a string, othwise signal an error." (or (slime-string-at-point) (error "No string at point."))) (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. (cl-loop do (skip-chars-forward " \t\r\n)") until (eobp) do (forward-sexp)) t))) (t t)))) ;;;; slime.el in pretty colors (cl-loop for sym in (list 'slime-def-connection-var 'slime-define-channel-type 'slime-define-channel-method 'define-slime-contrib 'slime-defun-if-undefined 'slime-defmacro-if-undefined) for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" sym) do (font-lock-add-keywords 'emacs-lisp-mode `((,regexp (1 font-lock-keyword-face) (2 font-lock-variable-name-face))))) ;;;; Finishing up (eval-when-compile (require 'bytecomp)) (defun slime--byte-compile (symbol) (require 'bytecomp) ;; tricky interaction between autoload and let. (let ((byte-compile-warnings '())) (byte-compile symbol))) (defun slime--compile-hotspots () (mapc (lambda (sym) (cond ((fboundp sym) (unless (byte-code-function-p (symbol-function sym)) (slime--byte-compile sym))) (t (error "%S is not fbound" sym)))) '(slime-alistify slime-log-event slime-events-buffer 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-insert-propertized slime-beginning-of-symbol slime-end-of-symbol slime-eval-feature-expression slime-forward-sexp slime-forward-cruft slime-forward-reader-conditional))) (slime--compile-hotspots) (add-to-list 'load-path (expand-file-name "contrib" slime-path)) (run-hooks 'slime-load-hook) (provide 'slime) (slime-setup) ;; Local Variables: ;; outline-regexp: ";;;;+" ;; indent-tabs-mode: nil ;; coding: latin-1-unix ;; End: ;;; slime.el ends here slime-2.20/start-swank.lisp000066400000000000000000000012621315100173500157120ustar00rootroot00000000000000;;; This file is intended to be loaded by an implementation to ;;; get a running swank server ;;; e.g. sbcl --load start-swank.lisp ;;; ;;; Default port is 4005 ;;; For additional swank-side configurations see ;;; 6.2 section of the Slime user manual. (load (merge-pathnames "swank-loader.lisp" *load-truename*)) (swank-loader:init :delete nil ; delete any existing SWANK packages :reload nil ; reload SWANK, even if the SWANK package already exists :load-contribs nil) ; load all contribs (swank:create-server :port 4005 ;; if non-nil the connection won't be closed ;; after connecting :dont-close nil) slime-2.20/swank-loader.lisp000066400000000000000000000334161315100173500160310ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- ;;; ;;; swank-loader.lisp --- Compile and load the Slime backend. ;;; ;;; Created 2003, James Bielman ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; ;; If you want customize the source- or fasl-directory you can set ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory* ;; before loading this files. ;; E.g.: ;; ;; (load ".../swank-loader.lisp") ;; (setq swank-loader::*fasl-directory* "/tmp/fasl/") ;; (swank-loader:init) (cl:defpackage :swank-loader (:use :cl) (:export :init :dump-image :list-fasls :*source-directory* :*fasl-directory*)) (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* #+cmu '((swank source-path-parser) (swank source-file-cache) (swank cmucl) (swank gray)) #+scl '((swank source-path-parser) (swank source-file-cache) (swank scl) (swank gray)) #+sbcl '((swank source-path-parser) (swank source-file-cache) (swank sbcl) (swank gray)) #+clozure '(metering (swank ccl) (swank gray)) #+lispworks '((swank lispworks) (swank gray)) #+allegro '((swank allegro) (swank gray)) #+clisp '(xref metering (swank clisp) (swank gray)) #+armedbear '((swank abcl)) #+cormanlisp '((swank corman) (swank gray)) #+ecl '((swank ecl) (swank gray)) #+clasp '((swank clasp) (swank gray)) #+mkcl '((swank mkcl) (swank gray)) ) (defparameter *implementation-features* '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp :armedbear :gcl :ecl :scl :mkcl :clasp)) (defparameter *os-features* '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux :unix)) (defparameter *architecture-features* '(:powerpc :ppc :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 :pentium3 :pentium4 :mips :mipsel :java-1.4 :java-1.5 :java-1.6 :java-1.7)) (defun q (s) (read-from-string s)) #+ecl (defun ecl-version-string () (format nil "~A~@[-~A~]" (lisp-implementation-version) (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id")))) (when (>= (length vcs-id) 8) (subseq vcs-id 0 8)))))) #+clasp (defun clasp-version-string () (format nil "~A~@[-~A~]" (lisp-implementation-version) (core:lisp-implementation-id))) (defun lisp-version-string () #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /")) (lisp-implementation-version)) #+(or cormanlisp scl mkcl) (lisp-implementation-version) #+sbcl (format nil "~a~:[~;-no-threads~]" (lisp-implementation-version) #+sb-thread nil #-sb-thread t) #+lispworks (lisp-implementation-version) #+allegro (format nil "~@{~a~}" excl::*common-lisp-version-number* (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn (if (member :smp *features*) "s" "") (if (member :64bit *features*) "-64bit" "") (excl:ics-target-case (:-ics "") (:+ics "-ics"))) #+clisp (let ((s (lisp-implementation-version))) (subseq s 0 (position #\space s))) #+armedbear (lisp-implementation-version) #+ecl (ecl-version-string) #+clasp (clasp-version-string)) (defun unique-dir-name () "Return a name that can be used as a directory name that is unique to a Lisp implementation, Lisp implementation version, operating system, and hardware architecture." (flet ((first-of (features) (loop for f in features when (find f *features*) return it)) (maybe-warn (value fstring &rest args) (cond (value) (t (apply #'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (first-of *implementation-features*) "No implementation feature found in ~a." *implementation-features*)) (os (maybe-warn (first-of *os-features*) "No os feature found in ~a." *os-features*)) (arch (maybe-warn (first-of *architecture-features*) "No architecture feature found in ~a." *architecture-features*)) (version (maybe-warn (lisp-version-string) "Don't know how to get Lisp ~ implementation version."))) (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) (defun file-newer-p (new-file old-file) "Returns true if NEW-FILE is newer than OLD-FILE." (> (file-write-date new-file) (file-write-date old-file))) (defun string-starts-with (string prefix) (string-equal string prefix :end1 (min (length string) (length prefix)))) (defun slime-version-string () "Return a string identifying the SLIME version. Return nil if nothing appropriate is available." (with-open-file (s (merge-pathnames "slime.el" *source-directory*) :if-does-not-exist nil) (loop with prefix = ";; Version: " for line = (read-line s nil :eof) until (eq line :eof) when (string-starts-with line prefix) return (subseq line (length prefix))))) (defun default-fasl-dir () (merge-pathnames (make-pathname :directory `(:relative ".slime" "fasl" ,@(if (slime-version-string) (list (slime-version-string))) ,(unique-dir-name))) (user-homedir-pathname))) (defvar *fasl-directory* (default-fasl-dir) "The directory where fasl files should be placed.") (defun binary-pathname (src-pathname binary-dir) "Return the pathname where SRC-PATHNAME's binary should be compiled." (let ((cfp (compile-file-pathname src-pathname))) (merge-pathnames (make-pathname :name (pathname-name cfp) :type (pathname-type cfp)) binary-dir))) (defun handle-swank-load-error (condition context pathname) (fresh-line *error-output*) (pprint-logical-block (*error-output* () :per-line-prefix ";; ") (format *error-output* "~%Error ~A ~A:~% ~A~%" context pathname condition))) (defun compile-files (files fasl-dir load quiet) "Compile each file in FILES if the source is newer than its corresponding binary, or the file preceding it was recompiled. If LOAD is true, load the fasl file." (let ((needs-recompile nil) (state :unknown)) (dolist (src files) (let ((dest (binary-pathname src fasl-dir))) (handler-bind ((error (lambda (c) (ecase state (:compile (handle-swank-load-error c "compiling" src)) (:load (handle-swank-load-error c "loading" dest)) (:unknown (handle-swank-load-error c "???ing" src)))))) (when (or needs-recompile (not (probe-file dest)) (file-newer-p src dest)) (ensure-directories-exist dest) ;; need to recompile SRC, so we'll need to recompile ;; everything after this too. (setf needs-recompile t state :compile) (or (compile-file src :output-file dest :print nil :verbose (not quiet)) ;; An implementation may not necessarily signal a ;; condition itself when COMPILE-FILE fails (e.g. ECL) (error "COMPILE-FILE returned NIL."))) (when load (setf state :load) (load dest :verbose (not quiet)))))))) #+cormanlisp (defun compile-files (files fasl-dir load quiet) "Corman Lisp has trouble with compiled files." (declare (ignore fasl-dir)) (when load (dolist (file files) (load file :verbose (not quiet) (force-output))))) (defun load-user-init-file () "Load the user init file, return NIL if it does not exist." (load (merge-pathnames (user-homedir-pathname) (make-pathname :name ".swank" :type "lisp")) :if-does-not-exist nil)) (defun load-site-init-file (dir) (load (make-pathname :name "site-init" :type "lisp" :defaults dir) :if-does-not-exist nil)) (defun src-files (names src-dir) (mapcar (lambda (name) (multiple-value-bind (dirs name) (etypecase name (symbol (values '() name)) (cons (values (butlast name) (car (last name))))) (make-pathname :directory (append (or (pathname-directory src-dir) '(:relative)) (mapcar #'string-downcase dirs)) :name (string-downcase name) :type "lisp" :defaults src-dir))) names)) (defvar *swank-files* `(packages (swank backend) ,@*sysdep-files* (swank match) (swank rpc) swank)) (defvar *contribs* '(swank-util swank-repl swank-c-p-c swank-arglists swank-fuzzy swank-fancy-inspector swank-presentations swank-presentation-streams #+(or asdf2 asdf3 sbcl ecl) swank-asdf swank-package-fu swank-hyperdoc #+sbcl swank-sbcl-exts swank-mrepl swank-trace-dialog swank-macrostep swank-quicklisp) "List of names for contrib modules.") (defun append-dir (absolute name) (merge-pathnames (make-pathname :directory `(:relative ,name) :defaults absolute) absolute)) (defun contrib-dir (base-dir) (append-dir base-dir "contrib")) (defun load-swank (&key (src-dir *source-directory*) (fasl-dir *fasl-directory*) quiet) (with-compilation-unit () (compile-files (src-files *swank-files* src-dir) fasl-dir t quiet)) (funcall (q "swank::before-init") (slime-version-string) (list (contrib-dir fasl-dir) (contrib-dir src-dir)))) (defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir) (let ((newest (reduce #'max (mapcar #'file-write-date swank-files)))) (dolist (src contrib-files) (let ((fasl (binary-pathname src fasl-dir))) (when (and (probe-file fasl) (<= (file-write-date fasl) newest)) (delete-file fasl)))))) (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*)) (fasl-dir (contrib-dir *fasl-directory*)) (swank-src-dir *source-directory*) load quiet) (let* ((swank-src-files (src-files *swank-files* swank-src-dir)) (contrib-src-files (src-files *contribs* src-dir))) (delete-stale-contrib-fasl-files swank-src-files contrib-src-files fasl-dir) (compile-files contrib-src-files fasl-dir load quiet))) (defun loadup () (load-swank) (compile-contribs :load t)) (defun setup () (load-site-init-file *source-directory*) (load-user-init-file) (when (#-clisp probe-file #+clisp ext:probe-directory (contrib-dir *source-directory*)) (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))) (funcall (q "swank::init"))) (defun list-swank-packages () (remove-if-not (lambda (package) (let ((name (package-name package))) (and (string-not-equal name "swank-loader") (string-starts-with name "swank")))) (list-all-packages))) (defun delete-packages (packages) (dolist (package packages) (flet ((handle-package-error (c) (let ((pkgs (set-difference (package-used-by-list package) packages))) (when pkgs (warn "deleting ~a which is used by ~{~a~^, ~}." package pkgs)) (continue c)))) (handler-bind ((package-error #'handle-package-error)) (delete-package package))))) (defun init (&key delete reload load-contribs (setup t) (quiet (not *load-verbose*))) "Load SWANK and initialize some global variables. If DELETE is true, delete any existing SWANK packages. If RELOAD is true, reload SWANK, even if the SWANK package already exists. If LOAD-CONTRIBS is true, load all contribs If SETUP is true, load user init files and initialize some global variabes in SWANK." (when (and delete (find-package :swank)) (delete-packages (list-swank-packages))) (cond ((or (not (find-package :swank)) reload) (load-swank :quiet quiet)) (t (warn "Not reloading SWANK. Package already exists."))) (when load-contribs (compile-contribs :load t :quiet quiet)) (when setup (setup))) (defun dump-image (filename) (init :setup nil) (funcall (q "swank/backend:save-image") filename)) (defun list-fasls (&key (include-contribs t) (compile t) (quiet (not *compile-verbose*))) "List up SWANK's fasls along with their dependencies." (flet ((collect-fasls (files fasl-dir) (when compile (compile-files files fasl-dir nil quiet)) (loop for src in files when (probe-file (binary-pathname src fasl-dir)) collect it))) (append (collect-fasls (src-files *swank-files* *source-directory*) *fasl-directory*) (when include-contribs (collect-fasls (src-files *contribs* (contrib-dir *source-directory*)) (contrib-dir *fasl-directory*)))))) slime-2.20/swank.asd000066400000000000000000000020571315100173500143620ustar00rootroot00000000000000;;; -*- 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 swank-loader-file (asdf:cl-source-file) ()) ;;;; after loading run init (defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file)) (load (asdf::component-pathname f)) (funcall (read-from-string "swank-loader::init") :reload t)) (asdf:defsystem :swank :default-component-class swank-loader-file :components ((:file "swank-loader"))) slime-2.20/swank.lisp000066400000000000000000004221311315100173500145610ustar00rootroot00000000000000;;;; swank.lisp --- Server for SLIME commands. ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; ;;; 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. (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.") (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 *backtrace-pprint-dispatch-table* (let ((table (copy-pprint-dispatch nil))) (flet ((print-string (stream string) (cond (*print-escape* (escape-string string stream :map '((#\" . "\\\"") (#\\ . "\\\\") (#\newline . "\\n") (#\return . "\\r")))) (t (write-string string stream))))) (set-pprint-dispatch 'string #'print-string 0 table) table))) (defvar *backtrace-printer-bindings* `((*print-pretty* . t) (*print-readably* . nil) (*print-level* . 4) (*print-length* . 6) (*print-lines* . 1) (*print-right-margin* . 200) (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*)) "Pretter settings for printing backtraces.") (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) ...)." (if (null alist) (funcall fun) (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 (eval-when (:compile-toplevel :load-toplevel :execute) (export ',name (symbol-package ',name))))) (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.") ;;;; 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). This ;;; is also the place where we keep everything that needs to be ;;; freed/closed/killed when we disconnect. (defstruct (connection (:constructor %make-connection) (:conc-name connection.) (:print-function print-connection)) ;; The listening socket. (usually closed) (socket (missing-arg) :type t :read-only t) ;; Character I/O stream of socket connection. Read-only to avoid ;; race conditions during initialization. (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)) ;; Bindings used for this connection (usually streams) (env '() :type list) ;; 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)) ;; 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)) ) (defun print-connection (conn stream depth) (declare (ignore depth)) (print-unreadable-object (conn stream :type t :identity t))) (defstruct (singlethreaded-connection (:include connection) (:conc-name sconn.)) ;; The SIGINT handler we should restore when the connection is ;; closed. saved-sigint-handler ;; A queue of events. Not all events can be processed in order and ;; we need a place to stored them. (event-queue '() :type list) ;; A counter that is incremented whenever an event is added to the ;; queue. This is used to detected modifications to the event queue ;; by interrupts. The counter wraps around. (events-enqueued 0 :type fixnum)) (defstruct (multithreaded-connection (:include connection) (:conc-name mconn.)) ;; 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 auto-flush-thread indentation-cache-thread ;; List of threads that are currently processing requests. We use ;; this to find the newest/current thread for an interrupt. In the ;; future we may store here (thread . request-tag) pairs so that we ;; can interrupt specific requests. (active-threads '() :type list) ) (defvar *emacs-connection* nil "The connection to Emacs currently in use.") (defun make-connection (socket stream style) (let ((conn (funcall (ecase style (:spawn #'make-multithreaded-connection) ((:sigio nil :fd-handler) #'make-singlethreaded-connection)) :socket socket :socket-io stream :communication-style style))) (run-hook *new-connection-hook* conn) (send-to-sentinel `(:add-connection ,conn)) conn)) (defslimefun ping (tag) tag) (defun safe-backtrace () (ignore-errors (call-with-debugging-environment (lambda () (backtrace 0 nil))))) (define-condition swank-error (error) ((backtrace :initarg :backtrace :reader swank-error.backtrace) (condition :initarg :condition :reader swank-error.condition)) (:report (lambda (c s) (princ (swank-error.condition c) s))) (:documentation "Condition which carries a backtrace.")) (defun signal-swank-error (condition &optional (backtrace (safe-backtrace))) (error 'swank-error :condition condition :backtrace backtrace)) (defvar *debug-on-swank-protocol-error* nil "When non-nil invoke the system debugger on errors that were signalled during decoding/encoding the wire protocol. Do not set this to T unless you want to debug swank internals.") (defmacro with-swank-error-handler ((connection) &body body) "Close the connection on internal `swank-error's." (let ((conn (gensym))) `(let ((,conn ,connection)) (handler-case (handler-bind ((swank-error (lambda (condition) (when *debug-on-swank-protocol-error* (invoke-default-debugger condition))))) (progn . ,body)) (swank-error (condition) (close-connection ,conn (swank-error.condition condition) (swank-error.backtrace condition))))))) (defmacro with-panic-handler ((connection) &body body) "Close the connection on unhandled `serious-condition's." (let ((conn (gensym))) `(let ((,conn ,connection)) (handler-bind ((serious-condition (lambda (condition) (close-connection ,conn condition (safe-backtrace)) (abort condition)))) . ,body)))) (add-hook *new-connection-hook* 'notify-backend-of-connection) (defun notify-backend-of-connection (connection) (declare (ignore connection)) (emacs-connected)) ;;;; Utilities ;;;;; Logging (defvar *swank-io-package* (let ((package (make-package :swank-io-package :use '()))) (import '(nil t quote) package) package)) (defvar *log-events* nil) (defun init-log-output () (unless *log-output* (setq *log-output* (real-output-stream *error-output*)))) (add-hook *after-init-hook* 'init-log-output) (defun real-input-stream (stream) (typecase stream (synonym-stream (real-input-stream (symbol-value (synonym-stream-symbol stream)))) (two-way-stream (real-input-stream (two-way-stream-input-stream stream))) (t stream))) (defun real-output-stream (stream) (typecase stream (synonym-stream (real-output-stream (symbol-value (synonym-stream-symbol stream)))) (two-way-stream (real-output-stream (two-way-stream-output-stream stream))) (t stream))) (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* (write-string (escape-non-ascii (format nil "~?" format-string args)) *log-output*) (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 clear-event-history () (fill *event-history* nil) (setq *event-history-index* 0)) (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 (write-string (escape-non-ascii (format nil "Unexpected event: ~A~%" event)) stream)))) (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)) ;;;;; Helper macros (defmacro dcase (value &body 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 "dcase failed: ~S" ,tmp)))))))) ;;;; Interrupt handling ;; Usually we'd like to enter the debugger when an interrupt happens. ;; But for some operations, in particular send&receive, it's crucial ;; that those are not interrupted when the mailbox is in an ;; inconsistent/locked state. Obviously, if send&receive don't work we ;; can't communicate and the debugger will not work. To solve that ;; problem, we try to handle interrupts only at certain safe-points. ;; ;; Whenever an interrupt happens we call the function ;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the ;; debugger, but if interrupts are disabled the interrupt is put in a ;; queue for later processing. At safe-points, we call ;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the ;; debugger if needed. ;; ;; The queue for interrupts is stored in a thread local variable. ;; WITH-CONNECTION sets it up. WITH-SLIME-INTERRUPTS allows ;; interrupts, i.e. the debugger is entered immediately. When we call ;; "user code" or non-problematic code we allow interrupts. When ;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued. When we ;; switch from "user code" to more delicate operations we need to ;; disable interrupts. In particular, interrupts should be disabled ;; for SEND and RECEIVE-IF. ;; If true execute interrupts, otherwise queue them. ;; Note: `with-connection' binds *pending-slime-interrupts*. (defvar *slime-interrupts-enabled*) (defmacro with-interrupts-enabled% (flag body) `(progn ,@(if flag '((check-slime-interrupts))) (multiple-value-prog1 (let ((*slime-interrupts-enabled* ,flag)) ,@body) ,@(if flag '((check-slime-interrupts)))))) (defmacro with-slime-interrupts (&body body) `(with-interrupts-enabled% t ,body)) (defmacro without-slime-interrupts (&body body) `(with-interrupts-enabled% nil ,body)) (defun queue-thread-interrupt (thread function) (interrupt-thread thread (lambda () ;; safely interrupt THREAD (when (invoke-or-queue-interrupt function) (wake-thread thread))))) (defun invoke-or-queue-interrupt (function) (log-event "invoke-or-queue-interrupt: ~a~%" function) (cond ((not (boundp '*slime-interrupts-enabled*)) (without-slime-interrupts (funcall function))) (*slime-interrupts-enabled* (log-event "interrupts-enabled~%") (funcall function)) (t (setq *pending-slime-interrupts* (nconc *pending-slime-interrupts* (list function))) (cond ((cdr *pending-slime-interrupts*) (log-event "too many queued interrupts~%") (with-simple-restart (continue "Continue from interrupt") (handler-bind ((serious-condition #'invoke-slime-debugger)) (check-slime-interrupts)))) (t (log-event "queue-interrupt: ~a~%" function) (when *interrupt-queued-handler* (funcall *interrupt-queued-handler*)) t))))) ;;; FIXME: poor name? (defmacro with-io-redirection ((connection) &body body) "Execute BODY I/O redirection to CONNECTION. " `(with-bindings (connection.env ,connection) . ,body)) ;; Thread local variable used for flow-control. ;; It's bound by `with-connection'. (defvar *send-counter*) (defmacro with-connection ((connection) &body body) "Execute BODY in the context of CONNECTION." `(let ((connection ,connection) (function (lambda () . ,body))) (if (eq *emacs-connection* connection) (funcall function) (let ((*emacs-connection* connection) (*pending-slime-interrupts* '()) (*send-counter* 0)) (without-slime-interrupts (with-swank-error-handler (connection) (with-io-redirection (connection) (call-with-debugger-hook #'swank-debugger-hook function)))))))) (defun call-with-retry-restart (msg thunk) (loop (with-simple-restart (retry "~a" msg) (return (funcall thunk))))) (defmacro with-retry-restart ((&key (msg "Retry.")) &body body) (check-type msg string) `(call-with-retry-restart ,msg (lambda () ,@body))) (defmacro with-struct* ((conc-name get obj) &body body) (let ((var (gensym))) `(let ((,var ,obj)) (macrolet ((,get (slot) (let ((getter (intern (concatenate 'string ',(string conc-name) (string slot)) (symbol-package ',conc-name)))) `(,getter ,',var)))) ,@body)))) (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))) ;;;;; Sentinel ;;; ;;; The sentinel thread manages some global lists. ;;; FIXME: Overdesigned? (defvar *connections* '() "List of all active connections, with the most recent at the front.") (defvar *servers* '() "A list ((server-socket port thread) ...) describing the listening sockets. Used to close sockets on server shutdown or restart.") ;; FIXME: we simply access the global variable here. We could ask the ;; sentinel thread instead but then we still have the problem that the ;; connection could be closed before we use it. (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." (car *connections*)) (defun start-sentinel () (unless (find-registered 'sentinel) (let ((thread (spawn #'sentinel :name "Swank Sentinel"))) (register-thread 'sentinel thread)))) (defun sentinel () (catch 'exit-sentinel (loop (sentinel-serve (receive))))) (defun send-to-sentinel (msg) (let ((sentinel (find-registered 'sentinel))) (cond (sentinel (send sentinel msg)) (t (sentinel-serve msg))))) (defun sentinel-serve (msg) (dcase msg ((:add-connection conn) (push conn *connections*)) ((:close-connection connection condition backtrace) (close-connection% connection condition backtrace) (sentinel-maybe-exit)) ((:add-server socket port thread) (push (list socket port thread) *servers*)) ((:stop-server key port) (sentinel-stop-server key port) (sentinel-maybe-exit)))) (defun sentinel-stop-server (key value) (let ((probe (find value *servers* :key (ecase key (:socket #'car) (:port #'cadr))))) (cond (probe (setq *servers* (delete probe *servers*)) (destructuring-bind (socket _port thread) probe (declare (ignore _port)) (ignore-errors (close-socket socket)) (when (and thread (thread-alive-p thread) (not (eq thread (current-thread)))) (kill-thread thread)))) (t (warn "No server for ~s: ~s" key value))))) (defun sentinel-maybe-exit () (when (and (null *connections*) (null *servers*) (and (current-thread) (eq (find-registered 'sentinel) (current-thread)))) (register-thread 'sentinel nil) (throw 'exit-sentinel nil))) ;;;;; Misc (defun use-threads-p () (eq (connection.communication-style *emacs-connection*) :spawn)) (defun current-thread-id () (thread-id (current-thread))) (declaim (inline ensure-list)) (defun ensure-list (thing) (if (listp thing) thing (list thing))) ;;;;; Symbols ;; FIXME: this docstring is more confusing than helpful. (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)) ;;;; TCP Server (defvar *communication-style* (preferred-communication-style)) (defvar *dont-close* nil "Default value of :dont-close argument to start-server and create-server.") (defparameter *loopback-interface* "127.0.0.1") (defun start-server (port-file &key (style *communication-style*) (dont-close *dont-close*)) "Start the server and write the listen port number to PORT-FILE. This is the entry point for Emacs." (setup-server 0 (lambda (port) (announce-server-port port-file port)) style dont-close nil)) (defun create-server (&key (port default-server-port) (style *communication-style*) (dont-close *dont-close*) interface backlog) "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. Optionally, an INTERFACE could be specified and swank will bind the PORT on this interface. By default, interface is 127.0.0.1." (let ((*loopback-interface* (or interface *loopback-interface*))) (setup-server port #'simple-announce-function style dont-close backlog))) (defun find-external-format-or-lose (coding-system) (or (find-external-format coding-system) (error "Unsupported coding system: ~s" coding-system))) (defmacro restart-loop (form &body clauses) "Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's environment before trying again (by returning normally) or giving up (through an explicit transfer of control), all within an implicit block named nil. e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))" `(loop (restart-case (return ,form) ,@clauses))) (defun socket-quest (port backlog) (restart-loop (create-socket *loopback-interface* port :backlog backlog) (use-value (&optional (new-port (1+ port))) :report (lambda (stream) (format stream "Try a port other than ~D" port)) :interactive (lambda () (format *query-io* "Enter port (defaults to ~D): " (1+ port)) (finish-output *query-io*) ; necessary for tunnels (ignore-errors (list (parse-integer (read-line *query-io*))))) (setq port new-port)))) (defun setup-server (port announce-fn style dont-close backlog) (init-log-output) (let* ((socket (socket-quest port backlog)) (port (local-port socket))) (funcall announce-fn port) (labels ((serve () (accept-connections socket style dont-close)) (note () (send-to-sentinel `(:add-server ,socket ,port ,(current-thread)))) (serve-loop () (note) (loop do (serve) while dont-close))) (ecase style (:spawn (initialize-multiprocessing (lambda () (start-sentinel) (spawn #'serve-loop :name (format nil "Swank ~s" port))))) ((:fd-handler :sigio) (note) (add-fd-handler socket #'serve)) ((nil) (serve-loop)))) port)) (defun stop-server (port) "Stop server running on PORT." (send-to-sentinel `(:stop-server :port ,port))) (defun restart-server (&key (port default-server-port) (style *communication-style*) (dont-close *dont-close*)) "Stop the server listening on PORT, then start a new 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." (stop-server port) (sleep 5) (create-server :port port :style style :dont-close dont-close)) (defun accept-connections (socket style dont-close) (let ((client (unwind-protect (accept-connection socket :external-format nil :buffering t) (unless dont-close (close-socket socket))))) (authenticate-client client) (serve-requests (make-connection socket client style)) (unless dont-close (send-to-sentinel `(:stop-server :socket ,socket))))) (defun authenticate-client (stream) (let ((secret (slime-secret))) (when secret (set-stream-timeout stream 20) (let ((first-val (read-packet stream))) (unless (and (stringp first-val) (string= first-val secret)) (error "Incoming connection doesn't know the password."))) (set-stream-timeout stream nil)))) (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." (etypecase connection (multithreaded-connection (spawn-threads-for-connection connection)) (singlethreaded-connection (ecase (connection.communication-style connection) ((nil) (simple-serve-requests connection)) (:sigio (install-sigio-handler connection)) (:fd-handler (install-fd-handler connection)))))) (defun stop-serving-requests (connection) (etypecase connection (multithreaded-connection (cleanup-connection-threads connection)) (singlethreaded-connection (ecase (connection.communication-style connection) ((nil)) (:sigio (deinstall-sigio-handler connection)) (:fd-handler (deinstall-fd-handler 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*))) ;;;;; Event Decoding/Encoding (defun decode-message (stream) "Read an S-expression from STREAM using the SLIME protocol." (log-event "decode-message~%") (without-slime-interrupts (handler-bind ((error #'signal-swank-error)) (handler-case (read-message stream *swank-io-package*) (swank-reader-error (c) `(:reader-error ,(swank-reader-error.packet c) ,(swank-reader-error.cause c))))))) (defun encode-message (message stream) "Write an S-expression to STREAM using the SLIME protocol." (log-event "encode-message~%") (without-slime-interrupts (handler-bind ((error #'signal-swank-error)) (write-message message *swank-io-package* stream)))) ;;;;; Event Processing (defvar *sldb-quit-restart* nil "The restart that will be invoked when the user calls sldb-quit.") ;; Establish a top-level restart and execute BODY. ;; Execute K if the restart is invoked. (defmacro with-top-level-restart ((connection k) &body body) `(with-connection (,connection) (restart-case (let ((*sldb-quit-restart* (find-restart 'abort))) ,@body) (abort (&optional v) :report "Return to SLIME's top level." (declare (ignore v)) (force-user-output) ,k)))) (defun handle-requests (connection &optional timeout) "Read and process :emacs-rex requests. The processing is done in the extent of the toplevel restart." (with-connection (connection) (cond (*sldb-quit-restart* (process-requests timeout)) (t (tagbody start (with-top-level-restart (connection (go start)) (process-requests timeout))))))) (defun process-requests (timeout) "Read and process requests from Emacs." (loop (multiple-value-bind (event timeout?) (wait-for-event `(or (:emacs-rex . _) (:emacs-channel-send . _)) timeout) (when timeout? (return)) (dcase event ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) ((:emacs-channel-send channel (selector &rest args)) (channel-send channel selector args)))))) (defun current-socket-io () (connection.socket-io *emacs-connection*)) (defun close-connection (connection condition backtrace) (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace))) (defun close-connection% (c condition backtrace) (let ((*debugger-hook* nil)) (log-event "close-connection: ~a ...~%" condition) (format *log-output* "~&;; swank:close-connection: ~A~%" (escape-non-ascii (safe-condition-message condition))) (stop-serving-requests 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~%~ ;; style: ~S]~%" (loop for (i f) in backtrace collect (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f)))) (escape-non-ascii (safe-condition-message condition) ) (type-of condition) (connection.communication-style c))) (finish-output *log-output*) (log-event "close-connection ~a ... done.~%" condition))) ;;;;;; Thread based communication (defun read-loop (connection) (let ((input-stream (connection.socket-io connection)) (control-thread (mconn.control-thread connection))) (with-swank-error-handler (connection) (loop (send control-thread (decode-message input-stream)))))) (defun dispatch-loop (connection) (let ((*emacs-connection* connection)) (with-panic-handler (connection) (loop (dispatch-event connection (receive)))))) (defvar *auto-flush-interval* 0.2) (defun auto-flush-loop (stream) (loop (when (not (and (open-stream-p stream) (output-stream-p stream))) (return nil)) (force-output stream) (sleep *auto-flush-interval*))) (defgeneric thread-for-evaluation (connection id) (:documentation "Find or create a thread to evaluate the next request.") (:method ((connection multithreaded-connection) (id (eql t))) (spawn-worker-thread connection)) (:method ((connection multithreaded-connection) (id (eql :find-existing))) (car (mconn.active-threads connection))) (:method (connection (id integer)) (declare (ignorable connection)) (find-thread id)) (:method ((connection singlethreaded-connection) id) (declare (ignorable connection connection id)) (current-thread))) (defun interrupt-worker-thread (connection id) (let ((thread (thread-for-evaluation connection (cond ((eq id t) :find-existing) (t id))))) (log-event "interrupt-worker-thread: ~a ~a~%" id thread) (if thread (etypecase connection (multithreaded-connection (queue-thread-interrupt thread #'simple-break)) (singlethreaded-connection (simple-break))) (encode-message (list :debug-condition (current-thread-id) (format nil "Thread with id ~a not found" id)) (current-socket-io))))) (defun spawn-worker-thread (connection) (spawn (lambda () (with-bindings *default-worker-thread-bindings* (with-top-level-restart (connection nil) (apply #'eval-for-emacs (cdr (wait-for-event `(:emacs-rex . _))))))) :name "worker")) (defun add-active-thread (connection thread) (etypecase connection (multithreaded-connection (push thread (mconn.active-threads connection))) (singlethreaded-connection))) (defun remove-active-thread (connection thread) (etypecase connection (multithreaded-connection (setf (mconn.active-threads connection) (delete thread (mconn.active-threads connection) :count 1))) (singlethreaded-connection))) (defun dispatch-event (connection event) "Handle an event triggered either by Emacs or within Lisp." (log-event "dispatch-event: ~s~%" event) (dcase event ((:emacs-rex form package thread-id id) (let ((thread (thread-for-evaluation connection thread-id))) (cond (thread (add-active-thread connection thread) (send-event thread `(:emacs-rex ,form ,package ,id))) (t (encode-message (list :invalid-rpc id (format nil "Thread not found: ~s" thread-id)) (current-socket-io)))))) ((:return thread &rest args) (remove-active-thread connection thread) (encode-message `(:return ,@args) (current-socket-io))) ((:emacs-interrupt thread-id) (interrupt-worker-thread connection thread-id)) (((:write-string :debug :debug-condition :debug-activate :debug-return :channel-send :presentation-start :presentation-end :new-package :new-features :ed :indentation-update :eval :eval-no-wait :background-message :inspect :ping :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay :write-image) &rest _) (declare (ignore _)) (encode-message event (current-socket-io))) (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args) (send-event (find-thread thread-id) (cons (car event) args))) ((:emacs-channel-send channel-id msg) (let ((ch (find-channel channel-id))) (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg)))) ((:reader-error packet condition) (encode-message `(:reader-error ,packet ,(safe-condition-message condition)) (current-socket-io))))) (defun send-event (thread event) (log-event "send-event: ~s ~s~%" thread event) (let ((c *emacs-connection*)) (etypecase c (multithreaded-connection (send thread event)) (singlethreaded-connection (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event))) (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c)) most-positive-fixnum)))))) (defun send-to-emacs (event) "Send EVENT to Emacs." ;;(log-event "send-to-emacs: ~a" event) (without-slime-interrupts (let ((c *emacs-connection*)) (etypecase c (multithreaded-connection (send (mconn.control-thread c) event)) (singlethreaded-connection (dispatch-event c event))) (maybe-slow-down)))) ;;;;;; Flow control ;; After sending N (usually 100) messages we slow down and ping Emacs ;; to make sure that everything we have sent so far was received. (defconstant send-counter-limit 100) (defun maybe-slow-down () (let ((counter (incf *send-counter*))) (when (< send-counter-limit counter) (setf *send-counter* 0) (ping-pong)))) (defun ping-pong () (let* ((tag (make-tag)) (pattern `(:emacs-pong ,tag))) (send-to-emacs `(:ping ,(current-thread-id) ,tag)) (wait-for-event pattern))) (defun wait-for-event (pattern &optional timeout) "Scan the event queue for PATTERN and return the event. If TIMEOUT is 'nil wait until a matching event is enqued. If TIMEOUT is 't only scan the queue without waiting. The second return value is t if the timeout expired before a matching event was found." (log-event "wait-for-event: ~s ~s~%" pattern timeout) (without-slime-interrupts (let ((c *emacs-connection*)) (etypecase c (multithreaded-connection (receive-if (lambda (e) (event-match-p e pattern)) timeout)) (singlethreaded-connection (wait-for-event/event-loop c pattern timeout)))))) (defun wait-for-event/event-loop (connection pattern timeout) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (let ((event (poll-for-event connection pattern))) (when event (return (car event)))) (let ((events-enqueued (sconn.events-enqueued connection)) (ready (wait-for-input (list (current-socket-io)) timeout))) (cond ((and timeout (not ready)) (return (values nil t))) ((or (/= events-enqueued (sconn.events-enqueued connection)) (eq ready :interrupt)) ;; rescan event queue, interrupts may enqueue new events ) (t (assert (equal ready (list (current-socket-io)))) (dispatch-event connection (decode-message (current-socket-io)))))))) (defun poll-for-event (connection pattern) (let* ((c connection) (tail (member-if (lambda (e) (event-match-p e pattern)) (sconn.event-queue c)))) (when tail (setf (sconn.event-queue c) (nconc (ldiff (sconn.event-queue c) tail) (cdr tail))) tail))) ;;; FIXME: Make this use SWANK-MATCH. (defun event-match-p (event pattern) (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) (member pattern '(nil t))) (equal event pattern)) ((symbolp pattern) t) ((consp pattern) (case (car pattern) ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern))) (t (and (consp event) (and (event-match-p (car event) (car pattern)) (event-match-p (cdr event) (cdr pattern))))))) (t (error "Invalid pattern: ~S" pattern)))) (defun spawn-threads-for-connection (connection) (setf (mconn.control-thread connection) (spawn (lambda () (control-thread connection)) :name "control-thread")) connection) (defun control-thread (connection) (with-struct* (mconn. @ connection) (setf (@ control-thread) (current-thread)) (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) :name "reader-thread")) (setf (@ indentation-cache-thread) (spawn (lambda () (indentation-cache-loop connection)) :name "swank-indentation-cache-thread")) (dispatch-loop connection))) (defun cleanup-connection-threads (connection) (let* ((c connection) (threads (list (mconn.repl-thread c) (mconn.reader-thread c) (mconn.control-thread c) (mconn.auto-flush-thread c) (mconn.indentation-cache-thread c)))) (dolist (thread threads) (when (and thread (thread-alive-p thread) (not (equal (current-thread) thread))) (kill-thread thread))))) ;;;;;; Signal driven IO (defun install-sigio-handler (connection) (add-sigio-handler (connection.socket-io connection) (lambda () (process-io-interrupt connection))) (handle-requests connection t)) (defvar *io-interupt-level* 0) (defun process-io-interrupt (connection) (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) (let ((*io-interupt-level* (1+ *io-interupt-level*))) (invoke-or-queue-interrupt (lambda () (handle-requests connection t)))) (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*)) (defun deinstall-sigio-handler (connection) (log-event "deinstall-sigio-handler...~%") (remove-sigio-handlers (connection.socket-io connection)) (log-event "deinstall-sigio-handler...done~%")) ;;;;;; SERVE-EVENT based IO (defun install-fd-handler (connection) (add-fd-handler (connection.socket-io connection) (lambda () (handle-requests connection t))) (setf (sconn.saved-sigint-handler connection) (install-sigint-handler (lambda () (invoke-or-queue-interrupt (lambda () (dispatch-interrupt-event connection)))))) (handle-requests connection t)) (defun dispatch-interrupt-event (connection) (with-connection (connection) (dispatch-event connection `(:emacs-interrupt ,(current-thread-id))))) (defun deinstall-fd-handler (connection) (log-event "deinstall-fd-handler~%") (remove-fd-handlers (connection.socket-io connection)) (install-sigint-handler (sconn.saved-sigint-handler connection))) ;;;;;; Simple sequential IO (defun simple-serve-requests (connection) (unwind-protect (with-connection (connection) (call-with-user-break-handler (lambda () (invoke-or-queue-interrupt (lambda () (dispatch-interrupt-event connection)))) (lambda () (with-simple-restart (close-connection "Close SLIME connection.") (let* ((stdin (real-input-stream *standard-input*)) (*standard-input* (make-repl-input-stream connection stdin))) (tagbody toplevel (with-top-level-restart (connection (go toplevel)) (simple-repl)))))))) (close-connection connection nil (safe-backtrace)))) ;; this is signalled when our custom stream thinks the end-of-file is reached. ;; (not when the end-of-file on the socket is reached) (define-condition end-of-repl-input (end-of-file) ()) (defun simple-repl () (loop (format t "~a> " (package-string-for-prompt *package*)) (force-output) (let ((form (handler-case (read) (end-of-repl-input () (return))))) (let ((- form) (values (multiple-value-list (eval form)))) (setq *** ** ** * * (car values) /// // // / / values +++ ++ ++ + + form) (cond ((null values) (format t "; No values~&")) (t (mapc (lambda (v) (format t "~s~&" v)) values))))))) (defun make-repl-input-stream (connection stdin) (make-input-stream (lambda () (repl-input-stream-read connection stdin)))) (defun repl-input-stream-read (connection stdin) (loop (let* ((socket (connection.socket-io connection)) (inputs (list socket stdin)) (ready (wait-for-input inputs))) (cond ((eq ready :interrupt) (check-slime-interrupts)) ((member socket ready) ;; A Slime request from Emacs is pending; make sure to ;; redirect IO to the REPL buffer. (with-simple-restart (process-input "Continue reading input.") (let ((*sldb-quit-restart* (find-restart 'process-input))) (with-io-redirection (connection) (handle-requests connection t))))) ((member stdin ready) ;; User typed something into the *inferior-lisp* buffer, ;; so do not redirect. (return (read-non-blocking stdin))) (t (assert (null ready))))))) (defun read-non-blocking (stream) (with-output-to-string (str) (handler-case (loop (let ((c (read-char-no-hang stream))) (unless c (return)) (write-char c str))) (end-of-file () (error 'end-of-repl-input :stream stream))))) ;;; Channels ;; FIXME: should be per connection not global. (defvar *channels* '()) (defvar *channel-counter* 0) (defclass channel () ((id :reader channel-id) (thread :initarg :thread :initform (current-thread) :reader channel-thread) (name :initarg :name :initform nil))) (defmethod initialize-instance :after ((ch channel) &key) (with-slots (id) ch (setf id (incf *channel-counter*)) (push (cons id ch) *channels*))) (defmethod print-object ((c channel) stream) (print-unreadable-object (c stream :type t) (with-slots (id name) c (format stream "~d ~a" id name)))) (defun find-channel (id) (cdr (assoc id *channels*))) (defgeneric channel-send (channel selector args)) (defmacro define-channel-method (selector (channel &rest args) &body body) `(defmethod channel-send (,channel (selector (eql ',selector)) args) (destructuring-bind ,args args . ,body))) (defun send-to-remote-channel (channel-id msg) (send-to-emacs `(:channel-send ,channel-id ,msg))) (defvar *slime-features* nil "The feature list that has been sent to Emacs.") (defun send-oob-to-emacs (object) (send-to-emacs object)) ;; FIXME: belongs to swank-repl.lisp (defun force-user-output () (force-output (connection.user-io *emacs-connection*))) (add-hook *pre-reply-hook* 'force-user-output) ;; FIXME: belongs to swank-repl.lisp (defun clear-user-input () (clear-input (connection.user-input *emacs-connection*))) ;; FIXME: not thread save. (defvar *tag-counter* 0) (defun make-tag () (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22)))) (defun y-or-n-p-in-emacs (format-string &rest arguments) "Like y-or-n-p, but ask in the Emacs minibuffer." (let ((tag (make-tag)) (question (apply #'format nil format-string arguments))) (force-output) (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question)) (third (wait-for-event `(:emacs-return ,tag result))))) (defun read-from-minibuffer-in-emacs (prompt &optional initial-value) "Ask user a question in Emacs' minibuffer. Returns \"\" when user entered nothing, returns NIL when user pressed C-g." (check-type prompt string) (check-type initial-value (or null string)) (let ((tag (make-tag))) (force-output) (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag ,prompt ,initial-value)) (third (wait-for-event `(:emacs-return ,tag result))))) (defstruct (unredable-result (:constructor make-unredable-result (string)) (:copier nil) (:print-object (lambda (object stream) (print-unreadable-object (object stream :type t) (princ (unredable-result-string object) stream))))) string) (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' ? 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. `slime-enable-evaluate-in-emacs' should be set to T on the Emacs side." (cond (nowait (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) (t (force-output) (let ((tag (make-tag))) (send-to-emacs `(:eval ,(current-thread-id) ,tag ,(process-form-for-emacs form))) (let ((value (caddr (wait-for-event `(:emacs-return ,tag result))))) (dcase value ((:unreadable value) (make-unredable-result value)) ((:ok value) value) ((:error kind . data) (error "~a: ~{~a~}" kind data)) ((: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" (let ((c *emacs-connection*)) (setq *slime-features* *features*) `(:pid ,(getpid) :style ,(connection.communication-style c) :encoding (:coding-systems ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix") when (find-external-format cs) collect cs)) :lisp-implementation (:type ,(lisp-implementation-type) :name ,(lisp-implementation-type-name) :version ,(lisp-implementation-version) :program ,(lisp-implementation-program)) :machine (:instance ,(machine-instance) :type ,(machine-type) :version ,(machine-version)) :features ,(features-for-emacs) :modules ,*modules* :package (:name ,(package-name *package*) :prompt ,(package-string-for-prompt *package*)) :version ,*swank-wire-protocol-version*))) (defun debug-on-swank-error () (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*)) *debug-on-swank-protocol-error*) (defun (setf debug-on-swank-error) (new-value) (setf *debug-on-swank-protocol-error* new-value) (setf *debug-swank-backend* new-value)) (defslimefun toggle-debug-on-swank-error () (setf (debug-on-swank-error) (not (debug-on-swank-error)))) ;;;; Reading and printing (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 ((&optional package) &body body) "Execute BODY with appropriate *package* and *readtable* bindings. This should be used for code that is conceptionally executed in an Emacs buffer." `(call-with-buffer-syntax ,package (lambda () ,@body))) (defun call-with-buffer-syntax (package fun) (let ((*package* (if package (guess-buffer-package 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))))) (defmacro without-printing-errors ((&key object stream (msg "<>")) &body body) "Catches errors during evaluation of BODY and prints MSG instead." `(handler-case (progn ,@body) (serious-condition () ,(cond ((and stream object) (let ((gstream (gensym "STREAM+"))) `(let ((,gstream ,stream)) (print-unreadable-object (,object ,gstream :type t :identity t) (write-string ,msg ,gstream))))) (stream `(write-string ,msg ,stream)) (object `(with-output-to-string (s) (print-unreadable-object (,object s :type t :identity t) (write-string ,msg s)))) (t msg))))) (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)) (without-printing-errors (:object object :stream nil) (prin1-to-string object))))) (defun from-string (string) "Read string in the *BUFFER-PACKAGE*" (with-buffer-syntax () (let ((*read-suppress* nil)) (values (read-from-string string))))) (defun parse-string (string package) "Read STRING in PACKAGE." (with-buffer-syntax (package) (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 (not vertical))) (vertical (vector-push-extend char token)) ((char= char #\:) (cond ((and package internp) (return-from tokenize-symbol-thoroughly)) (package (setq internp t)) (t (setq package token token (make-array (length string) :element-type 'character :fill-pointer 0))))) (t (vector-push-extend (casify-char char) token)))) (unless vertical (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 find-symbol-with-status (symbol-name status &optional (package *package*)) (multiple-value-bind (symbol flag) (find-symbol symbol-name package) (if (and flag (eq flag status)) (values symbol flag) (values nil nil)))) (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 internalp) (tokenize-symbol-thoroughly string) (when sname (let ((package (cond ((string= pname "") keyword-package) (pname (find-package pname)) (t package)))) (if package (multiple-value-bind (symbol flag) (if internalp (find-symbol sname package) (find-symbol-with-status sname ':external 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)))) (defun parse-package (string) "Find the package named STRING. Return the package or nil." ;; STRING comes usually from a (in-package STRING) form. (ignore-errors (find-package (let ((*package* *swank-io-package*)) (read-from-string string))))) (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." (when string (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 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." (let (ok result condition) (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))) (handler-bind ((t (lambda (c) (setf condition c)))) (setq result (with-slime-interrupts (eval form)))) (run-hook *pre-reply-hook*) (setq ok t)) (send-to-emacs `(:return ,(current-thread) ,(if ok `(:ok ,result) `(:abort ,(prin1-to-string condition))) ,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 (integerp (car values)) (null (cdr values))) (let ((i (car values))) (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)" *echo-area-prefix* i (integer-length i) i i i))) ((and (typep (car values) 'ratio) (null (cdr values)) (ignore-errors ;; The ratio may be to large to be represented as a single float (format nil "~A~D (~:*~f)" *echo-area-prefix* (car values))))) (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values)))))) (defmacro values-to-string (values) `(format-values-for-echo-area (multiple-value-list ,values))) (defslimefun interactive-eval (string) (with-buffer-syntax () (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") (let ((values (multiple-value-list (eval (from-string string))))) (finish-output) (format-values-for-echo-area values))))) (defslimefun eval-and-grab-output (string) (with-buffer-syntax () (with-retry-restart (:msg "Retry SLIME evaluation request.") (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) (finish-output) (return (values values -))) (setq - form) (setq values (multiple-value-list (eval form))) (finish-output)))))) (defslimefun interactive-eval-region (string) (with-buffer-syntax () (with-retry-restart (:msg "Retry SLIME interactive evaluation request.") (format-values-for-echo-area (eval-region string))))) (defslimefun re-evaluate-defvar (form) (with-buffer-syntax () (with-retry-restart (:msg "Retry SLIME evaluation request.") (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 (values) "Bind some printer variables and pretty print each object in VALUES." (with-buffer-syntax () (with-bindings *swank-pprint-bindings* (cond ((null values) "; No value") (t (with-output-to-string (*standard-output*) (dolist (o values) (pprint o) (terpri)))))))) (defslimefun pprint-eval (string) (with-buffer-syntax () (let* ((s (make-string-output-stream)) (values (let ((*standard-output* s) (*trace-output* s)) (multiple-value-list (eval (read-from-string string)))))) (cat (get-output-stream-string s) (swank-pprint values))))) (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) nil "Package ~a doesn't exist." name) (setq *package* p) (list (package-name p) (package-string-for-prompt p)))) (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 truncate-string (string width &optional ellipsis) (let ((len (length string))) (cond ((< len width) string) (ellipsis (cat (subseq string 0 width) ellipsis)) (t (subseq string 0 width))))) (defun call/truncated-output-to-string (length function &optional (ellipsis "..")) "Call FUNCTION with a new stream, return the output written to the stream. If FUNCTION tries to write more than LENGTH characters, it will be aborted and return immediately with the output written so far." (let ((buffer (make-string (+ length (length ellipsis)))) (fill-pointer 0)) (block buffer-full (flet ((write-output (string) (let* ((free (- length fill-pointer)) (count (min free (length string)))) (replace buffer string :start1 fill-pointer :end2 count) (incf fill-pointer count) (when (> (length string) free) (replace buffer ellipsis :start1 fill-pointer) (return-from buffer-full buffer))))) (let ((stream (make-output-stream #'write-output))) (funcall function stream) (finish-output stream) (subseq buffer 0 fill-pointer)))))) (defmacro with-string-stream ((var &key length bindings) &body body) (cond ((and (not bindings) (not length)) `(with-output-to-string (,var) . ,body)) ((not bindings) `(call/truncated-output-to-string ,length (lambda (,var) . ,body))) (t `(with-bindings ,bindings (with-string-stream (,var :length ,length) . ,body))))) (defun to-line (object &optional width) "Print OBJECT to a single line. Return the string." (let ((width (or width 512))) (without-printing-errors (:object object :stream nil) (with-string-stream (stream :length width) (write object :stream stream :right-margin width :lines 1))))) (defun escape-string (string stream &key length (map '((#\" . "\\\"") (#\\ . "\\\\")))) "Write STRING to STREAM surronded by double-quotes. LENGTH -- if non-nil truncate output after LENGTH chars. MAP -- rewrite the chars in STRING according to this alist." (let ((limit (or length array-dimension-limit))) (write-char #\" stream) (loop for c across string for i from 0 do (when (= i limit) (write-string "..." stream) (return)) (let ((probe (assoc c map))) (cond (probe (write-string (cdr probe) stream)) (t (write-char c stream))))) (write-char #\" stream))) ;;;; Prompt ;; FIXME: do we really need 45 lines of code just to figure out the ;; prompt? (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.") (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* (loop with package-name = (package-name package) with offset = nil do (let ((last-dot-pos (position #\. package-name :end offset :from-end t))) (unless last-dot-pos (return nil)) ;; If a dot chunk contains only numbers, that chunk most ;; likely represents a version number; so we collect the ;; next chunks, too, until we find one with meat. (let ((name (subseq package-name (1+ last-dot-pos) offset))) (if (notevery #'digit-char-p name) (return (subseq package-name (1+ last-dot-pos))) (setq offset last-dot-pos))))))) (defun shortest-package-nickname (package) "Return the shortest nickname 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 &key LINE COLUMN POSITION), A function name (symbol or cons), NIL. " (flet ((canonicalize-filename (filename) (pathname-to-filename (or (probe-file filename) filename)))) (let ((target (etypecase what (null nil) ((or string pathname) `(:filename ,(canonicalize-filename what))) ((cons (or string pathname) *) `(:filename ,(canonicalize-filename (car what)) ,@(cdr what))) ((or symbol cons) `(:function-name ,(prin1-to-string what)))))) (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target))) ((default-connection) (with-connection ((default-connection)) (send-oob-to-emacs `(:ed ,target)))) (t (error "No connection")))))) (defslimefun inspect-in-emacs (what &key wait) "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the inspector has been closed in Emacs." (flet ((send-it () (let ((tag (when wait (make-tag))) (thread (when wait (current-thread-id)))) (with-buffer-syntax () (reset-inspector) (send-oob-to-emacs `(:inspect ,(inspect-object what) ,thread ,tag))) (when wait (wait-for-event `(:emacs-return ,tag result)))))) (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 () (let* ((value (eval (read-from-string form))) (*print-length* nil)) (prin1-to-string value)))) (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))))) ;; This is only used by the test suite. (defun sleep-for (seconds) "Sleep for at least SECONDS seconds. This is just like cl:sleep but guarantees to sleep at least SECONDS." (let* ((start (get-internal-real-time)) (end (+ start (* seconds internal-time-units-per-second)))) (loop (let ((now (get-internal-real-time))) (cond ((< end now) (return)) (t (sleep (/ (- end now) internal-time-units-per-second)))))))) ;;;; Debugger (defun invoke-slime-debugger (condition) "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." (without-slime-interrupts (cond (*emacs-connection* (debug-in-emacs condition)) ((default-connection) (with-connection ((default-connection)) (debug-in-emacs condition)))))) (define-condition invoke-default-debugger () ()) (defun swank-debugger-hook (condition hook) "Debugger function for binding *DEBUGGER-HOOK*." (declare (ignore hook)) (handler-case (call-with-debugger-hook #'swank-debugger-hook (lambda () (invoke-slime-debugger condition))) (invoke-default-debugger () (invoke-default-debugger condition)))) (defun invoke-default-debugger (condition) (call-with-debugger-hook nil (lambda () (invoke-debugger 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-restarts condition)) (*sldb-quit-restart* (and *sldb-quit-restart* (find-restart *sldb-quit-restart*))) (*package* (or (and (boundp '*buffer-package*) (symbol-value '*buffer-package*)) *package*)) (*sldb-level* (1+ *sldb-level*)) (*sldb-stepping-p* nil)) (force-user-output) (call-with-debugging-environment (lambda () (sldb-loop *sldb-level*))))) (defun sldb-loop (level) (unwind-protect (loop (with-simple-restart (abort "Return to sldb level ~D." level) (send-to-emacs (list* :debug (current-thread-id) level (debugger-info-for-emacs 0 *sldb-initial-frames*))) (send-to-emacs (list :debug-activate (current-thread-id) level nil)) (loop (handler-case (dcase (wait-for-event `(or (:emacs-rex . _) (:sldb-return ,(1+ level)))) ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) ((:sldb-return _) (declare (ignore _)) (return nil))) (sldb-condition (c) (handle-sldb-condition c)))))) (send-to-emacs `(:debug-return ,(current-thread-id) ,level ,*sldb-stepping-p*)) (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue (when (> level 1) (send-event (current-thread) `(:sldb-return ,level))))) (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-id) ,(princ-to-string real-condition))))) (defun %%condition-message (condition) (let ((limit (ash 1 16))) (with-string-stream (stream :length limit) (handler-case (let ((*print-readably* nil) (*print-pretty* t) (*print-right-margin* 65) (*print-circle* t) (*print-length* (or *print-length* limit)) (*print-level* (or *print-level* limit)) (*print-lines* (or *print-lines* limit))) (print-condition condition stream)) (serious-condition (c) (ignore-errors (with-standard-io-syntax (let ((*print-readably* nil)) (format stream "~&Error (~a) during printing: " (type-of c)) (print-unreadable-object (condition stream :type t :identity t)))))))))) (defun %condition-message (condition) (string-trim #(#\newline #\space #\tab) (%%condition-message condition))) (defvar *sldb-condition-printer* #'%condition-message "Function called to print a condition to an SLDB buffer.") (defun safe-condition-message (condition) "Print condition to a string, handling any errors during printing." (funcall *sldb-condition-printer* condition)) (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 (format nil "~:[~;*~]~a" (eq restart *sldb-quit-restart*) (restart-name restart)) (with-output-to-string (stream) (without-printing-errors (:object restart :stream stream :msg "<>") (princ restart stream))))))) ;;;;; SLDB entry points (defslimefun sldb-break-with-default-debugger (dont-unwind) "Invoke the default debugger." (cond (dont-unwind (invoke-default-debugger *swank-debugger-condition*)) (t (signal 'invoke-default-debugger)))) (defslimefun backtrace (start end) "Return a list ((I FRAME PLIST) ...) of frames from START to END. I is an integer, and can be used to reference the corresponding frame from Emacs; FRAME is a string representation of an implementation's frame." (loop for frame in (compute-backtrace start end) for i from start collect (list* i (frame-to-string frame) (ecase (frame-restartable-p frame) ((nil) nil) ((t) `((:restartable t))))))) (defun frame-to-string (frame) (with-string-stream (stream :length (* (or *print-lines* 1) (or *print-right-margin* 100)) :bindings *backtrace-printer-bindings*) (handler-case (print-frame frame stream) (serious-condition () (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 [plist]) extra ::= (:references and other random things) cont ::= continutation plist ::= (:restartable {nil | t | :unknown}) 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)\" (:restartable nil))) (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) (let ((restart (nth-restart index))) (when restart (invoke-restart-interactively restart)))) (defslimefun sldb-abort () (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name))) (defslimefun sldb-continue () (continue)) (defun coerce-to-condition (datum args) (etypecase datum (string (make-condition 'simple-error :format-control datum :format-arguments args)) (symbol (apply #'make-condition datum args)))) (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args) (with-simple-restart (continue "Continue from break.") (invoke-slime-debugger (coerce-to-condition datum args)))) ;; FIXME: (last (compute-restarts)) looks dubious. (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 (or (and *sldb-quit-restart* (find-restart *sldb-quit-restart*)) (car (last (compute-restarts)))))) (cond (restart (invoke-restart restart)) (t (format nil "Restart not active [~s]" *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)) (defun eval-in-frame-aux (frame string package print) (let* ((form (wrap-sldb-vars (parse-string string package))) (values (multiple-value-list (eval-in-frame form frame)))) (with-buffer-syntax (package) (funcall print values)))) (defslimefun eval-string-in-frame (string frame package) (eval-in-frame-aux frame string package #'format-values-for-echo-area)) (defslimefun pprint-eval-string-in-frame (string frame package) (eval-in-frame-aux frame string package #'swank-pprint)) (defslimefun frame-package-name (frame) (let ((pkg (frame-package frame))) (cond (pkg (package-name pkg)) (t (with-buffer-syntax () (package-name *package*)))))) (defslimefun frame-locals-and-catch-tags (index) "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. LOCALS is a list of the form ((&key NAME ID VALUE) ...). TAGS has is a list of strings." (list (frame-locals-for-emacs index) (mapcar #'to-string (frame-catch-tags index)))) (defun frame-locals-for-emacs (index) (with-bindings *backtrace-printer-bindings* (loop for var in (frame-locals index) collect (destructuring-bind (&key name id value) var (list :name (let ((*package* (or (frame-package index) *package*))) (prin1-to-string name)) :id id :value (to-line value *print-right-margin*)))))) (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) (defslimefun toggle-break-on-signals () (setq *break-on-signals* (not *break-on-signals*)) (format nil "*break-on-signals* = ~a" *break-on-signals*)) (defslimefun sdlb-print-condition () (princ-to-string *swank-debugger-condition*)) ;;;; Compilation Commands. (defstruct (compilation-result (:type list)) (type :compilation-result) notes (successp nil :type boolean) (duration 0.0 :type float) (loadp nil :type boolean) (faslfile nil :type (or null string))) (defun measure-time-interval (fun) "Call FUN and return the first return value and the elapsed time. The time is measured in seconds." (declare (type function fun)) (let ((before (get-internal-real-time))) (values (funcall fun) (/ (- (get-internal-real-time) before) (coerce internal-time-units-per-second 'float))))) (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 (source-context condition))) (if s (list :source-context s))))) (defun collect-notes (function) (let ((notes '())) (multiple-value-bind (result seconds) (handler-bind ((compiler-condition (lambda (c) (push (make-compiler-note c) notes)))) (measure-time-interval (lambda () ;; To report location of error-signaling toplevel forms ;; for errors in EVAL-WHEN or during macroexpansion. (restart-case (multiple-value-list (funcall function)) (abort () :report "Abort compilation." (list nil)))))) (destructuring-bind (successp &optional loadp faslfile) result (let ((faslfile (etypecase faslfile (null nil) (pathname (pathname-to-filename faslfile))))) (make-compilation-result :notes (reverse notes) :duration seconds :successp (if successp t) :loadp (if loadp t) :faslfile faslfile)))))) (defun swank-compile-file* (pathname load-p &rest options &key policy &allow-other-keys) (multiple-value-bind (output-pathname warnings? failure?) (swank-compile-file pathname (fasl-pathname pathname options) nil (or (guess-external-format pathname) :default) :policy policy) (declare (ignore warnings?)) (values t (not failure?) load-p output-pathname))) (defvar *compile-file-for-emacs-hook* '(swank-compile-file*)) (defslimefun compile-file-for-emacs (filename load-p &rest options) "Compile FILENAME and, when LOAD-P, load the result. Record compiler notes signalled as `compiler-condition's." (with-buffer-syntax () (collect-notes (lambda () (let ((pathname (filename-to-pathname filename)) (*compile-print* nil) (*compile-verbose* t)) (loop for hook in *compile-file-for-emacs-hook* do (multiple-value-bind (tried success load? output-pathname) (apply hook pathname load-p options) (when tried (return (values success load? output-pathname)))))))))) ;; FIXME: now that *compile-file-for-emacs-hook* is there this is ;; redundant and confusing. (defvar *fasl-pathname-function* nil "In non-nil, use this function to compute the name for fasl-files.") (defun pathname-as-directory (pathname) (append (pathname-directory pathname) (when (pathname-name pathname) (list (file-namestring pathname))))) (defun compile-file-output (file directory) (make-pathname :directory (pathname-as-directory directory) :defaults (compile-file-pathname file))) (defun fasl-pathname (input-file options) (cond (*fasl-pathname-function* (funcall *fasl-pathname-function* input-file options)) ((getf options :fasl-directory) (let ((dir (getf options :fasl-directory))) (assert (char= (aref dir (1- (length dir))) #\/)) (compile-file-output input-file dir))) (t (compile-file-pathname input-file)))) (defslimefun compile-string-for-emacs (string buffer position filename policy) "Compile STRING (exerpted from BUFFER at POSITION). Record compiler notes signalled as `compiler-condition's." (let ((offset (cadr (assoc :position position)))) (with-buffer-syntax () (collect-notes (lambda () (let ((*compile-print* t) (*compile-verbose* nil)) (swank-compile-string string :buffer buffer :position offset :filename filename :policy policy))))))) (defslimefun compile-multiple-strings-for-emacs (strings policy) "Compile STRINGS (exerpted from BUFFER at POSITION). Record compiler notes signalled as `compiler-condition's." (loop for (string buffer package position filename) in strings collect (collect-notes (lambda () (with-buffer-syntax (package) (let ((*compile-print* t) (*compile-verbose* nil)) (swank-compile-string string :buffer buffer :position position :filename filename :policy policy))))))) (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) (let ((pathname (filename-to-pathname filename))) (cond ((requires-compile-p pathname) (compile-file-for-emacs pathname loadp)) (t (collect-notes (lambda () (or (not loadp) (load (compile-file-pathname pathname))))))))) ;;;; Loading (defslimefun load-file (filename) (to-string (load (filename-to-pathname filename)))) ;;;;; swank-require (defslimefun swank-require (modules &optional filename) "Load the module MODULE." (dolist (module (ensure-list modules)) (unless (member (string module) *modules* :test #'string=) (require module (if filename (filename-to-pathname filename) (module-filename module))) (assert (member (string module) *modules* :test #'string=) () "Required module ~s was not provided" module))) *modules*) (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* '() "A list of directories to search for modules.") (defun module-candidates (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-candidates 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 swank-expand-1 (string) (apply-macro-expander #'expand-1 string)) (defslimefun swank-expand (string) (apply-macro-expander #'expand string)) (defun expand-1 (form) (multiple-value-bind (expansion expanded?) (macroexpand-1 form) (if expanded? (values expansion t) (compiler-macroexpand-1 form)))) (defun expand (form) (expand-repeatedly #'expand-1 form)) (defun expand-repeatedly (expander form) (loop (multiple-value-bind (expansion expanded?) (funcall expander form) (unless expanded? (return expansion)) (setq form expansion)))) (defslimefun swank-format-string-expand (string) (apply-macro-expander #'format-string-expand string)) (defslimefun disassemble-form (form) (with-buffer-syntax () (with-output-to-string (*standard-output*) (let ((*print-readably* nil)) (disassemble (eval (read-from-string form))))))) ;;;; Simple completion (defslimefun simple-completions (prefix package) "Return a list of completions for the string PREFIX." (let ((strings (all-completions prefix package))) (list strings (longest-common-prefix strings)))) (defun all-completions (prefix package) (multiple-value-bind (name pname intern) (tokenize-symbol prefix) (let* ((extern (and pname (not intern))) (pkg (cond ((equal pname "") keyword-package) ((not pname) (guess-buffer-package package)) (t (guess-package pname)))) (test (lambda (sym) (prefix-match-p name (symbol-name sym)))) (syms (and pkg (matching-symbols pkg extern test))) (strings (loop for sym in syms for str = (unparse-symbol sym) when (prefix-match-p name str) ; remove |Foo| collect str))) (format-completion-set strings 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)) :test #'char-equal))) (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))))) (cond ((eq args :not-available) nil) (t (princ-to-string (cons 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))))))))) (defun make-apropos-matcher (pattern case-sensitive) (let ((chr= (if case-sensitive #'char= #'char-equal))) (lambda (symbol) (search pattern (string symbol) :test chr=)))) (defun apropos-symbols (string external-only case-sensitive package) (let ((packages (or package (remove (find-package :keyword) (list-all-packages)))) (matcher (make-apropos-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) (with-buffer-syntax () (multiple-value-bind (sym foundp) (parse-symbol symbol-name) (if foundp (let ((vdoc (documentation sym 'variable)) (fdoc (documentation sym 'function))) (with-output-to-string (string) (format string "Documentation for the symbol ~a:~2%" sym) (unless (or vdoc fdoc) (format string "Not documented." )) (when vdoc (format string "Variable:~% ~a~2%" vdoc)) (when fdoc (format string "Function:~% Arglist: ~a~2% ~a" (arglist sym) fdoc)))) (format nil "No such symbol, ~a." symbol-name))))) ;;;; 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)))) (defvar *after-toggle-trace-hook* nil "Hook called whenever a SPEC is traced or untraced. If non-nil, called with two arguments SPEC and TRACED-P." ) (defslimefun swank-toggle-trace (spec-string) (let* ((spec (from-string spec-string)) (retval (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)))) (traced-p (let* ((tosearch "is now traced.") (start (- (length retval) (length tosearch))) (end (+ start (length tosearch)))) (search tosearch (subseq retval start end)))) (hook-msg (when *after-toggle-trace-hook* (funcall *after-toggle-trace-hook* spec traced-p)))) (if hook-msg (format nil "~a~%(also ~a)" retval hook-msg) retval))) (defslimefun untrace-all () (untrace)) ;;;; Undefing (defslimefun undefine-function (fname-string) (let ((fname (from-string fname-string))) (format nil "~S" (fmakunbound fname)))) (defslimefun unintern-symbol (name package) (let ((pkg (guess-package package))) (cond ((not pkg) (format nil "No such package: ~s" package)) (t (multiple-value-bind (sym found) (parse-symbol name pkg) (case found ((nil) (format nil "~s not in package ~s" name package)) (t (unintern sym pkg) (format nil "Uninterned symbol: ~s" sym)))))))) (defslimefun swank-delete-package (package-name) (let ((pkg (or (guess-package package-name) (error "No such package: ~s" package-name)))) (delete-package pkg) nil)) ;;;; 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))))) (defslimefun profile-by-substring (substring package) (let ((count 0)) (flet ((maybe-profile (symbol) (when (and (fboundp symbol) (not (profiledp symbol)) (search substring (symbol-name symbol) :test #'equalp)) (handler-case (progn (profile symbol) (incf count)) (error (condition) (warn "~a" condition)))))) (if package (do-symbols (symbol (parse-package package)) (maybe-profile symbol)) (do-all-symbols (symbol) (maybe-profile symbol)))) (format nil "~a function~:p ~:*~[are~;is~:;are~] now profiled" count))) (defslimefun swank-profile-package (package-name callersp methodsp) (let ((pkg (or (guess-package package-name) (error "Not a valid package name: ~s" package-name)))) (check-type callersp boolean) (check-type methodsp boolean) (profile-package pkg callersp methodsp))) ;;;; Source Locations (defslimefun find-definition-for-thing (thing) (find-source-location thing)) (defslimefun find-source-location-for-emacs (spec) (find-source-location (value-spec-ref spec))) (defun value-spec-ref (spec) (dcase spec ((:string string package) (with-buffer-syntax (package) (eval (read-from-string string)))) ((:inspector part) (inspector-nth-part part)) ((:sldb frame var) (frame-var-value frame var)))) (defvar *find-definitions-right-trim* ",:.>") (defvar *find-definitions-left-trim* "#:<") (defun find-definitions-find-symbol-or-package (name) (flet ((do-find (name) (multiple-value-bind (symbol found name) (with-buffer-syntax () (parse-symbol name)) (cond (found (return-from find-definitions-find-symbol-or-package (values symbol found))) ;; Packages are not named by symbols, so ;; not-interned symbols can refer to packages ((find-package name) (return-from find-definitions-find-symbol-or-package (values (make-symbol name) t))))))) (do-find name) (do-find (string-right-trim *find-definitions-right-trim* name)) (do-find (string-left-trim *find-definitions-left-trim* name)) (do-find (string-left-trim *find-definitions-left-trim* (string-right-trim *find-definitions-right-trim* name))))) (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 (symbol found) (find-definitions-find-symbol-or-package name) (when found (mapcar #'xref>elisp (find-definitions symbol))))) ;;; Generic function so contribs can extend it. (defgeneric xref-doit (type thing) (:method (type thing) (declare (ignore type thing)) :not-implemented)) (macrolet ((define-xref-action (xref-type handler) `(defmethod xref-doit ((type (eql ,xref-type)) thing) (declare (ignorable type)) (funcall ,handler thing)))) (define-xref-action :calls #'who-calls) (define-xref-action :calls-who #'calls-who) (define-xref-action :references #'who-references) (define-xref-action :binds #'who-binds) (define-xref-action :sets #'who-sets) (define-xref-action :macroexpands #'who-macroexpands) (define-xref-action :specializes #'who-specializes) (define-xref-action :callers #'list-callers) (define-xref-action :callees #'list-callees)) (defslimefun xref (type name) (multiple-value-bind (sexp error) (ignore-errors (from-string name)) (unless error (let ((xrefs (xref-doit type sexp))) (if (eq xrefs :not-implemented) :not-implemented (mapcar #'xref>elisp xrefs)))))) (defslimefun xrefs (types name) (loop for type in types for xrefs = (xref type name) when (and (not (eq :not-implemented xrefs)) (not (null xrefs))) collect (cons type xrefs))) (defun xref>elisp (xref) (destructuring-bind (name loc) xref (list (to-string name) loc))) ;;;;; Lazy lists (defstruct (lcons (:constructor %lcons (car %cdr)) (:predicate lcons?)) car (%cdr nil :type (or null lcons function)) (forced? nil)) (defmacro lcons (car cdr) `(%lcons ,car (lambda () ,cdr))) (defmacro lcons* (car cdr &rest more) (cond ((null more) `(lcons ,car ,cdr)) (t `(lcons ,car (lcons* ,cdr ,@more))))) (defun lcons-cdr (lcons) (with-struct* (lcons- @ lcons) (cond ((@ forced?) (@ %cdr)) (t (let ((value (funcall (@ %cdr)))) (setf (@ forced?) t (@ %cdr) value)))))) (defun llist-range (llist start end) (llist-take (llist-skip llist start) (- end start))) (defun llist-skip (lcons index) (do ((i 0 (1+ i)) (l lcons (lcons-cdr l))) ((or (= i index) (null l)) l))) (defun llist-take (lcons count) (let ((result '())) (do ((i 0 (1+ i)) (l lcons (lcons-cdr l))) ((or (= i count) (null l))) (push (lcons-car l) result)) (nreverse result))) (defun iline (label value) `(:line ,label ,value)) ;;;; Inspecting (defvar *inspector-verbose* nil) (defvar *inspector-printer-bindings* '((*print-lines* . 1) (*print-right-margin* . 75) (*print-pretty* . t) (*print-readably* . nil))) (defvar *inspector-verbose-printer-bindings* '((*print-escape* . t) (*print-circle* . t) (*print-array* . nil))) (defstruct inspector-state) (defstruct (istate (:conc-name istate.) (:include inspector-state)) object (verbose *inspector-verbose*) (parts (make-array 10 :adjustable t :fill-pointer 0)) (actions (make-array 10 :adjustable t :fill-pointer 0)) metadata-plist content next previous) (defvar *istate* nil) (defvar *inspector-history*) (defun reset-inspector () (setq *istate* nil *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) (defslimefun init-inspector (string) (with-buffer-syntax () (with-retry-restart (:msg "Retry SLIME inspection request.") (reset-inspector) (inspect-object (eval (read-from-string string)))))) (defun ensure-istate-metadata (o indicator default) (with-struct (istate. object metadata-plist) *istate* (assert (eq object o)) (let ((data (getf metadata-plist indicator default))) (setf (getf metadata-plist indicator) data) data))) (defun inspect-object (o) (let* ((prev *istate*) (istate (make-istate :object o :previous prev :verbose (cond (prev (istate.verbose prev)) (t *inspector-verbose*))))) (setq *istate* istate) (setf (istate.content istate) (emacs-inspect/istate istate)) (unless (find o *inspector-history*) (vector-push-extend o *inspector-history*)) (let ((previous (istate.previous istate))) (if previous (setf (istate.next previous) istate))) (istate>elisp istate))) (defun emacs-inspect/istate (istate) (with-bindings (if (istate.verbose istate) *inspector-verbose-printer-bindings* *inspector-printer-bindings*) (emacs-inspect (istate.object istate)))) (defun istate>elisp (istate) (list :title (prepare-title istate) :id (assign-index (istate.object istate) (istate.parts istate)) :content (prepare-range istate 0 500))) (defun prepare-title (istate) (if (istate.verbose istate) (with-bindings *inspector-verbose-printer-bindings* (to-string (istate.object istate))) (with-string-stream (stream :length 200 :bindings *inspector-printer-bindings*) (print-unreadable-object ((istate.object istate) stream :type t :identity t))))) (defun prepare-range (istate start end) (let* ((range (content-range (istate.content istate) start end)) (ps (loop for part in range append (prepare-part part istate)))) (list ps (if (< (length ps) (- end start)) (+ start (length ps)) (+ end 1000)) start end))) (defun prepare-part (part istate) (let ((newline '#.(string #\newline))) (etypecase part (string (list part)) (cons (dcase part ((:newline) (list newline)) ((:value obj &optional str) (list (value-part obj str (istate.parts istate)))) ((:label &rest strs) (list (list :label (apply #'cat (mapcar #'string strs))))) ((:action label lambda &key (refreshp t)) (list (action-part label lambda refreshp (istate.actions istate)))) ((:line label value) (list (princ-to-string label) ": " (value-part value nil (istate.parts istate)) newline))))))) (defun value-part (object string parts) (list :value (or string (print-part-to-string object)) (assign-index object parts))) (defun action-part (label lambda refreshp actions) (list :action label (assign-index (list lambda refreshp) actions))) (defun assign-index (object vector) (let ((index (fill-pointer vector))) (vector-push-extend object vector) index)) (defun print-part-to-string (value) (let* ((*print-readably* nil) (string (to-line value)) (pos (position value *inspector-history*))) (if pos (format nil "@~D=~A" pos string) string))) (defun content-range (list start end) (typecase list (list (let ((len (length list))) (subseq list start (min len end)))) (lcons (llist-range list start end)))) (defslimefun inspector-nth-part (index) "Return the current inspector's INDEXth part. The second value indicates if that part exists at all." (let* ((parts (istate.parts *istate*)) (foundp (< index (length parts)))) (values (and foundp (aref parts index)) foundp))) (defslimefun inspect-nth-part (index) (with-buffer-syntax () (inspect-object (inspector-nth-part index)))) (defslimefun inspector-range (from to) (prepare-range *istate* from to)) (defslimefun inspector-call-nth-action (index &rest args) (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index) (apply fun args) (if refreshp (inspector-reinspect) ;; tell emacs that we don't want to refresh the inspector buffer nil))) (defslimefun inspector-pop () "Inspect the previous object. Return nil if there's no previous object." (with-buffer-syntax () (cond ((istate.previous *istate*) (setq *istate* (istate.previous *istate*)) (istate>elisp *istate*)) (t nil)))) (defslimefun inspector-next () "Inspect the next element in the history of inspected objects.." (with-buffer-syntax () (cond ((istate.next *istate*) (setq *istate* (istate.next *istate*)) (istate>elisp *istate*)) (t nil)))) (defslimefun inspector-reinspect () (let ((istate *istate*)) (setf (istate.content istate) (emacs-inspect/istate istate)) (istate>elisp istate))) (defslimefun inspector-toggle-verbose () "Toggle verbosity of inspected object." (setf (istate.verbose *istate*) (not (istate.verbose *istate*))) (istate>elisp *istate*)) (defslimefun inspector-eval (string) (let* ((obj (istate.object *istate*)) (context (eval-context obj)) (form (with-buffer-syntax ((cdr (assoc '*package* context))) (read-from-string string))) (ignorable (remove-if #'boundp (mapcar #'car context)))) (to-string (eval `(let ((* ',obj) (- ',form) . ,(loop for (var . val) in context unless (constantp var) collect `(,var ',val))) (declare (ignorable . ,ignorable)) ,form))))) (defslimefun inspector-history () (with-output-to-string (out) (let ((newest (loop for s = *istate* then next for next = (istate.next s) if (not next) return s))) (format out "--- next/prev chain ---") (loop for s = newest then (istate.previous s) while s do (let ((val (istate.object s))) (format out "~%~:[ ~; *~]@~d " (eq s *istate*) (position val *inspector-history*)) (print-unreadable-object (val out :type t :identity t))))) (format out "~%~%--- all visited objects ---") (loop for val across *inspector-history* for i from 0 do (format out "~%~2,' d " i) (print-unreadable-object (val out :type t :identity t))))) (defslimefun quit-inspector () (reset-inspector) nil) (defslimefun describe-inspectee () "Describe the currently inspected object." (with-buffer-syntax () (describe-to-string (istate.object *istate*)))) (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 () (with-retry-restart (:msg "Retry SLIME inspection request.") (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)))) ;;;;; Lists (defmethod emacs-inspect ((o cons)) (if (listp (cdr o)) (inspect-list o) (inspect-cons o))) (defun inspect-cons (cons) (label-value-line* ('car (car cons)) ('cdr (cdr cons)))) (defun inspect-list (list) (multiple-value-bind (length tail) (safe-length list) (flet ((frob (title list) (list* title '(:newline) (inspect-list-aux list)))) (cond ((not length) (frob "A circular list:" (cons (car list) (ldiff (cdr list) list)))) ((not tail) (frob "A proper list:" list)) (t (frob "An improper list:" list)))))) (defun inspect-list-aux (list) (loop for i from 0 for rest on list while (consp rest) append (if (listp (cdr rest)) (label-value-line i (car rest)) (label-value-line* (i (car rest)) (:tail (cdr rest)))))) (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. Return NIL if 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))))))) ;;;;; Hashtables (defun hash-table-to-alist (ht) (let ((result '())) (maphash (lambda (key value) (setq result (acons key value result))) ht) result)) (defmethod emacs-inspect ((ht hash-table)) (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 (label-value-line "Weakness:" weakness))) (unless (zerop (hash-table-count ht)) `((:action "[clear hashtable]" ,(lambda () (clrhash ht))) (:newline) "Contents: " (:newline))) (let ((content (hash-table-to-alist ht))) (cond ((every (lambda (x) (typep (first x) '(or string symbol))) content) (setf content (sort content 'string< :key #'first))) ((every (lambda (x) (typep (first x) 'number)) content) (setf content (sort content '< :key #'first)))) (loop for (key . value) in content appending `((:value ,key) " = " (:value ,value) " " (:action "[remove entry]" ,(let ((key key)) (lambda () (remhash key ht)))) (:newline)))))) ;;;;; Arrays (defmethod emacs-inspect ((array array)) (lcons* (iline "Dimensions" (array-dimensions array)) (iline "Element type" (array-element-type array)) (iline "Total size" (array-total-size array)) (iline "Adjustable" (adjustable-array-p array)) (iline "Fill pointer" (if (array-has-fill-pointer-p array) (fill-pointer array))) "Contents:" '(:newline) (labels ((k (i max) (cond ((= i max) '()) (t (lcons (iline i (row-major-aref array i)) (k (1+ i) max)))))) (k 0 (array-total-size array))))) ;;;;; Chars (defmethod emacs-inspect ((char 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)))))) ;;;; 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 (LABELS (ID NAME STATUS ATTRS ...) ...). LABELS is a list of attribute names and the remaining lists are the corresponding attribute values per thread. Example: ((:id :name :status :priority) (6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0) (5 \"reader-thread\" \"Active\" 0) (4 \"control-thread\" \"Semaphore timed wait\" 0) (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0) (1 \"listener\" \"Active\" 0) (0 \"Initial\" \"Sleep\" 0))" (setq *thread-list* (all-threads)) (when (and *emacs-connection* (use-threads-p) (equalp (thread-name (current-thread)) "worker")) (setf *thread-list* (delete (current-thread) *thread-list*))) (let* ((plist (thread-attributes (car *thread-list*))) (labels (loop for (key) on plist by #'cddr collect key))) `((:id :name :status ,@labels) ,@(loop for thread in *thread-list* for name = (thread-name thread) for attributes = (thread-attributes thread) collect (list* (thread-id thread) (string name) (thread-status thread) (loop for label in labels collect (getf attributes label))))))) (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*)) (queue-thread-interrupt (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 () (send-to-indentation-cache `(:update-indentation-information)) 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* (send-to-indentation-cache `(:sync-indentation ,*buffer-package*)))) ;; Send REQUEST to the cache. If we are single threaded perform the ;; request right away, otherwise delegate the request to the ;; indentation-cache-thread. (defun send-to-indentation-cache (request) (let ((c *emacs-connection*)) (etypecase c (singlethreaded-connection (handle-indentation-cache-request c request)) (multithreaded-connection (without-slime-interrupts (send (mconn.indentation-cache-thread c) request)))))) (defun indentation-cache-loop (connection) (with-connection (connection) (loop (restart-case (handle-indentation-cache-request connection (receive)) (abort () :report "Return to the indentation cache request handling loop."))))) (defun handle-indentation-cache-request (connection request) (dcase request ((:sync-indentation package) (let ((fullp (need-full-indentation-update-p connection))) (perform-indentation-update connection fullp package))) ((:update-indentation-information) (perform-indentation-update connection t nil)))) (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 package) "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 package))) (setf (connection.indentation-cache-packages connection) (list-all-packages)) (unless (null delta) (setf (connection.indentation-cache connection) cache) (send-to-emacs (list :indentation-update delta)))))) (defun update-indentation/delta-for-emacs (cache force package) "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list. If FORCE is true then check all symbols, otherwise only check symbols belonging to PACKAGE." (let ((alist '())) (flet ((consider (symbol) (let ((indent (symbol-indentation symbol))) (when indent (unless (equal (gethash symbol cache) indent) (setf (gethash symbol cache) indent) (let ((pkgs (mapcar #'package-name (symbol-packages symbol))) (name (string-downcase symbol))) (push (list name indent pkgs) alist))))))) (cond (force (do-all-symbols (symbol) (consider symbol))) ((package-name package) ; don't try to iterate over a ; deleted package. (do-symbols (symbol package) (when (eq (symbol-package symbol) 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 symbol-packages (symbol) "Return the packages where SYMBOL can be found." (let ((string (string symbol))) (loop for p in (list-all-packages) when (eq symbol (find-symbol string p)) collect p))) (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)))))) ;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough. #-clasp (add-hook *pre-reply-hook* 'sync-indentation-to-emacs) ;;;; Testing (defslimefun io-speed-test (&optional (n 1000) (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)) (finish-output s))) (finish-output s) (when *emacs-connection* (eval-in-emacs '(message "done."))))) (terpri *trace-output*) (finish-output *trace-output*) nil)) (defslimefun flow-control-test (n delay) (let ((stream (make-output-stream (let ((conn *emacs-connection*)) (lambda (string) (declare (ignore string)) (with-connection (conn) (send-to-emacs `(:test-delay ,delay)))))))) (dotimes (i n) (print i stream) (force-output stream) (background-message "flow-control-test: ~d" i)))) (defun before-init (version load-path) (pushnew :swank *features*) (setq *swank-wire-protocol-version* version) (setq *load-path* load-path)) (defun init () (run-hook *after-init-hook*)) ;; Local Variables: ;; coding: latin-1-unix ;; indent-tabs-mode: nil ;; outline-regexp: ";;;;;*" ;; End: ;;; swank.lisp ends here slime-2.20/swank/000077500000000000000000000000001315100173500136655ustar00rootroot00000000000000slime-2.20/swank/abcl.lisp000066400000000000000000000717751315100173500155000ustar00rootroot00000000000000;;;; -*- 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. ;;; (defpackage swank/abcl (:use cl swank/backend)) (in-package swank/abcl) (eval-when (:compile-toplevel :load-toplevel :execute) (require :collect) ;just so that it doesn't spoil the flying letters (require :pprint) (require :gray-streams) (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4)) 0.22) () "This file needs ABCL version 0.22 or newer")) (defimplementation gray-package-name () "GRAY-STREAMS") ;; FIXME: switch to shared Gray stream implementation when bugs are ;; fixed in ABCL. See: http://abcl.org/trac/ticket/373. (progn (defimplementation make-output-stream (write-string) (ext:make-slime-output-stream write-string)) (defimplementation make-input-stream (read-string) (ext:make-slime-input-stream read-string (make-synonym-stream '*standard-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) (declare (ignore slot)) #+nil (documentation slot 't)) (defun slot-definition-type (slot) (declare (ignore slot)) t) (defun class-prototype (class) (declare (ignore class)) nil) (defun generic-function-declarations (gf) (declare (ignore gf)) nil) (defun specializer-direct-methods (spec) (mop:class-direct-methods spec)) (defun slot-definition-name (slot) (mop:slot-definition-name slot)) (defun class-slots (class) (mop:class-slots class)) (defun method-generic-function (method) (mop:method-generic-function method)) (defun method-function (method) (mop:method-function method)) (defun slot-boundp-using-class (class object slotdef) (declare (ignore class)) (system::slot-boundp object (slot-definition-name slotdef))) (defun slot-value-using-class (class object slotdef) (declare (ignore class)) (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 #+#.(swank/backend:with-symbol 'compute-applicable-methods-using-classes 'mop) mop:compute-applicable-methods-using-classes ;; 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 mop:finalize-inheritance 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 mop:slot-makunbound-using-class)) ;;;; TCP Server (defimplementation preferred-communication-style () :spawn) (defimplementation create-socket (host port &key backlog) (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)) (ext:get-socket-stream (ext:socket-accept socket) :element-type (if external-format 'character '(unsigned-byte 8)) :external-format (or external-format :default))) ;;;; UTF8 ;; faster please! (defimplementation string-to-utf8 (s) (jbytes-to-octets (java:jcall (java:jmethod "java.lang.String" "getBytes" "java.lang.String") s "UTF8"))) (defimplementation utf8-to-string (u) (java:jnew (java:jconstructor "org.armedbear.lisp.SimpleString" "java.lang.String") (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") (octets-to-jbytes u) "UTF8"))) (defun octets-to-jbytes (octets) (declare (type octets (simple-array (unsigned-byte 8) (*)))) (let* ((len (length octets)) (bytes (java:jnew-array "byte" len))) (loop for byte across octets for i from 0 do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" "java.lang.Object" "int" "byte") "java.lang.relect.Array" bytes i byte)) bytes)) (defun jbytes-to-octets (jbytes) (let* ((len (java:jarray-length jbytes)) (octets (make-array len :element-type '(unsigned-byte 8)))) (loop for i from 0 below len for jbyte = (java:jarray-ref jbytes i) do (setf (aref octets i) jbyte)) octets)) ;;;; External formats (defvar *external-format-to-coding-system* '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") ((:iso-8859-1 :eol-style :lf) "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") (:utf-8 "utf-8") ((:utf-8 :eol-style :lf) "utf-8-unix") (:euc-jp "euc-jp") ((:euc-jp :eol-style :lf) "euc-jp-unix") (:us-ascii "us-ascii") ((:us-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 (defimplementation getpid () (handler-case (let* ((runtime (java:jstatic "getRuntime" "java.lang.Runtime")) (command (java:jnew-array-from-array "java.lang.String" #("sh" "-c" "echo $PPID"))) (runtime-exec-jmethod ;; Complicated because java.lang.Runtime.exec() is ;; overloaded on a non-primitive type (array of ;; java.lang.String), so we have to use the actual ;; parameter instance to get java.lang.Class (java:jmethod "java.lang.Runtime" "exec" (java:jcall (java:jmethod "java.lang.Object" "getClass") command))) (process (java:jcall runtime-exec-jmethod runtime command)) (output (java:jcall (java:jmethod "java.lang.Process" "getInputStream") process))) (java:jcall (java:jmethod "java.lang.Process" "waitFor") process) (loop :with b :do (setq b (java:jcall (java:jmethod "java.io.InputStream" "read") output)) :until (member b '(-1 #x0a)) ; Either EOF or LF :collecting (code-char b) :into result :finally (return (parse-integer (coerce result 'string))))) (t () 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) (when (and (not present) (fboundp fun) (typep (symbol-function fun) 'standard-generic-function)) (setq arglist (mop::generic-function-lambda-list (symbol-function fun)) present t)) (if present arglist :not-available))) (t :not-available))) (defimplementation function-name (function) (nth-value 2 (function-lambda-expression function))) (defimplementation macroexpand-all (form &optional env) (ext:macroexpand-all form env)) (defimplementation collect-macro-forms (form &optional env) ;; Currently detects only normal macros, not compiler macros. (declare (ignore env)) (with-collected-macro-forms (macro-forms) (handler-bind ((warning #'muffle-warning)) (ignore-errors (compile nil `(lambda () ,(macroexpand-all form env))))) (values macro-forms 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))) (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 :class (if (find-class symbol nil) (doc 'class))) result))) (defimplementation describe-definition (symbol namespace) (ecase namespace ((:variable :macro) (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 ;; Copied from swank-sbcl.lisp. ;; ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*, ;; so we have to make sure that the latter gets run when it was ;; established locally by a user (i.e. changed meanwhile.) (defun make-invoke-debugger-hook (hook) (lambda (condition old-hook) (if *debugger-hook* (funcall *debugger-hook* condition old-hook) (funcall hook condition old-hook)))) (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook) (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook))) (funcall fun))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function))) (defvar *sldb-topframe*) (defimplementation call-with-debugging-environment (debugger-loop-fn) (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank)) (*sldb-topframe* (second (member magic-token (sys:backtrace) :key (lambda (frame) (first (sys:frame-to-list frame))))))) (funcall debugger-loop-fn))) (defun backtrace (start end) "A backtrace without initial SWANK frames." (let ((backtrace (sys:backtrace))) (subseq (or (member *sldb-topframe* backtrace) backtrace) start end))) (defun nth-frame (index) (nth index (backtrace 0 nil))) (defimplementation compute-backtrace (start end) (let ((end (or end most-positive-fixnum))) (backtrace start end))) (defimplementation print-frame (frame stream) (write-string (sys:frame-to-string frame) stream)) ;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET. ;;; --ME 20150403 (defun nth-frame-list (index) (java:jcall "toLispList" (nth-frame index))) (defun match-lambda (operator values) (jvm::match-lambda-list (multiple-value-list (jvm::parse-lambda-list (ext:arglist operator))) values)) (defimplementation frame-locals (index) (loop :for id :upfrom 0 :with frame = (nth-frame-list index) :with operator = (first frame) :with values = (rest frame) :with arglist = (if (and operator (consp values) (not (null values))) (handler-case (match-lambda operator values) (jvm::lambda-list-mismatch (e) :lambda-list-mismatch)) :not-available) :for value :in values :collecting (list :name (if (not (keywordp arglist)) (first (nth id arglist)) (format nil "arg~A" id)) :id id :value value))) (defimplementation frame-var-value (index id) (elt (rest (java:jcall "toLispList" (nth-frame index))) id)) #+nil (defimplementation disassemble-frame (index) (disassemble (debugger:frame-function (nth-frame index)))) (defimplementation frame-source-location (index) (let ((frame (nth-frame index))) (or (source-location (nth-frame index)) `(:error ,(format nil "No source for frame: ~a" frame))))) #+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*) (defvar *abcl-signaled-conditions*) (defun handle-compiler-warning (condition) (let ((loc (when (and jvm::*compile-file-pathname* system::*source-position*) (cons jvm::*compile-file-pathname* system::*source-position*)))) ;; filter condition signaled more than once. (unless (member condition *abcl-signaled-conditions*) (push condition *abcl-signaled-conditions*) (signal 'compiler-condition :original-condition condition :severity :warning :message (format nil "~A" condition) :location (cond (*buffer-name* (make-location (list :buffer *buffer-name*) (list :offset *buffer-start-position* 0))) (loc (destructuring-bind (file . pos) loc (make-location (list :file (namestring (truename file))) (list :position (1+ pos))))) (t (make-location (list :file (namestring *compile-filename*)) (list :position 1)))))))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore external-format policy)) (let ((jvm::*resignal-compiler-warnings* t) (*abcl-signaled-conditions* nil)) (handler-bind ((warning #'handle-compiler-warning)) (let ((*buffer-name* nil) (*compile-filename* input-file)) (multiple-value-bind (fn warn fail) (compile-file input-file :output-file output-file) (values fn warn (and fn load-p (not (load fn))))))))) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore filename policy)) (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) (sys::*source* (make-pathname :device "emacs-buffer" :name buffer)) (sys::*source-position* position)) (funcall (compile nil (read-from-string (format nil "(~S () ~A)" 'lambda string)))) t)))) #| ;;;; 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)) |# (defgeneric source-location (object)) (defmethod source-location ((symbol symbol)) (when (pathnamep (ext:source-pathname symbol)) (let ((pos (ext:source-file-position symbol)) (path (namestring (ext:source-pathname symbol)))) (cond ((ext:pathname-jar-p path) `(:location ;; strip off "jar:file:" = 9 characters (:zip ,@(split-string (subseq path 9) "!/")) ;; pos never seems right. Use function name. (:function-name ,(string symbol)) (:align t))) ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer") ;; conspire with swank-compile-string to keep the buffer ;; name in a pathname whose device is "emacs-buffer". `(:location (:buffer ,(pathname-name (ext:source-pathname symbol))) (:function-name ,(string symbol)) (:align t))) (t `(:location (:file ,path) ,(if pos (list :position (1+ pos)) (list :function-name (string symbol))) (:align t))))))) (defmethod source-location ((frame sys::java-stack-frame)) (destructuring-bind (&key class method file line) (sys:frame-to-list frame) (declare (ignore method)) (let ((file (or (find-file-in-path file *source-path*) (let ((f (format nil "~{~a/~}~a" (butlast (split-string class "\\.")) file))) (find-file-in-path f *source-path*))))) (and file `(:location ,file (:line ,line) ()))))) (defmethod source-location ((frame sys::lisp-stack-frame)) (destructuring-bind (operator &rest args) (sys:frame-to-list frame) (declare (ignore args)) (etypecase operator (function (source-location operator)) (list nil) (symbol (source-location operator))))) (defmethod source-location ((fun function)) (let ((name (function-name fun))) (and name (source-location name)))) (defun system-property (name) (java:jstatic "getProperty" "java.lang.System" name)) (defun pathname-parent (pathname) (make-pathname :directory (butlast (pathname-directory pathname)))) (defun pathname-absolute-p (pathname) (eq (car (pathname-directory pathname)) ':absolute)) (defun split-string (string regexp) (coerce (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String") string regexp) 'list)) (defun path-separator () (java:jfield "java.io.File" "pathSeparator")) (defun search-path-property (prop-name) (let ((string (system-property prop-name))) (and string (remove nil (mapcar #'truename (split-string string (path-separator))))))) (defun jdk-source-path () (let* ((jre-home (truename (system-property "java.home"))) (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) (truename (probe-file src-zip))) (and truename (list truename)))) (defun class-path () (append (search-path-property "java.class.path") (search-path-property "sun.boot.class.path"))) (defvar *source-path* (append (search-path-property "user.dir") (jdk-source-path) ;;(list (truename "/scratch/abcl/src")) ) "List of directories to search for source files.") (defun zipfile-contains-p (zipfile-name entry-name) (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile" "java.lang.String") zipfile-name))) (java:jcall (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") zipfile entry-name))) ;; (find-file-in-path "java/lang/String.java" *source-path*) ;; (find-file-in-path "Lisp.java" *source-path*) ;; Try to find FILENAME in PATH. If found, return a file spec as ;; needed by Emacs. We also look in zip files. (defun find-file-in-path (filename path) (labels ((try (dir) (cond ((not (pathname-type dir)) (let ((f (probe-file (merge-pathnames filename dir)))) (and f `(:file ,(namestring f))))) ((equal (pathname-type dir) "zip") (try-zip dir)) (t (error "strange path element: ~s" path)))) (try-zip (zip) (let* ((zipfile-name (namestring (truename zip)))) (and (zipfile-contains-p zipfile-name filename) `(:dir ,zipfile-name ,filename))))) (cond ((pathname-absolute-p filename) (probe-file filename)) (t (loop for dir in path if (try dir) return it))))) (defimplementation find-definitions (symbol) (ext:resolve symbol) (let ((srcloc (source-location symbol))) (and srcloc `((,symbol ,srcloc))))) #| 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 (defmethod emacs-inspect ((o t)) (let ((parts (sys:inspected-parts o))) `("The object is of type " ,(symbol-name (type-of o)) "." (:newline) ,@(if parts (loop :for (label . value) :in parts :appending (label-value-line label value)) (list "No inspectable parts, dumping output of CL:DESCRIBE:" '(:newline) (with-output-to-string (desc) (describe o desc))))))) (defmethod emacs-inspect ((slot mop::slot-definition)) `("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)) "#") (:newline) " Function: " (:value ,(mop:slot-definition-initfunction slot)) (:newline))) (defmethod emacs-inspect ((f 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))))) ;;; Although by convention toString() is supposed to be a ;;; non-computationally expensive operation this isn't always the ;;; case, so make its computation a user interaction. (defparameter *to-string-hashtable* (make-hash-table)) (defmethod emacs-inspect ((o java:java-object)) (let ((to-string (lambda () (handler-case (setf (gethash o *to-string-hashtable*) (java:jcall "toString" o)) (t (e) (setf (gethash o *to-string-hashtable*) (format nil "Could not invoke toString(): ~A" e))))))) (append (if (gethash o *to-string-hashtable*) (label-value-line "toString()" (gethash o *to-string-hashtable*)) `((:action "[compute toString()]" ,to-string) (:newline))) (loop :for (label . value) :in (sys:inspected-parts o) :appending (label-value-line label value))))) ;;;; Multithreading (defimplementation spawn (fn &key name) (threads:make-thread (lambda () (funcall fn)) :name name)) (defvar *thread-plists* (make-hash-table) ; should be a weak table "A hashtable mapping threads to a plist.") (defvar *thread-id-counter* 0) (defimplementation thread-id (thread) (threads:synchronized-on *thread-plists* (or (getf (gethash thread *thread-plists*) 'id) (setf (getf (gethash thread *thread-plists*) 'id) (incf *thread-id-counter*))))) (defimplementation find-thread (id) (find id (all-threads) :key (lambda (thread) (getf (gethash thread *thread-plists*) 'id)))) (defimplementation thread-name (thread) (threads:thread-name thread)) (defimplementation thread-status (thread) (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread))) (defimplementation make-lock (&key name) (declare (ignore name)) (threads:make-thread-lock)) (defimplementation call-with-lock-held (lock function) (threads:with-thread-lock (lock) (funcall function))) (defimplementation current-thread () (threads:current-thread)) (defimplementation all-threads () (copy-list (threads:mapcar-threads #'identity))) (defimplementation thread-alive-p (thread) (member thread (all-threads))) (defimplementation interrupt-thread (thread fn) (threads:interrupt-thread thread fn)) (defimplementation kill-thread (thread) (threads:destroy-thread thread)) (defstruct mailbox (queue '())) (defun mailbox (thread) "Return THREAD's mailbox." (threads:synchronized-on *thread-plists* (or (getf (gethash thread *thread-plists*) 'mailbox) (setf (getf (gethash thread *thread-plists*) 'mailbox) (make-mailbox))))) (defimplementation send (thread message) (let ((mbox (mailbox thread))) (threads:synchronized-on mbox (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) (list message))) (threads:object-notify-all mbox)))) (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox (current-thread)))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (threads:synchronized-on mbox (let* ((q (mailbox-queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))) (when (eq timeout t) (return (values nil t))) (threads:object-wait mbox 0.3)))))) (defimplementation quit-lisp () (ext:exit)) ;;; #+#.(swank/backend:with-symbol 'package-local-nicknames 'ext) (defimplementation package-local-nicknames (package) (ext:package-local-nicknames package)) slime-2.20/swank/allegro.lisp000066400000000000000000001137261315100173500162150ustar00rootroot00000000000000;;;; -*- 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. ;;; (defpackage swank/allegro (:use cl swank/backend)) (in-package swank/allegro) (eval-when (:compile-toplevel :load-toplevel :execute) (require :sock) (require :process) #+(version>= 8 2) (require 'lldb)) (defimplementation gray-package-name () '#:excl) ;;; swank-mop (import-swank-mop-symbols :clos '(:slot-definition-documentation)) (defun swank-mop:slot-definition-documentation (slot) (documentation slot t)) ;;;; UTF8 (define-symbol-macro utf8-ef (load-time-value (excl:crlf-base-ef (excl:find-external-format :utf-8)) t)) (defimplementation string-to-utf8 (s) (excl:string-to-octets s :external-format utf8-ef :null-terminate nil)) (defimplementation utf8-to-string (u) (excl:octets-to-string u :external-format utf8-ef)) ;;;; TCP Server (defimplementation preferred-communication-style () :spawn) (defimplementation create-socket (host port &key backlog) (socket:make-socket :connect :passive :local-port port :local-host host :reuse-address t :backlog (or backlog 5))) (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)) (defimplementation socket-fd (stream) (excl::stream-input-handle stream)) (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))))) ;;;; Unix signals (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 &optional env) (declare (ignore env)) #+(version>= 8 0) (excl::walk-form form) #-(version>= 8 0) (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 type-specifier-p (symbol) (or (ignore-errors (subtypep nil symbol)) (not (eq (type-specifier-arglist symbol) :not-available)))) (defimplementation function-name (f) (check-type f function) (cross-reference::object-to-function-name f)) ;;;; 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 ((magic-symbol (intern (symbol-name :swank-debugger-hook) (find-package :swank))) (top-frame (excl::int-newest-frame (excl::current-thread)))) (loop for frame = top-frame then (next-frame frame) for i from 0 while (and frame (< i 30)) when (eq (debugger:frame-name frame) magic-symbol) return (next-frame frame) finally (return top-frame)))) (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 disassemble-frame (index) (let ((frame (nth-frame index))) (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun) (disassemble (debugger:frame-function frame))))) (defimplementation frame-source-location (index) (let* ((frame (nth-frame index))) (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) (declare (ignore x xx xxx)) (cond ((and pc #+(version>= 8 2) (pc-source-location fun pc) #-(version>= 8 2) (function-source-location fun))) (t ; frames for unbound functions etc end up here (cadr (car (fspec-definition-locations (car (debugger:frame-expression frame)))))))))) (defun function-source-location (fun) (cadr (car (fspec-definition-locations (xref::object-to-function-name fun))))) #+(version>= 8 2) (defun pc-source-location (fun pc) (let* ((debug-info (excl::function-source-debug-info fun))) (cond ((not debug-info) (function-source-location fun)) (t (let* ((code-loc (find-if (lambda (c) (<= (- pc (sys::natural-width)) (let ((x (excl::ldb-code-pc c))) (or x -1)) pc)) debug-info))) (cond ((not code-loc) (ldb-code-to-src-loc (aref debug-info 0))) (t (ldb-code-to-src-loc code-loc)))))))) #+(version>= 8 2) (defun ldb-code-to-src-loc (code) (declare (optimize debug)) (let* ((func (excl::ldb-code-func code)) (debug-info (excl::function-source-debug-info func)) (start (loop for i from (excl::ldb-code-index code) downto 0 for bpt = (aref debug-info i) for start = (excl::ldb-code-start-char bpt) when start return start)) (src-file (excl:source-file func))) (cond (start (buffer-or-file-location src-file start)) (func (let* ((debug-info (excl::function-source-debug-info func)) (whole (aref debug-info 0)) (paths (source-paths-of (excl::ldb-code-source whole) (excl::ldb-code-source code))) (path (if paths (longest-common-prefix paths) '())) (start 0)) (buffer-or-file src-file (lambda (file) (make-location `(:file ,file) `(:source-path (0 . ,path) ,start))) (lambda (buffer bstart) (make-location `(:buffer ,buffer) `(:source-path (0 . ,path) ,(+ bstart start))))))) (t nil)))) (defun longest-common-prefix (sequences) (assert sequences) (flet ((common-prefix (s1 s2) (let ((diff-pos (mismatch s1 s2))) (if diff-pos (subseq s1 0 diff-pos) s1)))) (reduce #'common-prefix sequences))) (defun source-paths-of (whole part) (let ((result '())) (labels ((walk (form path) (cond ((eq form part) (push (reverse path) result)) ((consp form) (loop for i from 0 while (consp form) do (walk (pop form) (cons i path))))))) (walk whole '()) (reverse result)))) (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 (typep name '(and symbol (not null) (not keyword))) collect `(,name ',(debugger:frame-var-value frame i))))) (debugger:eval-form-in-context `(let* ,vars ,form) (debugger:environment-of-frame frame))))) (defimplementation frame-package (frame-number) (let* ((frame (nth-frame frame-number)) (exp (debugger:frame-expression frame))) (typecase exp ((cons symbol) (symbol-package (car exp))) ((cons (cons (eql :internal) (cons symbol))) (symbol-package (cadar exp)))))) (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 frame-restartable-p (frame) (handler-case (debugger:frame-retryable-p frame) (serious-condition (c) (funcall (read-from-string "swank::background-message") "~a ~a" frame (princ-to-string c)) nil))) (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 redefinition-p (condition) (and (typep condition 'style-warning) (every #'char-equal "redefin" (princ-to-string condition)))) (defun compiler-undefined-functions-called-warning-p (object) (typep object 'excl:compiler-undefined-functions-called-warning)) (deftype compiler-note () `(satisfies compiler-note-p)) (deftype redefinition () `(satisfies redefinition-p)) (defun signal-compiler-condition (&rest args) (apply #'signal 'compiler-condition args)) (defun handle-compiler-warning (condition) (declare (optimize (debug 3) (speed 0) (space 0))) (cond ((and #-(version>= 10 0) (not *buffer-name*) (compiler-undefined-functions-called-warning-p condition)) (handle-undefined-functions-warning condition)) ((and (typep condition 'excl::compiler-note) (let ((format (slot-value condition 'excl::format-control))) (and (search "Closure" format) (search "will be stack allocated" format)))) ;; Ignore "Closure will be stack allocated" notes. ;; That occurs often but is usually uninteresting. ) (t (signal-compiler-condition :original-condition condition :severity (etypecase condition (redefinition :redefinition) (style-warning :style-warning) (warning :warning) (compiler-note :note) (reader-error :read-error) (error :error)) :message (format nil "~A" condition) :location (compiler-warning-location condition))))) (defun condition-pathname-and-position (condition) (let* ((context #+(version>= 10 0) (getf (slot-value condition 'excl::plist) :source-context)) (location-available (and context (excl::source-context-start-char context)))) (cond (location-available (values (excl::source-context-pathname context) (when-let (start-char (excl::source-context-start-char context)) (1+ (if (listp start-char) ; HACK (first start-char) start-char))))) ((typep condition 'reader-error) (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) (file (pathname (stream-error-stream condition)))) (when (integerp pos) (values file pos)))) (t (let ((loc (getf (slot-value condition 'excl::plist) :loc))) (when loc (destructuring-bind (file . pos) loc (let ((start (if (consp pos) ; 8.2 and newer (car pos) pos))) (values file (1+ start)))))))))) (defun compiler-warning-location (condition) (multiple-value-bind (pathname position) (condition-pathname-and-position condition) (cond (*buffer-name* (make-location (list :buffer *buffer-name*) (if position (list :position position) (list :offset *buffer-start-position* 0)))) (pathname (make-location (list :file (namestring (truename pathname))) (list :position position))) (t (make-error-location "No error location available."))))) ;; TODO: report it as a bug to Franz that the condition's plist ;; slot contains (:loc nil). (defun handle-undefined-functions-warning (condition) (let ((fargs (slot-value condition 'excl::format-arguments))) (loop for (fname . locs) in (car fargs) do (dolist (loc locs) (multiple-value-bind (pos file) (ecase (length loc) (2 (values-list loc)) (3 (destructuring-bind (start end file) loc (declare (ignore end)) (values start file)))) (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) (reader-error #'handle-compiler-warning)) (funcall function))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (handler-case (with-compilation-hooks () (let ((*buffer-name* nil) (*compile-filename* input-file) #+(version>= 8 2) (compiler:save-source-level-debug-info-switch t) (excl:*load-source-file-info* t) #+(version>= 8 2) (excl:*load-source-debug-info* t)) (compile-file *compile-filename* :output-file output-file :load-after-compile load-p :external-format external-format))) (reader-error () (values nil nil t)))) (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)))) (defvar *temp-file-map* (make-hash-table :test #'equal) "A mapping from tempfile names to Emacs buffer names.") (defun write-tracking-preamble (stream file file-offset) "Instrument the top of the temporary file to be compiled. The header tells allegro that any definitions compiled in the temp file should be found in FILE exactly at FILE-OFFSET. To get Allegro to do this, this factors in the length of the inserted header itself." (with-standard-io-syntax (let* ((*package* (find-package :keyword)) (source-pathname-form `(cl:eval-when (:compile-toplevel :load-toplevel :execute) (cl:setq excl::*source-pathname* (pathname ,(sys::frob-source-file file))))) (source-pathname-string (write-to-string source-pathname-form)) (position-form-length-bound 160) ; should be enough for everyone (header-length (+ (length source-pathname-string) position-form-length-bound)) (position-form `(cl:eval-when (:compile-toplevel :load-toplevel :execute) (cl:setq excl::*partial-source-file-p* ,(- file-offset header-length 1 ; for the newline )))) (position-form-string (write-to-string position-form)) (padding-string (make-string (- position-form-length-bound (length position-form-string)) :initial-element #\;))) (write-string source-pathname-string stream) (write-string position-form-string stream) (write-string padding-string stream) (write-char #\newline stream)))) (defun compile-from-temp-file (string buffer offset file) (call-with-temp-file (lambda (stream filename) (when (and file offset (probe-file file)) (write-tracking-preamble stream file offset)) (write-string string stream) (finish-output stream) (multiple-value-bind (binary-filename warnings? failure?) (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension #+(version>= 8 2) (compiler:save-source-level-debug-info-switch t) (excl:*redefinition-warnings* nil)) (compile-file filename)) (declare (ignore warnings?)) (when binary-filename (let ((excl:*load-source-file-info* t) #+(version>= 8 2) (excl:*load-source-debug-info* t)) excl::*source-pathname* (load binary-filename)) (when (and buffer offset (or (not file) (not (probe-file file)))) (setf (gethash (pathname stream) *temp-file-map*) (list buffer offset))) (delete-file binary-filename)) (not failure?))))) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore policy)) (handler-case (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-start-position* position) (*buffer-string* string)) (compile-from-temp-file string buffer position filename))) (reader-error () nil))) ;;;; Definition Finding (defun buffer-or-file (file file-fun buffer-fun) (let* ((probe (gethash file *temp-file-map*))) (cond (probe (destructuring-bind (buffer start) probe (funcall buffer-fun buffer start))) (t (funcall file-fun (namestring (truename file))))))) (defun buffer-or-file-location (file offset) (buffer-or-file file (lambda (filename) (make-location `(:file ,filename) `(:position ,(1+ offset)))) (lambda (buffer start) (make-location `(:buffer ,buffer) `(:offset ,start ,offset))))) (defun fspec-primary-name (fspec) (etypecase fspec (symbol fspec) (list (fspec-primary-name (second fspec))))) (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)) (list :function-name (string (fspec-primary-name fspec)))))) (make-location (list :file (namestring (truename file))) pos))) (defun find-fspec-location (fspec type file top-level) (handler-case (etypecase file (pathname (let ((probe (gethash file *temp-file-map*))) (cond (probe (destructuring-bind (buffer offset) probe (make-location `(:buffer ,buffer) `(:offset ,offset 0)))) (t (find-definition-in-file fspec type file top-level))))) ((member :top-level) (make-error-location "Defined at toplevel: ~A" (fspec->string fspec)))) (error (e) (make-error-location "Error: ~A" e)))) (defun fspec->string (fspec) (typecase 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))))) (t (princ-to-string fspec)))) (defun fspec-definition-locations (fspec) (cond ((and (listp fspec) (eq (car fspec) :internal)) (destructuring-bind (_internal next _n) fspec (declare (ignore _internal _n)) (fspec-definition-locations next))) (t (let ((defs (excl::find-source-file fspec))) (when (and (null defs) (listp fspec) (string= (car fspec) '#:method)) ;; If methods are defined in a defgeneric form, the source location is ;; recorded for the gf but not for the methods. Therefore fall back to ;; the gf as the likely place of definition. (setq defs (excl::find-source-file (second fspec)))) (if (null defs) (list (list fspec (make-error-location "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)) (defimplementation find-source-location (obj) (first (rest (first (fspec-definition-locations obj))))) ;;;; 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-collection-control-2 (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 (read-from-string "swank:y-or-n-p-in-emacs"))) (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 (excl:without-redefinition-warnings (defmethod emacs-inspect ((o t)) (allegro-inspect o))) (defmethod emacs-inspect ((o function)) (allegro-inspect o)) (defmethod emacs-inspect ((o standard-object)) (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 :unsigned-long32) (label-value-line name (inspect::component-ref-v object access type))) ((:lisp :value :func) (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) (princ-to-string (mp:process-whostate thread))) (defimplementation thread-attributes (thread) (list :priority (mp:process-priority thread) :times-resumed (mp:process-times-resumed 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.)) (lock (mp:make-process-lock :name "process mailbox")) (queue '() :type list) (gate (mp:make-gate nil))) (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))) (mp:with-process-lock ((mailbox.lock mbox)) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) (mp:open-gate (mailbox.gate mbox))))) (defimplementation receive-if (test &optional timeout) (let ((mbox (mailbox mp:*current-process*))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-process-lock ((mailbox.lock mbox)) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))) (mp:close-gate (mailbox.gate mbox)))) (when (eq timeout t) (return (values nil t))) (mp:process-wait-with-timeout "receive-if" 0.5 #'mp:gate-open-p (mailbox.gate mbox))))) (let ((alist '()) (lock (mp:make-process-lock :name "register-thread"))) (defimplementation register-thread (name thread) (declare (type symbol name)) (mp:with-process-lock (lock) (etypecase thread (null (setf alist (delete name alist :key #'car))) (mp:process (let ((probe (assoc name alist))) (cond (probe (setf (cdr probe) thread)) (t (setf alist (acons name thread alist)))))))) nil) (defimplementation find-registered (name) (mp:with-process-lock (lock) (cdr (assoc name alist))))) (defimplementation set-default-initial-binding (var form) (push (cons var form) #+(version>= 9 0) excl:*required-thread-bindings* #-(version>= 9 0) excl::required-thread-bindings)) (defimplementation quit-lisp () (excl:exit 0 :quiet t)) ;;Trace implementations ;;In Allegro 7.0, we have: ;; (trace ) ;; (trace ((method ? (+)))) ;; (trace ((labels ))) ;; (trace ((labels (method (+)) ))) ;; 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))) ;;;; wrap interface implementation (defimplementation wrap (spec indicator &key before after replace) (let ((allegro-spec (process-fspec-for-allegro spec))) (excl:fwrap allegro-spec indicator (excl:def-fwrapper allegro-wrapper (&rest args) (let (retlist completed) (unwind-protect (progn (when before (funcall before args)) (setq retlist (multiple-value-list (if replace (funcall replace args) (excl:call-next-fwrapper)))) (setq completed t) (values-list retlist)) (when after (funcall after (if completed retlist :exited-non-locally))))))) allegro-spec)) (defimplementation unwrap (spec indicator) (let ((allegro-spec (process-fspec-for-allegro spec))) (excl:funwrap allegro-spec indicator) allegro-spec)) (defimplementation wrapped-p (spec indicator) (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) slime-2.20/swank/backend.lisp000066400000000000000000001573061315100173500161610ustar00rootroot00000000000000;;; -*- 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-.lisp provides methods. (in-package swank/backend) ;;;; Metacode (defparameter *debug-swank-backend* nil "If this is true, backends should not catch errors but enter the debugger where appropriate. Also, they should not perform backtrace magic but really show every frame including SWANK related ones.") (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.") (defvar *log-output* nil) ; should be nil for image dumpers (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 implemented" ',name))))) (pushnew ',name *interface-functions*) ,(if (null default-body) `(pushnew ',name *unimplemented-interfaces*) (gen-default-impl)) (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) ;; For implicit BLOCK. FLET because of interplay w/ decls. (flet ((,name ,args ,@body)) #',name)) (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." (let ((*print-pretty* t)) (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" (list (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))))) (definterface gray-package-name () "Return a package-name that contains the Gray stream symbols. This will be used like so: (defpackage foo (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)") ;;;; Utilities (defmacro with-struct ((conc-name &rest names) obj &body body) "Like with-slots but works only for structs." (check-type conc-name symbol) (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))))) (defmacro when-let ((var value) &body body) `(let ((,var ,value)) (when ,var ,@body))) (defun boolean-to-feature-expression (value) "Converts a boolean VALUE to a form suitable for testing with #+." (if value '(:and) '(:or))) (defun with-symbol (name package) "Check if a symbol with a given NAME exists in PACKAGE and returns a form suitable for testing with #+." (boolean-to-feature-expression (and (find-package package) (find-symbol (string name) package)))) (defun choose-symbol (package name alt-package alt-name) "If symbol package:name exists return that symbol, otherwise alt-package:alt-name. Suitable for use with #." (or (and (find-package package) (find-symbol (string name) package)) (find-symbol (string alt-name) alt-package))) ;;;; UFT8 (deftype octet () '(unsigned-byte 8)) (deftype octets () '(simple-array octet (*))) ;; Helper function. Decode the next N bytes starting from INDEX. ;; Return the decoded char and the new index. (defun utf8-decode-aux (buffer index limit byte0 n) (declare (type octets buffer) (fixnum index limit byte0 n)) (if (< (- limit index) n) (values nil index) (do ((i 0 (1+ i)) (code byte0 (let ((byte (aref buffer (+ index i)))) (cond ((= (ldb (byte 2 6) byte) #b10) (+ (ash code 6) (ldb (byte 6 0) byte))) (t (error "Invalid encoding")))))) ((= i n) (values (cond ((<= code #xff) (code-char code)) ((<= #xd800 code #xdfff) (error "Invalid Unicode code point: #x~x" code)) ((and (< code char-code-limit) (code-char code))) (t (error "Can't represent code point: #x~x ~ (char-code-limit is #x~x)" code char-code-limit))) (+ index n)))))) ;; Decode one character in BUFFER starting at INDEX. ;; Return 2 values: the character and the new index. ;; If there aren't enough bytes between INDEX and LIMIT return nil. (defun utf8-decode (buffer index limit) (declare (type octets buffer) (fixnum index limit)) (if (= index limit) (values nil index) (let ((b (aref buffer index))) (if (<= b #x7f) (values (code-char b) (1+ index)) (macrolet ((try (marker else) (let* ((l (integer-length marker)) (n (- l 2))) `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) (utf8-decode-aux buffer (1+ index) limit (ldb (byte ,(- 8 l) 0) b) ,n) ,else)))) (try #b110 (try #b1110 (try #b11110 (try #b111110 (try #b1111110 (error "Invalid encoding"))))))))))) ;; Decode characters from BUFFER and write them to STRING. ;; Return 2 values: LASTINDEX and LASTSTART where ;; LASTINDEX is the last index in BUFFER that was not decoded ;; and LASTSTART is the last index in STRING not written. (defun utf8-decode-into (buffer index limit string start end) (declare (string string) (fixnum index limit start end) (type octets buffer)) (loop (cond ((= start end) (return (values index start))) (t (multiple-value-bind (c i) (utf8-decode buffer index limit) (cond (c (setf (aref string start) c) (setq index i) (setq start (1+ start))) (t (return (values index start))))))))) (defun default-utf8-to-string (octets) (let* ((limit (length octets)) (str (make-string limit))) (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) (if (= i limit) (if (= limit s) str (adjust-array str s)) (loop (let ((end (+ (length str) (- limit i)))) (setq str (adjust-array str end)) (multiple-value-bind (i2 s2) (utf8-decode-into octets i limit str s end) (cond ((= i2 limit) (return (adjust-array str s2))) (t (setq i i2) (setq s s2)))))))))) (defmacro utf8-encode-aux (code buffer start end n) `(cond ((< (- ,end ,start) ,n) ,start) (t (setf (aref ,buffer ,start) (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) (byte ,(- 7 n) 0) ,(dpb 0 (byte 1 (- 7 n)) #xff))) ,@(loop for i from 0 upto (- n 2) collect `(setf (aref ,buffer (+ ,start ,(- n 1 i))) (dpb (ldb (byte 6 ,(* 6 i)) ,code) (byte 6 0) #b10111111))) (+ ,start ,n)))) (defun %utf8-encode (code buffer start end) (declare (type (unsigned-byte 31) code) (type octets buffer) (type (and fixnum unsigned-byte) start end)) (cond ((<= code #x7f) (cond ((< start end) (setf (aref buffer start) code) (1+ start)) (t start))) ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) ((<= #xd800 code #xdfff) (error "Invalid Unicode code point (surrogate): #x~x" code)) ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) (t (utf8-encode-aux code buffer start end 6)))) (defun utf8-encode (char buffer start end) (declare (type character char) (type octets buffer) (type (and fixnum unsigned-byte) start end)) (%utf8-encode (char-code char) buffer start end)) (defun utf8-encode-into (string start end buffer index limit) (declare (string string) (type octets buffer) (fixnum start end index limit)) (loop (cond ((= start end) (return (values start index))) ((= index limit) (return (values start index))) (t (let ((i2 (utf8-encode (char string start) buffer index limit))) (cond ((= i2 index) (return (values start index))) (t (setq index i2) (incf start)))))))) (defun default-string-to-utf8 (string) (let* ((len (length string)) (b (make-array len :element-type 'octet))) (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) (if (= s len) b (loop (let ((limit (+ (length b) (- len s)))) (setq b (coerce (adjust-array b limit) 'octets)) (multiple-value-bind (s2 i2) (utf8-encode-into string s len b i limit) (cond ((= s2 len) (return (coerce (adjust-array b i2) 'octets))) (t (setq i i2) (setq s s2)))))))))) (definterface string-to-utf8 (string) "Convert the string STRING to a (simple-array (unsigned-byte 8))" (default-string-to-utf8 string)) (definterface utf8-to-string (octets) "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." (default-utf8-to-string octets)) ;;;; TCP server (definterface create-socket (host port &key backlog) "Create a listening TCP socket on interface HOST and port PORT. BACKLOG queue length for incoming connections.") (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. If EXTERNAL-FORMAT is nil return a binary stream otherwise create a character stream. BUFFERING can be one of: nil ... no buffering t ... enable buffering :line ... enable buffering with automatic flushing on eol.") (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 getpid () "Return the (Unix) process ID of this superior Lisp.") (definterface install-sigint-handler (function) "Call FUNCTION on SIGINT (instead of invoking the debugger). Return old signal handler." (declare (ignore function)) nil) (definterface call-with-user-break-handler (handler function) "Install the break handler HANDLER while executing FUNCTION." (let ((old-handler (install-sigint-handler handler))) (unwind-protect (funcall function) (install-sigint-handler old-handler)))) (definterface quit-lisp () "Exit the current lisp image.") (definterface lisp-implementation-type-name () "Return a short name for the Lisp implementation." (lisp-implementation-type)) (definterface lisp-implementation-program () "Return the argv[0] of the running Lisp process, or NIL." (let ((file (car (command-line-args)))) (when (and file (probe-file file)) (namestring (truename file))))) (definterface socket-fd (socket-stream) "Return the file descriptor for SOCKET-STREAM.") (definterface make-fd-stream (fd external-format) "Create a character stream for the file descriptor FD.") (definterface dup (fd) "Duplicate a file descriptor. If the syscall fails, signal a condition. See dup(2).") (definterface exec-image (image-file args) "Replace the current process with a new process image. The new image is created by loading the previously dumped core file IMAGE-FILE. ARGS is a list of strings passed as arguments to the new image. This is thin wrapper around exec(3).") (definterface command-line-args () "Return a list of strings as passed by the OS." nil) ;; pathnames are sooo useless (definterface filename-to-pathname (filename) "Return a pathname for FILENAME. A filename in Emacs may for example contain asterisks which should not be translated to wildcards." (parse-namestring filename)) (definterface pathname-to-filename (pathname) "Return the filename for PATHNAME." (namestring pathname)) (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*." '()) ;;;; Packages (definterface package-local-nicknames (package) "Returns an alist of (local-nickname . actual-package) describing the nicknames local to the designated package." (declare (ignore package)) nil) (definterface find-locally-nicknamed-package (name base-package) "Return the package whose local nickname in BASE-PACKAGE matches NAME. Return NIL if local nicknames are not implemented or if there is no such package." (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal))) ;;;; 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 filename policy) "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 FILENAME is specified it may be used by certain implementations to rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of source information. If POLICY is supplied, and non-NIL, it may be used by certain implementations to compile with optimization qualities of its value. Should return T on successful compilation, NIL otherwise. ") (definterface swank-compile-file (input-file output-file load-p external-format &key policy) "Compile INPUT-FILE 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. If POLICY is supplied, and non-NIL, it may be used by certain implementations to compile with optimization qualities of its value. Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p like `compile-file'") (deftype severity () '(member :error :read-error :warning :style-warning :note :redefinition)) ;; 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) ;; Macro expansion history etc. which may be helpful in some cases ;; but is often very verbose. (source-context :initarg :source-context :type (or null string) :initform nil :accessor source-context) (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 (pathname) "Detect the external format for the file with name pathname. Return nil if the file contains no special markers." ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. (with-open-file (s pathname :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-output-stream (write-string) "Return a new character output stream. The stream calls WRITE-STRING when output is ready.") (definterface make-input-stream (read-string) "Return a new character input stream. The stream calls READ-STRING when input is needed.") ;;;; 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 variables)) (ignore '(&rest variables)) (ignorable '(&rest variables)) (special '(&rest variables)) (inline '(&rest function-names)) (notinline '(&rest function-names)) (declaration '(&rest names)) (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 variables)) ((and (listp decl-identifier) (typespec-p (first decl-identifier))) '(&rest variables)) (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 type-specifier-p (symbol) "Determine if SYMBOL is a type-specifier." (or (documentation symbol 'type) (not (eq (type-specifier-arglist symbol) :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 valid-function-name-p (form) "Is FORM syntactically valid to name a function? If true, FBOUNDP should not signal a type-error for FORM." (flet ((length=2 (list) (and (not (null (cdr list))) (null (cddr list))))) (or (symbolp form) (and (consp form) (length=2 form) (eq (first form) 'setf) (symbolp (second form)))))) (definterface macroexpand-all (form &optional env) "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) (valid-function-name-p (car form)) (compiler-macro-function (car form) env)))) (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))) (defmacro with-collected-macro-forms ((forms &optional result) instrumented-form &body body) "Collect macro forms by locally binding *MACROEXPAND-HOOK*. Evaluates INSTRUMENTED-FORM and collects any forms which undergo macro-expansion into a list. Then evaluates BODY with FORMS bound to the list of forms, and RESULT (optionally) bound to the value of INSTRUMENTED-FORM." (assert (and (symbolp forms) (not (null forms)))) (assert (symbolp result)) (let ((result-symbol (or result (gensym)))) `(call-with-collected-macro-forms (lambda (,forms ,result-symbol) (declare (ignore ,@(and (not result) `(,result-symbol)))) ,@body) (lambda () ,instrumented-form)))) (defun call-with-collected-macro-forms (body-fn instrumented-fn) (let ((return-value nil) (collected-forms '())) (let* ((real-macroexpand-hook *macroexpand-hook*) (*macroexpand-hook* (lambda (macro-function form environment) (let ((result (funcall real-macroexpand-hook macro-function form environment))) (unless (eq result form) (push form collected-forms)) result)))) (setf return-value (funcall instrumented-fn))) (funcall body-fn collected-forms return-value))) (definterface collect-macro-forms (form &optional env) "Collect subforms of FORM which undergo (compiler-)macro expansion. Returns two values: a list of macro forms and a list of compiler macro forms." (with-collected-macro-forms (macro-forms expansion) (ignore-errors (macroexpand-all form env)) (with-collected-macro-forms (compiler-macro-forms) (handler-bind ((warning #'muffle-warning)) (ignore-errors (compile nil `(lambda () ,expansion)))) (values macro-forms compiler-macro-forms)))) (definterface format-string-expand (control-string) "Expand the format string CONTROL-STRING." (macroexpand `(formatter ,control-string))) (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 NIL (or the obsolete :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 can be NIL. 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.")) ;;; The following functions in this section are supposed to be called ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. (definterface compute-backtrace (start end) "Returns a backtrace of the condition currently being debugged, that is an ordered list consisting of frames. ``Ordered list'' means that an integer I can be mapped back to the i-th frame of this backtrace. 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 print-frame (frame stream) "Print frame to stream.") (definterface frame-restartable-p (frame) "Is the frame FRAME restartable?. Return T if `restart-frame' can safely be called on the frame." (declare (ignore frame)) nil) (definterface frame-source-location (frame-number) "Return the source location for the frame associated to FRAME-NUMBER.") (definterface frame-catch-tags (frame-number) "Return a list of catch tags for being printed in a debugger stack frame." (declare (ignore frame-number)) '()) (definterface frame-locals (frame-number) "Return a list of ((&key NAME ID VALUE) ...) where each element of the list represents a local variable in the stack frame associated to FRAME-NUMBER. NAME, a symbol; the name of the local variable. ID, an integer; used as primary key for the local variable, unique relatively to the frame under operation. value, an object; the value of the local variable.") (definterface frame-var-value (frame-number var-id) "Return the value of the local variable associated to VAR-ID relatively to the frame associated to FRAME-NUMBER.") (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. 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 frame-package (frame-number) "Return the package corresponding to the frame at FRAME-NUMBER. Return nil if the backend can't figure it out." (declare (ignore frame-number)) nil) (definterface frame-call (frame-number) "Return a string representing a call to the entry point of a frame.") (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 print-condition (condition stream) "Print a condition for display in SLDB." (princ condition stream)) (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 gdb-initial-commands () "List of gdb commands supposed to be executed first for the ATTACH-GDB restart." nil) (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) (:constructor make-location (buffer position &optional hints))) (type :location) 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) (defmacro converting-errors-to-error-location (&body body) "Catches errors during BODY and converts them to an error location." (let ((gblock (gensym "CONVERTING-ERRORS+"))) `(block ,gblock (handler-bind ((error #'(lambda (e) (if *debug-swank-backend* nil ;decline (return-from ,gblock (make-error-location e)))))) ,@body)))) (defun make-error-location (datum &rest args) (cond ((typep datum 'condition) `(:error ,(format nil "Error: ~A" datum))) ((symbolp datum) `(:error ,(format nil "Error: ~A" (apply #'make-condition datum args)))) (t (assert (stringp datum)) `(:error ,(apply #'format nil datum args))))) (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 find-source-location (object) "Returns the source location of OBJECT, or NIL. That is the source location of the underlying datastructure of OBJECT. E.g. on a STANDARD-OBJECT, the source location of the respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the respective DEFSTRUCT definition, and so on." ;; This returns one source location and not a list of locations. It's ;; supposed to return the location of the DEFGENERIC definition on ;; #'SOME-GENERIC-FUNCTION. (declare (ignore object)) (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~ this implementation.")) (definterface buffer-first-change (filename) "Called for effect the first time FILENAME's buffer is modified. CMUCL/SBCL use this to cache the unmodified file and use the unmodified text to improve the precision of source locations." (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) ...)." (declare (ignore function-name)) :not-implemented) (definterface calls-who (function-name) "Return the call sites of FUNCTION-NAME (a symbol). The results is a list ((DSPEC LOCATION) ...)." (declare (ignore function-name)) :not-implemented) (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." (declare (ignore variable-name)) :not-implemented) (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." (declare (ignore variable-name)) :not-implemented) (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." (declare (ignore variable-name)) :not-implemented) (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." (declare (ignore macro-name)) :not-implemented) (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." (declare (ignore class-name)) :not-implemented) ;;; 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.") ;;;; Trace (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) ") ;;;; Inspector (defgeneric emacs-inspect (object) (:documentation "Explain to Emacs how to inspect OBJECT. Returns 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. ")) (defmethod emacs-inspect ((object 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." `("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)))) (definterface eval-context (object) "Return a list of bindings corresponding to OBJECT's slots." (declare (ignore object)) '()) ;;; 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 ) (thread-id )) <==> (eq )" thread) (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." (declare (ignore id)) (current-thread)) (definterface thread-name (thread) "Return the name of THREAD. Thread names are short strings 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 thread-attributes (thread) "Return a plist of implementation-dependent attributes for THREAD" (declare (ignore thread)) '()) (definterface current-thread () "Return the currently executing thread." 0) (definterface all-threads () "Return a fresh 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) "Terminate THREAD immediately. Don't execute unwind-protected sections, don't raise conditions. (Do not pass go, do not collect $200.)" (declare (ignore thread)) nil) (definterface send (thread object) "Send OBJECT to thread THREAD." (declare (ignore thread)) object) (definterface receive (&optional timeout) "Return the next message from current thread's mailbox." (receive-if (constantly t) timeout)) (definterface receive-if (predicate &optional timeout) "Return the first message satisfiying PREDICATE.") (definterface wake-thread (thread) "Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using asynchronous interrupts." (declare (ignore thread)) ;; Doesn't have to implement this if RECEIVE-IF periodically calls ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient nil) (definterface register-thread (name thread) "Associate the thread THREAD with the symbol NAME. The thread can then be retrieved with `find-registered'. If THREAD is nil delete the association." (declare (ignore name thread)) nil) (definterface find-registered (name) "Find the thread that was registered for the symbol NAME. Return nil if the no thread was registred or if the tread is dead." (declare (ignore name)) nil) (definterface set-default-initial-binding (var form) "Initialize special variable VAR by default with FORM. Some implementations initialize certain variables in each newly created thread. This function sets the form which is used to produce the initial value." (set var (eval form))) ;; List of delayed interrupts. ;; This should only have thread-local bindings, so no init form. (defvar *pending-slime-interrupts*) (defun check-slime-interrupts () "Execute pending interrupts if any. This should be called periodically in operations which can take a long time to complete. Return a boolean indicating whether any interrupts was processed." (when (and (boundp '*pending-slime-interrupts*) *pending-slime-interrupts*) (funcall (pop *pending-slime-interrupts*)) t)) (defvar *interrupt-queued-handler* nil "Function to call on queued interrupts. Interrupts get queued when an interrupt occurs while interrupt handling is disabled. Backends can use this function to abort slow operations.") (definterface wait-for-input (streams &optional timeout) "Wait for input on a list of streams. Return those that are ready. STREAMS is a list of streams TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams which are ready (or have reached end-of-file) without waiting. If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, return nil. Return :interrupt if an interrupt occurs while waiting.") ;;;; Locks ;; Please use locks only in swank-gray.lisp. Locks are too low-level ;; for our taste. (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 but that thread may hold it more than once." (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)) ;;;; 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) ;;;; Floating point (definterface float-nan-p (float) "Return true if FLOAT is a NaN value (Not a Number)." ;; When the float type implements IEEE-754 floats, two NaN values ;; are never equal; when the implementation does not support NaN, ;; the predicate should return false. An implementation can ;; implement comparison with "unordered-signaling predicates", which ;; emit floating point exceptions. (handler-case (not (= float float)) ;; Comparisons never signal an exception other than the invalid ;; operation exception (5.11 Details of comparison predicates). (floating-point-invalid-operation () t))) (definterface float-infinity-p (float) "Return true if FLOAT is positive or negative infinity." (not (< most-negative-long-float float most-positive-long-float))) ;;;; 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)) )) ;;; Heap dumps (definterface save-image (filename &optional restart-function) "Save a heap image to the file FILENAME. RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") (definterface background-save-image (filename &key restart-function completion-function) "Request saving a heap image to the file FILENAME. RESTART-FUNCTION, if non-nil, should be called when the image is loaded. COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") (defun deinit-log-output () ;; Can't hang on to an fd-stream from a previous session. (setf *log-output* nil)) ;;;; Wrapping (definterface wrap (spec indicator &key before after replace) "Intercept future calls to SPEC and surround them in callbacks. INDICATOR is a symbol identifying a particular wrapping, and is used to differentiate between multiple wrappings. Implementations intercept calls to SPEC and call, in this order: * the BEFORE callback, if it's provided, with a single argument set to the list of arguments passed to the intercepted call; * the original definition of SPEC recursively honouring any wrappings previously established under different values of INDICATOR. If the compatible function REPLACE is provided, call that instead. * the AFTER callback, if it's provided, with a single set to the list of values returned by the previous call, or, if that call exited non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY." (declare (ignore indicator)) (assert (symbolp spec) nil "The default implementation for WRAP allows only simple names") (assert (null (get spec 'slime-wrap)) nil "The default implementation for WRAP allows a single wrapping") (let* ((saved (symbol-function spec)) (replacement (lambda (&rest args) (let (retlist completed) (unwind-protect (progn (when before (funcall before args)) (setq retlist (multiple-value-list (apply (or replace saved) args))) (setq completed t) (values-list retlist)) (when after (funcall after (if completed retlist :exited-non-locally)))))))) (setf (get spec 'slime-wrap) (list saved replacement)) (setf (symbol-function spec) replacement)) spec) (definterface unwrap (spec indicator) "Remove from SPEC any wrappings tagged with INDICATOR." (if (wrapped-p spec indicator) (setf (symbol-function spec) (first (get spec 'slime-wrap))) (cerror "All right, so I did" "Hmmm, ~a is not correctly wrapped, you probably redefined it" spec)) (setf (get spec 'slime-wrap) nil) spec) (definterface wrapped-p (spec indicator) "Returns true if SPEC is wrapped with INDICATOR." (declare (ignore indicator)) (and (symbolp spec) (let ((prop-value (get spec 'slime-wrap))) (cond ((and prop-value (not (eq (second prop-value) (symbol-function spec)))) (warn "~a appears to be incorrectly wrapped" spec) nil) (prop-value t) (t nil))))) slime-2.20/swank/ccl.lisp000066400000000000000000000753441315100173500153340ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- ;;; ;;; swank-ccl.lisp --- SLIME backend for Clozure CL. ;;; ;;; Copyright (C) 2003, James Bielman ;;; ;;; This program is licensed under the terms of the Lisp Lesser GNU ;;; Public License, known as the LLGPL, and distributed with Clozure CL ;;; as the file "LICENSE". The LLGPL consists of a preamble and the ;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where ;;; these conflict, the preamble takes precedence. ;;; ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html (defpackage swank/ccl (:use cl swank/backend)) (in-package swank/ccl) (eval-when (:compile-toplevel :execute :load-toplevel) (assert (and (= ccl::*openmcl-major-version* 1) (>= ccl::*openmcl-minor-version* 4)) () "This file needs CCL version 1.4 or newer")) (defimplementation gray-package-name () "CCL") (eval-when (:compile-toplevel :load-toplevel :execute) (multiple-value-bind (ok err) (ignore-errors (require 'xref)) (unless ok (warn "~a~%" err)))) ;;; swank-mop (import-to-swank-mop '( ;; classes cl:standard-generic-function ccl:standard-slot-definition cl:method cl:standard-class ccl:eql-specializer openmcl-mop:finalize-inheritance openmcl-mop:compute-applicable-methods-using-classes ;; standard-class readers openmcl-mop:class-default-initargs openmcl-mop:class-direct-default-initargs openmcl-mop:class-direct-slots openmcl-mop:class-direct-subclasses openmcl-mop:class-direct-superclasses openmcl-mop:class-finalized-p cl:class-name openmcl-mop:class-precedence-list openmcl-mop:class-prototype openmcl-mop:class-slots openmcl-mop:specializer-direct-methods ;; eql-specializer accessors openmcl-mop:eql-specializer-object ;; generic function readers openmcl-mop:generic-function-argument-precedence-order openmcl-mop:generic-function-declarations openmcl-mop:generic-function-lambda-list openmcl-mop:generic-function-methods openmcl-mop:generic-function-method-class openmcl-mop:generic-function-method-combination openmcl-mop:generic-function-name ;; method readers openmcl-mop:method-generic-function openmcl-mop:method-function openmcl-mop:method-lambda-list openmcl-mop:method-specializers openmcl-mop:method-qualifiers ;; slot readers openmcl-mop:slot-definition-allocation openmcl-mop:slot-definition-documentation openmcl-mop:slot-value-using-class openmcl-mop:slot-definition-initargs openmcl-mop:slot-definition-initform openmcl-mop:slot-definition-initfunction openmcl-mop:slot-definition-name openmcl-mop:slot-definition-type openmcl-mop:slot-definition-readers openmcl-mop:slot-definition-writers openmcl-mop:slot-boundp-using-class openmcl-mop:slot-makunbound-using-class)) ;;; UTF8 (defimplementation string-to-utf8 (string) (ccl:encode-string-to-octets string :external-format :utf-8)) (defimplementation utf8-to-string (octets) (ccl:decode-string-from-octets octets :external-format :utf-8)) ;;; TCP Server (defimplementation preferred-communication-style () :spawn) (defimplementation create-socket (host port &key backlog) (ccl:make-socket :connect :passive :local-port port :local-host host :reuse-address t :backlog (or backlog 5))) (defimplementation local-port (socket) (ccl:local-port socket)) (defimplementation close-socket (socket) (close socket)) (defimplementation accept-connection (socket &key external-format buffering timeout) (declare (ignore buffering timeout)) (let ((stream-args (and external-format `(:external-format ,external-format)))) (ccl:accept-connection socket :wait t :stream-args stream-args))) (defvar *external-format-to-coding-system* '((:iso-8859-1 "latin-1" "latin-1-unix" "iso-latin-1-unix" "iso-8859-1" "iso-8859-1-unix") (:utf-8 "utf-8" "utf-8-unix"))) (defimplementation find-external-format (coding-system) (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*))) (defimplementation socket-fd (stream) (ccl::ioblock-device (ccl::stream-ioblock stream t))) ;;; Unix signals (defimplementation getpid () (ccl::getpid)) (defimplementation lisp-implementation-type-name () "ccl") ;;; Arglist (defimplementation arglist (fname) (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil)) (ccl:arglist fname)) (if binding arglist :not-available))) (defimplementation function-name (function) (ccl:function-name function)) (defmethod declaration-arglist ((decl-identifier (eql 'optimize))) (let ((flags (ccl:declaration-information decl-identifier))) (if flags `(&any ,flags) (call-next-method)))) ;;; Compilation (defun handle-compiler-warning (condition) "Resignal a ccl:compiler-warning as swank/backend:compiler-warning." (signal 'compiler-condition :original-condition condition :message (compiler-warning-short-message condition) :source-context nil :severity (compiler-warning-severity condition) :location (source-note-to-source-location (ccl:compiler-warning-source-note condition) (lambda () "Unknown source") (ccl:compiler-warning-function-name condition)))) (defgeneric compiler-warning-severity (condition)) (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning) (defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning) (defgeneric compiler-warning-short-message (condition)) ;; Pretty much the same as ccl:report-compiler-warning but ;; without the source position and function name stuff. (defmethod compiler-warning-short-message ((c ccl:compiler-warning)) (with-output-to-string (stream) (ccl:report-compiler-warning c stream :short t))) ;; Needed because `ccl:report-compiler-warning' would return ;; "Nonspecific warning". (defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause)) (princ-to-string c)) (defimplementation call-with-compilation-hooks (function) (handler-bind ((ccl:compiler-warning 'handle-compiler-warning)) (let ((ccl:*merge-compiler-warnings* nil)) (funcall function)))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (with-compilation-hooks () (compile-file input-file :output-file output-file :load load-p :external-format external-format))) ;; Use a temp file rather than in-core compilation in order to handle ;; eval-when's as compile-time. (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore policy)) (with-compilation-hooks () (let ((temp-file-name (ccl:temp-pathname)) (ccl:*save-source-locations* t)) (unwind-protect (progn (with-open-file (s temp-file-name :direction :output :if-exists :error :external-format :utf-8) (write-string string s)) (let ((binary-filename (compile-temp-file temp-file-name filename buffer position))) (delete-file binary-filename))) (delete-file temp-file-name))))) (defvar *temp-file-map* (make-hash-table :test #'equal) "A mapping from tempfile names to Emacs buffer names.") (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) (compile-file temp-file-name :load t :compile-file-original-truename (or buffer-file-name (progn (setf (gethash temp-file-name *temp-file-map*) buffer-name) temp-file-name)) :compile-file-original-buffer-offset (1- offset) :external-format :utf-8)) (defimplementation save-image (filename &optional restart-function) (ccl:save-application filename :toplevel-function restart-function)) ;;; Cross-referencing (defun xref-locations (relation name &optional inverse) (delete-duplicates (mapcan #'find-definitions (if inverse (ccl::get-relation relation name :wild :exhaustive t) (ccl::get-relation relation :wild name :exhaustive t))) :test 'equal)) (defimplementation who-binds (name) (xref-locations :binds name)) (defimplementation who-macroexpands (name) (xref-locations :macro-calls name t)) (defimplementation who-references (name) (remove-duplicates (append (xref-locations :references name) (xref-locations :sets name) (xref-locations :binds name)) :test 'equal)) (defimplementation who-sets (name) (xref-locations :sets name)) (defimplementation who-calls (name) (remove-duplicates (append (xref-locations :direct-calls name) (xref-locations :indirect-calls name) (xref-locations :macro-calls name t)) :test 'equal)) (defimplementation who-specializes (class) (when (symbolp class) (setq class (find-class class nil))) (when class (delete-duplicates (mapcar (lambda (m) (car (find-definitions m))) (ccl:specializer-direct-methods class)) :test 'equal))) (defimplementation list-callees (name) (remove-duplicates (append (xref-locations :direct-calls name t) (xref-locations :macro-calls name nil)) :test 'equal)) (defimplementation list-callers (symbol) (delete-duplicates (mapcan #'find-definitions (ccl:caller-functions symbol)) :test #'equal)) ;;; Profiling (alanr: lifted from swank-clisp) (defimplementation profile (fname) (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro (defimplementation profiled-functions () swank-monitor:*monitored-functions*) (defimplementation unprofile (fname) (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro (defimplementation unprofile-all () (swank-monitor:unmonitor)) (defimplementation profile-report () (swank-monitor:report-monitoring)) (defimplementation profile-reset () (swank-monitor:reset-all-monitoring)) (defimplementation profile-package (package callers-p methods) (declare (ignore callers-p methods)) (swank-monitor:monitor-all package)) ;;; Debugging (defimplementation call-with-debugging-environment (debugger-loop-fn) (let* (;;(*debugger-hook* nil) ;; don't let error while printing error take us down (ccl:*signal-printing-errors* nil)) (funcall debugger-loop-fn))) ;; This is called for an async interrupt and is running in a random ;; thread not selected by the user, so don't use thread-local vars ;; such as *emacs-connection*. (defun find-repl-thread () (let* ((*break-on-signals* nil) (conn (swank::default-connection))) (and (swank::multithreaded-connection-p conn) (swank::mconn.repl-thread conn)))) (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook) (ccl:*break-hook* hook) (ccl:*select-interactive-process-hook* 'find-repl-thread)) (funcall fun))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) (setq ccl:*break-hook* function) (setq ccl:*select-interactive-process-hook* 'find-repl-thread) ) (defun map-backtrace (function &optional (start-frame-number 0) end-frame-number) "Call FUNCTION passing information about each stack frame from frames START-FRAME-NUMBER to END-FRAME-NUMBER." (let ((end-frame-number (or end-frame-number most-positive-fixnum))) (ccl:map-call-frames function :origin ccl:*top-error-frame* :start-frame-number start-frame-number :count (- end-frame-number start-frame-number)))) (defimplementation compute-backtrace (start-frame-number end-frame-number) (let (result) (map-backtrace (lambda (p context) (push (list :frame p context) result)) start-frame-number end-frame-number) (nreverse result))) (defimplementation print-frame (frame stream) (assert (eq (first frame) :frame)) (destructuring-bind (p context) (rest frame) (let ((lfun (ccl:frame-function p context))) (format stream "(~S" (or (ccl:function-name lfun) lfun)) (let* ((unavailable (cons nil nil)) (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable))) (declare (dynamic-extent unavailable)) (if (eq args unavailable) (format stream " #") (dolist (arg args) (if (eq arg unavailable) (format stream " #") (format stream " ~s" arg))))) (format stream ")")))) (defmacro with-frame ((p context) frame-number &body body) `(call/frame ,frame-number (lambda (,p ,context) . ,body))) (defun call/frame (frame-number if-found) (map-backtrace (lambda (p context) (return-from call/frame (funcall if-found p context))) frame-number)) (defimplementation frame-call (frame-number) (with-frame (p context) frame-number (with-output-to-string (stream) (print-frame (list :frame p context) stream)))) (defimplementation frame-var-value (frame var) (with-frame (p context) frame (cdr (nth var (ccl:frame-named-variables p context))))) (defimplementation frame-locals (index) (with-frame (p context) index (loop for (name . value) in (ccl:frame-named-variables p context) collect (list :name name :value value :id 0)))) (defimplementation frame-source-location (index) (with-frame (p context) index (multiple-value-bind (lfun pc) (ccl:frame-function p context) (if pc (pc-source-location lfun pc) (function-source-location lfun))))) (defun function-name-package (name) (etypecase name (null nil) (symbol (symbol-package name)) ((cons (eql ccl::traced)) (function-name-package (second name))) ((cons (eql setf)) (symbol-package (second name))) ((cons (eql :internal)) (function-name-package (car (last name)))) ((cons (and symbol (not keyword)) (cons list null)) (symbol-package (car name))) (standard-method (function-name-package (ccl:method-name name))))) (defimplementation frame-package (frame-number) (with-frame (p context) frame-number (let* ((lfun (ccl:frame-function p context)) (name (ccl:function-name lfun))) (function-name-package name)))) (defimplementation eval-in-frame (form index) (with-frame (p context) index (let ((vars (ccl:frame-named-variables p context))) (eval `(let ,(loop for (var . val) in vars collect `(,var ',val)) (declare (ignorable ,@(mapcar #'car vars))) ,form))))) (defimplementation return-from-frame (index form) (let ((values (multiple-value-list (eval-in-frame form index)))) (with-frame (p context) index (declare (ignore context)) (ccl:apply-in-frame p #'values values)))) (defimplementation restart-frame (index) (with-frame (p context) index (ccl:apply-in-frame p (ccl:frame-function p context) (ccl:frame-supplied-arguments p context)))) (defimplementation disassemble-frame (the-frame-number) (with-frame (p context) the-frame-number (multiple-value-bind (lfun pc) (ccl:frame-function p context) (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) (disassemble lfun)))) ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) ;; contains some interesting details: ;; ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end ;; positions are file positions (not character positions). The text will ;; be NIL unless text recording was on at read-time. If the original ;; file is still available, you can force missing source text to be read ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. ;; ;; Source-note's are associated with definitions (via record-source-file) ;; and also stored in function objects (including anonymous and nested ;; functions). The former can be retrieved via ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. ;; ;; The recording behavior is controlled by the new variable ;; CCL:*SAVE-SOURCE-LOCATIONS*: ;; ;; If NIL, don't store source-notes in function objects, and store only ;; the filename for definitions (the latter only if ;; *record-source-file* is true). ;; ;; If T, store source-notes, including a copy of the original source ;; text, for function objects and definitions (the latter only if ;; *record-source-file* is true). ;; ;; If :NO-TEXT, store source-notes, but without saved text, for ;; function objects and defintions (the latter only if ;; *record-source-file* is true). This is the default. ;; ;; PC to source mapping is controlled by the new variable ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a ;; compressed table mapping pc offsets to corresponding source locations. ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) ;; which returns a source-note for the source at offset pc in the ;; function. (defun function-source-location (function) (source-note-to-source-location (or (ccl:function-source-note function) (function-name-source-note function)) (lambda () (format nil "Function has no source note: ~A" function)) (ccl:function-name function))) (defun pc-source-location (function pc) (source-note-to-source-location (or (ccl:find-source-note-at-pc function pc) (ccl:function-source-note function) (function-name-source-note function)) (lambda () (format nil "No source note at PC: ~a[~d]" function pc)) (ccl:function-name function))) (defun function-name-source-note (fun) (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function))) (and defs (destructuring-bind ((type . name) srcloc . srclocs) (car defs) (declare (ignore type name srclocs)) srcloc)))) (defun source-note-to-source-location (source if-nil-thunk &optional name) (labels ((filename-to-buffer (filename) (cond ((gethash filename *temp-file-map*) (list :buffer (gethash filename *temp-file-map*))) ((probe-file filename) (list :file (ccl:native-translated-namestring (truename filename)))) (t (error "File ~s doesn't exist" filename))))) (handler-case (cond ((ccl:source-note-p source) (let* ((full-text (ccl:source-note-text source)) (file-name (ccl:source-note-filename source)) (start-pos (ccl:source-note-start-pos source))) (make-location (when file-name (filename-to-buffer (pathname file-name))) (when start-pos (list :position (1+ start-pos))) (when full-text (list :snippet (subseq full-text 0 (min 40 (length full-text)))))))) ((and source name) ;; This branch is probably never used (make-location (filename-to-buffer source) (list :function-name (princ-to-string (if (functionp name) (ccl:function-name name) name))))) (t `(:error ,(funcall if-nil-thunk)))) (error (c) `(:error ,(princ-to-string c)))))) (defun alphatizer-definitions (name) (let ((alpha (gethash name ccl::*nx1-alphatizers*))) (and alpha (ccl:find-definition-sources alpha)))) (defun p2-definitions (name) (let ((nx1-op (gethash name ccl::*nx1-operators*))) (and nx1-op (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) (and (array-in-bounds-p dispatch nx1-op) (let ((p2 (aref dispatch nx1-op))) (and p2 (ccl:find-definition-sources p2)))))))) (defimplementation find-definitions (name) (let ((defs (append (or (ccl:find-definition-sources name) (and (symbolp name) (fboundp name) (ccl:find-definition-sources (symbol-function name)))) (alphatizer-definitions name) (p2-definitions name)))) (loop for ((type . name) . sources) in defs collect (list (definition-name type name) (source-note-to-source-location (find-if-not #'null sources) (lambda () "No source-note available") name))))) (defimplementation find-source-location (obj) (let* ((defs (ccl:find-definition-sources obj)) (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal) (car defs))) (note (find-if-not #'null (cdr best-def)))) (when note (source-note-to-source-location note (lambda () "No source note available"))))) (defun definition-name (type object) (case (ccl:definition-type-name type) (method (ccl:name-of object)) (t (list (ccl:definition-type-name type) (ccl:name-of object))))) ;;; Utilities (defimplementation describe-symbol-for-emacs (symbol) (let ((result '())) (flet ((doc (kind &optional (sym symbol)) (or (documentation sym kind) :not-documented)) (maybe-push (property value) (when value (setf result (list* property value result))))) (maybe-push :variable (when (boundp symbol) (doc 'variable))) (maybe-push :function (if (fboundp symbol) (doc 'function))) (maybe-push :setf (let ((setf-function-name (ccl:setf-function-spec-name `(setf ,symbol)))) (when (fboundp setf-function-name) (doc 'function setf-function-name)))) (maybe-push :type (when (ccl:type-specifier-p symbol) (doc 'type))) result))) (defimplementation describe-definition (symbol namespace) (ecase namespace (:variable (describe symbol)) ((:function :generic-function) (describe (symbol-function symbol))) (:setf (describe (ccl:setf-function-spec-name `(setf ,symbol)))) (:class (describe (find-class symbol))) (:type (describe (or (find-class symbol nil) symbol))))) ;; spec ::= (:defmethod {}* ({}*)) (defun parse-defmethod-spec (spec) (values (second spec) (subseq spec 2 (position-if #'consp spec)) (find-if #'consp (cddr spec)))) (defimplementation toggle-trace (spec) "We currently ignore just about everything." (let ((what (ecase (first spec) ((setf) spec) ((:defgeneric) (second spec)) ((:defmethod) (multiple-value-bind (name qualifiers specializers) (parse-defmethod-spec spec) (find-method (fdefinition name) qualifiers specializers)))))) (cond ((member what (trace) :test #'equal) (ccl::%untrace what) (format nil "~S is now untraced." what)) (t (ccl:trace-function what) (format nil "~S is now traced." what))))) ;;; Macroexpansion (defimplementation macroexpand-all (form &optional env) (ccl:macroexpand-all form env)) ;;;; Inspection (defun comment-type-p (type) (or (eq type :comment) (and (consp type) (eq (car type) :comment)))) (defmethod emacs-inspect ((o t)) (let* ((inspector:*inspector-disassembly* t) (i (inspector:make-inspector o)) (count (inspector:compute-line-count i))) (loop for l from 0 below count append (multiple-value-bind (value label type) (inspector:line-n i l) (etypecase type ((member nil :normal) `(,(or label "") (:value ,value) (:newline))) ((member :colon) (label-value-line label value)) ((member :static) (list (princ-to-string label) " " `(:value ,value) '(:newline))) ((satisfies comment-type-p) (list (princ-to-string label) '(:newline)))))))) (defmethod emacs-inspect :around ((o t)) (if (or (uvector-inspector-p o) (not (ccl:uvectorp o))) (call-next-method) (let ((value (call-next-method))) (cond ((listp value) (append value `((:newline) (:value ,(make-instance 'uvector-inspector :object o) "Underlying UVECTOR")))) (t value))))) (defmethod emacs-inspect ((f function)) (append (label-value-line "Name" (function-name f)) `("Its argument list is: " ,(princ-to-string (arglist f)) (:newline)) (label-value-line "Documentation" (documentation f t)) (when (function-lambda-expression f) (label-value-line "Lambda Expression" (function-lambda-expression f))) (when (ccl:function-source-note f) (label-value-line "Source note" (ccl:function-source-note f))) (when (typep f 'ccl:compiled-lexical-closure) (append (label-value-line "Inner function" (ccl::closure-function f)) '("Closed over values:" (:newline)) (loop for (name value) in (ccl::closure-closed-over-values f) append (label-value-line (format nil " ~a" name) value)))))) (defclass uvector-inspector () ((object :initarg :object))) (defgeneric uvector-inspector-p (object) (:method ((object t)) nil) (:method ((object uvector-inspector)) t)) (defmethod emacs-inspect ((uv uvector-inspector)) (with-slots (object) uv (loop for i below (ccl:uvsize object) append (label-value-line (princ-to-string i) (ccl:uvref object i))))) (defimplementation type-specifier-p (symbol) (or (ccl:type-specifier-p symbol) (not (eq (type-specifier-arglist symbol) :not-available)))) ;;; Multiprocessing (defvar *known-processes* (make-hash-table :size 20 :weak :key :test #'eq) "A map from threads to mailboxes.") (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) (defstruct (mailbox (:conc-name mailbox.)) (mutex (ccl:make-lock "thread mailbox")) (semaphore (ccl:make-semaphore)) (queue '() :type list)) (defimplementation spawn (fun &key name) (ccl:process-run-function (or name "Anonymous (Swank)") fun)) (defimplementation thread-id (thread) (ccl:process-serial-number thread)) (defimplementation find-thread (id) (find id (ccl:all-processes) :key #'ccl:process-serial-number)) (defimplementation thread-name (thread) (ccl:process-name thread)) (defimplementation thread-status (thread) (format nil "~A" (ccl:process-whostate thread))) (defimplementation thread-attributes (thread) (list :priority (ccl:process-priority thread))) (defimplementation make-lock (&key name) (ccl:make-lock name)) (defimplementation call-with-lock-held (lock function) (ccl:with-lock-grabbed (lock) (funcall function))) (defimplementation current-thread () ccl:*current-process*) (defimplementation all-threads () (ccl:all-processes)) (defimplementation kill-thread (thread) ;;(ccl:process-kill thread) ; doesn't cut it (ccl::process-initial-form-exited thread :kill)) (defimplementation thread-alive-p (thread) (not (ccl:process-exhausted-p thread))) (defimplementation interrupt-thread (thread function) (ccl:process-interrupt thread (lambda () (let ((ccl:*top-error-frame* (ccl::%current-exception-frame))) (funcall function))))) (defun mailbox (thread) (ccl:with-lock-grabbed (*known-processes-lock*) (or (gethash thread *known-processes*) (setf (gethash thread *known-processes*) (make-mailbox))))) (defimplementation send (thread message) (assert message) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) (ccl:with-lock-grabbed (mutex) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) (ccl:signal-semaphore (mailbox.semaphore mbox))))) (defimplementation wake-thread (thread) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) (ccl:with-lock-grabbed (mutex) (ccl:signal-semaphore (mailbox.semaphore mbox))))) (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox ccl:*current-process*)) (mutex (mailbox.mutex mbox))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (ccl:with-lock-grabbed (mutex) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))))) (when (eq timeout t) (return (values nil t))) (ccl:wait-on-semaphore (mailbox.semaphore mbox))))) (let ((alist '()) (lock (ccl:make-lock "register-thread"))) (defimplementation register-thread (name thread) (declare (type symbol name)) (ccl:with-lock-grabbed (lock) (etypecase thread (null (setf alist (delete name alist :key #'car))) (ccl:process (let ((probe (assoc name alist))) (cond (probe (setf (cdr probe) thread)) (t (setf alist (acons name thread alist)))))))) nil) (defimplementation find-registered (name) (ccl:with-lock-grabbed (lock) (cdr (assoc name alist))))) (defimplementation set-default-initial-binding (var form) (eval `(ccl::def-standard-initial-binding ,var ,form))) (defimplementation quit-lisp () (ccl:quit)) (defimplementation set-default-directory (directory) (let ((dir (truename (merge-pathnames directory)))) (setf *default-pathname-defaults* (truename (merge-pathnames directory))) (ccl:cwd dir) (default-directory))) ;;; Weak datastructures (defimplementation make-weak-key-hash-table (&rest args) (apply #'make-hash-table :weak :key args)) (defimplementation make-weak-value-hash-table (&rest args) (apply #'make-hash-table :weak :value args)) (defimplementation hash-table-weakness (hashtable) (ccl:hash-table-weak-p hashtable)) (pushnew 'deinit-log-output ccl:*save-exit-functions*) slime-2.20/swank/clasp.lisp000066400000000000000000000652671315100173500157000ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- ;;; ;;; swank-clasp.lisp --- SLIME backend for CLASP. ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; ;;; Administrivia (defpackage swank/clasp (:use cl swank/backend)) (in-package swank/clasp) (eval-when (:compile-toplevel :load-toplevel :execute) (setq swank::*log-output* (open "/tmp/slime.log" :direction :output)) (setq swank:*log-events* t)) (defmacro slime-dbg (fmt &rest args) `(swank::log-event "slime-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args))) ;; Hard dependencies. (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sockets)) ;; Soft dependencies. (eval-when (:compile-toplevel :load-toplevel :execute) (when (probe-file "sys:profile.fas") (require :profile) (pushnew :profile *features*)) (when (probe-file "sys:serve-event") (require :serve-event) (pushnew :serve-event *features*))) (declaim (optimize (debug 3))) ;;; Swank-mop (eval-when (:compile-toplevel :load-toplevel :execute) (import-swank-mop-symbols :clos `(:eql-specializer :eql-specializer-object :generic-function-declarations :specializer-direct-methods ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) '(:compute-applicable-methods-using-classes))))) (defimplementation gray-package-name () "GRAY") ;;;; TCP Server (defimplementation preferred-communication-style () ;; As of March 2017 CLASP provides threads. ;; But it's experimental. ;; ECLs swank implementation says that CLOS is not thread safe and ;; I use ECLs CLOS implementation - this is a worry for the future. ;; nil or :spawn :spawn #| #+threads :spawn #-threads nil |# ) (defun resolve-hostname (name) (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name name)))) (defimplementation create-socket (host port &key backlog) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) (defimplementation close-socket (socket) (sb-bsd-sockets:socket-close socket)) (defimplementation accept-connection (socket &key external-format buffering timeout) (declare (ignore timeout)) (sb-bsd-sockets:socket-make-stream (accept socket) :output t :input t :buffering (ecase buffering ((t) :full) ((nil) :none) (:line :line)) :element-type (if external-format 'character '(unsigned-byte 8)) :external-format external-format)) (defun accept (socket) "Like socket-accept, but retry on EAGAIN." (loop (handler-case (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) (defimplementation socket-fd (socket) (etypecase socket (fixnum socket) (two-way-stream (socket-fd (two-way-stream-input-stream socket))) (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) (file-stream (si:file-stream-fd socket)))) (defvar *external-format-to-coding-system* '((:latin-1 "latin-1" "latin-1-unix" "iso-latin-1-unix" "iso-8859-1" "iso-8859-1-unix") (:utf-8 "utf-8" "utf-8-unix"))) (defun external-format (coding-system) (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*)) (find coding-system (ext:all-encodings) :test #'string-equal))) (defimplementation find-external-format (coding-system) #+unicode (external-format coding-system) ;; Without unicode support, CLASP uses the one-byte encoding of the ;; underlying OS, and will barf on anything except :DEFAULT. We ;; return NIL here for known multibyte encodings, so ;; SWANK:CREATE-SERVER will barf. #-unicode (let ((xf (external-format coding-system))) (if (member xf '(:utf-8)) nil :default))) ;;;; Unix Integration ;;; If CLASP is built with thread support, it'll spawn a helper thread ;;; executing the SIGINT handler. We do not want to BREAK into that ;;; helper but into the main thread, though. This is coupled with the ;;; current choice of NIL as communication-style in so far as CLASP's ;;; main-thread is also the Slime's REPL thread. #+clasp-working (defimplementation call-with-user-break-handler (real-handler function) (let ((old-handler #'si:terminal-interrupt)) (setf (symbol-function 'si:terminal-interrupt) (make-interrupt-handler real-handler)) (unwind-protect (funcall function) (setf (symbol-function 'si:terminal-interrupt) old-handler)))) #+threads (defun make-interrupt-handler (real-handler) (let ((main-thread (find 'si:top-level (mp:all-processes) :key #'mp:process-name))) #'(lambda (&rest args) (declare (ignore args)) (mp:interrupt-process main-thread real-handler)))) #-threads (defun make-interrupt-handler (real-handler) #'(lambda (&rest args) (declare (ignore args)) (funcall real-handler))) (defimplementation getpid () (si:getpid)) (defimplementation set-default-directory (directory) (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. (default-directory)) (defimplementation default-directory () (namestring (ext:getcwd))) (defimplementation quit-lisp () (core:quit)) ;;; Instead of busy waiting with communication-style NIL, use select() ;;; on the sockets' streams. #+serve-event (progn (defun poll-streams (streams timeout) (let* ((serve-event::*descriptor-handlers* (copy-list serve-event::*descriptor-handlers*)) (active-fds '()) (fd-stream-alist (loop for s in streams for fd = (socket-fd s) collect (cons fd s) do (serve-event:add-fd-handler fd :input #'(lambda (fd) (push fd active-fds)))))) (serve-event:serve-event timeout) (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (loop (cond ((check-slime-interrupts) (return :interrupt)) (timeout (return (poll-streams streams 0))) (t (when-let (ready (poll-streams streams 0.2)) (return ready)))))) ) ; #+serve-event (progn ... #-serve-event (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (loop (cond ((check-slime-interrupts) (return :interrupt)) (timeout (return (remove-if-not #'listen streams))) (t (let ((ready (remove-if-not #'listen streams))) (if ready (return ready)) (sleep 0.1)))))) ;;;; Compilation (defvar *buffer-name* nil) (defvar *buffer-start-position*) (defun signal-compiler-condition (&rest args) (apply #'signal 'compiler-condition args)) #-clasp-bytecmp (defun handle-compiler-message (condition) ;; CLASP emits lots of noise in compiler-notes, like "Invoking ;; external command". (unless (typep condition 'c::compiler-note) (signal-compiler-condition :original-condition condition :message (princ-to-string condition) :severity (etypecase condition (cmp:compiler-fatal-error :error) (cmp:compiler-error :error) (error :error) (style-warning :style-warning) (warning :warning)) :location (condition-location condition)))) #-clasp-bytecmp (defun condition-location (condition) (let ((file (cmp:compiler-message-file condition)) (position (cmp:compiler-message-file-position condition))) (if (and position (not (minusp position))) (if *buffer-name* (make-buffer-location *buffer-name* *buffer-start-position* position) (make-file-location file position)) (make-error-location "No location found.")))) (defimplementation call-with-compilation-hooks (function) (funcall function)) #|| #-clasp-bytecmp (handler-bind ((c:compiler-message #'handle-compiler-message)) (funcall function))) ||# (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) ;; Ignore the output-file and generate our own (let ((tmp-output-file (compile-file-pathname (si:mkstemp "TMP:clasp-swank-compile-file-")))) (format t "Using tmp-output-file: ~a~%" tmp-output-file) (multiple-value-bind (fasl warnings-p failure-p) (with-compilation-hooks () (compile-file input-file :output-file tmp-output-file :external-format external-format)) (values fasl warnings-p (or failure-p (when load-p (not (load fasl)))))))) (defvar *tmpfile-map* (make-hash-table :test #'equal)) (defun note-buffer-tmpfile (tmp-file buffer-name) ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. (let ((tmp-namestring (namestring (truename tmp-file)))) (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) tmp-namestring)) (defun tmpfile-to-buffer (tmp-file) (gethash tmp-file *tmpfile-map*)) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore policy)) (with-compilation-hooks () (let ((*buffer-name* buffer) ; for compilation hooks (*buffer-start-position* position)) (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-")) (fasl-file) (warnings-p) (failure-p)) (unwind-protect (with-open-file (tmp-stream tmp-file :direction :output :if-exists :supersede) (write-string string tmp-stream) (finish-output tmp-stream) (multiple-value-setq (fasl-file warnings-p failure-p) (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) (compile-file tmp-file :source-debug-namestring truename :source-debug-offset (1- position))))) (when fasl-file (load fasl-file)) (when (probe-file tmp-file) (delete-file tmp-file)) (when fasl-file (delete-file fasl-file))) (not failure-p))))) ;;;; Documentation (defimplementation arglist (name) (multiple-value-bind (arglist foundp) (core:function-lambda-list name) ;; Uses bc-split (if foundp arglist :not-available))) (defimplementation function-name (f) (typecase f (generic-function (clos::generic-function-name f)) (function (ext:compiled-function-name f)))) ;; FIXME (defimplementation macroexpand-all (form &optional env) (declare (ignore env)) (macroexpand form)) ;;; modified from sbcl.lisp (defimplementation collect-macro-forms (form &optional environment) (let ((macro-forms '()) (compiler-macro-forms '()) (function-quoted-forms '())) (format t "In collect-macro-forms~%") (cmp:code-walk form environment :code-walker-function (lambda (form environment) (when (and (consp form) (symbolp (car form))) (cond ((eq (car form) 'function) (push (cadr form) function-quoted-forms)) ((member form function-quoted-forms) nil) ((macro-function (car form) environment) (push form macro-forms)) ((not (eq form (core:compiler-macroexpand-1 form environment))) (push form compiler-macro-forms)))) form)) (values macro-forms compiler-macro-forms))) (defimplementation describe-symbol-for-emacs (symbol) (let ((result '())) (flet ((frob (type boundp) (when (funcall boundp symbol) (let ((doc (describe-definition symbol type))) (setf result (list* type doc result)))))) (frob :VARIABLE #'boundp) (frob :FUNCTION #'fboundp) (frob :CLASS (lambda (x) (find-class x nil)))) result)) (defimplementation describe-definition (name type) (case type (:variable (documentation name 'variable)) (:function (documentation name 'function)) (:class (documentation name 'class)) (t nil))) (defimplementation type-specifier-p (symbol) (or (subtypep nil symbol) (not (eq (type-specifier-arglist symbol) :not-available)))) ;;; Debugging (eval-when (:compile-toplevel :load-toplevel :execute) (import '(si::*break-env* si::*ihs-top* si::*ihs-current* si::*ihs-base* #+frs si::*frs-base* #+frs si::*frs-top* si::*tpl-commands* si::*tpl-level* #+frs si::frs-top si::ihs-top si::ihs-fun si::ihs-env #+frs si::sch-frs-base si::set-break-env si::set-current-ihs si::tpl-commands))) (defun make-invoke-debugger-hook (hook) (when hook #'(lambda (condition old-hook) ;; Regard *debugger-hook* if set by user. (if *debugger-hook* nil ; decline, *DEBUGGER-HOOK* will be tried next. (funcall hook condition old-hook))))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)) ) (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook) (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) (funcall fun)) ) (defvar *backtrace* '()) ;;; Commented out; it's not clear this is a good way of doing it. In ;;; particular because it makes errors stemming from this file harder ;;; to debug, and given the "young" age of CLASP's swank backend, that's ;;; a bad idea. ;; (defun in-swank-package-p (x) ;; (and ;; (symbolp x) ;; (member (symbol-package x) ;; (list #.(find-package :swank) ;; #.(find-package :swank/backend) ;; #.(ignore-errors (find-package :swank-mop)) ;; #.(ignore-errors (find-package :swank-loader)))) ;; t)) ;; (defun is-swank-source-p (name) ;; (setf name (pathname name)) ;; (pathname-match-p ;; name ;; (make-pathname :defaults swank-loader::*source-directory* ;; :name (pathname-name name) ;; :type (pathname-type name) ;; :version (pathname-version name)))) ;; (defun is-ignorable-fun-p (x) ;; (or ;; (in-swank-package-p (frame-name x)) ;; (multiple-value-bind (file position) ;; (ignore-errors (si::bc-file (car x))) ;; (declare (ignore position)) ;; (if file (is-swank-source-p file))))) (defimplementation call-with-debugging-environment (debugger-loop-fn) (declare (type function debugger-loop-fn)) (let* ((*ihs-top* (or #+#.(swank/backend:with-symbol '*stack-top-hint* 'core) core:*stack-top-hint* (ihs-top))) (*ihs-current* *ihs-top*) #+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) #+frs (*frs-top* (frs-top)) (*tpl-level* (1+ *tpl-level*)) (*backtrace* (loop for ihs from 0 below *ihs-top* collect (list (si::ihs-fun ihs) (si::ihs-env ihs) ihs)))) (declare (special *ihs-current*)) #+frs (loop for f from *frs-base* until *frs-top* do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) (when (plusp i) (let* ((x (elt *backtrace* i)) (name (si::frs-tag f))) (unless (si::fixnump name) (push name (third x))))))) (setf *backtrace* (nreverse *backtrace*)) (set-break-env) (set-current-ihs) (let ((*ihs-base* *ihs-top*)) (funcall debugger-loop-fn)))) (defimplementation compute-backtrace (start end) (subseq *backtrace* start (and (numberp end) (min end (length *backtrace*))))) (defun frame-name (frame) (let ((x (first frame))) (if (symbolp x) x (function-name x)))) (defun frame-function (frame-number) (let ((x (first (elt *backtrace* frame-number)))) (etypecase x (symbol (and (fboundp x) (fdefinition x))) (function x)))) (defimplementation print-frame (frame stream) (format stream "(~s~{ ~s~})" (function-name (first frame)) #+#.(swank/backend:with-symbol 'ihs-arguments 'core) (coerce (core:ihs-arguments (third frame)) 'list) #-#.(swank/backend:with-symbol 'ihs-arguments 'core) nil)) (defimplementation frame-source-location (frame-number) (source-location (frame-function frame-number))) #+clasp-working (defimplementation frame-catch-tags (frame-number) (third (elt *backtrace* frame-number))) (defun ihs-frame-id (frame-number) (- (core:ihs-top) frame-number)) (defimplementation frame-locals (frame-number) (let* ((frame (elt *backtrace* frame-number)) (env (second frame)) (locals (loop for x = env then (core:get-parent-environment x) while x nconc (loop for name across (core:environment-debug-names x) for value across (core:environment-debug-values x) collect (list :name name :id 0 :value value))))) (nconc (loop for arg across (core:ihs-arguments (third frame)) for i from 0 collect (list :name (intern (format nil "ARG~d" i) #.*package*) :id 0 :value arg)) locals))) (defimplementation frame-var-value (frame-number var-number) (let* ((frame (elt *backtrace* frame-number)) (env (second frame)) (args (core:ihs-arguments (third frame)))) (if (< var-number (length args)) (svref args var-number) (elt (frame-locals frame-number) var-number)))) #+clasp-working (defimplementation disassemble-frame (frame-number) (let ((fun (frame-function frame-number))) (disassemble fun))) (defimplementation eval-in-frame (form frame-number) (let ((env (second (elt *backtrace* frame-number)))) (core:compile-form-and-eval-with-env form env))) #+clasp-working (defimplementation gdb-initial-commands () ;; These signals are used by the GC. #+linux '("handle SIGPWR noprint nostop" "handle SIGXCPU noprint nostop")) #+clasp-working (defimplementation command-line-args () (loop for n from 0 below (si:argc) collect (si:argv n))) ;;;; Inspector ;;; FIXME: Would be nice if it was possible to inspect objects ;;; implemented in C. ;;;; Definitions (defun make-file-location (file file-position) ;; File positions in CL start at 0, but Emacs' buffer positions ;; start at 1. We specify (:ALIGN T) because the positions comming ;; from CLASP point at right after the toplevel form appearing before ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. (make-location `(:file ,(namestring (translate-logical-pathname file))) `(:position ,(1+ file-position)) `(:align t))) (defun make-buffer-location (buffer-name start-position &optional (offset 0)) (make-location `(:buffer ,buffer-name) `(:offset ,start-position ,offset) `(:align t))) (defun translate-location (location) (make-location (list :file (namestring (ext:source-location-pathname location))) (list :position (ext:source-location-offset location)) '(:align t))) (defimplementation find-definitions (name) (loop for kind in ext:*source-location-kinds* for locations = (ext:source-location name kind) when locations nconc (loop for location in locations collect (list kind (translate-location location))))) (defun source-location (object) (let ((location (ext:source-location object t))) (when location (translate-location (car location))))) (defimplementation find-source-location (object) (or (source-location object) (make-error-location "Source definition of ~S not found." object))) ;;;; Profiling #+profile (progn (defimplementation profile (fname) (when fname (eval `(profile:profile ,fname)))) (defimplementation unprofile (fname) (when fname (eval `(profile:unprofile ,fname)))) (defimplementation unprofile-all () (profile:unprofile-all) "All functions unprofiled.") (defimplementation profile-report () (profile:report)) (defimplementation profile-reset () (profile:reset) "Reset profiling counters.") (defimplementation profiled-functions () (profile:profile)) (defimplementation profile-package (package callers methods) (declare (ignore callers methods)) (eval `(profile:profile ,(package-name (find-package package))))) ) ; #+profile (progn ... ;;;; Threads #+threads (progn (defvar *thread-id-counter* 0) (defparameter *thread-id-map* (make-hash-table)) (defvar *thread-id-map-lock* (mp:make-lock :name "thread id map lock")) (defimplementation spawn (fn &key name) (mp:process-run-function name fn)) (defimplementation thread-id (target-thread) (block thread-id (mp:with-lock (*thread-id-map-lock*) ;; Does TARGET-THREAD have an id already? (maphash (lambda (id thread-pointer) (let ((thread (si:weak-pointer-value thread-pointer))) (cond ((not thread) (remhash id *thread-id-map*)) ((eq thread target-thread) (return-from thread-id id))))) *thread-id-map*) ;; TARGET-THREAD not found in *THREAD-ID-MAP* (let ((id (incf *thread-id-counter*)) (thread-pointer (si:make-weak-pointer target-thread))) (setf (gethash id *thread-id-map*) thread-pointer) id)))) (defimplementation find-thread (id) (mp:with-lock (*thread-id-map-lock*) (let* ((thread-ptr (gethash id *thread-id-map*)) (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) (unless thread (remhash id *thread-id-map*)) thread))) (defimplementation thread-name (thread) (mp:process-name thread)) (defimplementation thread-status (thread) (if (mp:process-active-p thread) "RUNNING" "STOPPED")) (defimplementation make-lock (&key name) (mp:make-lock :name name :recursive t)) (defimplementation call-with-lock-held (lock function) (declare (type function function)) (mp:with-lock (lock) (funcall function))) (defimplementation current-thread () mp:*current-process*) (defimplementation all-threads () (mp:all-processes)) (defimplementation interrupt-thread (thread fn) (mp:interrupt-process thread fn)) (defimplementation kill-thread (thread) (mp:process-kill thread)) (defimplementation thread-alive-p (thread) (mp:process-active-p thread)) (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) (defvar *mailboxes* (list)) (declaim (type list *mailboxes*)) (defstruct (mailbox (:conc-name mailbox.)) thread (mutex (mp:make-lock)) (cvar (mp:make-condition-variable)) (queue '() :type list)) (defun mailbox (thread) "Return THREAD's mailbox." (mp:with-lock (*mailbox-lock*) (or (find thread *mailboxes* :key #'mailbox.thread) (let ((mb (make-mailbox :thread thread))) (push mb *mailboxes*) mb)))) (defimplementation wake-thread (thread) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) (format t "About to with-lock in wake-thread~%") (mp:with-lock (mutex) (format t "In wake-thread~%") (mp:condition-variable-broadcast (mailbox.cvar mbox))))) (defimplementation send (thread message) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) (swank::log-event "clasp.lisp: send message ~a mutex: ~a~%" message mutex) (swank::log-event "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) (swank::log-event "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) (mp:with-lock (mutex) (swank::log-event "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) (swank::log-event "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) (swank::log-event "clasp.lisp: send about to broadcast~%") (mp:condition-variable-broadcast (mailbox.cvar mbox))))) (defimplementation receive-if (test &optional timeout) (slime-dbg "Entered receive-if") (let* ((mbox (mailbox (current-thread))) (mutex (mailbox.mutex mbox))) (slime-dbg "receive-if assert") (assert (or (not timeout) (eq timeout t))) (loop (slime-dbg "receive-if check-slime-interrupts") (check-slime-interrupts) (slime-dbg "receive-if with-lock") (mp:with-lock (mutex) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail)))) (slime-dbg "receive-if when (eq") (when (eq timeout t) (return (values nil t))) (slime-dbg "receive-if condition-variable-timedwait") (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2 (slime-dbg "came out of condition-variable-timedwait") (core:check-pending-interrupts))))) ) ; #+threads (progn ... (defmethod emacs-inspect ((object core:cxx-object)) (let ((encoded (core:encode object))) (loop for (key . value) in encoded append (list (string key) ": " (list :value value) (list :newline))))) slime-2.20/swank/clisp.lisp000066400000000000000000001035721315100173500157000ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- ;;;; SWANK support for CLISP. ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License as ;;;; published by the Free Software Foundation; either version 2 of ;;;; the License, or (at your option) any later version. ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. ;;;; You should have received a copy of the GNU General Public ;;;; License along with this program; if not, write to the Free ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ;;;; MA 02111-1307, USA. ;;; This is work in progress, but it's already usable. Many things ;;; are adapted from other swank-*.lisp, in particular from ;;; swank-allegro (I don't use allegro at all, but it's the shortest ;;; one and I found Helmut Eller's code there enlightening). ;;; This code will work better with recent versions of CLISP (say, the ;;; last release or CVS HEAD) while it may not work at all with older ;;; versions. It is reasonable to expect it to work on platforms with ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like ;;; systems, but also on Win32. This backend uses the portable xref ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which ;;; are conveniently included in SLIME. ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ (defpackage swank/clisp (:use cl swank/backend)) (in-package swank/clisp) (eval-when (:compile-toplevel) (unless (string< "2.44" (lisp-implementation-version)) (error "Need at least CLISP version 2.44"))) (defimplementation gray-package-name () "GRAY") ;;;; if this lisp has the complete CLOS then we use it, otherwise we ;;;; build up a "fake" swank-mop and then override the methods in the ;;;; inspector. (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *have-mop* (and (find-package :clos) (eql :external (nth-value 1 (find-symbol (string ':standard-slot-definition) :clos)))) "True in those CLISP images which have a complete MOP implementation.")) #+#.(cl:if swank/clisp::*have-mop* '(cl:and) '(cl:or)) (progn (import-swank-mop-symbols :clos '(:slot-definition-documentation)) (defun swank-mop:slot-definition-documentation (slot) (clos::slot-definition-documentation slot))) #-#.(cl:if swank/clisp::*have-mop* '(and) '(or)) (defclass swank-mop:standard-slot-definition () () (:documentation "Dummy class created so that swank.lisp will compile and load.")) (let ((getpid (or (find-symbol "PROCESS-ID" :system) ;; old name prior to 2005-03-01, clisp <= 2.33.2 (find-symbol "PROGRAM-ID" :system) #+win32 ; integrated into the above since 2005-02-24 (and (find-package :win32) ; optional modules/win32 (find-symbol "GetCurrentProcessId" :win32))))) (defimplementation getpid () ; a required interface (cond (getpid (funcall getpid)) #+win32 ((ext:getenv "PID")) ; where does that come from? (t -1)))) (defimplementation call-with-user-break-handler (handler function) (handler-bind ((system::simple-interrupt-condition (lambda (c) (declare (ignore c)) (funcall handler) (when (find-restart 'socket-status) (invoke-restart (find-restart 'socket-status))) (continue)))) (funcall function))) (defimplementation lisp-implementation-type-name () "clisp") (defimplementation set-default-directory (directory) (setf (ext:default-directory) directory) (namestring (setf *default-pathname-defaults* (ext:default-directory)))) (defimplementation filename-to-pathname (string) (cond ((member :cygwin *features*) (parse-cygwin-filename string)) (t (parse-namestring string)))) (defun parse-cygwin-filename (string) (multiple-value-bind (match _ drive absolute) (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) (declare (ignore _)) (assert (and match (if drive absolute t)) () "Invalid filename syntax: ~a" string) (let* ((sans-prefix (subseq string (regexp:match-end match))) (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) (path (loop for name in path collect (cond ((equal name "..") ':back) (t name)))) (directoryp (or (equal string "") (find (aref string (1- (length string))) "\\/")))) (multiple-value-bind (file type) (cond ((and (not directoryp) (last path)) (let* ((file (car (last path))) (pos (position #\. file :from-end t))) (cond ((and pos (> pos 0)) (values (subseq file 0 pos) (subseq file (1+ pos)))) (t file))))) (make-pathname :host nil :device nil :directory (cons (if absolute :absolute :relative) (let ((path (if directoryp path (butlast path)))) (if drive (cons (regexp:match-string string drive) path) path))) :name file :type type))))) ;;;; UTF (defimplementation string-to-utf8 (string) (let ((enc (load-time-value (ext:make-encoding :charset "utf-8" :line-terminator :unix) t))) (ext:convert-string-to-bytes string enc))) (defimplementation utf8-to-string (octets) (let ((enc (load-time-value (ext:make-encoding :charset "utf-8" :line-terminator :unix) t))) (ext:convert-string-from-bytes octets enc))) ;;;; TCP Server (defimplementation create-socket (host port &key backlog) (socket:socket-server port :interface host :backlog (or backlog 5))) (defimplementation local-port (socket) (socket:socket-server-port socket)) (defimplementation close-socket (socket) (socket:socket-server-close socket)) (defimplementation accept-connection (socket &key external-format buffering timeout) (declare (ignore buffering timeout)) (socket:socket-accept socket :buffered buffering ;; XXX may not work if t :element-type (if external-format 'character '(unsigned-byte 8)) :external-format (or external-format :default))) #-win32 (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams))) (loop (cond ((check-slime-interrupts) (return :interrupt)) (timeout (socket:socket-status streams 0 0) (return (loop for (s nil . x) in streams if x collect s))) (t (with-simple-restart (socket-status "Return from socket-status.") (socket:socket-status streams 0 500000)) (let ((ready (loop for (s nil . x) in streams if x collect s))) (when ready (return ready)))))))) #+win32 (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (loop (cond ((check-slime-interrupts) (return :interrupt)) (t (let ((ready (remove-if-not #'input-available-p streams))) (when ready (return ready))) (when timeout (return nil)) (sleep 0.1))))) #+win32 ;; Some facts to remember (for the next time we need to debug this): ;; - interactive-sream-p returns t for socket-streams ;; - listen returns nil for socket-streams ;; - (type-of ) is 'stream ;; - (type-of *terminal-io*) is 'two-way-stream ;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8) ;; - calling socket:socket-status on non sockets signals an error, ;; but seems to mess up something internally. ;; - calling read-char-no-hang on sockets does not signal an error, ;; but seems to mess up something internally. (defun input-available-p (stream) (case (stream-element-type stream) (character (let ((c (read-char-no-hang stream nil nil))) (cond ((not c) nil) (t (unread-char c stream) t)))) (t (eq (socket:socket-status (cons stream :input) 0 0) :input)))) ;;;; Coding systems (defvar *external-format-to-coding-system* '(((:charset "iso-8859-1" :line-terminator :unix) "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") ((:charset "iso-8859-1") "latin-1" "iso-latin-1" "iso-8859-1") ((:charset "utf-8") "utf-8") ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") ((:charset "euc-jp") "euc-jp") ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") ((:charset "us-ascii") "us-ascii") ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) (defimplementation find-external-format (coding-system) (let ((args (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*)))) (and args (apply #'ext:make-encoding args)))) ;;;; Swank functions (defimplementation arglist (fname) (block nil (or (ignore-errors (let ((exp (function-lambda-expression fname))) (and exp (return (second exp))))) (ignore-errors (return (ext:arglist fname))) :not-available))) (defimplementation macroexpand-all (form &optional env) (declare (ignore env)) (ext:expand-form form)) (defimplementation collect-macro-forms (form &optional env) ;; Currently detects only normal macros, not compiler macros. (declare (ignore env)) (with-collected-macro-forms (macro-forms) (handler-bind ((warning #'muffle-warning)) (ignore-errors (compile nil `(lambda () ,form)))) (values macro-forms nil))) (defimplementation describe-symbol-for-emacs (symbol) "Return a plist describing SYMBOL. Return NIL if the symbol is unbound." (let ((result ())) (flet ((doc (kind) (or (documentation symbol kind) :not-documented)) (maybe-push (property value) (when value (setf result (list* property value result))))) (maybe-push :variable (when (boundp symbol) (doc 'variable))) (when (fboundp symbol) (maybe-push ;; Report WHEN etc. as macros, even though they may be ;; implemented as special operators. (if (macro-function symbol) :macro (typecase (fdefinition symbol) (generic-function :generic-function) (function :function) ;; (type-of 'progn) -> ext:special-operator (t :special-operator))) (doc 'function))) (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) (get symbol 'system::setf-expander)); defsetf (maybe-push :setf (doc 'setf))) (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp (get symbol 'system::defstruct-description) (get symbol 'system::deftype-expander)) (maybe-push :type (doc 'type))) ; even for 'structure (when (find-class symbol nil) (maybe-push :class (doc 'type))) ;; Let this code work compiled in images without FFI (let ((types (load-time-value (and (find-package "FFI") (symbol-value (find-symbol "*C-TYPE-TABLE*" "FFI")))))) ;; Use ffi::*c-type-table* so as not to suffer the overhead of ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols ;; which are not FFI type names. (when (and types (nth-value 1 (gethash symbol types))) ;; Maybe use (case (head (ffi:deparse-c-type))) ;; to distinguish struct and union types? (maybe-push :alien-type :not-documented))) result))) (defimplementation describe-definition (symbol namespace) (ecase namespace (:variable (describe symbol)) (:macro (describe (macro-function symbol))) (:function (describe (symbol-function symbol))) (:class (describe (find-class symbol))))) (defimplementation type-specifier-p (symbol) (or (ignore-errors (subtypep nil symbol)) (not (eq (type-specifier-arglist symbol) :not-available)))) (defun fspec-pathname (spec) (let ((path spec) type lines) (when (consp path) (psetq type (car path) path (cadr path) lines (cddr path))) (when (and path (member (pathname-type path) custom:*compiled-file-types* :test #'equal)) (setq path (loop for suffix in custom:*source-file-types* thereis (probe-file (make-pathname :defaults path :type suffix))))) (values path type lines))) (defun fspec-location (name fspec) (multiple-value-bind (file type lines) (fspec-pathname fspec) (list (if type (list name type) name) (cond (file (multiple-value-bind (truename c) (ignore-errors (truename file)) (cond (truename (make-location (list :file (namestring truename)) (if (consp lines) (list* :line lines) (list :function-name (string name))) (when (consp type) (list :snippet (format nil "~A" type))))) (t (list :error (princ-to-string c)))))) (t (list :error (format nil "No source information available for: ~S" fspec))))))) (defimplementation find-definitions (name) (mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file))) (defun trim-whitespace (string) (string-trim #(#\newline #\space #\tab) string)) (defvar *sldb-backtrace*) (defun sldb-backtrace () "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." (let* ((modes '((:all-stack-elements 1) (:all-frames 2) (:only-lexical-frames 3) (:only-eval-and-apply-frames 4) (:only-apply-frames 5))) (mode (cadr (assoc :all-stack-elements modes)))) (do ((frames '()) (last nil frame) (frame (sys::the-frame) (sys::frame-up 1 frame mode))) ((eq frame last) (nreverse frames)) (unless (boring-frame-p frame) (push frame frames))))) (defimplementation call-with-debugging-environment (debugger-loop-fn) (let* (;;(sys::*break-count* (1+ sys::*break-count*)) ;;(sys::*driver* debugger-loop-fn) ;;(sys::*fasoutput-stream* nil) (*sldb-backtrace* (let* ((f (sys::the-frame)) (bt (sldb-backtrace)) (rest (member f bt))) (if rest (nthcdr 8 rest) bt)))) (funcall debugger-loop-fn))) (defun nth-frame (index) (nth index *sldb-backtrace*)) (defun boring-frame-p (frame) (member (frame-type frame) '(stack-value bind-var bind-env compiled-tagbody compiled-block))) (defun frame-to-string (frame) (with-output-to-string (s) (sys::describe-frame s frame))) (defun frame-type (frame) ;; FIXME: should bind *print-length* etc. to small values. (frame-string-type (frame-to-string frame))) ;; FIXME: they changed the layout in 2.44 and not all patterns have ;; been updated. (defvar *frame-prefixes* '(("\\[[0-9]\\+\\] frame binding variables" bind-var) ("<1> # # # " fun) ("<2> " 2nd-frame) )) (defun frame-string-type (string) (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) *frame-prefixes*))) (defimplementation compute-backtrace (start end) (let* ((bt *sldb-backtrace*) (len (length bt))) (loop for f in (subseq bt start (min (or end len) len)) collect f))) (defimplementation print-frame (frame stream) (let* ((str (frame-to-string frame))) (write-string (extract-frame-line str) stream))) (defun extract-frame-line (frame-string) (let ((s frame-string)) (trim-whitespace (case (frame-string-type s) ((eval special-op) (string-match "EVAL frame .*for form \\(.*\\)" s 1)) (apply (string-match "APPLY frame for call \\(.*\\)" s 1)) ((compiled-fun sys-fun fun) (extract-function-name s)) (t s))))) (defun extract-function-name (string) (let ((1st (car (split-frame-string string)))) (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") 1st 1) (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) 1st))) (defun split-frame-string (string) (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" (mapcar #'car *frame-prefixes*)))) (loop for pos = 0 then (1+ (regexp:match-start match)) for match = (regexp:match rx string :start pos) if match collect (subseq string pos (regexp:match-start match)) else collect (subseq string pos) while match))) (defun string-match (pattern string n) (let* ((match (nth-value n (regexp:match pattern string)))) (if match (regexp:match-string string match)))) (defimplementation eval-in-frame (form frame-number) (sys::eval-at (nth-frame frame-number) form)) (defimplementation frame-locals (frame-number) (let ((frame (nth-frame frame-number))) (loop for i below (%frame-count-vars frame) collect (list :name (%frame-var-name frame i) :value (%frame-var-value frame i) :id 0)))) (defimplementation frame-var-value (frame var) (%frame-var-value (nth-frame frame) var)) ;;; Interpreter-Variablen-Environment has the shape ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). (defun %frame-count-vars (frame) (cond ((sys::eval-frame-p frame) (do ((venv (frame-venv frame) (next-venv venv)) (count 0 (+ count (/ (1- (length venv)) 2)))) ((not venv) count))) ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) (length (%parse-stack-values frame))) (t 0))) (defun %frame-var-name (frame i) (cond ((sys::eval-frame-p frame) (nth-value 0 (venv-ref (frame-venv frame) i))) (t (format nil "~D" i)))) (defun %frame-var-value (frame i) (cond ((sys::eval-frame-p frame) (let ((name (venv-ref (frame-venv frame) i))) (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) (if c (format-sldb-condition c) v)))) ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) (let ((str (nth i (%parse-stack-values frame)))) (trim-whitespace (subseq str 2)))) (t (break "Not implemented")))) (defun frame-venv (frame) (let ((env (sys::eval-at frame '(sys::the-environment)))) (svref env 0))) (defun next-venv (venv) (svref venv (1- (length venv)))) (defun venv-ref (env i) "Reference the Ith binding in ENV. Return two values: NAME and VALUE" (let ((idx (* i 2))) (if (< idx (1- (length env))) (values (svref env idx) (svref env (1+ idx))) (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) (defun %parse-stack-values (frame) (labels ((next (fp) (sys::frame-down 1 fp 1)) (parse (fp accu) (let ((str (frame-to-string fp))) (cond ((is-prefix-p "- " str) (parse (next fp) (cons str accu))) ((is-prefix-p "<1> " str) ;;(when (eq (frame-type frame) 'compiled-fun) ;; (pop accu)) (dolist (str (cdr (split-frame-string str))) (when (is-prefix-p "- " str) (push str accu))) (nreverse accu)) (t (parse (next fp) accu)))))) (parse (next frame) '()))) (defun is-prefix-p (regexp string) (if (regexp:match (concatenate 'string "^" regexp) string) t)) (defimplementation return-from-frame (index form) (sys::return-from-eval-frame (nth-frame index) form)) (defimplementation restart-frame (index) (sys::redo-eval-frame (nth-frame index))) (defimplementation frame-source-location (index) `(:error ,(format nil "frame-source-location not implemented. (frame: ~A)" (nth-frame index)))) ;;;; Profiling (defimplementation profile (fname) (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro (defimplementation profiled-functions () swank-monitor:*monitored-functions*) (defimplementation unprofile (fname) (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro (defimplementation unprofile-all () (swank-monitor:unmonitor)) (defimplementation profile-report () (swank-monitor:report-monitoring)) (defimplementation profile-reset () (swank-monitor:reset-all-monitoring)) (defimplementation profile-package (package callers-p methods) (declare (ignore callers-p methods)) (swank-monitor:monitor-all package)) ;;;; Handle compiler conditions (find out location of error etc.) (defmacro compile-file-frobbing-notes ((&rest args) &body body) "Pass ARGS to COMPILE-FILE, send the compiler notes to *STANDARD-INPUT* and frob them in BODY." `(let ((*error-output* (make-string-output-stream)) (*compile-verbose* t)) (multiple-value-prog1 (compile-file ,@args) (handler-case (with-input-from-string (*standard-input* (get-output-stream-string *error-output*)) ,@body) (sys::simple-end-of-file () nil))))) (defvar *orig-c-warn* (symbol-function 'system::c-warn)) (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) (defvar *orig-c-error* (symbol-function 'system::c-error)) (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) (defmacro dynamic-flet (names-functions &body body) "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) Execute BODY with NAME's function slot set to FUNCTION." `(ext:letf* ,(loop for (name function) in names-functions collect `((symbol-function ',name) ,function)) ,@body)) (defvar *buffer-name* nil) (defvar *buffer-offset*) (defun compiler-note-location () "Return the current compiler location." (let ((lineno1 sys::*compile-file-lineno1*) (lineno2 sys::*compile-file-lineno2*) (file sys::*compile-file-truename*)) (cond ((and file lineno1 lineno2) (make-location (list ':file (namestring file)) (list ':line lineno1))) (*buffer-name* (make-location (list ':buffer *buffer-name*) (list ':offset *buffer-offset* 0))) (t (list :error "No error location available"))))) (defun signal-compiler-warning (cstring args severity orig-fn) (signal 'compiler-condition :severity severity :message (apply #'format nil cstring args) :location (compiler-note-location)) (apply orig-fn cstring args)) (defun c-warn (cstring &rest args) (signal-compiler-warning cstring args :warning *orig-c-warn*)) (defun c-style-warn (cstring &rest args) (dynamic-flet ((sys::c-warn *orig-c-warn*)) (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) (defun c-error (&rest args) (signal 'compiler-condition :severity :error :message (apply #'format nil (if (= (length args) 3) (cdr args) args)) :location (compiler-note-location)) (apply *orig-c-error* args)) (defimplementation call-with-compilation-hooks (function) (handler-bind ((warning #'handle-notification-condition)) (dynamic-flet ((system::c-warn #'c-warn) (system::c-style-warn #'c-style-warn) (system::c-error #'c-error)) (funcall function)))) (defun handle-notification-condition (condition) "Handle a condition caused by a compiler warning." (signal 'compiler-condition :original-condition condition :severity :warning :message (princ-to-string condition) :location (compiler-note-location))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (with-compilation-hooks () (with-compilation-unit () (multiple-value-bind (fasl-file warningsp failurep) (compile-file input-file :output-file output-file :external-format external-format) (values fasl-file warningsp (or failurep (and load-p (not (load fasl-file))))))))) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore filename policy)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-offset* position)) (funcall (compile nil (read-from-string (format nil "(~S () ~A)" 'lambda string)))) t))) ;;;; Portable XREF from the CMU AI repository. (setq pxref::*handle-package-forms* '(cl:in-package)) (defmacro defxref (name function) `(defimplementation ,name (name) (xref-results (,function name)))) (defxref who-calls pxref:list-callers) (defxref who-references pxref:list-readers) (defxref who-binds pxref:list-setters) (defxref who-sets pxref:list-setters) (defxref list-callers pxref:list-callers) (defxref list-callees pxref:list-callees) (defun xref-results (symbols) (let ((xrefs '())) (dolist (symbol symbols) (push (fspec-location symbol symbol) xrefs)) xrefs)) (when (find-package :swank-loader) (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader)) (lambda () (let ((home (user-homedir-pathname))) (and (ext:probe-directory home) (probe-file (format nil "~A/.swank.lisp" (namestring (truename home))))))))) ;;; Don't set *debugger-hook* to nil on break. (ext:without-package-lock () (defun break (&optional (format-string "Break") &rest args) (if (not sys::*use-clcs*) (progn (terpri *error-output*) (apply #'format *error-output* (concatenate 'string "*** - " format-string) args) (funcall ext:*break-driver* t)) (let ((condition (make-condition 'simple-condition :format-control format-string :format-arguments args)) ;;(*debugger-hook* nil) ;; Issue 91 ) (ext:with-restarts ((continue :report (lambda (stream) (format stream (sys::text "Return from ~S loop") 'break)) ())) (with-condition-restarts condition (list (find-restart 'continue)) (invoke-debugger condition))))) nil)) ;;;; Inspecting (defmethod emacs-inspect ((o t)) (let* ((*print-array* nil) (*print-pretty* t) (*print-circle* t) (*print-escape* t) (*print-lines* custom:*inspect-print-lines*) (*print-level* custom:*inspect-print-level*) (*print-length* custom:*inspect-print-length*) (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) (*package* tmp-pack) (sys::*inspect-unbound-value* (intern "#" tmp-pack))) (let ((inspection (sys::inspect-backend o))) (append (list (format nil "~S~% ~A~{~%~A~}~%" o (sys::insp-title inspection) (sys::insp-blurb inspection))) (loop with count = (sys::insp-num-slots inspection) for i below count append (multiple-value-bind (value name) (funcall (sys::insp-nth-slot inspection) i) `((:value ,name) " = " (:value ,value) (:newline)))))))) (defimplementation quit-lisp () #+lisp=cl (ext:quit) #-lisp=cl (lisp:quit)) (defimplementation preferred-communication-style () nil) ;;; FIXME ;;; ;;; Clisp 2.48 added experimental support for threads. Basically, you ;;; can use :SPAWN now, BUT: ;;; ;;; - there are problems with GC, and threads stuffed into weak ;;; hash-tables as is the case for *THREAD-PLIST-TABLE*. ;;; ;;; See test case at ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429 ;;; ;;; Even though said to be fixed, it's not: ;;; ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443 ;;; ;;; - The DYNAMIC-FLET above is an implementation technique that's ;;; probably not sustainable in light of threads. This got to be ;;; rewritten. ;;; ;;; TCR (2009-07-30) #+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) (progn (defimplementation spawn (fn &key name) (mp:make-thread fn :name name)) (defvar *thread-plist-table-lock* (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK")) (defvar *thread-plist-table* (make-hash-table :weak :key) "A hashtable mapping threads to a plist.") (defvar *thread-id-counter* 0) (defimplementation thread-id (thread) (mp:with-mutex-lock (*thread-plist-table-lock*) (or (getf (gethash thread *thread-plist-table*) 'thread-id) (setf (getf (gethash thread *thread-plist-table*) 'thread-id) (incf *thread-id-counter*))))) (defimplementation find-thread (id) (find id (all-threads) :key (lambda (thread) (getf (gethash thread *thread-plist-table*) 'thread-id)))) (defimplementation thread-name (thread) ;; To guard against returning #. (princ-to-string (mp:thread-name thread))) (defimplementation thread-status (thread) (if (thread-alive-p thread) "RUNNING" "STOPPED")) (defimplementation make-lock (&key name) (mp:make-mutex :name name :recursive-p t)) (defimplementation call-with-lock-held (lock function) (mp:with-mutex-lock (lock) (funcall function))) (defimplementation current-thread () (mp:current-thread)) (defimplementation all-threads () (mp:list-threads)) (defimplementation interrupt-thread (thread fn) (mp:thread-interrupt thread :function fn)) (defimplementation kill-thread (thread) (mp:thread-interrupt thread :function t)) (defimplementation thread-alive-p (thread) (mp:thread-active-p thread)) (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK")) (defvar *mailboxes* (list)) (defstruct (mailbox (:conc-name mailbox.)) thread (lock (make-lock :name "MAILBOX.LOCK")) (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE")) (queue '() :type list)) (defun mailbox (thread) "Return THREAD's mailbox." (mp:with-mutex-lock (*mailboxes-lock*) (or (find thread *mailboxes* :key #'mailbox.thread) (let ((mb (make-mailbox :thread thread))) (push mb *mailboxes*) mb)))) (defimplementation send (thread message) (let* ((mbox (mailbox thread)) (lock (mailbox.lock mbox))) (mp:with-mutex-lock (lock) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) (mp:exemption-broadcast (mailbox.waitqueue mbox))))) (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox (current-thread))) (lock (mailbox.lock mbox))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-mutex-lock (lock) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail)))) (when (eq timeout t) (return (values nil t))) (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2)))))) ;;;; Weak hashtables (defimplementation make-weak-key-hash-table (&rest args) (apply #'make-hash-table :weak :key args)) (defimplementation make-weak-value-hash-table (&rest args) (apply #'make-hash-table :weak :value args)) (defimplementation save-image (filename &optional restart-function) (let ((args `(,filename ,@(if restart-function `((:init-function ,restart-function)))))) (apply #'ext:saveinitmem args))) slime-2.20/swank/cmucl.lisp000066400000000000000000002747061315100173500157010ustar00rootroot00000000000000;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- ;;; ;;; License: Public Domain ;;; ;;;; Introduction ;;; ;;; This is the CMUCL implementation of the `swank/backend' package. (defpackage swank/cmucl (:use cl swank/backend swank/source-path-parser swank/source-file-cache fwrappers)) (in-package swank/cmucl) (eval-when (:compile-toplevel :load-toplevel :execute) (let ((min-version #x20c)) (assert (>= c:byte-fasl-file-version min-version) () "This file requires CMUCL version ~x or newer" min-version)) (require 'gray-streams)) (import-swank-mop-symbols :pcl '(:slot-definition-documentation)) (defun swank-mop:slot-definition-documentation (slot) (documentation slot t)) ;;; UTF8 (locally (declare (optimize (ext:inhibit-warnings 3))) ;; Compile and load the utf8 format, if not already loaded. (stream::find-external-format :utf-8)) (defimplementation string-to-utf8 (string) (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) (stream:string-to-octets string :external-format ef))) (defimplementation utf8-to-string (octets) (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) (stream:octets-to-string octets :external-format ef))) ;;;; 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 &key backlog) (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 :backlog (or backlog 5)))) ;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. #+(or darwin mips) (defimplementation create-socket (host port &key backlog) (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)) (make-socket-io-stream (ext:accept-tcp-connection socket) (ecase buffering ((t) :full) (:line :line) ((nil) :none)) external-format)) ;;;;; Sockets (defimplementation 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)))) (defvar *external-format-to-coding-system* '((:iso-8859-1 "iso-latin-1-unix") #+unicode (:utf-8 "utf-8-unix"))) (defimplementation find-external-format (coding-system) (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*))) (defun make-socket-io-stream (fd buffering external-format) "Create a new input/output fd-stream for FD." (cond (external-format (sys:make-fd-stream fd :input t :output t :element-type 'character :buffering buffering :external-format external-format)) (t (sys:make-fd-stream fd :input t :output t :element-type '(unsigned-byte 8) :buffering buffering)))) (defimplementation make-fd-stream (fd external-format) (make-socket-io-stream fd :full external-format)) (defimplementation dup (fd) (multiple-value-bind (clone error) (unix:unix-dup fd) (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error))) clone)) (defimplementation command-line-args () ext:*command-line-strings*) (defimplementation exec-image (image-file args) (multiple-value-bind (ok error) (unix:unix-execve (car (command-line-args)) (list* (car (command-line-args)) "-core" image-file "-noinit" args)) (error "~a" (unix:get-unix-error-msg error)) ok)) ;;;;; Signal-driven I/O (defimplementation install-sigint-handler (function) (sys:enable-interrupt :sigint (lambda (signal code scp) (declare (ignore signal code scp)) (funcall function)))) (defvar *sigio-handlers* '() "List of (key . function) pairs. All functions are called on SIGIO, and the key is used for removing specific functions.") (defun reset-sigio-handlers () (setq *sigio-handlers* '())) ;; All file handlers are invalid afer reload. (pushnew 'reset-sigio-handlers ext:*after-save-initializations*) (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) (cond (ok) (t (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)) (let ((old-flags (fcntl fd unix:f-getfl 0))) (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) (assert (not (assoc fd *sigio-handlers*))) (push (cons fd fn) *sigio-handlers*))) (defimplementation remove-sigio-handlers (socket) (let ((fd (socket-fd socket))) (when (assoc fd *sigio-handlers*) (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) (let ((old-flags (fcntl fd unix:f-getfl 0))) (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) (sys:invalidate-descriptor fd)) (assert (not (assoc fd *sigio-handlers*))) (when (null *sigio-handlers*) (sys:default-interrupt :sigio)))) ;;;;; 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))) (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (loop (let ((ready (remove-if-not #'listen streams))) (when ready (return ready))) (when timeout (return nil)) (multiple-value-bind (in out) (make-pipe) (let* ((f (constantly t)) (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams)) collect (add-one-shot-handler s f)))) (unwind-protect (let ((*interrupt-queued-handler* (lambda () (write-char #\! out)))) (when (check-slime-interrupts) (return :interrupt)) (sys:serve-event)) (mapc #'sys:remove-fd-handler handlers) (close in) (close out)))))) (defun to-fd-stream (stream) (etypecase stream (sys:fd-stream stream) (synonym-stream (to-fd-stream (symbol-value (synonym-stream-symbol stream)))) (two-way-stream (to-fd-stream (two-way-stream-input-stream stream))))) (defun add-one-shot-handler (stream function) (let (handler) (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input (lambda (fd) (declare (ignore fd)) (sys:remove-fd-handler handler) (funcall function stream)))))) (defun make-pipe () (multiple-value-bind (in out) (unix:unix-pipe) (values (sys:make-fd-stream in :input t :buffering :none) (sys:make-fd-stream out :output t :buffering :none)))) ;;;; Stream handling (defimplementation gray-package-name () "EXT") ;;;; 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 (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (clear-xref-info input-file) (with-compilation-hooks () (let ((*buffer-name* nil) (ext:*ignore-extra-close-parentheses* nil)) (multiple-value-bind (output-file warnings-p failure-p) (compile-file input-file :output-file output-file :external-format external-format) (values output-file warnings-p (or failure-p (when load-p ;; Cache the latest source file for definition-finding. (source-cache-get input-file (file-write-date input-file)) (not (load output-file))))))))) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore filename policy)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-start-position* position) (*buffer-substring* string) (source-info (list :emacs-buffer buffer :emacs-buffer-offset position :emacs-buffer-string string))) (with-input-from-string (stream string) (let ((failurep (ext:compile-from-stream stream :source-info source-info))) (not failurep)))))) ;;;;; 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 'compiler-condition :original-condition condition :severity (severity-for-emacs condition) :message (compiler-condition-message condition) :source-context (compiler-error-context 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 compiler-condition-message (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 compiler-error-context (error-context) "Describe context information for Emacs." (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))) (if (or enclosing source) (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~ ~@[==>~{~&~A~}~]" enclosing source)))) (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 :offset *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) (with-struct (c::compiler-error-context- file-name original-source original-source-path) context (or (locate-compiler-note file-name original-source (reverse original-source-path)) (note-error-location))))) (defun note-error-location () "Pseudo-location for notes that can't be located." (cond (*compile-file-truename* (make-location (list :file (unix-truename *compile-file-truename*)) (list :eof))) (*buffer-name* (make-location (list :buffer *buffer-name*) (list :position *buffer-start-position*))) (t (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 (make-location (list :buffer *buffer-name*) (list :offset *buffer-start-position* (source-path-string-position source-path *buffer-substring*)))) ((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: ;;; (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* xref::*who-is-called* 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. (labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t)) (map-cpool (code fun) (declare (type kernel:code-component code) (type function fun)) (loop for i from vm:code-constants-offset below (kernel:get-header-data code) do (funcall fun (kernel:code-header-ref code i)))) (callees (fun) (let ((callees (make-stack))) (map-cpool (vm::find-code-object fun) (lambda (o) (when (kernel:fdefn-p o) (vector-push-extend (kernel:fdefn-function o) callees)))) (coerce callees 'list))) (callers (fun) (declare (function fun)) (let ((callers (make-stack))) (ext:gc :full t) ;; scan :dynamic first to avoid the need for even more gcing (dolist (space '(:dynamic :read-only :static)) (vm::map-allocated-objects (lambda (obj header size) (declare (type fixnum header) (ignore size)) (when (= vm:code-header-type header) (map-cpool obj (lambda (c) (when (and (kernel:fdefn-p c) (eq (kernel:fdefn-function c) fun)) (vector-push-extend obj callers)))))) space) (ext:gc)) (coerce callers 'list))) (entry-points (code) (loop for entry = (kernel:%code-entry-points code) then (kernel::%function-next entry) while entry collect entry)) (guess-main-entry-point (entry-points) (or (find-if (lambda (fun) (ext:valid-function-name-p (kernel:%function-name fun))) entry-points) (car entry-points))) (fun-dspec (fun) (list (kernel:%function-name fun) (function-location fun))) (code-dspec (code) (let ((eps (entry-points code)) (di (kernel:%code-debug-info code))) (cond (eps (fun-dspec (guess-main-entry-point eps))) (di (list (c::debug-info-name di) (debug-info-function-name-location di))) (t (list (princ-to-string code) `(:error "No src-loc available"))))))) (declare (inline map-cpool)) (defimplementation list-callers (symbol) (mapcar #'code-dspec (callers (coerce symbol 'function) ))) (defimplementation list-callees (symbol) (mapcar #'fun-dspec (callees symbol)))) (defun test-list-callers (count) (let ((funsyms '())) (do-all-symbols (s) (when (and (fboundp s) (functionp (symbol-function s)) (not (macro-function s)) (not (special-operator-p s))) (push s funsyms))) (let ((len (length funsyms))) (dotimes (i count) (let ((sym (nth (random len) funsyms))) (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym)))))))) ;; (test-list-callers 100) ;;;; 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 ;;; `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.") (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)) (root-number (di:debug-source-root-number 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 root-number))) `(: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 :offset (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 root) "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) root)) (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 0))) ;;;; 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) (template-definitions name) (primitive-definitions name) (vm-support-routine-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))) (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))))) (function? (let ((function (fdefinition name))) (if (genericp function) (gf-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 (fun) "Return the location of the byte-compiled function FUN." (etypecase fun ((or c::hairy-byte-function c::simple-byte-function) (let* ((di (kernel:%code-debug-info (c::byte-function-component fun)))) (if di (debug-info-function-name-location di) `(:error ,(format nil "Byte-function without debug-info: ~a" fun))))) (c::byte-closure (byte-function-location (c::byte-closure-function fun))))) ;;; 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'." (let ((ctor (struct-constructor dd))) (cond (ctor (function-location (coerce ctor 'function))) (t (let ((name (kernel:dd-name dd))) (multiple-value-bind (location foundp) (ext:info :source-location :defvar name) (cond (foundp (resolve-source-location location)) (t (error "No location for defstruct: ~S" name))))))))) (defun struct-constructor (dd) "Return the name of the constructor from a defstruct definition." (let* ((constructor (or (kernel:dd-default-constructor dd) (car (kernel::dd-constructors dd))))) (if (consp constructor) (car constructor) constructor))) ;;;;;; Generic functions and methods (defun gf-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)))) (defun method-location (method) (typecase method (pcl::standard-accessor-method (definition-source-location (cond ((pcl::definition-source method) method) (t (pcl::slot-definition-class (pcl::accessor-method-slot-definition method)))) (pcl::accessor-method-slot-name method))) (t (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) (pcl-class-location (find-class name))))) ((or kernel::built-in-class conditions::condition-class kernel:funcallable-structure-class) (list (list `(class ,name) (class-location class)))))))) (defun pcl-class-location (class) "Return the `defclass' location for CLASS." (definition-source-location class (pcl:class-name class))) ;; FIXME: eval used for backward compatibility. (defun class-location (class) (declare (type kernel::class class)) (let ((name (kernel:%class-name class))) (multiple-value-bind (loc found?) (let ((x (ignore-errors (multiple-value-list (eval `(ext:info :source-location :class ',name)))))) (values-list x)) (cond (found? (resolve-source-location loc)) (`(:error ,(format nil "No location recorded for class: ~S" name))))))) (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) `(:offset ,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 ((f (or (ext:info :setf :inverse name) (ext:info :setf :expander name) (and (symbolp name) (fboundp `(setf ,name)) (fdefinition `(setf ,name)))))) (if f `(((setf ,name) ,(function-location (cond ((functionp f) f) ((macro-function f)) ((fdefinition f))))))))) (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 `(,(type-of template) ,(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)) (defun template-definitions (name) (let* ((templates (c::backend-template-names c::*backend*)) (template (gethash name templates))) (etypecase template (null) (c::vop-info (maybe-make-definition (c::vop-info-generator-function template) (type-of template) name))))) ;; for cases like: (%primitive NAME ...) (defun primitive-definitions (name) (let ((csym (find-symbol (string name) 'c))) (and csym (not (eq csym name)) (template-definitions csym)))) (defun vm-support-routine-definitions (name) (let ((sr (c::backend-support-routines c::*backend*)) (name (find-symbol (string name) 'c))) (and name (slot-exists-p sr name) (maybe-make-definition (slot-value sr name) (find-symbol (string 'vm-support-routine) 'c) 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 &optional env) (walker:macroexpand-all form env)) (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 getpid () (unix:unix-getpid)) (defimplementation lisp-implementation-type-name () "cmucl") (defimplementation quit-lisp () (ext::quit)) ;;; source-path-{stream,file,string,etc}-position moved into ;;; 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 '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 (index) (let ((frame (nth-frame index))) (cond ((foreign-frame-p frame) (foreign-frame-source-location frame)) ((code-location-source-location (di:frame-code-location frame)))))) (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." (let ((loc (di:frame-code-location frame))) (remove-if (lambda (v) (not (eq (di:debug-variable-validity v loc) :valid))) (di::debug-function-debug-variables (di:frame-debug-function frame))))) (defun debug-var-value (var frame) (let* ((loc (di:frame-code-location frame)) (validity (di:debug-variable-validity var loc))) (ecase validity (:valid (di:debug-variable-value var frame)) ((:invalid :unknown) (make-symbol (string validity)))))) (defimplementation frame-locals (index) (let ((frame (nth-frame index))) (loop for v across (frame-debug-vars frame) collect (list :name (di:debug-variable-symbol v) :id (di:debug-variable-id v) :value (debug-var-value v frame))))) (defimplementation frame-var-value (frame var) (let* ((frame (nth-frame frame)) (dvar (aref (frame-debug-vars frame) var))) (debug-var-value dvar frame))) (defimplementation frame-catch-tags (index) (mapcar #'car (di:frame-catches (nth-frame index)))) (defimplementation frame-package (frame-number) (let* ((frame (nth-frame frame-number)) (dbg-fun (di:frame-debug-function frame))) (typecase dbg-fun (di::compiled-debug-function (let* ((comp (di::compiled-debug-function-component dbg-fun)) (dbg-info (kernel:%code-debug-info comp))) (typecase dbg-info (c::compiled-debug-info (find-package (c::compiled-debug-info-package dbg-info))))))))) (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*) (define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) (let ((*breakpoint-sigcontext* sigcontext) (*breakpoint-pc* offset)) (call-next-function))) (set-fwrappers 'di::handle-breakpoint '()) (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 (speed 0))) (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 "<>" 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 (funcall '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))) (di::interpreted-debug-function -1) (di::bogus-debug-function #-x86 (let* ((real (di::frame-real-frame (di::frame-up frame))) (fp (di::frame-pointer real))) ;;#+(or) (progn (format *debug-io* "Frame-real-frame = ~S~%" real) (format *debug-io* "fp = ~S~%" fp) (format *debug-io* "lra = ~S~%" (kernel:stack-ref fp vm::lra-save-offset))) (values (sys:int-sap (- (kernel:get-lisp-obj-address (kernel:stack-ref fp vm::lra-save-offset)) (- (ash vm:function-code-offset vm:word-shift) vm:function-pointer-type))) 0)) #+x86 (let ((fp (di::frame-pointer (di:frame-up frame)))) (multiple-value-bind (ra ofp) (di::x86-call-context fp) (declare (ignore ofp)) (values ra 0)))))))) (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 "~ ~8X Stack Pointer ~8X Frame Pointer ~8X Instruction Pointer ~8X Saved Frame Pointer ~8X Saved Instruction Pointer~%" (mapcar #'fixnum (multiple-value-list (frame-registers frame))))))) (defvar *gdb-program-name* (ext:enumerate-search-list (p "path:gdb") (when (probe-file p) (return p)))) (defimplementation disassemble-frame (frame-number) (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 (cond ((probe-file *gdb-program-name*) (let ((ip (sys:sap-int (frame-ip frame)))) (princ (gdb-command "disas 0x~x" ip)))) (t (format t "~%[Disassembling bogus frames not implemented]"))))))) (defmacro with-temporary-file ((stream filename) &body body) `(call/temporary-file (lambda (,stream ,filename) . ,body))) (defun call/temporary-file (fun) (let ((name (system::pick-temporary-file-name))) (unwind-protect (with-open-file (stream name :direction :output :if-exists :supersede) (funcall fun stream name)) (delete-file name)))) (defun gdb-command (format-string &rest args) (let ((str (gdb-exec (format nil "interpreter-exec mi2 \"attach ~d\"~%~ interpreter-exec console ~s~%detach" (getpid) (apply #'format nil format-string args)))) (prompt (format nil #-(and darwin x86) "~%^done~%(gdb) ~%" #+(and darwin x86) "~%^done,thread-id=\"1\"~%(gdb) ~%"))) (subseq str (+ (or (search prompt str) 0) (length prompt))))) (defun gdb-exec (cmd) (with-temporary-file (file filename) (write-string cmd file) (force-output file) (let* ((output (make-string-output-stream)) ;; gdb on sparc needs to know the executable to find the ;; symbols. Without this, gdb can't disassemble anything. ;; NOTE: We assume that the first entry in ;; lisp::*cmucl-lib* is the bin directory where lisp is ;; located. If this is not true, we'll have to do ;; something better to find the lisp executable. (lisp-path #+sparc (list (namestring (probe-file (merge-pathnames "lisp" (car (lisp::parse-unix-search-path lisp::*cmucl-lib*)))))) #-sparc nil) (proc (ext:run-program *gdb-program-name* `(,@lisp-path "-batch" "-x" ,filename) :wait t :output output))) (assert (eq (ext:process-status proc) :exited)) (assert (eq (ext:process-exit-code proc) 0)) (get-output-stream-string output)))) (defun foreign-frame-p (frame) #-x86 (let ((ip (frame-ip frame))) (and (sys:system-area-pointer-p ip) (typep (di::frame-debug-function frame) 'di::bogus-debug-function))) #+x86 (let ((ip (frame-ip frame))) (and (sys:system-area-pointer-p ip) (multiple-value-bind (pc code) (di::compute-lra-data-from-pc ip) (declare (ignore pc)) (not code))))) (defun foreign-frame-source-location (frame) (let ((ip (sys:sap-int (frame-ip frame)))) (cond ((probe-file *gdb-program-name*) (parse-gdb-line-info (gdb-command "info line *0x~x" ip))) (t `(:error "no srcloc available for ~a" frame))))) ;; The output of gdb looks like: ;; Line 215 of "../../src/lisp/x86-assem.S" ;; starts at address 0x805318c ;; and ends at 0x805318e . ;; The ../../ are fixed up with the "target:" search list which might ;; be wrong sometimes. (defun parse-gdb-line-info (string) (with-input-from-string (*standard-input* string) (let ((w1 (read-word))) (cond ((equal w1 "Line") (let ((line (read-word))) (assert (equal (read-word) "of")) (let* ((file (read-from-string (read-word))) (pathname (or (probe-file file) (probe-file (format nil "target:lisp/~a" file)) file))) (make-location (list :file (unix-truename pathname)) (list :line (parse-integer line)))))) (t `(:error ,string)))))) (defun read-word (&optional (stream *standard-input*)) (peek-char t stream) (concatenate 'string (loop until (whitespacep (peek-char nil stream)) collect (read-char stream)))) (defun whitespacep (char) (member char '(#\space #\newline))) ;;;; Inspecting (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 emacs-inspect ((o t)) (cond ((di::indirect-value-cell-p 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) (list* (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 emacs-inspect ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (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) (list* (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 emacs-inspect ((o kernel:funcallable-instance)) (append (label-value-line* (:function (kernel:%funcallable-instance-function o)) (:lexenv (kernel:%funcallable-instance-lexenv o)) (:layout (kernel:%funcallable-instance-layout o))) (cmucl-inspect o))) (defmethod emacs-inspect ((o kernel:code-component)) (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 (*standard-output*) (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) (disassem:disassemble-code-component o)) ((or (c::debug-info-p (kernel:%code-debug-info o)) (consp (kernel:code-header-ref o vm:code-trace-table-offset-slot))) (c:disassem-byte-component o)) (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)))))))) (defmethod emacs-inspect ((o kernel:fdefn)) (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))))) #+(or) (defmethod emacs-inspect ((o array)) (if (typep o 'simple-array) (call-next-method) (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 emacs-inspect ((o simple-vector)) (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) (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))) (declare (optimize (speed 0))) (label-value-line slot (alien:slot alien slot)))))))) (defun inspect-alien-pointer (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)))) (defimplementation eval-context (obj) (cond ((typep (class-of obj) 'structure-class) (let* ((dd (kernel:layout-info (kernel:layout-of obj))) (slots (kernel:dd-slots dd))) (list* (cons '*package* (symbol-package (if slots (kernel:dsd-name (car slots)) (kernel:dd-name dd)))) (loop for slot in slots collect (cons (kernel:dsd-name slot) (funcall (kernel:dsd-accessor slot) obj)))))))) ;;;; 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 :methods 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) (check-slime-interrupts) (let* ((mbox (mailbox thread))) (mp:with-lock-held ((mailbox.mutex mbox)) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message)))))) (defimplementation receive-if (test &optional timeout) (let ((mbox (mailbox mp:*current-process*))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-lock-held ((mailbox.mutex mbox)) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))))) (when (eq timeout t) (return (values nil t))) (mp:process-wait-with-timeout "receive-if" 0.5 (lambda () (some test (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) (swank::background-message 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 ) ;; (trace (method ? (+))) ;; (trace :methods t ') ;;to trace all methods of the gf ;; 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)) ;;; Save image (defimplementation save-image (filename &optional restart-function) (multiple-value-bind (pid error) (unix:unix-fork) (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error))) (cond ((= pid 0) (apply #'ext:save-lisp filename (if restart-function `(:init-function ,restart-function)))) (t (let ((status (waitpid pid))) (destructuring-bind (&key exited? status &allow-other-keys) status (assert (and exited? (equal status 0)) () "Invalid exit status: ~a" status))))))) (defun waitpid (pid) (alien:with-alien ((status c-call:int)) (let ((code (alien:alien-funcall (alien:extern-alien waitpid (alien:function c-call:int c-call:int (* c-call:int) c-call:int)) pid (alien:addr status) 0))) (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) (t (assert (= code pid)) (decode-wait-status status)))))) (defun decode-wait-status (status) (let ((output (with-output-to-string (s) (call-program (list (process-status-program) (format nil "~d" status)) :output s)))) (read-from-string output))) (defun call-program (args &key output) (destructuring-bind (program &rest args) args (let ((process (ext:run-program program args :output output))) (when (not program) (error "fork failed")) (unless (and (eq (ext:process-status process) :exited) (= (ext:process-exit-code process) 0)) (error "Non-zero exit status"))))) (defvar *process-status-program* nil) (defun process-status-program () (or *process-status-program* (setq *process-status-program* (compile-process-status-program)))) (defun compile-process-status-program () (let ((infile (system::pick-temporary-file-name "/tmp/process-status~d~c.c"))) (with-open-file (stream infile :direction :output :if-exists :supersede) (format stream " #include #include #include #include #include #define FLAG(value) (value ? \"t\" : \"nil\") int main (int argc, char** argv) { assert (argc == 2); { char* endptr = NULL; char* arg = argv[1]; long int status = strtol (arg, &endptr, 10); assert (endptr != arg && *endptr == '\\0'); printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\" \" :stopped? %s :stopsig %d)\\n\", FLAG(WIFEXITED(status)), WEXITSTATUS(status), FLAG(WIFSIGNALED(status)), WTERMSIG(status), FLAG(WCOREDUMP(status)), FLAG(WIFSTOPPED(status)), WSTOPSIG(status)); fflush (NULL); return 0; } } ") (finish-output stream)) (let* ((outfile (system::pick-temporary-file-name)) (args (list "cc" "-o" outfile infile))) (warn "Running cc: ~{~a ~}~%" args) (call-program args :output t) (delete-file infile) outfile))) ;; FIXME: lisp:unicode-complete introduced in version 20d. #+#.(swank/backend:with-symbol 'unicode-complete 'lisp) (defun match-semi-standard (prefix matchp) ;; Handle the CMUCL's short character names. (loop for name in lisp::char-name-alist when (funcall matchp prefix (car name)) collect (car name))) #+#.(swank/backend:with-symbol 'unicode-complete 'lisp) (defimplementation character-completion-set (prefix matchp) (let ((names (lisp::unicode-complete prefix))) ;; Match prefix against semistandard names. If there's a match, ;; add it to our list of matches. (let ((semi-standard (match-semi-standard prefix matchp))) (when semi-standard (setf names (append semi-standard names)))) (setf names (mapcar #'string-capitalize names)) (loop for n in names when (funcall matchp prefix n) collect n))) slime-2.20/swank/corman.lisp000066400000000000000000000464001315100173500160410ustar00rootroot00000000000000;;; ;;; swank-corman.lisp --- Corman Lisp specific code for SLIME. ;;; ;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org) ;;; ;;; License ;;; ======= ;;; This software is provided 'as-is', without any express or implied ;;; warranty. In no event will the author be held liable for any damages ;;; arising from the use of this software. ;;; ;;; Permission is granted to anyone to use this software for any purpose, ;;; including commercial applications, and to alter it and redistribute ;;; it freely, subject to the following restrictions: ;;; ;;; 1. The origin of this software must not be misrepresented; you must ;;; not claim that you wrote the original software. If you use this ;;; software in a product, an acknowledgment in the product documentation ;;; would be appreciated but is not required. ;;; ;;; 2. Altered source versions must be plainly marked as such, and must ;;; not be misrepresented as being the original software. ;;; ;;; 3. This notice may not be removed or altered from any source ;;; distribution. ;;; ;;; Notes ;;; ===== ;;; You will need CCL 2.51, and you will *definitely* need to patch ;;; CCL with the patches at ;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME ;;; will blow up in your face. You should also follow the ;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime. ;;; ;;; The only communication style currently supported is NIL. ;;; ;;; Starting CCL inside emacs (with M-x slime) seems to work for me ;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 ;;; (sometimes it works, other times it hangs on start or hangs when ;;; initializing WinSock) - starting CCL externally and using M-x ;;; slime-connect always works fine. ;;; ;;; Sometimes CCL gets confused and starts giving you random memory ;;; access violation errors on startup; if this happens, try redumping ;;; your image. ;;; ;;; What works ;;; ========== ;;; * Basic editing and evaluation ;;; * Arglist display ;;; * Compilation ;;; * Loading files ;;; * apropos/describe ;;; * Debugger ;;; * Inspector ;;; ;;; TODO ;;; ==== ;;; * More debugger functionality (missing bits: restart-frame, ;;; return-from-frame, disassemble-frame, activate-stepping, ;;; toggle-trace) ;;; * XREF ;;; * Profiling ;;; * More sophisticated communication styles than NIL ;;; (in-package :swank/backend) ;;; Pull in various needed bits (require :composite-streams) (require :sockets) (require :winbase) (require :lp) (use-package :gs) ;; MOP stuff (defclass swank-mop:standard-slot-definition () () (:documentation "Dummy class created so that swank.lisp will compile and load.")) (defun named-by-gensym-p (c) (null (symbol-package (class-name c)))) (deftype swank-mop:eql-specializer () '(satisfies named-by-gensym-p)) (defun swank-mop:eql-specializer-object (specializer) (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) (loop (multiple-value-bind (more key value) (next-entry) (unless more (return nil)) (when (eq specializer value) (return key)))))) (defun swank-mop:class-finalized-p (class) (declare (ignore class)) t) (defun swank-mop:class-prototype (class) (make-instance class)) (defun swank-mop:specializer-direct-methods (obj) (declare (ignore obj)) nil) (defun swank-mop:generic-function-argument-precedence-order (gf) (generic-function-lambda-list gf)) (defun swank-mop:generic-function-method-combination (gf) (declare (ignore gf)) :standard) (defun swank-mop:generic-function-declarations (gf) (declare (ignore gf)) nil) (defun swank-mop:slot-definition-documentation (slot) (declare (ignore slot)) (getf slot :documentation nil)) (defun swank-mop:slot-definition-type (slot) (declare (ignore slot)) t) (import-swank-mop-symbols :cl '(;; classes :standard-slot-definition :eql-specializer :eql-specializer-object ;; standard class readers :class-default-initargs :class-direct-default-initargs :class-finalized-p :class-prototype :specializer-direct-methods ;; gf readers :generic-function-argument-precedence-order :generic-function-declarations :generic-function-method-combination ;; method readers ;; slot readers :slot-definition-documentation :slot-definition-type)) ;;;; swank implementations ;;; Debugger (defvar *stack-trace* nil) (defvar *frame-trace* nil) (defstruct frame name function address debug-info variables) (defimplementation call-with-debugging-environment (fn) (let* ((real-stack-trace (cl::stack-trace)) (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace :key #'car))) (*frame-trace* (let* ((db::*debug-level* (1+ db::*debug-level*)) (db::*debug-frame-pointer* (db::stash-ebp (ct:create-foreign-ptr))) (db::*debug-max-level* (length real-stack-trace)) (db::*debug-min-level* 1)) (cdr (member #'cl:invoke-debugger (cons (make-frame :function nil) (loop for i from db::*debug-min-level* upto db::*debug-max-level* until (eq (db::get-frame-function i) cl::*top-level*) collect (make-frame :function (db::get-frame-function i) :address (db::get-frame-address i)))) :key #'frame-function))))) (funcall fn))) (defimplementation compute-backtrace (start end) (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) collect f)) (defimplementation print-frame (frame stream) (format stream "~S" frame)) (defun get-frame-debug-info (frame) (or (frame-debug-info frame) (setf (frame-debug-info frame) (db::prepare-frame-debug-info (frame-function frame) (frame-address frame))))) (defimplementation frame-locals (frame-number) (let* ((frame (elt *frame-trace* frame-number)) (info (get-frame-debug-info frame))) (let ((var-list (loop for i from 4 below (length info) by 2 collect `(list :name ',(svref info i) :id 0 :value (db::debug-filter ,(svref info i)))))) (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) (setf (frame-variables frame) vars))))) (defimplementation eval-in-frame (form frame-number) (let ((frame (elt *frame-trace* frame-number))) (let ((cl::*compiler-environment* (get-frame-debug-info frame))) (eval form)))) (defimplementation frame-var-value (frame-number var) (let ((vars (frame-variables (elt *frame-trace* frame-number)))) (when vars (second (elt vars var))))) (defimplementation frame-source-location (frame-number) (fspec-location (frame-function (elt *frame-trace* frame-number)))) (defun break (&optional (format-control "Break") &rest format-arguments) (with-simple-restart (continue "Return from BREAK.") (let ();(*debugger-hook* nil)) (let ((condition (make-condition 'simple-condition :format-control format-control :format-arguments format-arguments))) ;;(format *debug-io* ";;; User break: ~A~%" condition) (invoke-debugger condition)))) nil) ;;; Socket communication (defimplementation create-socket (host port &key backlog) (sockets:start-sockets) (sockets:make-server-socket :host host :port port)) (defimplementation local-port (socket) (sockets:socket-port socket)) (defimplementation close-socket (socket) (close socket)) (defimplementation accept-connection (socket &key external-format buffering timeout) (declare (ignore buffering timeout external-format)) (sockets:make-socket-stream (sockets:accept-socket socket))) ;;; Misc (defimplementation preferred-communication-style () nil) (defimplementation getpid () ccl:*current-process-id*) (defimplementation lisp-implementation-type-name () "cormanlisp") (defimplementation quit-lisp () (sockets:stop-sockets) (win32:exitprocess 0)) (defimplementation set-default-directory (directory) (setf (ccl:current-directory) directory) (directory-namestring (setf *default-pathname-defaults* (truename (merge-pathnames directory))))) (defimplementation default-directory () (directory-namestring (ccl:current-directory))) (defimplementation macroexpand-all (form &optional env) (declare (ignore env)) (ccl:macroexpand-all form)) ;;; Documentation (defun fspec-location (fspec) (when (symbolp fspec) (setq fspec (symbol-function fspec))) (let ((file (ccl::function-source-file fspec))) (if file (handler-case (let ((truename (truename (merge-pathnames file ccl:*cormanlisp-directory*)))) (make-location (list :file (namestring truename)) (if (ccl::function-source-line fspec) (list :line (1+ (ccl::function-source-line fspec))) (list :function-name (princ-to-string (function-name fspec)))))) (error (c) (list :error (princ-to-string c)))) (list :error (format nil "No source information available for ~S" fspec))))) (defimplementation find-definitions (name) (list (list name (fspec-location name)))) (defimplementation arglist (name) (handler-case (cond ((and (symbolp name) (macro-function name)) (ccl::macro-lambda-list (symbol-function name))) (t (when (symbolp name) (setq name (symbol-function name))) (if (eq (class-of name) cl::the-class-standard-gf) (generic-function-lambda-list name) (ccl:function-lambda-list name)))) (error () :not-available))) (defimplementation function-name (fn) (handler-case (getf (cl::function-info-list fn) 'cl::function-name) (error () nil))) (defimplementation describe-symbol-for-emacs (symbol) (let ((result '())) (flet ((doc (kind &optional (sym symbol)) (or (documentation sym kind) :not-documented)) (maybe-push (property value) (when value (setf result (list* property value result))))) (maybe-push :variable (when (boundp symbol) (doc 'variable))) (maybe-push :function (if (fboundp symbol) (doc 'function))) (maybe-push :class (if (find-class symbol nil) (doc 'class))) result))) (defimplementation describe-definition (symbol namespace) (ecase namespace (:variable (describe symbol)) ((:function :generic-function) (describe (symbol-function symbol))) (:class (describe (find-class symbol))))) ;;; Compiler (defvar *buffer-name* nil) (defvar *buffer-position*) (defvar *buffer-string*) (defvar *compile-filename* nil) ;; FIXME (defimplementation call-with-compilation-hooks (FN) (handler-bind ((error (lambda (c) (signal 'compiler-condition :original-condition c :severity :warning :message (format nil "~A" c) :location (cond (*buffer-name* (make-location (list :buffer *buffer-name*) (list :offset *buffer-position* 0))) (*compile-filename* (make-location (list :file *compile-filename*) (list :position 1))) (t (list :error "No location"))))))) (funcall fn))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore external-format policy)) (with-compilation-hooks () (let ((*buffer-name* nil) (*compile-filename* input-file)) (multiple-value-bind (output-file warnings? failure?) (compile-file input-file :output-file output-file) (values output-file warnings? (or failure? (and load-p (load output-file)))))))) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore filename policy)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-position* position) (*buffer-string* string)) (funcall (compile nil (read-from-string (format nil "(~S () ~A)" 'lambda string)))) t))) ;;;; Inspecting ;; Hack to make swank.lisp load, at least (defclass file-stream ()) (defun comma-separated (list &optional (callback (lambda (v) `(:value ,v)))) (butlast (loop for e in list collect (funcall callback e) collect ", "))) (defmethod emacs-inspect ((class standard-class)) `("Name: " (:value ,(class-name class)) (:newline) "Super classes: " ,@(comma-separated (swank-mop:class-direct-superclasses class)) (:newline) "Direct Slots: " ,@(comma-separated (swank-mop:class-direct-slots class) (lambda (slot) `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot))))) (:newline) "Effective Slots: " ,@(if (swank-mop:class-finalized-p class) (comma-separated (swank-mop:class-slots class) (lambda (slot) `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot))))) '("#")) (: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))))) '("#")) (:newline))) (defmethod emacs-inspect ((slot cons)) ;; Inspects slot definitions (if (eq (car slot) :name) `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) ,@(when (swank-mop:slot-definition-documentation slot) `("Documentation:" (:newline) (:value ,(swank-mop:slot-definition-documentation slot)) (:newline))) "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline) "Init form: " ,(if (swank-mop:slot-definition-initfunction slot) `(:value ,(swank-mop:slot-definition-initform slot)) "#") (:newline) "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline)) (call-next-method))) (defmethod emacs-inspect ((pathname pathnames::pathname-internal)) (list* (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") '(:newline) (append (label-value-line* ("Namestring" (namestring pathname)) ("Host" (pathname-host pathname)) ("Device" (pathname-device pathname)) ("Directory" (pathname-directory pathname)) ("Name" (pathname-name pathname)) ("Type" (pathname-type pathname)) ("Version" (pathname-version pathname))) (unless (or (wild-pathname-p pathname) (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) (defmethod emacs-inspect ((o t)) (cond ((cl::structurep o) (inspect-structure o)) (t (call-next-method)))) (defun inspect-structure (o) (let* ((template (cl::uref o 1)) (num-slots (cl::struct-template-num-slots template))) (cond ((symbolp template) (loop for i below num-slots append (label-value-line i (cl::uref o (+ 2 i))))) (t (loop for i below num-slots append (label-value-line (elt template (+ 6 (* i 5))) (cl::uref o (+ 2 i)))))))) ;;; Threads (require 'threads) (defstruct (mailbox (:conc-name mailbox.)) thread (lock (make-instance 'threads:critical-section)) (queue '() :type list)) (defvar *mailbox-lock* (make-instance 'threads:critical-section)) (defvar *mailboxes* (list)) (defmacro with-lock (lock &body body) `(threads:with-synchronization (threads:cs ,lock) ,@body)) (defimplementation spawn (fun &key name) (declare (ignore name)) (th:create-thread (lambda () (handler-bind ((serious-condition #'invoke-debugger)) (unwind-protect (funcall fun) (with-lock *mailbox-lock* (setq *mailboxes* (remove cormanlisp:*current-thread-id* *mailboxes* :key #'mailbox.thread)))))))) (defimplementation thread-id (thread) thread) (defimplementation find-thread (thread) (if (thread-alive-p thread) thread)) (defimplementation thread-alive-p (thread) (if (threads:thread-handle thread) t nil)) (defimplementation current-thread () cormanlisp:*current-thread-id*) ;; XXX implement it (defimplementation all-threads () '()) ;; XXX something here is broken (defimplementation kill-thread (thread) (threads:terminate-thread thread 'killed)) (defun mailbox (thread) (with-lock *mailbox-lock* (or (find thread *mailboxes* :key #'mailbox.thread) (let ((mb (make-mailbox :thread thread))) (push mb *mailboxes*) mb)))) (defimplementation send (thread message) (let ((mbox (mailbox thread))) (with-lock (mailbox.lock mbox) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message)))))) (defimplementation receive () (let ((mbox (mailbox cormanlisp:*current-thread-id*))) (loop (with-lock (mailbox.lock mbox) (when (mailbox.queue mbox) (return (pop (mailbox.queue mbox))))) (sleep 0.1)))) ;;; This is probably not good, but it WFM (in-package :common-lisp) (defvar *old-documentation* #'documentation) (defun documentation (thing &optional (type 'function)) (if (symbolp thing) (funcall *old-documentation* thing type) (values))) (defmethod print-object ((restart restart) stream) (if (or *print-escape* *print-readably*) (print-unreadable-object (restart stream :type t :identity t) (princ (restart-name restart) stream)) (when (functionp (restart-report-function restart)) (funcall (restart-report-function restart) stream)))) slime-2.20/swank/ecl.lisp000066400000000000000000001037111315100173500153240ustar00rootroot00000000000000;;;; -*- 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 (defpackage swank/ecl (:use cl swank/backend)) (in-package swank/ecl) (eval-when (:compile-toplevel :load-toplevel :execute) (defun ecl-version () (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT))) (if version (symbol-value version) 0))) (when (< (ecl-version) 100301) (error "~&IMPORTANT:~% ~ The version of ECL you're using (~A) is too old.~% ~ Please upgrade to at least 10.3.1.~% ~ Sorry for the inconvenience.~%~%" (lisp-implementation-version)))) ;; Hard dependencies. (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sockets)) ;; Soft dependencies. (eval-when (:compile-toplevel :load-toplevel :execute) (when (probe-file "sys:profile.fas") (require :profile) (pushnew :profile *features*)) (when (probe-file "sys:serve-event.fas") (require :serve-event) (pushnew :serve-event *features*))) (declaim (optimize (debug 3))) ;;; Swank-mop (eval-when (:compile-toplevel :load-toplevel :execute) (import-swank-mop-symbols :clos (and (< (ecl-version) 121201) `(:eql-specializer :eql-specializer-object :generic-function-declarations :specializer-direct-methods ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) '(:compute-applicable-methods-using-classes)))))) (defimplementation gray-package-name () "GRAY") ;;;; UTF8 ;;; Convert the string STRING to a (simple-array (unsigned-byte 8)). ;;; ;;; string-to-utf8 (string) ;;; Convert the (simple-array (unsigned-byte 8)) OCTETS to a string. ;;; ;;; utf8-to-string (octets) ;;;; TCP Server (defun resolve-hostname (name) (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name name)))) (defimplementation create-socket (host port &key backlog) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) (defimplementation close-socket (socket) (sb-bsd-sockets:socket-close socket)) (defun accept (socket) "Like socket-accept, but retry on EAGAIN." (loop (handler-case (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) (defimplementation accept-connection (socket &key external-format buffering timeout) (declare (ignore timeout)) (sb-bsd-sockets:socket-make-stream (accept socket) :output t :input t :buffering (ecase buffering ((t) :full) ((nil) :none) (:line :line)) :element-type (if external-format 'character '(unsigned-byte 8)) :external-format external-format)) ;;; Call FN whenever SOCKET is readable. ;;; ;;; add-sigio-handler (socket fn) ;;; Remove all sigio handlers for SOCKET. ;;; ;;; remove-sigio-handlers (socket) ;;; Call FN when Lisp is waiting for input and SOCKET is readable. ;;; ;;; add-fd-handler (socket fn) ;;; Remove all fd-handlers for SOCKET. ;;; ;;; remove-fd-handlers (socket) (defimplementation preferred-communication-style () (cond ((member :threads *features*) :spawn) ((member :windows *features*) nil) (t #|:fd-handler|# nil))) ;;; Set the 'stream 'timeout. The timeout is either the real number ;;; specifying the timeout in seconds or 'nil for no timeout. ;;; ;;; set-stream-timeout (stream timeout) ;;; 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. ;;; ;;; emacs-connected () ;;;; Unix Integration (defimplementation getpid () (si:getpid)) ;;; Call FUNCTION on SIGINT (instead of invoking the debugger). ;;; Return old signal handler. ;;; ;;; install-sigint-handler (function) ;;; XXX! ;;; If ECL is built with thread support, it'll spawn a helper thread ;;; executing the SIGINT handler. We do not want to BREAK into that ;;; helper but into the main thread, though. This is coupled with the ;;; current choice of NIL as communication-style in so far as ECL's ;;; main-thread is also the Slime's REPL thread. (defun make-interrupt-handler (real-handler) #+threads (let ((main-thread (find 'si:top-level (mp:all-processes) :key #'mp:process-name))) #'(lambda (&rest args) (declare (ignore args)) (mp:interrupt-process main-thread real-handler))) #-threads #'(lambda (&rest args) (declare (ignore args)) (funcall real-handler))) (defimplementation call-with-user-break-handler (real-handler function) (let ((old-handler #'si:terminal-interrupt)) (setf (symbol-function 'si:terminal-interrupt) (make-interrupt-handler real-handler)) (unwind-protect (funcall function) (setf (symbol-function 'si:terminal-interrupt) old-handler)))) (defimplementation quit-lisp () (ext:quit)) ;;; Default implementation is fine. ;;; ;;; lisp-implementation-type-name ;;; lisp-implementation-program (defimplementation socket-fd (socket) (etypecase socket (fixnum socket) (two-way-stream (socket-fd (two-way-stream-input-stream socket))) (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) (file-stream (si:file-stream-fd socket)))) ;;; Create a character stream for the file descriptor FD. This ;;; interface implementation requires either `ffi:c-inline' or has to ;;; wait for the exported interface. ;;; ;;; make-fd-stream (socket-stream) ;;; Duplicate a file descriptor. If the syscall fails, signal a ;;; condition. See dup(2). This interface requiers `ffi:c-inline' or ;;; has to wait for the exported interface. ;;; ;;; dup (fd) ;;; Does not apply to ECL which doesn't dump images. ;;; ;;; exec-image (image-file args) (defimplementation command-line-args () (ext:command-args)) ;;;; pathnames ;;; Return a pathname for FILENAME. ;;; A filename in Emacs may for example contain asterisks which should not ;;; be translated to wildcards. ;;; ;;; filename-to-pathname (filename) ;;; Return the filename for PATHNAME. ;;; ;;; pathname-to-filename (pathname) (defimplementation default-directory () (namestring (ext:getcwd))) (defimplementation set-default-directory (directory) (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. (default-directory)) ;;; Call FN with hooks to handle special syntax. Can we use it for ;;; `ffi:c-inline' to be handled as C/C++ code? ;;; ;;; call-with-syntax-hooks ;;; Return a suitable initial value for SWANK:*READTABLE-ALIST*. ;;; ;;; default-readtable-alist ;;;; Packages #+package-local-nicknames (defimplementation package-local-nicknames (package) (ext:package-local-nicknames package)) ;;;; Compilation (defvar *buffer-name* nil) (defvar *buffer-start-position*) (defun signal-compiler-condition (&rest args) (apply #'signal 'compiler-condition args)) #-ecl-bytecmp (defun handle-compiler-message (condition) ;; ECL emits lots of noise in compiler-notes, like "Invoking ;; external command". (unless (typep condition 'c::compiler-note) (signal-compiler-condition :original-condition condition :message (princ-to-string condition) :severity (etypecase condition (c:compiler-fatal-error :error) (c:compiler-error :error) (error :error) (style-warning :style-warning) (warning :warning)) :location (condition-location condition)))) #-ecl-bytecmp (defun condition-location (condition) (let ((file (c:compiler-message-file condition)) (position (c:compiler-message-file-position condition))) (if (and position (not (minusp position))) (if *buffer-name* (make-buffer-location *buffer-name* *buffer-start-position* position) (make-file-location file position)) (make-error-location "No location found.")))) (defimplementation call-with-compilation-hooks (function) #+ecl-bytecmp (funcall function) #-ecl-bytecmp (handler-bind ((c:compiler-message #'handle-compiler-message)) (funcall function))) (defvar *tmpfile-map* (make-hash-table :test #'equal)) (defun note-buffer-tmpfile (tmp-file buffer-name) ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. (let ((tmp-namestring (namestring (truename tmp-file)))) (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) tmp-namestring)) (defun tmpfile-to-buffer (tmp-file) (gethash tmp-file *tmpfile-map*)) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore policy)) (with-compilation-hooks () (let ((*buffer-name* buffer) ; for compilation hooks (*buffer-start-position* position)) (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-")) (fasl-file) (warnings-p) (failure-p)) (unwind-protect (with-open-file (tmp-stream tmp-file :direction :output :if-exists :supersede) (write-string string tmp-stream) (finish-output tmp-stream) (multiple-value-setq (fasl-file warnings-p failure-p) (compile-file tmp-file :load t :source-truename (or filename (note-buffer-tmpfile tmp-file buffer)) :source-offset (1- position)))) (when (probe-file tmp-file) (delete-file tmp-file)) (when fasl-file (delete-file fasl-file))) (not failure-p))))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (with-compilation-hooks () (compile-file input-file :output-file output-file :load load-p :external-format external-format))) (defvar *external-format-to-coding-system* '((:latin-1 "latin-1" "latin-1-unix" "iso-latin-1-unix" "iso-8859-1" "iso-8859-1-unix") (:utf-8 "utf-8" "utf-8-unix"))) (defun external-format (coding-system) (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*)) (find coding-system (ext:all-encodings) :test #'string-equal))) (defimplementation find-external-format (coding-system) #+unicode (external-format coding-system) ;; Without unicode support, ECL uses the one-byte encoding of the ;; underlying OS, and will barf on anything except :DEFAULT. We ;; return NIL here for known multibyte encodings, so ;; SWANK:CREATE-SERVER will barf. #-unicode (let ((xf (external-format coding-system))) (if (member xf '(:utf-8)) nil :default))) ;;; Default implementation is fine ;;; ;;; guess-external-format ;;;; Streams ;;; Implemented in `gray' ;;; ;;; make-output-stream ;;; make-input-stream ;;;; Documentation (defimplementation arglist (name) (multiple-value-bind (arglist foundp) (ext:function-lambda-list name) (if foundp arglist :not-available))) (defimplementation type-specifier-p (symbol) (or (subtypep nil symbol) (not (eq (type-specifier-arglist symbol) :not-available)))) (defimplementation function-name (f) (typecase f (generic-function (clos:generic-function-name f)) (function (si:compiled-function-name f)))) ;;; Default implementation is fine (CL). ;;; ;;; valid-function-name-p (form) #+walker (defimplementation macroexpand-all (form &optional env) (walker:macroexpand-all form env)) ;;; Default implementation is fine. ;;; ;;; compiler-macroexpand-1 ;;; compiler-macroexpand (defimplementation collect-macro-forms (form &optional env) ;; Currently detects only normal macros, not compiler macros. (declare (ignore env)) (with-collected-macro-forms (macro-forms) (handler-bind ((warning #'muffle-warning)) (ignore-errors (compile nil `(lambda () ,form)))) (values macro-forms nil))) ;;; Expand the format string CONTROL-STRING. ;;; Default implementation is fine. ;;; ;;; format-string-expand (defimplementation describe-symbol-for-emacs (symbol) (let ((result '())) (flet ((frob (type boundp) (when (funcall boundp symbol) (let ((doc (describe-definition symbol type))) (setf result (list* type doc result)))))) (frob :VARIABLE #'boundp) (frob :FUNCTION #'fboundp) (frob :CLASS (lambda (x) (find-class x nil)))) result)) (defimplementation describe-definition (name type) (case type (:variable (documentation name 'variable)) (:function (documentation name 'function)) (:class (documentation name 'class)) (t nil))) ;;;; Debugging (eval-when (:compile-toplevel :load-toplevel :execute) (import '(si::*break-env* si::*ihs-top* si::*ihs-current* si::*ihs-base* si::*frs-base* si::*frs-top* si::*tpl-commands* si::*tpl-level* si::frs-top si::ihs-top si::ihs-fun si::ihs-env si::sch-frs-base si::set-break-env si::set-current-ihs si::tpl-commands))) (defun make-invoke-debugger-hook (hook) (when hook #'(lambda (condition old-hook) ;; Regard *debugger-hook* if set by user. (if *debugger-hook* nil ; decline, *DEBUGGER-HOOK* will be tried next. (funcall hook condition old-hook))))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook) (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) (funcall fun))) (defvar *backtrace* '()) (defun in-swank-package-p (x) (and (symbolp x) (member (symbol-package x) (list #.(find-package :swank) #.(find-package :swank/backend) #.(ignore-errors (find-package :swank-mop)) #.(ignore-errors (find-package :swank-loader)))) t)) (defun is-swank-source-p (name) (setf name (pathname name)) (pathname-match-p name (make-pathname :defaults swank-loader::*source-directory* :name (pathname-name name) :type (pathname-type name) :version (pathname-version name)))) (defun is-ignorable-fun-p (x) (or (in-swank-package-p (frame-name x)) (multiple-value-bind (file position) (ignore-errors (si::bc-file (car x))) (declare (ignore position)) (if file (is-swank-source-p file))))) (defimplementation call-with-debugging-environment (debugger-loop-fn) (declare (type function debugger-loop-fn)) (let* ((*ihs-top* (ihs-top)) (*ihs-current* *ihs-top*) (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*tpl-level* (1+ *tpl-level*)) (*backtrace* (loop for ihs from 0 below *ihs-top* collect (list (si::ihs-fun ihs) (si::ihs-env ihs) nil)))) (declare (special *ihs-current*)) (loop for f from *frs-base* until *frs-top* do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) (when (plusp i) (let* ((x (elt *backtrace* i)) (name (si::frs-tag f))) (unless (si::fixnump name) (push name (third x))))))) (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) (set-break-env) (set-current-ihs) (let ((*ihs-base* *ihs-top*)) (funcall debugger-loop-fn)))) (defimplementation compute-backtrace (start end) (subseq *backtrace* start (and (numberp end) (min end (length *backtrace*))))) (defun frame-name (frame) (let ((x (first frame))) (if (symbolp x) x (function-name x)))) (defun function-position (fun) (multiple-value-bind (file position) (si::bc-file fun) (when file (make-file-location file position)))) (defun frame-function (frame) (let* ((x (first frame)) fun position) (etypecase x (symbol (and (fboundp x) (setf fun (fdefinition x) position (function-position fun)))) (function (setf fun x position (function-position x)))) (values fun position))) (defun frame-decode-env (frame) (let ((functions '()) (blocks '()) (variables '())) (setf frame (si::decode-ihs-env (second frame))) (dolist (record (remove-if-not #'consp frame)) (let* ((record0 (car record)) (record1 (cdr record))) (cond ((or (symbolp record0) (stringp record0)) (setq variables (acons record0 record1 variables))) ((not (si::fixnump record0)) (push record1 functions)) ((symbolp record1) (push record1 blocks)) (t )))) (values functions blocks variables))) (defimplementation print-frame (frame stream) (format stream "~A" (first frame))) ;;; Is the frame FRAME restartable?. ;;; Return T if `restart-frame' can safely be called on the frame. ;;; ;;; frame-restartable-p (frame) (defimplementation frame-source-location (frame-number) (nth-value 1 (frame-function (elt *backtrace* frame-number)))) (defimplementation frame-catch-tags (frame-number) (third (elt *backtrace* frame-number))) (defimplementation frame-locals (frame-number) (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) collect (list :name name :id 0 :value value))) (defimplementation frame-var-value (frame-number var-number) (destructuring-bind (name . value) (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-number) (declare (ignore name)) value)) (defimplementation disassemble-frame (frame-number) (let ((fun (frame-function (elt *backtrace* frame-number)))) (disassemble fun))) (defimplementation eval-in-frame (form frame-number) (let ((env (second (elt *backtrace* frame-number)))) (si:eval-with-env form env))) ;;; frame-package ;;; frame-call ;;; return-from-frame ;;; restart-frame ;;; print-condition ;;; condition-extras (defimplementation gdb-initial-commands () ;; These signals are used by the GC. #+linux '("handle SIGPWR noprint nostop" "handle SIGXCPU noprint nostop")) ;;; active-stepping ;;; sldb-break-on-return ;;; sldb-break-at-start ;;; sldb-stepper-condition-p ;;; sldb-setp-into ;;; sldb-step-next ;;; sldb-step-out ;;;; Definition finding (defvar +TAGS+ (namestring (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")))) (defun make-file-location (file file-position) ;; File positions in CL start at 0, but Emacs' buffer positions ;; start at 1. We specify (:ALIGN T) because the positions comming ;; from ECL point at right after the toplevel form appearing before ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. (make-location `(:file ,(namestring (translate-logical-pathname file))) `(:position ,(1+ file-position)) `(:align t))) (defun make-buffer-location (buffer-name start-position &optional (offset 0)) (make-location `(:buffer ,buffer-name) `(:offset ,start-position ,offset) `(:align t))) (defun make-TAGS-location (&rest tags) (make-location `(:etags-file ,+TAGS+) `(:tag ,@tags))) (defimplementation find-definitions (name) (let ((annotations (ext:get-annotation name 'si::location :all))) (cond (annotations (loop for annotation in annotations collect (destructuring-bind (dspec file . pos) annotation `(,dspec ,(make-file-location file pos))))) (t (mapcan #'(lambda (type) (find-definitions-by-type name type)) (classify-definition-name name)))))) (defun classify-definition-name (name) (let ((types '())) (when (fboundp name) (cond ((special-operator-p name) (push :special-operator types)) ((macro-function name) (push :macro types)) ((typep (fdefinition name) 'generic-function) (push :generic-function types)) ((si:mangle-name name t) (push :c-function types)) (t (push :lisp-function types)))) (when (boundp name) (cond ((constantp name) (push :constant types)) (t (push :global-variable types)))) types)) (defun find-definitions-by-type (name type) (ecase type (:lisp-function (when-let (loc (source-location (fdefinition name))) (list `((defun ,name) ,loc)))) (:c-function (when-let (loc (source-location (fdefinition name))) (list `((c-source ,name) ,loc)))) (:generic-function (loop for method in (clos:generic-function-methods (fdefinition name)) for specs = (clos:method-specializers method) for loc = (source-location method) when loc collect `((defmethod ,name ,specs) ,loc))) (:macro (when-let (loc (source-location (macro-function name))) (list `((defmacro ,name) ,loc)))) (:constant (when-let (loc (source-location name)) (list `((defconstant ,name) ,loc)))) (:global-variable (when-let (loc (source-location name)) (list `((defvar ,name) ,loc)))) (:special-operator))) ;;; FIXME: There ought to be a better way. (eval-when (:compile-toplevel :load-toplevel :execute) (defun c-function-name-p (name) (and (symbolp name) (si:mangle-name name t) t)) (defun c-function-p (object) (and (functionp object) (let ((fn-name (function-name object))) (and fn-name (c-function-name-p fn-name)))))) (deftype c-function () `(satisfies c-function-p)) (defun assert-source-directory () (unless (probe-file #P"SRC:") (error "ECL's source directory ~A does not exist. ~ You can specify a different location via the environment ~ variable `ECLSRCDIR'." (namestring (translate-logical-pathname #P"SYS:"))))) (defun assert-TAGS-file () (unless (probe-file +TAGS+) (error "No TAGS file ~A found. It should have been installed with ECL." +TAGS+))) (defun package-names (package) (cons (package-name package) (package-nicknames package))) (defun source-location (object) (converting-errors-to-error-location (typecase object (c-function (assert-source-directory) (assert-TAGS-file) (let ((lisp-name (function-name object))) (assert lisp-name) (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t) (assert flag) ;; In ECL's code base sometimes the mangled name is used ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or ;; @EXT::SYMBOL is used. We cannot predict here, so we just ;; provide several candidates. (apply #'make-TAGS-location c-name (loop with s = (symbol-name lisp-name) for p in (package-names (symbol-package lisp-name)) collect (format nil "~A::~A" p s) collect (format nil "~(~A::~A~)" p s)))))) (function (multiple-value-bind (file pos) (ext:compiled-function-file object) (cond ((not file) (return-from source-location nil)) ((tmpfile-to-buffer file) (make-buffer-location (tmpfile-to-buffer file) pos)) (t (assert (probe-file file)) (assert (not (minusp pos))) (make-file-location file pos))))) (method ;; FIXME: This will always return NIL at the moment; ECL does not ;; store debug information for methods yet. (source-location (clos:method-function object))) ((member nil t) (multiple-value-bind (flag c-name) (si:mangle-name object) (assert flag) (make-TAGS-location c-name)))))) (defimplementation find-source-location (object) (or (source-location object) (make-error-location "Source definition of ~S not found." object))) ;;; buffer-first-change ;;;; XREF ;;; who-calls ;;; calls-who ;;; who-references ;;; who-binds ;;; who-sets ;;; who-macroexpands ;;; who-specializes ;;; list-callers ;;; list-callees ;;;; Profiling ;;; XXX: use monitor.lisp (ccl,clisp) #+profile (progn (defimplementation profile (fname) (when fname (eval `(profile:profile ,fname)))) (defimplementation unprofile (fname) (when fname (eval `(profile:unprofile ,fname)))) (defimplementation unprofile-all () (profile:unprofile-all) "All functions unprofiled.") (defimplementation profile-report () (profile:report)) (defimplementation profile-reset () (profile:reset) "Reset profiling counters.") (defimplementation profiled-functions () (profile:profile)) (defimplementation profile-package (package callers methods) (declare (ignore callers methods)) (eval `(profile:profile ,(package-name (find-package package))))) ) ; #+profile (progn ... ;;;; Trace ;;; 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) ;;; ;;; toggle-trace (spec) ;;;; Inspector ;;; FIXME: Would be nice if it was possible to inspect objects ;;; implemented in C. ;;; Return a list of bindings corresponding to OBJECT's slots. ;;; eval-context (object) ;;; Return a string describing the primitive type of object. ;;; describe-primitive-type (object) ;;;; Multithreading ;;; Not needed in ECL ;;; ;;; initialize-multiprocessing #+threads (progn (defvar *thread-id-counter* 0) (defparameter *thread-id-map* (make-hash-table)) (defvar *thread-id-map-lock* (mp:make-lock :name "thread id map lock")) (defimplementation spawn (fn &key name) (mp:process-run-function name fn)) (defimplementation thread-id (target-thread) (block thread-id (mp:with-lock (*thread-id-map-lock*) ;; Does TARGET-THREAD have an id already? (maphash (lambda (id thread-pointer) (let ((thread (si:weak-pointer-value thread-pointer))) (cond ((not thread) (remhash id *thread-id-map*)) ((eq thread target-thread) (return-from thread-id id))))) *thread-id-map*) ;; TARGET-THREAD not found in *THREAD-ID-MAP* (let ((id (incf *thread-id-counter*)) (thread-pointer (si:make-weak-pointer target-thread))) (setf (gethash id *thread-id-map*) thread-pointer) id)))) (defimplementation find-thread (id) (mp:with-lock (*thread-id-map-lock*) (let* ((thread-ptr (gethash id *thread-id-map*)) (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) (unless thread (remhash id *thread-id-map*)) thread))) (defimplementation thread-name (thread) (mp:process-name thread)) (defimplementation thread-status (thread) (if (mp:process-active-p thread) "RUNNING" "STOPPED")) ;; thread-attributes (defimplementation current-thread () mp:*current-process*) (defimplementation all-threads () (mp:all-processes)) (defimplementation thread-alive-p (thread) (mp:process-active-p thread)) (defimplementation interrupt-thread (thread fn) (mp:interrupt-process thread fn)) (defimplementation kill-thread (thread) (mp:process-kill thread)) (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) (defvar *mailboxes* (list)) (declaim (type list *mailboxes*)) (defstruct (mailbox (:conc-name mailbox.)) thread (mutex (mp:make-lock)) (cvar (mp:make-condition-variable)) (queue '() :type list)) (defun mailbox (thread) "Return THREAD's mailbox." (mp:with-lock (*mailbox-lock*) (or (find thread *mailboxes* :key #'mailbox.thread) (let ((mb (make-mailbox :thread thread))) (push mb *mailboxes*) mb)))) (defimplementation send (thread message) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) (mp:with-lock (mutex) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) (mp:condition-variable-broadcast (mailbox.cvar mbox))))) ;; receive (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox (current-thread))) (mutex (mailbox.mutex mbox))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-lock (mutex) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail)))) (when (eq timeout t) (return (values nil t))) (mp:condition-variable-wait (mailbox.cvar mbox) mutex))))) ;; Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using ;; asynchronous interrupts. ;; ;; Doesn't have to implement this if RECEIVE-IF periodically calls ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient. ;; ;; wake-thread (thread) ;; Copied from sbcl.lisp and adjusted to ECL. (let ((alist '()) (mutex (mp:make-lock :name "register-thread"))) (defimplementation register-thread (name thread) (declare (type symbol name)) (mp:with-lock (mutex) (etypecase thread (null (setf alist (delete name alist :key #'car))) (mp:process (let ((probe (assoc name alist))) (cond (probe (setf (cdr probe) thread)) (t (setf alist (acons name thread alist)))))))) nil) (defimplementation find-registered (name) (mp:with-lock (mutex) (cdr (assoc name alist))))) ;; Not needed in ECL (?). ;; ;; set-default-initial-binding (var form) ) ; #+threads ;;; Instead of busy waiting with communication-style NIL, use select() ;;; on the sockets' streams. #+serve-event (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (flet ((poll-streams (streams timeout) (let* ((serve-event::*descriptor-handlers* (copy-list serve-event::*descriptor-handlers*)) (active-fds '()) (fd-stream-alist (loop for s in streams for fd = (socket-fd s) collect (cons fd s) do (serve-event:add-fd-handler fd :input #'(lambda (fd) (push fd active-fds)))))) (serve-event:serve-event timeout) (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))) (loop (cond ((check-slime-interrupts) (return :interrupt)) (timeout (return (poll-streams streams 0))) (t (when-let (ready (poll-streams streams 0.2)) (return ready))))))) #-serve-event (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (loop (cond ((check-slime-interrupts) (return :interrupt)) (timeout (return (remove-if-not #'listen streams))) (t (let ((ready (remove-if-not #'listen streams))) (if ready (return ready)) (sleep 0.1)))))) ;;;; Locks #+threads (defimplementation make-lock (&key name) (mp:make-lock :name name :recursive t)) (defimplementation call-with-lock-held (lock function) (declare (type function function)) (mp:with-lock (lock) (funcall function))) ;;;; Weak datastructures #+ecl-weak-hash (progn (defimplementation make-weak-key-hash-table (&rest args) (apply #'make-hash-table :weakness :key args)) (defimplementation make-weak-value-hash-table (&rest args) (apply #'make-hash-table :weakness :value args)) (defimplementation hash-table-weakness (hashtable) (ext:hash-table-weakness hashtable))) ;;;; Character names ;;; Default implementation is fine. ;;; ;;; character-completion-set (prefix matchp) ;;;; Heap dumps ;;; Doesn't apply to ECL. ;;; ;;; save-image (filename &optional restart-function) ;;; background-save-image (filename &key restart-function completion-function) ;;;; Wrapping ;;; Intercept future calls to SPEC and surround them in callbacks. ;;; Very much similar to so-called advices for normal functions. ;;; ;;; wrap (spec indicator &key before after replace) ;;; unwrap (spec indicator) ;;; wrapped-p (spec indicator) slime-2.20/swank/gray.lisp000066400000000000000000000121751315100173500155260ustar00rootroot00000000000000;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- ;;; ;;; swank-gray.lisp --- Gray stream based IO redirection. ;;; ;;; Created 2003 ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; (in-package swank/backend) #.(progn (defvar *gray-stream-symbols* '(fundamental-character-output-stream stream-write-char stream-write-string stream-fresh-line stream-force-output stream-finish-output fundamental-character-input-stream stream-read-char stream-peek-char stream-read-line stream-listen stream-unread-char stream-clear-input stream-line-column stream-read-char-no-hang)) nil) (defpackage swank/gray (:use cl swank/backend) (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) (:export . #.*gray-stream-symbols*)) (in-package swank/gray) (defclass slime-output-stream (fundamental-character-output-stream) ((output-fn :initarg :output-fn) (buffer :initform (make-string 8000)) (fill-pointer :initform 0) (column :initform 0) (lock :initform (make-lock :name "buffer write lock")))) (defmacro with-slime-output-stream (stream &body body) `(with-slots (lock output-fn buffer fill-pointer column) ,stream (call-with-lock-held lock (lambda () ,@body)))) (defmethod stream-write-char ((stream slime-output-stream) char) (with-slime-output-stream stream (setf (schar buffer fill-pointer) char) (incf fill-pointer) (incf column) (when (char= #\newline char) (setf column 0)) (when (= fill-pointer (length buffer)) (finish-output stream))) char) (defmethod stream-write-string ((stream slime-output-stream) string &optional start end) (with-slime-output-stream stream (let* ((start (or start 0)) (end (or end (length string))) (len (length buffer)) (count (- end start)) (free (- len fill-pointer))) (when (>= count free) (stream-finish-output stream)) (cond ((< count len) (replace buffer string :start1 fill-pointer :start2 start :end2 end) (incf fill-pointer count)) (t (funcall output-fn (subseq string start end)))) (let ((last-newline (position #\newline string :from-end t :start start :end end))) (setf column (if last-newline (- end last-newline 1) (+ column count)))))) string) (defmethod stream-line-column ((stream slime-output-stream)) (with-slime-output-stream stream column)) (defmethod stream-finish-output ((stream slime-output-stream)) (with-slime-output-stream stream (unless (zerop fill-pointer) (funcall output-fn (subseq buffer 0 fill-pointer)) (setf fill-pointer 0))) nil) (defmethod stream-force-output ((stream slime-output-stream)) (stream-finish-output stream)) (defmethod stream-fresh-line ((stream slime-output-stream)) (with-slime-output-stream stream (cond ((zerop column) nil) (t (terpri stream) t)))) (defclass slime-input-stream (fundamental-character-input-stream) ((input-fn :initarg :input-fn) (buffer :initform "") (index :initform 0) (lock :initform (make-lock :name "buffer read lock")))) (defmethod stream-read-char ((s slime-input-stream)) (call-with-lock-held (slot-value s 'lock) (lambda () (with-slots (buffer index input-fn) s (when (= index (length buffer)) (let ((string (funcall input-fn))) (cond ((zerop (length string)) (return-from stream-read-char :eof)) (t (setf buffer string) (setf index 0))))) (assert (plusp (length buffer))) (prog1 (aref buffer index) (incf index)))))) (defmethod stream-listen ((s slime-input-stream)) (call-with-lock-held (slot-value s 'lock) (lambda () (with-slots (buffer index) s (< index (length buffer)))))) (defmethod stream-unread-char ((s slime-input-stream) char) (call-with-lock-held (slot-value s 'lock) (lambda () (with-slots (buffer index) s (decf index) (cond ((eql (aref buffer index) char) (setf (aref buffer index) char)) (t (warn "stream-unread-char: ignoring ~S (expected ~S)" char (aref buffer index))))))) nil) (defmethod stream-clear-input ((s slime-input-stream)) (call-with-lock-held (slot-value s 'lock) (lambda () (with-slots (buffer index) s (setf buffer "" index 0)))) nil) (defmethod stream-line-column ((s slime-input-stream)) nil) (defmethod stream-read-char-no-hang ((s slime-input-stream)) (call-with-lock-held (slot-value s 'lock) (lambda () (with-slots (buffer index) s (when (< index (length buffer)) (prog1 (aref buffer index) (incf index))))))) ;;; (defimplementation make-output-stream (write-string) (make-instance 'slime-output-stream :output-fn write-string)) (defimplementation make-input-stream (read-string) (make-instance 'slime-input-stream :input-fn read-string)) slime-2.20/swank/lispworks.lisp000066400000000000000000001100071315100173500166120ustar00rootroot00000000000000;;; -*- 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. ;;; (defpackage swank/lispworks (:use cl swank/backend)) (in-package swank/lispworks) (eval-when (:compile-toplevel :load-toplevel :execute) (require "comm")) (defimplementation gray-package-name () "STREAM") (import-swank-mop-symbols :clos '(:slot-definition-documentation :slot-boundp-using-class :slot-value-using-class :slot-makunbound-using-class :eql-specializer :eql-specializer-object :compute-applicable-methods-using-classes)) (defun swank-mop:slot-definition-documentation (slot) (documentation slot t)) (defun swank-mop:slot-boundp-using-class (class object slotd) (clos:slot-boundp-using-class class object (clos:slot-definition-name slotd))) (defun swank-mop:slot-value-using-class (class object slotd) (clos:slot-value-using-class class object (clos:slot-definition-name slotd))) (defun (setf swank-mop:slot-value-using-class) (value class object slotd) (setf (clos:slot-value-using-class class object (clos:slot-definition-name slotd)) value)) (defun swank-mop:slot-makunbound-using-class (class object slotd) (clos:slot-makunbound-using-class class object (clos:slot-definition-name slotd))) (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)) (eval-when (:compile-toplevel :execute :load-toplevel) (defvar *original-defimplementation* (macro-function 'defimplementation)) (defmacro defimplementation (&whole whole name args &body body &environment env) (declare (ignore args body)) `(progn (dspec:record-definition '(defun ,name) (dspec:location) :check-redefinition-p nil) ,(funcall *original-defimplementation* whole env)))) ;;; UTF8 (defimplementation string-to-utf8 (string) (ef:encode-lisp-string string '(:utf-8 :eol-style :lf))) (defimplementation utf8-to-string (octets) (ef:decode-external-string octets '(:utf-8 :eol-style :lf))) ;;; 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 &key backlog) (multiple-value-bind (socket where errno) #-(or lispworks4.1 (and macosx lispworks4.3)) (comm::create-tcp-socket-for-service port :address host :backlog (or backlog 5)) #+(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)) (let* ((fd (comm::get-fd-from-socket socket))) (assert (/= fd -1)) (cond ((not external-format) (make-instance 'comm:socket-stream :socket fd :direction :io :read-timeout timeout :element-type '(unsigned-byte 8))) (t (assert (valid-external-format-p external-format)) (ecase (first external-format) ((:latin-1 :ascii) (make-instance 'comm:socket-stream :socket fd :direction :io :read-timeout timeout :element-type 'base-char)) (:utf-8 (make-flexi-stream (make-instance 'comm:socket-stream :socket fd :direction :io :read-timeout timeout :element-type '(unsigned-byte 8)) external-format))))))) (defun make-flexi-stream (stream external-format) (unless (member :flexi-streams *features*) (error "Cannot use external format ~A~ without having installed flexi-streams in the inferior-lisp." external-format)) (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM") stream :external-format (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") external-format))) ;;; Coding Systems (defun valid-external-format-p (external-format) (member external-format *external-format-to-coding-system* :test #'equal :key #'car)) (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))) (defun set-sigint-handler () ;; Set SIGINT handler on Swank request handler thread. #-win32 (sys::set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*))) #-win32 (defimplementation install-sigint-handler (handler) (sys::set-signal-handler +sigint+ (let ((self mp:*current-process*)) (lambda (&rest args) (declare (ignore args)) (mp:process-interrupt self handler))))) (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 (defun map-list (function list) "Map over proper and not proper lists." (loop for (car . cdr) on list collect (funcall function car) into result when (null cdr) return result when (atom cdr) return (nconc result (funcall function cdr)))) (defun replace-strings-with-symbols (tree) (map-list (lambda (x) (typecase x (list (replace-strings-with-symbols x)) (symbol x) (string (intern x)) (t (intern (write-to-string x))))) tree)) (defimplementation arglist (symbol-or-function) (let ((arglist (lw:function-lambda-list symbol-or-function))) (etypecase arglist ((member :dont-know) :not-available) (list (replace-strings-with-symbols arglist))))) (defimplementation function-name (function) (nth-value 2 (function-lambda-expression function))) (defimplementation macroexpand-all (form &optional env) (declare (ignore env)) (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 (or (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 ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" symbol (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))) (defimplementation type-specifier-p (symbol) (or (ignore-errors (subtypep nil symbol)) (not (eq (type-specifier-arglist symbol) :not-available)))) ;;; 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 condition)) (swank:swank-debugger-hook condition *debugger-hook*)) (defmethod env-internals:environment-display-debugger ((env slime-env)) *debug-io*) (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args) (apply #'swank:y-or-n-p-in-emacs msg args)) (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook)) (env:with-environment ((slime-env hook '())) (funcall fun)))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) (setf (env:environment) (slime-env function '()))) (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*) (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." (flet ((find-named-frame (name) (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) name))) (nth-next-frame frame 1))))) (or (find-named-frame 'invoke-debugger) (find-named-frame 'swank::safe-backtrace) ;; if we can't find a likely top 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) (kind nil)) (loop for arg in (dbg::call-frame-arglist frame) if (eq kind '&rest) nconc (handler-case (dbg::dbg-eval arg frame) (error (e) (list (format nil "<~A>" arg)))) and do (loop-finish) else if (member arg '(&rest &optional &key)) do (setq kind arg) else nconc (handler-case (nconc (and (eq kind '&key) (list (cond ((symbolp arg) (intern (symbol-name arg) :keyword)) ((and (consp arg) (symbolp (car arg))) (intern (symbol-name (car arg)) :keyword)) (t (caar arg))))) (list (dbg::dbg-eval (cond ((symbolp arg) arg) ((and (consp arg) (symbolp (car arg))) (car arg)) (t (cadar arg))) frame))) (error (e) (list (format nil "<~A>" arg))))))) (defimplementation print-frame (frame stream) (cond ((dbg::call-frame-p frame) (prin1 (cons (dbg::call-frame-function-name frame) (frame-actual-args frame)) stream)) (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-source-location (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))) (path (and (dbg::call-frame-p frame) (dbg::call-frame-edit-path frame)))) (if dspec (frame-location dspec cname path)))))) (defimplementation eval-in-frame (form frame-number) (let ((frame (nth-frame frame-number))) (dbg::dbg-eval form frame))) (defun function-name-package (name) (typecase name (null nil) (symbol (symbol-package name)) ((cons (eql hcl:subfunction)) (destructuring-bind (name parent) (cdr name) (declare (ignore name)) (function-name-package parent))) ((cons (eql lw:top-level-form)) nil) (t nil))) (defimplementation frame-package (frame-number) (let ((frame (nth-frame frame-number))) (if (dbg::call-frame-p frame) (function-name-package (dbg::call-frame-function-name 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))) (defimplementation disassemble-frame (frame-number) (let* ((frame (nth-frame frame-number))) (when (dbg::call-frame-p frame) (let ((function (dbg::get-call-frame-function frame))) (disassemble function))))) ;;; Definition finding (defun frame-location (dspec callee-name edit-path) (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))) (path (edit-path-to-cmucl-source-path edit-path))) (make-dspec-location rdspec location `(:call-site ,name :edit-path ,path))))) (t (list :error (format nil "Source location not available for: ~S" dspec)))))) ;; dbg::call-frame-edit-path is not documented but lets assume the ;; binary representation of the integer EDIT-PATH should be ;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the ;; same as cadadddr. Something is odd with the highest bit. (defun edit-path-to-cmucl-source-path (edit-path) (and edit-path (cons 0 (let ((n -1)) (loop for i from (1- (integer-length edit-path)) downto 0 if (logbitp i edit-path) do (incf n) else collect (prog1 n (setq n 0))))))) ;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1) (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 (multiple-value-prog1 (progn ,@body) (signal-error-data-base compiler::*error-database* ,location) (signal-undefined-functions compiler::*unknown-functions* ,location)))))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (with-swank-compilation-unit (input-file) (compile-file input-file :output-file output-file :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) (multiple-value-bind (condition path) (if (consp c) (values (car c) (cdr c)) (values c nil)) (funcall fn filename dspec condition path)))))) (defun lispworks-severity (condition) (cond ((not condition) :warning) (t (etypecase condition #-(or lispworks4 lispworks5) (conditions:compiler-note :note) (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))) (defvar *temp-file-format* '(:utf-8 :eol-style :lf)) (defun compile-from-temp-file (string filename) (unwind-protect (progn (with-open-file (s filename :direction :output :if-exists :supersede :external-format *temp-file-format*) (write-string string s) (finish-output s)) (multiple-value-bind (binary-filename warnings? failure?) (compile-file filename :load t :external-format *temp-file-format*) (declare (ignore warnings?)) (when binary-filename (delete-file binary-filename)) (not failure?))) (delete-file filename))) (defun dspec-function-name-position (dspec fallback) (etypecase dspec (cons (let ((name (dspec:dspec-primary-name dspec))) (typecase name ((or symbol string) (list :function-name (string name))) (t fallback)))) (null fallback) (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))))) (defun skip-comments (stream) (let ((pos0 (file-position stream))) (cond ((equal (ignore-errors (list (read-delimited-list #\( stream))) '(())) (file-position stream (1- (file-position stream)))) (t (file-position stream pos0))))) #-(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 (progn (skip-comments stream) (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) (ignore-errors (dspec-stream-position stream dspec)))) (if pos (list :position (1+ pos)) (dspec-function-name-position dspec `(:position 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) location (declare (ignore _)) (make-location `(:buffer ,buffer) (dspec-function-name-position dspec `(:offset ,offset 0)) hints))))) (defun make-dspec-progenitor-location (dspec location edit-path) (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 (if edit-path (list :edit-path (edit-path-to-cmucl-source-path edit-path)))))) (defun signal-error-data-base (database &optional location) (map-error-database database (lambda (filename dspec condition edit-path) (signal-compiler-condition (format nil "~A" condition) (make-dspec-progenitor-location dspec (or location filename) edit-path) condition)))) (defun unmangle-unfun (symbol) "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to function names like \(SETF GET)." (cond ((sys::setf-symbol-p symbol) (sys::setf-pair-from-underlying-name symbol)) (t 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) nil))) htab)) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore filename policy)) (assert buffer) (assert position) (let* ((location (list :emacs-buffer buffer position)) (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-Unix-Lisp (sys:callablep object) #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) (sys:compiled-code-p 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))))) (defun list-callees-internal (name) (let ((callees '())) (system::find-constant$funcallable 'junk name :test #'(lambda (junk constant) (declare (ignore junk)) (when (and (symbolp constant) (fboundp constant)) (pushnew (list 'function constant) callees :test 'equal)) ;; Return nil so we iterate over all constants. nil)) callees)) ;; 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 (defmethod emacs-inspect ((o t)) (lispworks-inspect o)) (defmethod emacs-inspect ((o function)) (lispworks-inspect o)) ;; FIXME: slot-boundp-using-class in LW works with names so we can't ;; use our method in swank.lisp. (defmethod emacs-inspect ((o standard-object)) (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)) (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) (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)) (defstruct (mailbox (:conc-name mailbox.)) (mutex (mp:make-lock :name "thread mailbox")) (queue '() :type list)) (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) (make-mailbox))))) (defimplementation receive-if (test &optional timeout) (let* ((mbox (mailbox mp:*current-process*)) (lock (mailbox.mutex mbox))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (mp:with-lock (lock "receive-if/try") (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail))))) (when (eq timeout t) (return (values nil t))) (mp:process-wait-with-timeout "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox))))))) (defimplementation send (thread message) (let ((mbox (mailbox thread))) (mp:with-lock ((mailbox.mutex mbox)) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message)))))) (let ((alist '()) (lock (mp:make-lock :name "register-thread"))) (defimplementation register-thread (name thread) (declare (type symbol name)) (mp:with-lock (lock) (etypecase thread (null (setf alist (delete name alist :key #'car))) (mp:process (let ((probe (assoc name alist))) (cond (probe (setf (cdr probe) thread)) (t (setf alist (acons name thread alist)))))))) nil) (defimplementation find-registered (name) (mp:with-lock (lock) (cdr (assoc name alist))))) (defimplementation set-default-initial-binding (var form) (setq mp:*process-initial-bindings* (acons var `(eval (quote ,form)) mp:*process-initial-bindings* ))) (defimplementation thread-attributes (thread) (list :priority (mp:process-priority thread) :idle (mp:process-idle-time thread))) ;;;; 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)) slime-2.20/swank/match.lisp000066400000000000000000000214721315100173500156600ustar00rootroot00000000000000;; ;; SELECT-MATCH macro (and IN macro) ;; ;; Copyright 1990 Stephen Adams ;; ;; You are free to copy, distribute and make derivative works of this ;; source provided that this copyright notice is displayed near the ;; beginning of the file. No liability is accepted for the ;; correctness or performance of the code. If you modify the code ;; please indicate this fact both at the place of modification and in ;; this copyright message. ;; ;; Stephen Adams ;; Department of Electronics and Computer Science ;; University of Southampton ;; SO9 5NH, UK ;; ;; sra@ecs.soton.ac.uk ;; ;; ;; Synopsis: ;; ;; (select-match expression ;; (pattern action+)*) ;; ;; --- or --- ;; ;; (select-match expression ;; pattern => expression ;; pattern => expression ;; ...) ;; ;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) ;; | symbol ;matches anything ;; | 'anything ;must be EQUAL ;; | (pattern = pattern) ;both patterns must match ;; | (#'function pattern) ;predicate test ;; | (pattern . pattern) ;cons cell ;; ;; Example ;; ;; (select-match item ;; (('if e1 e2 e3) 'if-then-else) ;(1) ;; ((#'oddp k) 'an-odd-integer) ;(2) ;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) ;; (other 'anything-else)) ;(4) ;; ;; Notes ;; ;; . Each pattern is tested in turn. The first match is taken. ;; ;; . If no pattern matches, an error is signalled. ;; ;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. ;; numbers, strings, characters, etc.) match things which are EQUAL. ;; ;; . Quoted patterns (which are CONSTANTP) are constants. ;; ;; . Symbols match anything. The symbol is bound to the matched item ;; for the execution of the actions. ;; For example, (SELECT-MATCH '(1 2 3) ;; (1 . X) => X) ;; returns (2 3) because X is bound to the cdr of the candidate. ;; ;; . The two pattern match (p1 = p2) can be used to name parts ;; of the matched structure. For example, (ALL = (HD . TL)) ;; matches a cons cell. ALL is bound to the cons cell, HD to its car ;; and TL to its tail. ;; ;; . A predicate test applies the predicate to the item being matched. ;; If the predicate returns NIL then the match fails. ;; If it returns truth, then the nested pattern is matched. This is ;; often just a symbol like K in the example. ;; ;; . Care should be taken with the domain values for predicate matches. ;; If, in the above eg, item is not an integer, an error would occur ;; during the test. A safer pattern would be ;; (#'integerp (#'oddp k)) ;; This would only test for oddness of the item was an integer. ;; ;; . A single symbol will match anything so it can be used as a default ;; case, like OTHER above. ;; (in-package swank/match) (defmacro match (expression &body patterns) `(select-match ,expression ,@patterns)) (defmacro select-match (expression &rest patterns) (let* ((do-let (not (atom expression))) (key (if do-let (gensym) expression)) (cbody (expand-select-patterns key patterns)) (cform `(cond . ,cbody))) (if do-let `(let ((,key ,expression)) ,cform) cform))) (defun expand-select-patterns (key patterns) (if (eq (second patterns) '=>) (expand-select-patterns-style-2 key patterns) (expand-select-patterns-style-1 key patterns))) (defun expand-select-patterns-style-1 (key patterns) (if (null patterns) `((t (error "Case select pattern match failure on ~S" ,key))) (let* ((pattern (caar patterns)) (actions (cdar patterns)) (rest (cdr patterns)) (test (compile-select-test key pattern)) (bindings (compile-select-bindings key pattern actions))) `(,(if bindings `(,test (let ,bindings . ,actions)) `(,test . ,actions)) . ,(unless (eq test t) (expand-select-patterns-style-1 key rest)))))) (defun expand-select-patterns-style-2 (key patterns) (cond ((null patterns) `((t (error "Case select pattern match failure on ~S" ,key)))) (t (when (or (< (length patterns) 3) (not (eq (second patterns) '=>))) (error "Illegal patterns: ~S" patterns)) (let* ((pattern (first patterns)) (actions (list (third patterns))) (rest (cdddr patterns)) (test (compile-select-test key pattern)) (bindings (compile-select-bindings key pattern actions))) `(,(if bindings `(,test (let ,bindings . ,actions)) `(,test . ,actions)) . ,(unless (eq test t) (expand-select-patterns-style-2 key rest))))))) (defun compile-select-test (key pattern) (let ((tests (remove t (compile-select-tests key pattern)))) (cond ;; note AND does this anyway, but this allows us to tell if ;; the pattern will always match. ((null tests) t) ((= (length tests) 1) (car tests)) (t `(and . ,tests))))) (defun compile-select-tests (key pattern) (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) ((symbolp pattern) 'eq) (t 'equal)) ,key ,pattern))) ((symbolp pattern) '(t)) ((select-double-match? pattern) (append (compile-select-tests key (first pattern)) (compile-select-tests key (third pattern)))) ((select-predicate? pattern) (append `((,(second (first pattern)) ,key)) (compile-select-tests key (second pattern)))) ((consp pattern) (append `((consp ,key)) (compile-select-tests (cs-car key) (car pattern)) (compile-select-tests (cs-cdr key) (cdr pattern)))) (t (error "Illegal select pattern: ~S" pattern)))) (defun compile-select-bindings (key pattern action) (cond ((constantp pattern) '()) ((symbolp pattern) (if (select-in-tree pattern action) `((,pattern ,key)) '())) ((select-double-match? pattern) (append (compile-select-bindings key (first pattern) action) (compile-select-bindings key (third pattern) action))) ((select-predicate? pattern) (compile-select-bindings key (second pattern) action)) ((consp pattern) (append (compile-select-bindings (cs-car key) (car pattern) action) (compile-select-bindings (cs-cdr key) (cdr pattern) action))))) (defun select-in-tree (atom tree) (or (eq atom tree) (if (consp tree) (or (select-in-tree atom (car tree)) (select-in-tree atom (cdr tree)))))) (defun select-double-match? (pattern) ;; ( = ) (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) (null (cdddr pattern)) (eq (second pattern) '=))) (defun select-predicate? (pattern) ;; ((function ) ) (and (consp pattern) (consp (cdr pattern)) (null (cddr pattern)) (consp (first pattern)) (consp (cdr (first pattern))) (null (cddr (first pattern))) (eq (caar pattern) 'function))) (defun cs-car (exp) (cs-car/cdr 'car exp '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) (cdar . cadar) (cddr . caddr) (caaar . caaaar) (caadr . caaadr) (cadar . caadar) (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) (cddar . caddar) (cdddr . cadddr)))) (defun cs-cdr (exp) (cs-car/cdr 'cdr exp '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) (cdar . cddar) (cddr . cdddr) (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) (cddar . cdddar) (cdddr . cddddr)))) (defun cs-car/cdr (op exp table) (if (and (consp exp) (= (length exp) 2)) (let ((replacement (assoc (car exp) table))) (if replacement `(,(cdr replacement) ,(second exp)) `(,op ,exp))) `(,op ,exp))) ;; (setf c1 '(select-match x (a 1) (b 2 3 4))) ;; (setf c2 '(select-match (car y) ;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ ;; else)))) ;; (setf c3 '(select-match (caddr y) ;; ((all = (x y)) (list x y all)) ;; ((a '= b) (list 'assign a b)) ;; ((#'oddp k) (1+ k))))) slime-2.20/swank/mkcl.lisp000066400000000000000000000745251315100173500155210ustar00rootroot00000000000000;;;; -*- indent-tabs-mode: nil -*- ;;; ;;; swank-mkcl.lisp --- SLIME backend for MKCL. ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; ;;; Administrivia (defpackage swank/mkcl (:use cl swank/backend)) (in-package swank/mkcl) ;;(declaim (optimize (debug 3))) (defvar *tmp*) (defimplementation gray-package-name () '#:gray) (eval-when (:compile-toplevel :load-toplevel) (swank/backend::import-swank-mop-symbols :clos ;; '(:eql-specializer ;; :eql-specializer-object ;; :generic-function-declarations ;; :specializer-direct-methods ;; :compute-applicable-methods-using-classes) nil )) ;;; UTF8 (defimplementation string-to-utf8 (string) (mkcl:octets (si:utf-8 string))) (defimplementation utf8-to-string (octets) (string (si:utf-8 octets))) ;;;; TCP Server (eval-when (:compile-toplevel :load-toplevel) ;; At compile-time we need access to the sb-bsd-sockets package for the ;; the following code to be read properly. ;; It is a bit a shame we have to load the entire module to get that. (require 'sockets)) (defun resolve-hostname (name) (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name name)))) (defimplementation create-socket (host port &key backlog) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) (defimplementation close-socket (socket) (sb-bsd-sockets:socket-close socket)) (defun accept (socket) "Like socket-accept, but retry on EINTR." (loop (handler-case (return (sb-bsd-sockets:socket-accept socket)) (sb-bsd-sockets:interrupted-error ())))) (defimplementation accept-connection (socket &key external-format buffering timeout) (declare (ignore timeout)) (sb-bsd-sockets:socket-make-stream (accept socket) :output t ;; bogus :input t ;; bogus :buffering buffering ;; bogus :element-type (if external-format 'character '(unsigned-byte 8)) :external-format external-format )) (defimplementation preferred-communication-style () :spawn ) (defvar *external-format-to-coding-system* '((:iso-8859-1 "latin-1" "latin-1-unix" "iso-latin-1-unix" "iso-8859-1" "iso-8859-1-unix") (:utf-8 "utf-8" "utf-8-unix"))) (defun external-format (coding-system) (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*)) (find coding-system (si:all-encodings) :test #'string-equal))) (defimplementation find-external-format (coding-system) #+unicode (external-format coding-system) ;; Without unicode support, MKCL uses the one-byte encoding of the ;; underlying OS, and will barf on anything except :DEFAULT. We ;; return NIL here for known multibyte encodings, so ;; SWANK:CREATE-SERVER will barf. #-unicode (let ((xf (external-format coding-system))) (if (member xf '(:utf-8)) nil :default))) ;;;; Unix signals (defimplementation install-sigint-handler (handler) (let ((old-handler (symbol-function 'si:terminal-interrupt))) (setf (symbol-function 'si:terminal-interrupt) (if (consp handler) (car handler) (lambda (&rest args) (declare (ignore args)) (funcall handler) (continue)))) (list old-handler))) (defimplementation getpid () (mkcl:getpid)) (defimplementation set-default-directory (directory) (mk-ext::chdir (namestring directory)) (default-directory)) (defimplementation default-directory () (namestring (mk-ext:getcwd))) (defmacro progf (plist &rest forms) `(let (_vars _vals) (do ((p ,plist (cddr p))) ((endp p)) (push (car p) _vars) (push (cadr p) _vals)) (progv _vars _vals ,@forms) ) ) (defvar *inferior-lisp-sleeping-post* nil) (defimplementation quit-lisp () (progf (ignore-errors (eval (read-from-string "swank::*saved-global-streams*"))) ;; restore original IO streams. (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*)) ;;(mk-ext:quit :verbose t) )) ;;;; Compilation (defvar *buffer-name* nil) (defvar *buffer-start-position*) (defvar *buffer-string*) (defvar *compile-filename*) (defun signal-compiler-condition (&rest args) (signal (apply #'make-condition 'compiler-condition args))) #| (defun handle-compiler-warning (condition) (signal-compiler-condition :original-condition condition :message (format nil "~A" condition) :severity :warning :location (if *buffer-name* (make-location (list :buffer *buffer-name*) (list :offset *buffer-start-position* 0)) ;; ;; compiler::*current-form* ;; (if compiler::*current-function* ;; (make-location (list :file *compile-filename*) ;; (list :function-name ;; (symbol-name ;; (slot-value compiler::*current-function* ;; 'compiler::name)))) (list :error "No location found.") ;; ) ))) |# #| (defun condition-location (condition) (let ((file (compiler:compiler-message-file condition)) (position (compiler:compiler-message-file-position condition))) (if (and position (not (minusp position))) (if *buffer-name* (make-buffer-location *buffer-name* *buffer-start-position* position) (make-file-location file position)) (make-error-location "No location found.")))) |# (defun condition-location (condition) (if *buffer-name* (make-location (list :buffer *buffer-name*) (list :offset *buffer-start-position* 0)) ;; ;; compiler::*current-form* ; ;; (if compiler::*current-function* ; ;; (make-location (list :file *compile-filename*) ; ;; (list :function-name ; ;; (symbol-name ; ;; (slot-value compiler::*current-function* ; ;; 'compiler::name)))) ; (if (typep condition 'compiler::compiler-message) (make-location (list :file (namestring (compiler:compiler-message-file condition))) (list :end-position (compiler:compiler-message-file-end-position condition))) (list :error "No location found.")) ) ) (defun handle-compiler-message (condition) (unless (typep condition 'compiler::compiler-note) (signal-compiler-condition :original-condition condition :message (princ-to-string condition) :severity (etypecase condition (compiler:compiler-fatal-error :error) (compiler:compiler-error :error) (error :error) (style-warning :style-warning) (warning :warning)) :location (condition-location condition)))) (defimplementation call-with-compilation-hooks (function) (handler-bind ((compiler:compiler-message #'handle-compiler-message)) (funcall function))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (with-compilation-hooks () (let ((*buffer-name* nil) (*compile-filename* input-file)) (handler-bind (#| (compiler::compiler-note #'(lambda (n) (format t "~%swank saw a compiler note: ~A~%" n) (finish-output) nil)) (compiler::compiler-warning #'(lambda (w) (format t "~%swank saw a compiler warning: ~A~%" w) (finish-output) nil)) (compiler::compiler-error #'(lambda (e) (format t "~%swank saw a compiler error: ~A~%" e) (finish-output) nil)) |# ) (multiple-value-bind (output-truename warnings-p failure-p) (compile-file input-file :output-file output-file :external-format external-format) (values output-truename warnings-p (or failure-p (and load-p (not (load output-truename)))))))))) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore filename policy)) (with-compilation-hooks () (let ((*buffer-name* buffer) (*buffer-start-position* position) (*buffer-string* string)) (with-input-from-string (s string) (when position (file-position position)) (compile-from-stream s))))) (defun compile-from-stream (stream) (let ((file (mkcl:mkstemp "TMP:MKCL-SWANK-TMPXXXXXX")) output-truename warnings-p failure-p ) (with-open-file (s file :direction :output :if-exists :overwrite) (do ((line (read-line stream nil) (read-line stream nil))) ((not line)) (write-line line s))) (unwind-protect (progn (multiple-value-setq (output-truename warnings-p failure-p) (compile-file file)) (and (not failure-p) (load output-truename))) (when (probe-file file) (delete-file file)) (when (probe-file output-truename) (delete-file output-truename))))) ;;;; Documentation (defun grovel-docstring-for-arglist (name type) (flet ((compute-arglist-offset (docstring) (when docstring (let ((pos1 (search "Args: " docstring))) (if pos1 (+ pos1 6) (let ((pos2 (search "Syntax: " docstring))) (when pos2 (+ pos2 8)))))))) (let* ((docstring (si::get-documentation name type)) (pos (compute-arglist-offset docstring))) (if pos (multiple-value-bind (arglist errorp) (ignore-errors (values (read-from-string docstring t nil :start pos))) (if (or errorp (not (listp arglist))) :not-available arglist )) :not-available )))) (defimplementation arglist (name) (cond ((and (symbolp name) (special-operator-p name)) (let ((arglist (grovel-docstring-for-arglist name 'function))) (if (consp arglist) (cdr arglist) arglist))) ((and (symbolp name) (macro-function name)) (let ((arglist (grovel-docstring-for-arglist name 'function))) (if (consp arglist) (cdr arglist) arglist))) ((or (functionp name) (fboundp name)) (multiple-value-bind (name fndef) (if (functionp name) (values (function-name name) name) (values name (fdefinition name))) (let ((fle (function-lambda-expression fndef))) (case (car fle) (si:lambda-block (caddr fle)) (t (typecase fndef (generic-function (clos::generic-function-lambda-list fndef)) (compiled-function (grovel-docstring-for-arglist name 'function)) (function :not-available))))))) (t :not-available))) (defimplementation function-name (f) (si:compiled-function-name f) ) (eval-when (:compile-toplevel :load-toplevel) ;; At compile-time we need access to the walker package for the ;; the following code to be read properly. ;; It is a bit a shame we have to load the entire module to get that. (require 'walker)) (defimplementation macroexpand-all (form &optional env) (declare (ignore env)) (walker:macroexpand-all form)) (defimplementation describe-symbol-for-emacs (symbol) (let ((result '())) (dolist (type '(:VARIABLE :FUNCTION :CLASS)) (let ((doc (describe-definition symbol type))) (when doc (setf result (list* type doc result))))) result)) (defimplementation describe-definition (name type) (case type (:variable (documentation name 'variable)) (:function (documentation name 'function)) (:class (documentation name 'class)) (t nil))) ;;; Debugging (eval-when (:compile-toplevel :load-toplevel) (import '(si::*break-env* si::*ihs-top* si::*ihs-current* si::*ihs-base* si::*frs-base* si::*frs-top* si::*tpl-commands* si::*tpl-level* si::frs-top si::ihs-top si::ihs-fun si::ihs-env si::sch-frs-base si::set-break-env si::set-current-ihs si::tpl-commands))) (defvar *backtrace* '()) (defun in-swank-package-p (x) (and (symbolp x) (member (symbol-package x) (list #.(find-package :swank) #.(find-package :swank/backend) #.(ignore-errors (find-package :swank-mop)) #.(ignore-errors (find-package :swank-loader)))) t)) (defun is-swank-source-p (name) (setf name (pathname name)) #+(or) (pathname-match-p name (make-pathname :defaults swank-loader::*source-directory* :name (pathname-name name) :type (pathname-type name) :version (pathname-version name))) nil) (defun is-ignorable-fun-p (x) (or (in-swank-package-p (frame-name x)) (multiple-value-bind (file position) (ignore-errors (si::compiled-function-file (car x))) (declare (ignore position)) (if file (is-swank-source-p file))))) (defmacro find-ihs-top (x) (declare (ignore x)) '(si::ihs-top)) (defimplementation call-with-debugging-environment (debugger-loop-fn) (declare (type function debugger-loop-fn)) (let* (;;(*tpl-commands* si::tpl-commands) (*ihs-base* 0) (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) (*ihs-current* *ihs-top*) (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*read-suppress* nil) ;;(*tpl-level* (1+ *tpl-level*)) (*backtrace* (loop for ihs from 0 below *ihs-top* collect (list (si::ihs-fun ihs) (si::ihs-env ihs) nil)))) (declare (special *ihs-current*)) (loop for f from *frs-base* to *frs-top* do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) (when (plusp i) (let* ((x (elt *backtrace* i)) (name (si::frs-tag f))) (unless (mkcl:fixnump name) (push name (third x))))))) (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) (setf *tmp* *backtrace*) (set-break-env) (set-current-ihs) (let ((*ihs-base* *ihs-top*)) (funcall debugger-loop-fn)))) (defimplementation call-with-debugger-hook (hook fun) (let ((*debugger-hook* hook) (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) (funcall fun))) (defimplementation compute-backtrace (start end) (when (numberp end) (setf end (min end (length *backtrace*)))) (loop for f in (subseq *backtrace* start end) collect f)) (defimplementation format-sldb-condition (condition) "Format a condition for display in SLDB." ;;(princ-to-string condition) (format nil "~A~%In thread: ~S" condition mt:*thread*) ) (defun frame-name (frame) (let ((x (first frame))) (if (symbolp x) x (function-name x)))) (defun function-position (fun) (multiple-value-bind (file position) (si::compiled-function-file fun) (and file (make-location `(:file ,(if (stringp file) file (namestring file))) ;;`(:position ,position) `(:end-position , position))))) (defun frame-function (frame) (let* ((x (first frame)) fun position) (etypecase x (symbol (and (fboundp x) (setf fun (fdefinition x) position (function-position fun)))) (function (setf fun x position (function-position x)))) (values fun position))) (defun frame-decode-env (frame) (let ((functions '()) (blocks '()) (variables '())) (setf frame (si::decode-ihs-env (second frame))) (dolist (record frame) (let* ((record0 (car record)) (record1 (cdr record))) (cond ((or (symbolp record0) (stringp record0)) (setq variables (acons record0 record1 variables))) ((not (mkcl:fixnump record0)) (push record1 functions)) ((symbolp record1) (push record1 blocks)) (t )))) (values functions blocks variables))) (defimplementation print-frame (frame stream) (let ((function (first frame))) (let ((fname ;;; (cond ((symbolp function) function) ;;; ((si:instancep function) (slot-value function 'name)) ;;; ((compiled-function-p function) ;;; (or (si::compiled-function-name function) 'lambda)) ;;; (t :zombi)) (si::get-fname function) )) (if (eq fname 'si::bytecode) (format stream "~A [Evaluation of: ~S]" fname (function-lambda-expression function)) (format stream "~A" fname) ) (when (si::closurep function) (format stream ", closure generated from ~A" (si::get-fname (si:closure-producer function))) ) ) ) ) (defimplementation frame-source-location (frame-number) (nth-value 1 (frame-function (elt *backtrace* frame-number)))) (defimplementation frame-catch-tags (frame-number) (third (elt *backtrace* frame-number))) (defimplementation frame-locals (frame-number) (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) with i = 0 collect (list :name name :id (prog1 i (incf i)) :value value))) (defimplementation frame-var-value (frame-number var-id) (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id))) (defimplementation disassemble-frame (frame-number) (let ((fun (frame-fun (elt *backtrace* frame-number)))) (disassemble fun))) (defimplementation eval-in-frame (form frame-number) (let ((env (second (elt *backtrace* frame-number)))) (si:eval-in-env form env))) #| (defimplementation gdb-initial-commands () ;; These signals are used by the GC. #+linux '("handle SIGPWR noprint nostop" "handle SIGXCPU noprint nostop")) (defimplementation command-line-args () (loop for n from 0 below (si:argc) collect (si:argv n))) |# ;;;; Inspector (defmethod emacs-inspect ((o t)) ; ecl clos support leaves some to be desired (cond ((streamp o) (list* (format nil "~S is an ordinary stream~%" o) (append (list "Open for " (cond ((ignore-errors (interactive-stream-p o)) "Interactive") ((and (input-stream-p o) (output-stream-p o)) "Input and output") ((input-stream-p o) "Input") ((output-stream-p o) "Output")) `(:newline) `(:newline)) (label-value-line* ("Element type" (stream-element-type o)) ("External format" (stream-external-format o))) (ignore-errors (label-value-line* ("Broadcast streams" (broadcast-stream-streams o)))) (ignore-errors (label-value-line* ("Concatenated streams" (concatenated-stream-streams o)))) (ignore-errors (label-value-line* ("Echo input stream" (echo-stream-input-stream o)))) (ignore-errors (label-value-line* ("Echo output stream" (echo-stream-output-stream o)))) (ignore-errors (label-value-line* ("Output String" (get-output-stream-string o)))) (ignore-errors (label-value-line* ("Synonym symbol" (synonym-stream-symbol o)))) (ignore-errors (label-value-line* ("Input stream" (two-way-stream-input-stream o)))) (ignore-errors (label-value-line* ("Output stream" (two-way-stream-output-stream o))))))) ((si:instancep o) ;;t (let* ((cl (si:instance-class o)) (slots (clos::class-slots cl))) (list* (format nil "~S is an instance of class ~A~%" o (clos::class-name cl)) (loop for x in slots append (let* ((name (clos::slot-definition-name x)) (value (if (slot-boundp o name) (clos::slot-value o name) "Unbound" ))) (list (format nil "~S: " name) `(:value ,value) `(:newline))))))) (t (list (format nil "~A" o))))) ;;;; Definitions (defimplementation find-definitions (name) (if (fboundp name) (let ((tmp (find-source-location (symbol-function name)))) `(((defun ,name) ,tmp))))) (defimplementation find-source-location (obj) (setf *tmp* obj) (or (typecase obj (function (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj)) (if (and file pos) (make-location `(:file ,(if (stringp file) file (namestring file))) `(:end-position ,pos) ;; `(:position ,pos) `(:snippet ,(with-open-file (s file) (file-position s pos) (skip-comments-and-whitespace s) (read-snippet s)))))))) `(:error (format nil "Source definition of ~S not found" obj)))) ;;;; Profiling (eval-when (:compile-toplevel :load-toplevel) ;; At compile-time we need access to the profile package for the ;; the following code to be read properly. ;; It is a bit a shame we have to load the entire module to get that. (require 'profile)) (defimplementation profile (fname) (when fname (eval `(profile:profile ,fname)))) (defimplementation unprofile (fname) (when fname (eval `(profile:unprofile ,fname)))) (defimplementation unprofile-all () (profile:unprofile-all) "All functions unprofiled.") (defimplementation profile-report () (profile:report)) (defimplementation profile-reset () (profile:reset) "Reset profiling counters.") (defimplementation profiled-functions () (profile:profile)) (defimplementation profile-package (package callers methods) (declare (ignore callers methods)) (eval `(profile:profile ,(package-name (find-package package))))) ;;;; Threads (defvar *thread-id-counter* 0) (defvar *thread-id-counter-lock* (mt:make-lock :name "thread id counter lock")) (defun next-thread-id () (mt:with-lock (*thread-id-counter-lock*) (incf *thread-id-counter*)) ) (defparameter *thread-id-map* (make-hash-table)) (defparameter *id-thread-map* (make-hash-table)) (defvar *thread-id-map-lock* (mt:make-lock :name "thread id map lock")) (defparameter +default-thread-local-variables+ '(*macroexpand-hook* *default-pathname-defaults* *readtable* *random-state* *compile-print* *compile-verbose* *load-print* *load-verbose* *print-array* *print-base* *print-case* *print-circle* *print-escape* *print-gensym* *print-length* *print-level* *print-lines* *print-miser-width* *print-pprint-dispatch* *print-pretty* *print-radix* *print-readably* *print-right-margin* *read-base* *read-default-float-format* *read-eval* *read-suppress* )) (defun thread-local-default-bindings () (let (local) (dolist (var +default-thread-local-variables+ local) (setq local (acons var (symbol-value var) local)) ))) ;; mkcl doesn't have weak pointers (defimplementation spawn (fn &key name initial-bindings) (let* ((local-defaults (thread-local-default-bindings)) (thread ;;(mt:make-thread :name name) (mt:make-thread :name name :initial-bindings (nconc initial-bindings local-defaults)) ) (id (next-thread-id))) (mt:with-lock (*thread-id-map-lock*) (setf (gethash id *thread-id-map*) thread) (setf (gethash thread *id-thread-map*) id)) (mt:thread-preset thread #'(lambda () (unwind-protect (progn ;;(format t "~&Starting thread: ~S.~%" name) (finish-output) (mt:thread-detach nil) (funcall fn)) (progn ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output) (mt:with-lock (*thread-id-map-lock*) (remhash thread *id-thread-map*) (remhash id *thread-id-map*)) ;;(format t "~&Finished thread: ~S~%" name) (finish-output) )))) (mt:thread-enable thread) (mt:thread-yield) thread )) (defimplementation thread-id (thread) (block thread-id (mt:with-lock (*thread-id-map-lock*) (or (gethash thread *id-thread-map*) (let ((id (next-thread-id))) (setf (gethash id *thread-id-map*) thread) (setf (gethash thread *id-thread-map*) id) id))))) (defimplementation find-thread (id) (mt:with-lock (*thread-id-map-lock*) (gethash id *thread-id-map*))) (defimplementation thread-name (thread) (mt:thread-name thread)) (defimplementation thread-status (thread) (if (mt:thread-active-p thread) "RUNNING" "STOPPED")) (defimplementation make-lock (&key name) (mt:make-lock :name name :recursive t)) (defimplementation call-with-lock-held (lock function) (declare (type function function)) (mt:with-lock (lock) (funcall function))) (defimplementation current-thread () mt:*thread*) (defimplementation all-threads () (mt:all-threads)) (defimplementation interrupt-thread (thread fn) (mt:interrupt-thread thread fn)) (defimplementation kill-thread (thread) (mt:interrupt-thread thread #'mt:terminate-thread) ) (defimplementation thread-alive-p (thread) (mt:thread-active-p thread)) (defvar *mailbox-lock* (mt:make-lock :name "mailbox lock")) (defvar *mailboxes* (list)) (declaim (type list *mailboxes*)) (defstruct (mailbox (:conc-name mailbox.)) thread locked-by (mutex (mt:make-lock :name "thread mailbox")) (semaphore (mt:make-semaphore)) (queue '() :type list)) (defun mailbox (thread) "Return THREAD's mailbox." (mt:with-lock (*mailbox-lock*) (or (find thread *mailboxes* :key #'mailbox.thread) (let ((mb (make-mailbox :thread thread))) (push mb *mailboxes*) mb)))) (defimplementation send (thread message) (handler-case (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) ;; (mt:interrupt-thread ;; thread ;; (lambda () ;; (mt:with-lock (mutex) ;; (setf (mailbox.queue mbox) ;; (nconc (mailbox.queue mbox) (list message)))))) ;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%" ;; mt:*thread* thread message) (finish-output) (mt:with-lock (mutex) (setf (mailbox.locked-by mbox) mt:*thread*) (setf (mailbox.queue mbox) (nconc (mailbox.queue mbox) (list message))) ;;(format t "*") (finish-output) (handler-case (mt:semaphore-signal (mailbox.semaphore mbox)) (condition (condition) (format t "Something went bad with semaphore-signal ~A" condition) (finish-output) ;;(break) )) (setf (mailbox.locked-by mbox) nil) ) ;;(format t "+") (finish-output) ) (condition (condition) (format t "~&Error in send: ~S~%" condition) (finish-output)) ) ) ;; (defimplementation receive () ;; (block got-mail ;; (let* ((mbox (mailbox mt:*thread*)) ;; (mutex (mailbox.mutex mbox))) ;; (loop ;; (mt:with-lock (mutex) ;; (if (mailbox.queue mbox) ;; (return-from got-mail (pop (mailbox.queue mbox))))) ;; ;;interrupt-thread will halt this if it takes longer than 1sec ;; (sleep 1))))) (defimplementation receive-if (test &optional timeout) (handler-case (let* ((mbox (mailbox (current-thread))) (mutex (mailbox.mutex mbox)) got-one) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) ;;(format t "~&: ~S~%" mt:*thread*) (finish-output) (handler-case (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2)) (condition (condition) (format t "~&In (swank-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition) (finish-output) nil ) ) (mt:with-lock (mutex) (setf (mailbox.locked-by mbox) mt:*thread*) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (setf (mailbox.locked-by mbox) nil) ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail)) (return (car tail)))) (setf (mailbox.locked-by mbox) nil) ) ;;(format t "/ ~S~%" mt:*thread*) (finish-output) (when (eq timeout t) (return (values nil t))) ;; (unless got-one ;; (format t "~&In (swank-mkcl) receive-if: semaphore-wait timed out!~%")) ) ) (condition (condition) (format t "~&Error in (swank-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output) nil ) ) ) (defmethod stream-finish-output ((stream stream)) (finish-output stream)) ;; ;;#+windows (defimplementation doze-in-repl () (setq *inferior-lisp-sleeping-post* (mt:make-semaphore)) ;;(loop (sleep 1)) (mt:semaphore-wait *inferior-lisp-sleeping-post*) (mk-ext:quit :verbose t) ) slime-2.20/swank/rpc.lisp000066400000000000000000000123361315100173500153470ustar00rootroot00000000000000;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- ;;; ;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. ;;; ;;; Created 2010, Terje Norderhaug ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; (in-package swank/rpc) ;;;;; Input (define-condition swank-reader-error (reader-error) ((packet :type string :initarg :packet :reader swank-reader-error.packet) (cause :type reader-error :initarg :cause :reader swank-reader-error.cause))) (defun read-message (stream package) (let ((packet (read-packet stream))) (handler-case (values (read-form packet package)) (reader-error (c) (error 'swank-reader-error :packet packet :cause c))))) (defun read-packet (stream) (let* ((length (parse-header stream)) (octets (read-chunk stream length))) (handler-case (swank/backend:utf8-to-string octets) (error (c) (error 'swank-reader-error :packet (asciify octets) :cause c))))) (defun asciify (packet) (with-output-to-string (*standard-output*) (loop for code across (etypecase packet (string (map 'vector #'char-code packet)) (vector packet)) do (cond ((<= code #x7f) (write-char (code-char code))) (t (format t "\\x~x" code)))))) (defun parse-header (stream) (parse-integer (map 'string #'code-char (read-chunk stream 6)) :radix 16)) (defun read-chunk (stream length) (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) (count (read-sequence buffer stream))) (cond ((= count length) buffer) ((zerop count) (error 'end-of-file :stream stream)) (t (error "Short read: length=~D count=~D" length count))))) (defparameter *validate-input* nil "Set to true to require input that more strictly conforms to the protocol") (defun read-form (string package) (with-standard-io-syntax (let ((*package* package)) (if *validate-input* (validating-read string) (read-from-string string))))) (defun validating-read (string) (with-input-from-string (*standard-input* string) (simple-read))) (defun simple-read () "Read a form that conforms to the protocol, otherwise signal an error." (let ((c (read-char))) (case c (#\( (loop collect (simple-read) while (ecase (read-char) (#\) nil) (#\space t)))) (#\' `(quote ,(simple-read))) (t (cond ((digit-char-p c) (parse-integer (map 'simple-string #'identity (loop for ch = c then (read-char nil nil) while (and ch (digit-char-p ch)) collect ch finally (unread-char ch))))) ((or (member c '(#\: #\")) (alpha-char-p c)) (unread-char c) (read-preserving-whitespace)) (t (error "Invalid character ~:c" c))))))) ;;;;; Output (defun write-message (message package stream) (let* ((string (prin1-to-string-for-emacs message package)) (octets (handler-case (swank/backend:string-to-utf8 string) (error (c) (encoding-error c string)))) (length (length octets))) (write-header stream length) (write-sequence octets stream) (finish-output stream))) ;; FIXME: for now just tell emacs that we and an encoding problem. (defun encoding-error (condition string) (swank/backend:string-to-utf8 (prin1-to-string-for-emacs `(:reader-error ,(asciify string) ,(format nil "Error during string-to-utf8: ~a" (or (ignore-errors (asciify (princ-to-string condition))) (asciify (princ-to-string (type-of condition)))))) (find-package :cl)))) (defun write-header (stream length) (declare (type (unsigned-byte 24) length)) ;;(format *trace-output* "length: ~d (#x~x)~%" length length) (loop for c across (format nil "~6,'0x" length) do (write-byte (char-code c) stream))) (defun switch-to-double-floats (x) (typecase x (double-float x) (float (coerce x 'double-float)) (null x) (list (loop for (x . cdr) on x collect (switch-to-double-floats x) into result until (atom cdr) finally (return (append result (switch-to-double-floats cdr))))) (t x))) (defun prin1-to-string-for-emacs (object package) (with-standard-io-syntax (let ((*print-case* :downcase) (*print-readably* nil) (*print-pretty* nil) (*package* package) ;; Emacs has only double floats. (*read-default-float-format* 'double-float)) (prin1-to-string (switch-to-double-floats object))))) #| TEST/DEMO: (defparameter *transport* (with-output-to-string (out) (write-message '(:message (hello "world")) *package* out) (write-message '(:return 5) *package* out) (write-message '(:emacs-rex NIL) *package* out))) *transport* (with-input-from-string (in *transport*) (loop while (peek-char T in NIL) collect (read-message in *package*))) |# slime-2.20/swank/sbcl.lisp000066400000000000000000002365521315100173500155160ustar00rootroot00000000000000;;;;; -*- indent-tabs-mode: nil -*- ;;; ;;; swank-sbcl.lisp --- SLIME backend for SBCL. ;;; ;;; Created 2003, Daniel Barlow ;;; ;;; This code has been placed in the Public Domain. All warranties are ;;; disclaimed. ;;; Requires the SB-INTROSPECT contrib. ;;; Administrivia (defpackage swank/sbcl (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) (in-package swank/sbcl) (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-bsd-sockets) (require 'sb-introspect) (require 'sb-posix) (require 'sb-cltl2)) (declaim (optimize (debug 2) (sb-c::insert-step-conditions 0) (sb-c::insert-debug-catch 0))) ;;; 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 () (with-symbol 'enable-stepping 'sb-impl)) ;; Ditto for weak hash-tables (defun sbcl-with-weak-hash-tables () (with-symbol 'hash-table-weakness 'sb-ext)) ;; And for xref support (1.0.1) (defun sbcl-with-xref-p () (with-symbol 'who-calls 'sb-introspect)) ;; ... for restart-frame support (1.0.2) (defun sbcl-with-restart-frame () (with-symbol 'frame-has-debug-tag-p 'sb-debug)) ;; ... for :setf :inverse info (1.1.17) (defun sbcl-with-setf-inverse-meta-info () (boolean-to-feature-expression ;; going through FIND-SYMBOL since META-INFO was renamed from ;; TYPE-INFO in 1.2.10. (let ((sym (find-symbol "META-INFO" "SB-C"))) (and sym (fboundp sym) (funcall sym :setf :inverse ())))))) ;;; swank-mop (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation)) (defun swank-mop:slot-definition-documentation (slot) (sb-pcl::documentation slot t)) ;; stream support (defimplementation gray-package-name () "SB-GRAY") ;; Pretty printer calls this, apparently (defmethod sb-gray:stream-line-length ((s sb-gray:fundamental-character-input-stream)) nil) ;;; Connection info (defimplementation lisp-implementation-type-name () "sbcl") ;; Declare return type explicitly to shut up STYLE-WARNINGS about ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below. (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid)) (defimplementation getpid () (sb-posix:getpid)) ;;; UTF8 (defimplementation string-to-utf8 (string) (sb-ext:string-to-octets string :external-format :utf8)) (defimplementation utf8-to-string (octets) (sb-ext:octets-to-string octets :external-format :utf8)) ;;; TCP Server (defimplementation preferred-communication-style () (cond ;; fixme: when SBCL/win32 gains better select() support, remove ;; this. ((member :sb-thread *features*) :spawn) ((member :win32 *features*) nil) (t :fd-handler))) (defun resolve-hostname (host) "Returns valid IPv4 or IPv6 address for the host." ;; get all IPv4 and IPv6 addresses as a list (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host))) ;; remove protocols for which we don't have an address (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents))) ;; Return the first one or nil, ;; but actually, it shouln't return nil, because ;; get-host-by-name will signal NAME-SERVICE-ERROR condition ;; if there isn't any address for the host. (first addresses))) (defimplementation create-socket (host port &key backlog) (let* ((host-ent (resolve-hostname host)) (socket (make-instance (cond #+#.(swank/backend:with-symbol 'inet6-socket 'sb-bsd-sockets) ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10) 'sb-bsd-sockets:inet6-socket) (t 'sb-bsd-sockets:inet-socket)) :type :stream :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port) (sb-bsd-sockets:socket-listen socket (or backlog 5)) socket)) (defimplementation local-port (socket) (nth-value 1 (sb-bsd-sockets:socket-name socket))) (defimplementation close-socket (socket) (sb-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) external-format (ecase buffering ((t :full) :full) ((nil :none) :none) ((:line) :line)))) ;; The SIGIO stuff should probably be removed as it's unlikey that ;; anybody uses it. #-win32 (progn (defimplementation install-sigint-handler (function) (sb-sys:enable-interrupt sb-unix:sigint (lambda (&rest args) (declare (ignore args)) (sb-sys:invoke-interruption (lambda () (sb-sys:with-interrupts (funcall function))))))) (defvar *sigio-handlers* '() "List of (key . fn) pairs to be called on SIGIO.") (defun sigio-handler (signal code scp) (declare (ignore signal code scp)) (sb-sys:with-interrupts (mapc (lambda (handler) (funcall (the function (cdr handler)))) *sigio-handlers*))) (defun set-sigio-handler () (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler)) (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)) (values)) (defimplementation add-sigio-handler (socket fn) (set-sigio-handler) (let ((fd (socket-fd socket))) (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 fun) (let ((fd (socket-fd socket)) (handler nil)) (labels ((add () (setq handler (sb-sys:add-fd-handler fd :input #'run))) (run (fd) (sb-sys:remove-fd-handler handler) ; prevent recursion (unwind-protect (funcall fun) (when (sb-unix:unix-fstat fd) ; still open? (add))))) (add)))) (defimplementation remove-fd-handlers (socket) (sb-sys:invalidate-descriptor (socket-fd socket))) (defimplementation 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)))) (defimplementation command-line-args () sb-ext:*posix-argv*) (defimplementation dup (fd) (sb-posix:dup fd)) (defvar *wait-for-input-called*) (defimplementation wait-for-input (streams &optional timeout) (assert (member timeout '(nil t))) (when (boundp '*wait-for-input-called*) (setq *wait-for-input-called* t)) (let ((*wait-for-input-called* nil)) (loop (let ((ready (remove-if-not #'input-ready-p streams))) (when ready (return ready))) (when (check-slime-interrupts) (return :interrupt)) (when *wait-for-input-called* (return :interrupt)) (when timeout (return nil)) (sleep 0.1)))) (defun fd-stream-input-buffer-empty-p (stream) (let ((buffer (sb-impl::fd-stream-ibuf stream))) (or (not buffer) (= (sb-impl::buffer-head buffer) (sb-impl::buffer-tail buffer))))) #-win32 (defun input-ready-p (stream) (or (not (fd-stream-input-buffer-empty-p stream)) #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl) (eq :regular (sb-impl::fd-stream-fd-type stream)) (not (sb-impl::sysread-may-block-p stream)))) #+win32 (progn (defun input-ready-p (stream) (or (not (fd-stream-input-buffer-empty-p stream)) (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream))))) (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) sb-win32:handle) (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) sb-alien:int (event sb-win32:handle)) (defconstant +fd-read+ #.(ash 1 0)) (defconstant +fd-close+ #.(ash 1 5)) (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) sb-alien:int (fd sb-alien:int) (handle sb-win32:handle) (mask sb-alien:long)) (sb-alien:load-shared-object "kernel32.dll") (sb-alien:define-alien-routine ("WaitForSingleObjectEx" wait-for-single-object-ex) sb-alien:int (event sb-win32:handle) (milliseconds sb-alien:long) (alertable sb-alien:int)) ;; see SB-WIN32:HANDLE-LISTEN (defun handle-listen (handle) (sb-alien:with-alien ((avail sb-win32:dword) (buf (array char #.sb-win32::input-record-size))) (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil (sb-alien:alien-sap (sb-alien:addr avail)) nil)) (return-from handle-listen (plusp avail))) (unless (zerop (sb-win32:peek-console-input handle (sb-alien:alien-sap buf) sb-win32::input-record-size (sb-alien:alien-sap (sb-alien:addr avail)))) (return-from handle-listen (plusp avail)))) (let ((event (wsa-create-event))) (wsa-event-select handle event (logior +fd-read+ +fd-close+)) (let ((val (wait-for-single-object-ex event 0 0))) (wsa-close-event event) (unless (= val -1) (return-from handle-listen (zerop val))))) nil) ) (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"))) ;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, ;; 2008-08-22. (defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) (defimplementation filename-to-pathname (filename) (sb-ext:parse-native-namestring filename *physical-pathname-host*)) (defimplementation find-external-format (coding-system) (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) *external-format-to-coding-system*))) (defimplementation set-default-directory (directory) (let ((directory (truename (merge-pathnames directory)))) (sb-posix:chdir directory) (setf *default-pathname-defaults* directory) (default-directory))) (defun make-socket-io-stream (socket external-format buffering) (let ((args `(:output t :input t :element-type ,(if external-format 'character '(unsigned-byte 8)) :buffering ,buffering ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) `(:external-format ,external-format)) (t '())) :serve-events ,(eq :fd-handler swank:*communication-style*) ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS ;; argument. :allow-other-keys t))) (apply #'sb-bsd-sockets:socket-make-stream socket args))) (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 ())))) ;;;; 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))) ;; Don't use ECASE since SBCL also has :host-feature, ;; don't need to handle it or anything else appearing in ;; the future or in erronous code. (case (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) (when filename (loop for (nil 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)))) ;;; Packages #+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext) (defimplementation package-local-nicknames (package) (sb-ext:package-local-nicknames package)) ;;; Utilities #+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) (defimplementation arglist (fname) (sb-introspect:function-lambda-list fname)) #-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect) (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))))) #+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect) (defmethod type-specifier-arglist :around (typespec-operator) (multiple-value-bind (arglist foundp) (sb-introspect:deftype-lambda-list typespec-operator) (if foundp arglist (call-next-method)))) (defimplementation type-specifier-p (symbol) (or (sb-ext:valid-type-specifier-p symbol) (not (eq (type-specifier-arglist symbol) :not-available)))) (defvar *buffer-name* nil) (defvar *buffer-tmpfile* 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." (unless (or (eq condition *previous-compiler-condition*)) ;; First resignal warnings, so that outer handlers -- which may choose to ;; muffle this -- get a chance to run. (when (typep condition 'warning) (signal condition)) (setq *previous-compiler-condition* condition) (signal-compiler-condition (real-condition condition) (sb-c::find-error-context nil)))) (defun signal-compiler-condition (condition context) (signal 'compiler-condition :original-condition condition :severity (etypecase condition (sb-ext:compiler-note :note) (sb-c:compiler-error :error) (reader-error :read-error) (error :error) #+#.(swank/backend:with-symbol redefinition-warning sb-kernel) (sb-kernel:redefinition-warning :redefinition) (style-warning :style-warning) (warning :warning)) :references (condition-references condition) :message (brief-compiler-message-for-emacs condition) :source-context (compiler-error-context context) :location (compiler-note-location condition 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 (condition context) (flet ((bailout () (return-from compiler-note-location (make-error-location "No error location available")))) (cond (context (locate-compiler-note (sb-c::compiler-error-context-file-name context) (compiler-source-path context) (sb-c::compiler-error-context-original-source context))) ((typep condition 'reader-error) (let* ((stream (stream-error-stream condition)) (file (pathname stream))) (unless (open-stream-p stream) (bailout)) (if (compiling-from-buffer-p file) ;; The stream position for e.g. "comma not inside ;; backquote" is at the character following the ;; comma, :offset is 0-based, hence the 1-. (make-location (list :buffer *buffer-name*) (list :offset *buffer-offset* (1- (file-position stream)))) (progn (assert (compiling-from-file-p file)) ;; No 1- because :position is 1-based. (make-location (list :file (namestring file)) (list :position (file-position stream))))))) (t (bailout))))) (defun compiling-from-buffer-p (filename) (and *buffer-name* ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P ;; in LOCATE-COMPILER-NOTE, and allows handling nested ;; compilation from eg. hitting C-C on (eval-when ... (require ..))). ;; ;; PROBE-FILE to handle tempfile directory being a symlink. (pathnamep filename) (let ((true1 (probe-file filename)) (true2 (probe-file *buffer-tmpfile*))) (and true1 (equal true1 true2))))) (defun compiling-from-file-p (filename) (and (pathnamep filename) (or (null *buffer-name*) (null *buffer-tmpfile*) (let ((true1 (probe-file filename)) (true2 (probe-file *buffer-tmpfile*))) (not (and true1 (equal true1 true2))))))) (defun compiling-from-generated-code-p (filename source) (and (eq filename :lisp) (stringp source))) (defun locate-compiler-note (file source-path source) (cond ((compiling-from-buffer-p file) (make-location (list :buffer *buffer-name*) (list :offset *buffer-offset* (source-path-string-position source-path *buffer-substring*)))) ((compiling-from-file-p file) (let ((position (source-path-file-position source-path file))) (make-location (list :file (namestring file)) (list :position (and position (1+ position)))))) ((compiling-from-generated-code-p file source) (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 compiler-error-context (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))) (and (or enclosing source) (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]" enclosing source)))) (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 ;; N.B. Even though these handlers are called HANDLE-FOO they ;; actually decline, i.e. the signalling of the original ;; condition continues upward. ((sb-c:fatal-compiler-error #'handle-notification-condition) (sb-c:compiler-error #'handle-notification-condition) (sb-ext:compiler-note #'handle-notification-condition) (error #'handle-notification-condition) (warning #'handle-notification-condition)) (funcall function))) ;;; HACK: SBCL 1.2.12 shipped with a bug where ;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there ;;; were no policy restrictions in place. This workaround ensures the ;;; existence of at least one dummy restriction. (handler-case (sb-ext:restrict-compiler-policy) (error () (sb-ext:restrict-compiler-policy 'debug))) (defun compiler-policy (qualities) "Return compiler policy qualities present in the QUALITIES alist. QUALITIES is an alist with (quality . value)" #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) (loop with policy = (sb-ext:restrict-compiler-policy) for (quality) in qualities collect (cons quality (or (cdr (assoc quality policy)) 0)))) (defun (setf compiler-policy) (policy) (declare (ignorable policy)) #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext) (loop for (qual . value) in policy do (sb-ext:restrict-compiler-policy qual value))) (defmacro with-compiler-policy (policy &body body) (let ((current-policy (gensym))) `(let ((,current-policy (compiler-policy ,policy))) (setf (compiler-policy) ,policy) (unwind-protect (progn ,@body) (setf (compiler-policy) ,current-policy))))) (defimplementation swank-compile-file (input-file output-file load-p external-format &key policy) (multiple-value-bind (output-file warnings-p failure-p) (with-compiler-policy policy (with-compilation-hooks () (compile-file input-file :output-file output-file :external-format external-format))) (values output-file warnings-p (or failure-p (when load-p ;; Cache the latest source file for definition-finding. (source-cache-get input-file (file-write-date input-file)) (not (load output-file))))))) ;;;; 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. (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) sb-alien:c-string (dir sb-alien:c-string) (prefix sb-alien:c-string))) (defun temp-file-name () "Return a temporary file name to compile strings into." (tempnam nil "slime")) (defvar *trap-load-time-warnings* t) (defimplementation swank-compile-string (string &key buffer position filename policy) (let ((*buffer-name* buffer) (*buffer-offset* position) (*buffer-substring* string) (*buffer-tmpfile* (temp-file-name))) (labels ((load-it (filename) (cond (*trap-load-time-warnings* (with-compilation-hooks () (load filename))) (t (load filename)))) (cf () (with-compiler-policy policy (with-compilation-unit (:source-plist (list :emacs-buffer buffer :emacs-filename filename :emacs-package (package-name *package*) :emacs-position position :emacs-string string) :source-namestring filename :allow-other-keys t) (compile-file *buffer-tmpfile* :external-format :utf-8))))) (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error :external-format :utf-8) (write-string string s)) (unwind-protect (multiple-value-bind (output-file warningsp failurep) (with-compilation-hooks () (cf)) (declare (ignore warningsp)) (when output-file (load-it output-file)) (not failurep)) (ignore-errors (delete-file *buffer-tmpfile*) (delete-file (compile-file-pathname *buffer-tmpfile*))))))) ;;;; Definitions (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 :ir1-convert :def-ir1-translator :declaration declaim :alien-type :define-alien-type) "Map SB-INTROSPECT definition type names to Slime-friendly forms") (defun definition-specifier (type) "Return a pretty specifier for NAME representing a definition of type TYPE." (getf *definition-types* type)) (defun make-dspec (type name source-location) (list* (definition-specifier type) name (sb-introspect::definition-source-description source-location))) (defimplementation find-definitions (name) (loop for type in *definition-types* by #'cddr for defsrcs = (sb-introspect:find-definition-sources-by-name name type) append (loop for defsrc in defsrcs collect (list (make-dspec type name defsrc) (converting-errors-to-error-location (definition-source-for-emacs defsrc type name)))))) (defimplementation find-source-location (obj) (flet ((general-type-of (obj) (typecase obj (method :method) (generic-function :generic-function) (function :function) (structure-class :structure-class) (class :class) (method-combination :method-combination) (package :package) (condition :condition) (structure-object :structure-object) (standard-object :standard-object) (t :thing))) (to-string (obj) (typecase obj ;; Packages are possibly named entities. (package (princ-to-string obj)) ((or structure-object standard-object condition) (with-output-to-string (s) (print-unreadable-object (obj s :type t :identity t)))) (t (princ-to-string obj))))) (converting-errors-to-error-location (let ((defsrc (sb-introspect:find-definition-source obj))) (definition-source-for-emacs defsrc (general-type-of obj) (to-string obj)))))) (defmacro with-definition-source ((&rest names) obj &body body) "Like with-slots but works only for structs." (flet ((reader (slot) ;; Use read-from-string instead of intern so that ;; conc-name can be a string such as ext:struct- and not ;; cause errors and not force interning ext::struct- (read-from-string (concatenate 'string "sb-introspect:definition-source-" (string slot))))) (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))))) (defun categorize-definition-source (definition-source) (with-definition-source (pathname form-path character-offset plist) definition-source (let ((file-p (and pathname (probe-file pathname) (or form-path character-offset)))) (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) ((getf plist :emacs-buffer) :buffer) (file-p :file) (pathname :file-without-position) (t :invalid))))) #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) (defun form-number-position (definition-source stream) (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source))) (form-number (sb-introspect:definition-source-form-number definition-source))) (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))))) #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) (defun file-form-number-position (definition-source) (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source)) (filename (sb-introspect:definition-source-pathname definition-source)) (*readtable* (guess-readtable-for-filename filename)) (source-code (get-source-code filename code-date))) (with-debootstrapping (with-input-from-string (s source-code) (form-number-position definition-source s))))) #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) (defun string-form-number-position (definition-source string) (with-input-from-string (s string) (form-number-position definition-source s))) (defun definition-source-buffer-location (definition-source) (with-definition-source (form-path character-offset plist) definition-source (destructuring-bind (&key emacs-buffer emacs-position emacs-directory emacs-string &allow-other-keys) plist (let ((*readtable* (guess-readtable-for-filename emacs-directory)) start end) (with-debootstrapping (or (and form-path (or #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) (setf (values start end) (and (sb-introspect:definition-source-form-number definition-source) (string-form-number-position definition-source emacs-string))) (setf (values start end) (source-path-string-position form-path emacs-string)))) (setf start character-offset end most-positive-fixnum))) (make-location `(:buffer ,emacs-buffer) `(:offset ,emacs-position ,start) `(:snippet ,(subseq emacs-string start (min end (+ start *source-snippet-size*))))))))) (defun definition-source-file-location (definition-source) (with-definition-source (pathname form-path character-offset plist file-write-date) definition-source (let* ((namestring (namestring (translate-logical-pathname pathname))) (pos (or (and form-path (or #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect) (and (sb-introspect:definition-source-form-number definition-source) (ignore-errors (file-form-number-position definition-source))) (ignore-errors (source-file-position namestring file-write-date form-path)))) character-offset)) (snippet (source-hint-snippet namestring file-write-date pos))) (make-location `(:file ,namestring) ;; /file positions/ in Common Lisp start from ;; 0, buffer positions in Emacs start from 1. `(:position ,(1+ pos)) `(:snippet ,snippet))))) (defun definition-source-buffer-and-file-location (definition-source) (let ((buffer (definition-source-buffer-location definition-source))) (make-location (list :buffer-and-file (cadr (location-buffer buffer)) (namestring (sb-introspect:definition-source-pathname definition-source))) (location-position buffer) (location-hints buffer)))) (defun definition-source-for-emacs (definition-source type name) (with-definition-source (pathname form-path character-offset plist file-write-date) definition-source (ecase (categorize-definition-source definition-source) (:buffer-and-file (definition-source-buffer-and-file-location definition-source)) (:buffer (definition-source-buffer-location definition-source)) (:file (definition-source-file-location definition-source)) (:file-without-position (make-location `(:file ,(namestring (translate-logical-pathname pathname))) '(:position 1) (when (eql type :function) `(:snippet ,(format nil "(defun ~a " (symbol-name name)))))) (:invalid (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ meaningful information." type name))))) (defun source-file-position (filename write-date form-path) (let ((source (get-source-code filename write-date)) (*readtable* (guess-readtable-for-filename filename))) (with-debootstrapping (source-path-string-position form-path source)))) (defun source-hint-snippet (filename write-date position) (read-snippet-from-string (get-source-code filename write-date) position)) (defun function-source-location (function &optional name) (declare (type function function)) (definition-source-for-emacs (sb-introspect:find-definition-source function) :function (or name (function-name function)))) (defun setf-expander (symbol) (or #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info) (sb-int:info :setf :inverse symbol) (sb-int:info :setf :expander symbol))) (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 (and (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 (setf-expander symbol))) (:class (describe (find-class symbol))) (:type (describe (sb-kernel:values-specifier-type symbol))))) #+#.(swank/sbcl::sbcl-with-xref-p) (progn (defmacro defxref (name &optional fn-name) `(defimplementation ,name (what) (sanitize-xrefs (mapcar #'source-location-for-xref-data (,(find-symbol (symbol-name (if fn-name fn-name name)) "SB-INTROSPECT") what))))) (defxref who-calls) (defxref who-binds) (defxref who-sets) (defxref who-references) (defxref who-macroexpands) #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect) (defxref who-specializes who-specializes-directly)) (defun source-location-for-xref-data (xref-data) (destructuring-bind (name . defsrc) xref-data (list name (converting-errors-to-error-location (definition-source-for-emacs defsrc 'function name))))) (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/sbcl::sbcl-with-new-stepper-p) '(nil sb-c::step-form sb-c::step-values) #+#.(swank/sbcl::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 (function-name fn))) (list name (converting-errors-to-error-location (function-source-location fn name))))) ;;; macroexpansion (defimplementation macroexpand-all (form &optional env) (sb-cltl2:macroexpand-all form env)) (defimplementation collect-macro-forms (form &optional environment) (let ((macro-forms '()) (compiler-macro-forms '()) (function-quoted-forms '())) (sb-walker:walk-form form environment (lambda (form context environment) (declare (ignore context)) (when (and (consp form) (symbolp (car form))) (cond ((eq (car form) 'function) (push (cadr form) function-quoted-forms)) ((member form function-quoted-forms) nil) ((macro-function (car form) environment) (push form macro-forms)) ((not (eq form (compiler-macroexpand-1 form environment))) (push form compiler-macro-forms)))) form)) (values macro-forms compiler-macro-forms))) ;;; Debugging ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger ;;; than just a hook into BREAK. In particular, it'll make ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather ;;; than the native debugger. That should probably be considered a ;;; feature. (defun make-invoke-debugger-hook (hook) (when hook #'(sb-int:named-lambda swank-invoke-debugger-hook (condition old-hook) (if *debugger-hook* nil ; decline, *DEBUGGER-HOOK* will be tried next. (funcall hook condition old-hook))))) (defun set-break-hook (hook) (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) (defun call-with-break-hook (hook continuation) (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) (funcall continuation))) (defimplementation install-debugger-globally (function) (setq *debugger-hook* function) (set-break-hook function)) (defimplementation condition-extras (condition) (cond #+#.(swank/sbcl::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)))))) (defvar *sldb-stack-top*) (defimplementation call-with-debugging-environment (debugger-loop-fn) (declare (type function debugger-loop-fn)) (let ((*sldb-stack-top* (if (and (not *debug-swank-backend*) sb-debug:*stack-top-hint*) #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) (sb-debug::resolve-stack-top-hint) #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug) sb-debug:*stack-top-hint* (sb-di:top-frame))) (sb-debug:*stack-top-hint* nil)) (handler-bind ((sb-di:debug-condition (lambda (condition) (signal 'sldb-condition :original-condition condition)))) (funcall debugger-loop-fn)))) #+#.(swank/sbcl::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 ((*debugger-hook* hook) #+#.(swank/sbcl::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/sbcl::sbcl-with-new-stepper-p) (sb-ext:step-condition #'sb-impl::invoke-stepper)) (call-with-break-hook hook 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)) (defimplementation frame-restartable-p (frame) #+#.(swank/sbcl::sbcl-with-restart-frame) (not (null (sb-debug:frame-has-debug-tag-p frame)))) (defimplementation frame-call (frame-number) (multiple-value-bind (name args) (sb-debug::frame-call (nth-frame frame-number)) (with-output-to-string (stream) (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (pprint-logical-block (stream nil :prefix "(" :suffix ")") (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) (let ((*print-length* nil) (*print-level* nil)) (prin1 (sb-debug::ensure-printable-object name) stream)) (let ((args (sb-debug::ensure-printable-object args))) (if (listp args) (format stream "~{ ~_~S~}" args) (format stream " ~S" args))))))))) ;;;; 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)) (package (getf plist :emacs-package)) (*package* (or (and package (find-package package)) *package*))) (if (getf plist :emacs-buffer) (emacs-buffer-source-location code-location plist) #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di) (ecase (sb-di:debug-source-from dsource) (:file (file-source-location code-location)) (:lisp (lisp-source-location code-location))) #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di) (if (sb-di:debug-source-namestring dsource) (file-source-location code-location) (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))) (condition swank:*swank-debugger-condition*)) (if (and (typep condition 'sb-impl::step-form-condition) (search "SB-IMPL::WITH-STEPPING-ENABLED" source :test #'char-equal) (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal)) ;; The initial form is utterly uninteresting -- and almost ;; certainly right there in the REPL. (make-error-location "Stepping...") (make-location `(:source-form ,source) '(:position 1))))) (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 (read-snippet-from-string emacs-string pos))) (make-location `(:buffer ,emacs-buffer) `(:offset ,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)) (*readtable* (guess-readtable-for-filename filename)) (source-code (get-source-code filename code-date))) (with-debootstrapping (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 ,pos) `(:snippet ,snippet))))))) (defun code-location-debug-source-name (code-location) (namestring (truename (#.(swank/backend:choose-symbol 'sb-c 'debug-source-name 'sb-c 'debug-source-namestring) (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 source-path-parser (defimplementation frame-source-location (index) (converting-errors-to-error-location (code-location-source-location (sb-di:frame-code-location (nth-frame index))))) (defvar *keep-non-valid-locals* nil) (defun frame-debug-vars (frame) "Return a vector of debug-variables in frame." (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))) (cond (*keep-non-valid-locals* all-vars) (t (let ((loc (sb-di:frame-code-location frame))) (remove-if (lambda (var) (ecase (sb-di:debug-var-validity var loc) (:valid nil) ((:invalid :unknown) t))) all-vars)))))) (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) ':))) (defun debug-var-info (var) ;; Introduced by SBCL 1.0.49.76. (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) (when (and s (fboundp s)) (funcall s var)))) (defimplementation frame-locals (index) (let* ((frame (nth-frame index)) (loc (sb-di:frame-code-location frame)) (vars (frame-debug-vars frame)) ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE ;; specially. (more-name (or (find-symbol "MORE" :sb-debug) 'more)) (more-context nil) (more-count nil)) (when vars (let ((locals (loop for v across vars unless (case (debug-var-info v) (:more-context (setf more-context (debug-var-value v frame loc)) t) (:more-count (setf more-count (debug-var-value v frame loc)) t)) collect (list :name (sb-di:debug-var-symbol v) :id (sb-di:debug-var-id v) :value (debug-var-value v frame loc))))) (when (and more-context more-count) (setf locals (append locals (list (list :name more-name :id 0 :value (multiple-value-list (sb-c:%more-arg-values more-context 0 more-count))))))) locals)))) (defimplementation frame-var-value (frame var) (let* ((frame (nth-frame frame)) (vars (frame-debug-vars frame)) (loc (sb-di:frame-code-location frame)) (dvar (if (= var (length vars)) ;; If VAR is out of bounds, it must be the fake var ;; we made up for &MORE. (let* ((context-var (find :more-context vars :key #'debug-var-info)) (more-context (debug-var-value context-var frame loc)) (count-var (find :more-count vars :key #'debug-var-info)) (more-count (debug-var-value count-var frame loc))) (return-from frame-var-value (multiple-value-list (sb-c:%more-arg-values more-context 0 more-count)))) (aref vars var)))) (debug-var-value dvar frame loc))) (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))) (defimplementation frame-package (frame-number) (let* ((frame (nth-frame frame-number)) (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))) (when fun (let ((name (function-name fun))) (typecase name (null nil) (symbol (symbol-package name)) ((cons (eql setf) (cons symbol)) (symbol-package (cadr name)))))))) #+#.(swank/sbcl::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))) (when (sb-debug:frame-has-debug-tag-p frame) (multiple-value-bind (fname args) (sb-debug::frame-call frame) (multiple-value-bind (fun arglist) (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) (values (fdefinition fname) args) (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) (sb-debug::frame-args-as-list frame))) (when (functionp fun) (sb-debug:unwind-to-frame-and-call frame (lambda () ;; Ensure TCO. (declare (optimize (debug 0))) (apply fun arglist))))))) (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/sbcl::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 print-condition (condition stream) (let ((sb-int:*print-condition-references* nil)) (princ condition stream))) ;;;; 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 (defmethod emacs-inspect ((o t)) (cond ((sb-di::indirect-value-cell-p o) (label-value-line* (:value (sb-kernel:value-cell-ref o)))) (t (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) (list* (string-right-trim '(#\Newline) text) '(:newline) (if label (loop for (l . v) in parts append (label-value-line l v)) (loop for value in parts for i from 0 append (label-value-line i value)))))))) (defmethod emacs-inspect ((o function)) (cond ((sb-kernel:simple-fun-p o) (label-value-line* (:name (sb-kernel:%simple-fun-name o)) (:arglist (sb-kernel:%simple-fun-arglist o)) (:next (sb-kernel:%simple-fun-next o)) (:type (sb-kernel:%simple-fun-type o)) (:code (sb-kernel:fun-code-header o)))) ((sb-kernel:closurep o) (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 emacs-inspect ((o sb-kernel:code-component)) (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))) `("Constants:" (:newline)) (loop for i from sb-vm:code-constants-offset below (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words '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 emacs-inspect ((o sb-ext:weak-pointer)) (label-value-line* (:value (sb-ext:weak-pointer-value o)))) (defmethod emacs-inspect ((o sb-kernel:fdefn)) (label-value-line* (:name (sb-kernel:fdefn-name o)) (:function (sb-kernel:fdefn-fun o)))) (defmethod emacs-inspect :around ((o generic-function)) (append (call-next-method) (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 #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD")) (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-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 wake-thread (thread) (let* ((mbox (mailbox thread)) (mutex (mailbox.mutex mbox))) (sb-thread:with-mutex (mutex) (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) (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-if (test &optional timeout) (let* ((mbox (mailbox (current-thread))) (mutex (mailbox.mutex mbox)) (waitq (mailbox.waitqueue mbox))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (sb-thread:with-mutex (mutex) (let* ((q (mailbox.queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail)))) (when (eq timeout t) (return (values nil t))) (sb-thread:condition-wait waitq mutex))))) (let ((alist '()) (mutex (sb-thread:make-mutex :name "register-thread"))) (defimplementation register-thread (name thread) (declare (type symbol name)) (sb-thread:with-mutex (mutex) (etypecase thread (null (setf alist (delete name alist :key #'car))) (sb-thread:thread (let ((probe (assoc name alist))) (cond (probe (setf (cdr probe) thread)) (t (setf alist (acons name thread alist)))))))) nil) (defimplementation find-registered (name) (sb-thread:with-mutex (mutex) (cdr (assoc name alist))))) ;; Workaround for deadlocks between the world-lock and auto-flush-thread ;; buffer write lock. ;; ;; Another alternative would be to grab the world-lock here, but that's less ;; future-proof, and could introduce other lock-ordering issues in the ;; future. ;; ;; In an ideal world we would just have an :AROUND method on ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this ;; file is loaded -- so first we need a dummy definition that will be ;; overridden by swank-gray.lisp. #.(unless (find-package 'swank/gray) (make-package 'swank/gray) nil) (eval-when (:load-toplevel :execute) (unless (find-package 'swank/gray) (make-package 'swank/gray) nil)) (defclass swank/gray::slime-output-stream (sb-gray:fundamental-character-output-stream) ()) (defmethod sb-gray:stream-force-output :around ((stream swank/gray::slime-output-stream)) (handler-case (sb-sys:with-deadline (:seconds 0.1) (call-next-method)) (sb-sys:deadline-timeout () nil))) ) (defimplementation quit-lisp () #+#.(swank/backend:with-symbol 'exit 'sb-ext) (sb-ext:exit) #-#.(swank/backend:with-symbol 'exit 'sb-ext) (progn #+sb-thread (dolist (thread (remove (current-thread) (all-threads))) (ignore-errors (sb-thread:terminate-thread thread))) (sb-ext:quit))) ;;Trace implementations ;;In SBCL, we have: ;; (trace ) ;; (trace :methods ') ;to trace all methods of the gf ;; (trace (method ? (+))) ;; 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/sbcl::sbcl-with-weak-hash-tables) (apply #'make-hash-table :weakness :key args) #-#.(swank/sbcl::sbcl-with-weak-hash-tables) (apply #'make-hash-table args)) (defimplementation make-weak-value-hash-table (&rest args) #+#.(swank/sbcl::sbcl-with-weak-hash-tables) (apply #'make-hash-table :weakness :value args) #-#.(swank/sbcl::sbcl-with-weak-hash-tables) (apply #'make-hash-table args)) (defimplementation hash-table-weakness (hashtable) #+#.(swank/sbcl::sbcl-with-weak-hash-tables) (sb-ext:hash-table-weakness hashtable)) ;;; Floating point (defimplementation float-nan-p (float) (sb-ext:float-nan-p float)) (defimplementation float-infinity-p (float) (sb-ext:float-infinity-p float)) #-win32 (defimplementation save-image (filename &optional restart-function) (flet ((restart-sbcl () (sb-debug::enable-debugger) (setf sb-impl::*descriptor-handlers* nil) (funcall restart-function))) (let ((pid (sb-posix:fork))) (cond ((= pid 0) (sb-debug::disable-debugger) (apply #'sb-ext:save-lisp-and-die filename (when restart-function (list :toplevel #'restart-sbcl)))) (t (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) (assert (= pid rpid)) (assert (and (sb-posix:wifexited status) (zerop (sb-posix:wexitstatus status)))))))))) #+unix (progn (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int (program sb-alien:c-string) (argv (* sb-alien:c-string))) (defun execv (program args) "Replace current executable with another one." (let ((a-args (sb-alien:make-alien sb-alien:c-string (+ 1 (length args))))) (unwind-protect (progn (loop for index from 0 by 1 and item in (append args '(nil)) do (setf (sb-alien:deref a-args index) item)) (when (minusp (sys-execv program a-args)) (error "execv(3) returned."))) (sb-alien:free-alien a-args)))) (defun runtime-pathname () #+#.(swank/backend:with-symbol '*runtime-pathname* 'sb-ext) sb-ext:*runtime-pathname* #-#.(swank/backend:with-symbol '*runtime-pathname* 'sb-ext) (car sb-ext:*posix-argv*)) (defimplementation exec-image (image-file args) (loop with fd-arg = (loop for arg in args and key = "" then arg when (string-equal key "--swank-fd") return (parse-integer arg)) for my-fd from 3 to 1024 when (/= my-fd fd-arg) do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) (let* ((self-string (pathname-to-filename (runtime-pathname)))) (execv self-string (apply 'list self-string "--core" image-file args))))) (defimplementation make-fd-stream (fd external-format) (sb-sys:make-fd-stream fd :input t :output t :element-type 'character :buffering :full :dual-channel-p t :external-format external-format)) #-win32 (defimplementation background-save-image (filename &key restart-function completion-function) (flet ((restart-sbcl () (sb-debug::enable-debugger) (setf sb-impl::*descriptor-handlers* nil) (funcall restart-function))) (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) (let ((pid (sb-posix:fork))) (cond ((= pid 0) (sb-posix:close pipe-in) (sb-debug::disable-debugger) (apply #'sb-ext:save-lisp-and-die filename (when restart-function (list :toplevel #'restart-sbcl)))) (t (sb-posix:close pipe-out) (sb-sys:add-fd-handler pipe-in :input (lambda (fd) (sb-sys:invalidate-descriptor fd) (sb-posix:close fd) (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) (assert (= pid rpid)) (assert (sb-posix:wifexited status)) (funcall completion-function (zerop (sb-posix:wexitstatus status)))))))))))) (pushnew 'deinit-log-output sb-ext:*save-hooks*) ;;;; wrap interface implementation (defun sbcl-version>= (&rest subversions) #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t)) #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext) nil) (defimplementation wrap (spec indicator &key before after replace) (when (wrapped-p spec indicator) (warn "~a already wrapped with indicator ~a, unwrapping first" spec indicator) (sb-int:unencapsulate spec indicator)) (sb-int:encapsulate spec indicator #-#.(swank/backend:with-symbol 'arg-list 'sb-int) (lambda (function &rest args) (sbcl-wrap spec before after replace function args)) #+#.(swank/backend:with-symbol 'arg-list 'sb-int) (if (sbcl-version>= 1 1 16) (lambda () (sbcl-wrap spec before after replace (symbol-value 'sb-int:basic-definition) (symbol-value 'sb-int:arg-list))) `(sbcl-wrap ',spec ,before ,after ,replace (symbol-value 'sb-int:basic-definition) (symbol-value 'sb-int:arg-list))))) (defimplementation unwrap (spec indicator) (sb-int:unencapsulate spec indicator)) (defimplementation wrapped-p (spec indicator) (sb-int:encapsulated-p spec indicator)) (defun sbcl-wrap (spec before after replace function args) (declare (ignore spec)) (let (retlist completed) (unwind-protect (progn (when before (funcall before args)) (setq retlist (multiple-value-list (if replace (funcall replace args) (apply function args)))) (setq completed t) (values-list retlist)) (when after (funcall after (if completed retlist :exited-non-locally)))))) #+#.(swank/backend:with-symbol 'comma-expr 'sb-impl) (progn (defmethod sexp-in-bounds-p ((s sb-impl::comma) i) (= i 1)) (defmethod sexp-ref ((s sb-impl::comma) i) (sb-impl::comma-expr s))) slime-2.20/swank/scl.lisp000066400000000000000000002037061315100173500153470ustar00rootroot00000000000000;;; -*- 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. ;;; (defpackage swank/scl (:use cl swank/backend swank/source-path-parser swank/source-file-cache)) (in-package swank/scl) ;;; 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 &key backlog) (let ((addr (resolve-hostname host))) (ext:create-inet-listener port :stream :host addr :reuse-address t :backlog (or backlog 5)))) (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 ((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 (ecase buffering ((t) :full) ((nil) :none) (:line :line))))))))) (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 'lisp::stream) 'lisp::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." (cond ((not external-format) (sys:make-fd-stream fd :input t :output t :buffering buffering :element-type '(unsigned-byte 8))) (t (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 (lisp::character-conversion-stream-input-error-value stream) #\?) (setf (lisp::character-conversion-stream-output-error-value stream) #\?) stream)))) ;;;; Stream handling (defimplementation gray-package-name () '#:ext) ;;;; 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 (input-file output-file load-p external-format &key policy) (declare (ignore policy)) (with-compilation-hooks () (let ((*buffer-name* nil) (ext:*ignore-extra-close-parentheses* nil)) (multiple-value-bind (output-file warnings-p failure-p) (compile-file input-file :output-file output-file :external-format external-format) (values output-file warnings-p (or failure-p (when load-p ;; Cache the latest source file for definition-finding. (source-cache-get input-file (file-write-date input-file)) (not (load output-file))))))))) (defimplementation swank-compile-string (string &key buffer position filename policy) (declare (ignore filename policy)) (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 'compiler-condition :original-condition condition :severity (severity-for-emacs condition) :message (brief-compiler-message-for-emacs condition) :source-context (compiler-error-context 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 compiler-error-context (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))) (if (and enclosing source) (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]" enclosing source)))) (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 :offset *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 ) 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 (make-location (list :buffer *buffer-name*) (list :offset *buffer-start-position* (source-path-string-position source-path *buffer-substring*)))) ((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 ;;; `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.") (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 :offset (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) (multiple-value-bind (args winp) (ext:function-arglist fun) (if winp args :not-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 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))))) ;;;; Miscellaneous. (defimplementation macroexpand-all (form &optional env) (declare (ignore env)) (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 pathname-to-filename (pathname) (ext:unix-namestring pathname nil)) (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 ;;; 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 '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 (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 "<>" 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 (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 emacs-inspect ((o t)) (cond ((di::indirect-value-cell-p 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) (list* (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 emacs-inspect ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (list* (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) (list* (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 emacs-inspect ((o kernel:code-component)) (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 emacs-inspect ((o kernel:fdefn)) (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 emacs-inspect ((o array)) (cond ((kernel:array-header-p o) (list* (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 (list* (format nil "~A is an simple-array.~%" o) (label-value-line* (:header (describe-primitive-type o)) (:length (length o))))))) (defmethod emacs-inspect ((o simple-vector)) (list* (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) (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) (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" :interruptible nil)) (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." (sys:without-interrupts (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))) #+nil (defimplementation receive () (receive-if (constantly t))) (defimplementation receive-if (test &optional timeout) (let ((mbox (mailbox thread:*thread*))) (assert (or (not timeout) (eq timeout t))) (loop (check-slime-interrupts) (sys:without-interrupts (mp:with-lock-held ((mailbox-lock mbox)) (let* ((q (mailbox-queue mbox)) (tail (member-if test q))) (when tail (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) (return (car tail)))))) (when (eq timeout t) (return (values nil t))) (mp:process-wait-with-timeout "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox))))))) (defimplementation emacs-connected ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;Trace implementations ;; In SCL, we have: ;; (trace ) ;; (trace (method ? (+))) ;; (trace :methods t ') ;;to trace all methods of the gf ;; 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)) slime-2.20/swank/source-file-cache.lisp000066400000000000000000000121021315100173500200300ustar00rootroot00000000000000;;;; Source-file cache ;;; ;;; To robustly find source locations in CMUCL and SBCL it's useful to ;;; have the exact source code that the loaded code was compiled from. ;;; In this source we can accurately find the right location, and from ;;; that location we can extract a "snippet" of code to show what the ;;; definition looks like. Emacs can use this snippet in a best-match ;;; search to locate the right definition, which works well even if ;;; the buffer has been modified. ;;; ;;; The idea is that if a definition previously started with ;;; `(define-foo bar' then it probably still does. ;;; ;;; Whenever we see that the file on disk has the same ;;; `file-write-date' as a location we're looking for we cache the ;;; whole file inside Lisp. That way we will still have the matching ;;; version even if the file is later modified on disk. If the file is ;;; later recompiled and reloaded then we replace our cache entry. ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. (defpackage swank/source-file-cache (:use cl) (:import-from swank/backend defimplementation buffer-first-change guess-external-format find-external-format) (:export get-source-code source-cache-get ;FIXME: isn't it odd that both are exported? *source-snippet-size* read-snippet read-snippet-from-string )) (in-package swank/source-file-cache) (defvar *cache-sourcecode* t "When true complete source files are cached. The cache is used to keep known good copies of the source text which correspond to the loaded code. Finding definitions is much more reliable when the exact source is available, so we cache it in case it gets edited on disk later.") (defvar *source-file-cache* (make-hash-table :test 'equal) "Cache of source file contents. Maps from truename to source-cache-entry structure.") (defstruct (source-cache-entry (:conc-name source-cache-entry.) (:constructor make-source-cache-entry (text date))) text date) (defimplementation buffer-first-change (filename) "Load a file into the cache when the user modifies its buffer. This is a win if the user then saves the file and tries to M-. into it." (unless (source-cached-p filename) (ignore-errors (source-cache-get filename (file-write-date filename)))) nil) (defun get-source-code (filename code-date) "Return the source code for FILENAME as written on DATE in a string. If the exact version cannot be found then return the current one from disk." (or (source-cache-get filename code-date) (read-file filename))) (defun source-cache-get (filename date) "Return the source code for FILENAME as written on DATE in a string. Return NIL if the right version cannot be found." (when *cache-sourcecode* (let ((entry (gethash filename *source-file-cache*))) (cond ((and entry (equal date (source-cache-entry.date entry))) ;; Cache hit. (source-cache-entry.text entry)) ((or (null entry) (not (equal date (source-cache-entry.date entry)))) ;; Cache miss. (if (equal (file-write-date filename) date) ;; File on disk has the correct version. (let ((source (read-file filename))) (setf (gethash filename *source-file-cache*) (make-source-cache-entry source date)) source) nil)))))) (defun source-cached-p (filename) "Is any version of FILENAME in the source cache?" (if (gethash filename *source-file-cache*) t)) (defun read-file (filename) "Return the entire contents of FILENAME as a string." (with-open-file (s filename :direction :input :external-format (or (guess-external-format filename) (find-external-format "latin-1") :default)) (let* ((string (make-string (file-length s))) (length (read-sequence string s))) (subseq string 0 length)))) ;;;; Snippets (defvar *source-snippet-size* 256 "Maximum number of characters in a snippet of source code. Snippets at the beginning of definitions are used to tell Emacs what the definitions looks like, so that it can accurately find them by text search.") (defun read-snippet (stream &optional position) "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. If POSITION is given, set the STREAM's file position first." (when position (file-position stream position)) #+sbcl (skip-comments-and-whitespace stream) (read-upto-n-chars stream *source-snippet-size*)) (defun read-snippet-from-string (string &optional position) (with-input-from-string (s string) (read-snippet s position))) (defun skip-comments-and-whitespace (stream) (case (peek-char nil stream nil nil) ((#\Space #\Tab #\Newline #\Linefeed #\Page) (read-char stream) (skip-comments-and-whitespace stream)) (#\; (read-line stream) (skip-comments-and-whitespace stream)))) (defun read-upto-n-chars (stream n) "Return a string of upto N chars from STREAM." (let* ((string (make-string n)) (chars (read-sequence string stream))) (subseq string 0 chars))) slime-2.20/swank/source-path-parser.lisp000066400000000000000000000220671315100173500203110ustar00rootroot00000000000000;;;; Source-paths ;;; CMUCL/SBCL use a data structure called "source-path" to locate ;;; subforms. The compiler assigns a source-path to each form in a ;;; compilation unit. Compiler notes usually contain the source-path ;;; of the error location. ;;; ;;; Compiled code objects don't contain source paths, only the ;;; "toplevel-form-number" and the (sub-) "form-number". To get from ;;; the form-number to the source-path we need the entire toplevel-form ;;; (i.e. we have to read the source code). CMUCL has already some ;;; utilities to do this translation, but we use some extended ;;; versions, because we need more exact position info. Apparently ;;; Hemlock is happy with the position of the toplevel-form; we also ;;; need the position of subforms. ;;; ;;; We use a special readtable to get the positions of the subforms. ;;; The readtable stores the start and end position for each subform in ;;; hashtable for later retrieval. ;;; ;;; This code has been placed in the Public Domain. All warranties ;;; are disclaimed. ;;; Taken from swank-cmucl.lisp, by Helmut Eller (defpackage swank/source-path-parser (:use cl) (:export read-source-form source-path-string-position source-path-file-position source-path-source-position sexp-in-bounds-p sexp-ref) (:shadow ignore-errors)) (in-package swank/source-path-parser) ;; Some test to ensure the required conformance (let ((rt (copy-readtable nil))) (assert (or (not (get-macro-character #\space rt)) (nth-value 1 (get-macro-character #\space rt)))) (assert (not (get-macro-character #\\ rt)))) (eval-when (:compile-toplevel) (defmacro ignore-errors (&rest forms) ;;`(progn . ,forms) ; for debugging `(cl:ignore-errors . ,forms))) (defun make-sharpdot-reader (orig-sharpdot-reader) (lambda (s c n) ;; We want things like M-. to work regardless of any #.-fu in ;; the source file that is to be visited. (For instance, when a ;; file contains #. forms referencing constants that do not ;; currently exist in the image.) (ignore-errors (funcall orig-sharpdot-reader s c n)))) (defun make-source-recorder (fn source-map) "Return a macro character function that does the same as FN, but additionally stores the result together with the stream positions before and after of calling FN in the hashtable SOURCE-MAP." (lambda (stream char) (let ((start (1- (file-position stream))) (values (multiple-value-list (funcall fn stream char))) (end (file-position stream))) #+(or) (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" start values end (char-code char) char) (when values (destructuring-bind (&optional existing-start &rest existing-end) (car (gethash (car values) source-map)) ;; Some macros may return what a sub-call to another macro ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, ;; once from #\# and once from #\(. If the saved form ;; is a subform, don't save it again. (unless (and existing-start existing-end (<= start existing-start end) (<= start existing-end end)) (push (cons start end) (gethash (car values) source-map))))) (values-list values)))) (defun make-source-recording-readtable (readtable source-map) (declare (type readtable readtable) (type hash-table source-map)) "Return a source position recording copy of READTABLE. The source locations are stored in SOURCE-MAP." (flet ((install-special-sharpdot-reader (rt) (let ((fun (ignore-errors (get-dispatch-macro-character #\# #\. rt)))) (when fun (let ((wrapper (make-sharpdot-reader fun))) (set-dispatch-macro-character #\# #\. wrapper rt))))) (install-wrappers (rt) (dotimes (code 128) (let ((char (code-char code))) (multiple-value-bind (fun nt) (get-macro-character char rt) (when fun (let ((wrapper (make-source-recorder fun source-map))) (set-macro-character char wrapper nt rt)))))))) (let ((rt (copy-readtable readtable))) (install-special-sharpdot-reader rt) (install-wrappers rt) rt))) ;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. ;; Should be possible as we only need the right "list structure" and ;; not the right atoms. (defun read-and-record-source-map (stream) "Read the next object from STREAM. Return the object together with a hashtable that maps subexpressions of the object to stream positions." (let* ((source-map (make-hash-table :test #'eq)) (*readtable* (make-source-recording-readtable *readtable* source-map)) (*read-suppress* nil) (start (file-position stream)) (form (ignore-errors (read stream))) (end (file-position stream))) ;; ensure that at least FORM is in the source-map (unless (gethash form source-map) (push (cons start end) (gethash form source-map))) (values form source-map))) (defun starts-with-p (string prefix) (declare (type string string prefix)) (not (mismatch string prefix :end1 (min (length string) (length prefix)) :test #'char-equal))) (defun extract-package (line) (declare (type string line)) (let ((name (cadr (read-from-string line)))) (find-package name))) #+(or) (progn (assert (extract-package "(in-package cl)")) (assert (extract-package "(cl:in-package cl)")) (assert (extract-package "(in-package \"CL\")")) (assert (extract-package "(in-package #:cl)"))) ;; FIXME: do something cleaner than this. (defun readtable-for-package (package) ;; KLUDGE: due to the load order we can't reference the swank ;; package. (funcall (read-from-string "swank::guess-buffer-readtable") (string-upcase (package-name package)))) ;; Search STREAM for a "(in-package ...)" form. Use that to derive ;; the values for *PACKAGE* and *READTABLE*. ;; ;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends ;; use the same heuristic and to avoid the need to access ;; swank::guess-buffer-readtable from here. (defun guess-reader-state (stream) (let* ((point (file-position stream)) (pkg *package*)) (file-position stream 0) (loop for line = (read-line stream nil nil) do (when (not line) (return)) (when (or (starts-with-p line "(in-package ") (starts-with-p line "(cl:in-package ")) (let ((p (extract-package line))) (when p (setf pkg p))) (return))) (file-position stream point) (values (readtable-for-package pkg) pkg))) (defun skip-whitespace (stream) (peek-char t stream nil nil)) ;; Skip over N toplevel forms. (defun skip-toplevel-forms (n stream) (let ((*read-suppress* t)) (dotimes (i n) (read stream)) (skip-whitespace stream))) (defun read-source-form (n stream) "Read the Nth toplevel form number with source location recording. Return the form and the source-map." (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) (skip-toplevel-forms n stream) (read-and-record-source-map stream))) (defun source-path-stream-position (path stream) "Search the source-path PATH in STREAM and return its position." (check-source-path path) (destructuring-bind (tlf-number . path) path (multiple-value-bind (form source-map) (read-source-form tlf-number stream) (source-path-source-position (cons 0 path) form source-map)))) (defun check-source-path (path) (unless (and (consp path) (every #'integerp path)) (error "The source-path ~S is not valid." path))) (defun source-path-string-position (path string) (with-input-from-string (s string) (source-path-stream-position path s))) (defun source-path-file-position (path filename) ;; We go this long way round, and don't directly operate on the file ;; stream because FILE-POSITION (used above) is not totally savy even ;; on file character streams; on SBCL, FILE-POSITION returns the binary ;; offset, and not the character offset---screwing up on Unicode. (let ((toplevel-number (first path)) (buffer)) (with-open-file (file filename) (skip-toplevel-forms (1+ toplevel-number) file) (let ((endpos (file-position file))) (setq buffer (make-array (list endpos) :element-type 'character :initial-element #\Space)) (assert (file-position file 0)) (read-sequence buffer file :end endpos))) (source-path-string-position path buffer))) (defgeneric sexp-in-bounds-p (sexp i) (:method ((list list) i) (< i (loop for e on list count t))) (:method ((sexp t) i) nil)) (defgeneric sexp-ref (sexp i) (:method ((s list) i) (elt s i))) (defun source-path-source-position (path form source-map) "Return the start position of PATH from FORM and SOURCE-MAP. All subforms along the path are considered and the start and end position of the deepest (i.e. smallest) possible form is returned." ;; compute all subforms along path (let ((forms (loop for i in path for f = form then (if (sexp-in-bounds-p f i) (sexp-ref f i)) collect f))) ;; select the first subform present in source-map (loop for form in (nreverse forms) for ((start . end) . rest) = (gethash form source-map) when (and start end (not rest)) return (return (values start end)))))