slime-2.18.orig/0000755000175000017500000000000013004177010011627 5ustar pdmpdmslime-2.18.orig/swank-loader.lisp0000644000175000017500000003313612720104623015121 0ustar pdmpdm;;;; -*- 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 slime-version-string () "Return a string identifying the SLIME version. Return nil if nothing appropriate is available." (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*) :if-does-not-exist nil) (and s (symbol-name (read s))))) (defun default-fasl-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 string-starts-with (string prefix) (string-equal string prefix :end1 (min (length string) (length prefix)))) (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.18.orig/start-swank.lisp0000644000175000017500000000126212720104623015003 0ustar pdmpdm;;; 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.18.orig/NEWS0000644000175000017500000004531512720104623012342 0ustar pdmpdm* SLIME News -*- mode: outline; coding: utf-8 -*- * 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.18.orig/swank.lisp0000644000175000017500000042150512720104623013656 0ustar pdmpdm;;;; 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 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*))))))) ;;; 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.") (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*) 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." (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))) (defparameter *loopback-interface* "127.0.0.1") (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 (decode-message 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 (interrupt-thread thread (lambda () ;; safely interrupt THREAD (invoke-or-queue-interrupt #'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) :named) 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*)) (interrupt-thread (nth-thread index) (lambda () (invoke-or-queue-interrupt (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.18.orig/sbcl-pprint-patch.lisp0000644000175000017500000002765412720104623016074 0ustar pdmpdm;; 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.18.orig/slime-tests.el0000644000175000017500000015575312720104623014446 0ustar pdmpdm;;; 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.18.orig/slime.el0000644000175000017500000106000512720104623013270 0ustar pdmpdm;;; 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.18 ;;;; 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)) (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-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." (add-to-list 'load-path (expand-file-name "contrib" slime-path)) (when slime-contribs (dolist (c slime-contribs) (unless (and (featurep c) (memq c slime-required-modules)) (require c) (let ((init (intern (format "%s-init" c)))) (when (fboundp init) (funcall init))))))) (defun slime-lisp-mode-hook () (slime-mode 1) (set (make-local-variable 'lisp-indent-function) 'common-lisp-indent-function)) (eval-and-compile (defun slime--changelog-file-name () (expand-file-name "ChangeLog" (if (and (boundp 'byte-compile-current-file) byte-compile-current-file) (file-name-directory byte-compile-current-file) slime-path))) (defun slime-changelog-date (&optional interactivep) "Return the datestring of the latest entry in the ChangeLog file. Return nil if the ChangeLog file cannot be found." (interactive "p") (let ((changelog (slime--changelog-file-name)) (date nil)) (when (file-exists-p changelog) (with-temp-buffer (insert-file-contents-literally changelog nil 0 100) (goto-char (point-min)) (setq date (symbol-name (read (current-buffer)))))) (when interactivep (message "Slime ChangeLog dates %s." date)) date))) (defvar slime-protocol-version nil) (setq slime-protocol-version (eval-when-compile (slime-changelog-date))) ;;;; Customize groups ;; ;;;;; slime (defgroup slime nil "Interaction with the Superior Lisp Environment." :prefix "slime-" :group 'applications) ;;;;; slime-ui (defgroup slime-ui nil "Interaction with the Superior Lisp Environment." :prefix "slime-" :group 'slime) (defcustom slime-truncate-lines t "Set `truncate-lines' in popup buffers. This applies to buffers that present lines as rows of data, such as debugger backtraces and apropos listings." :type 'boolean :group 'slime-ui) (defcustom slime-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) (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)) (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!" ,(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-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)) (let ((secret (slime-secret))) (when secret (slime-net-send secret proc))) proc)) (defun slime-make-net-buffer (name) "Make a buffer suitable for a network process." (let ((buffer (generate-new-buffer name))) (with-current-buffer buffer (buffer-disable-undo) (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) (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.18.orig/swank/0000755000175000017500000000000012720104623012756 5ustar pdmpdmslime-2.18.orig/swank/backend.lisp0000644000175000017500000015540212720104623015245 0ustar pdmpdm;;; -*- 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)))) ;;;; 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))))) (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) :named (:constructor make-location (buffer position &optional hints))) buffer position ;; Hints is a property list optionally containing: ;; :snippet SOURCE-TEXT ;; This is a snippet of the actual source text at the start of ;; the definition, which could be used in a text search. hints) (defstruct (:error (:type list) :named (:constructor)) message) ;;; Valid content for BUFFER slot (defstruct (:file (:type list) :named (:constructor)) name) (defstruct (:buffer (:type list) :named (:constructor)) name) (defstruct (:etags-file (:type list) :named (:constructor)) filename) ;;; Valid content for POSITION slot (defstruct (:position (:type list) :named (:constructor)) pos) (defstruct (:tag (:type list) :named (:constructor)) tag1 tag2) (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 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) ;;;; 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.18.orig/swank/abcl.lisp0000644000175000017500000007013212720104623014553 0ustar pdmpdm;;;; -*- 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)) (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))) `(:location (:file ,(namestring (ext:source-pathname symbol))) ,(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.18.orig/swank/gray.lisp0000644000175000017500000001217512720104623014617 0ustar pdmpdm;;;; -*- 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.18.orig/swank/allegro.lisp0000644000175000017500000011237712720104623015307 0ustar pdmpdm;;;; -*- 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 (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 (if (typep condition 'reader-error) (location-for-reader-error condition) (location-for-warning condition)))))) (defun location-for-warning (condition) (let ((loc (getf (slot-value condition 'excl::plist) :loc))) (cond (*buffer-name* (make-location (list :buffer *buffer-name*) (list :offset *buffer-start-position* 0))) (loc (destructuring-bind (file . pos) loc (let ((start (cond ((consp pos) ; 8.2 and newer (car pos)) (t pos)))) (make-location (list :file (namestring (truename file))) (list :position (1+ start)))))) (t (make-error-location "No error location available."))))) (defun location-for-reader-error (condition) (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) (file (pathname (stream-error-stream condition)))) (if (integerp pos) (if *buffer-name* (make-location `(:buffer ,*buffer-name*) `(:offset ,*buffer-start-position* ,pos)) (make-location `(:file ,(namestring (truename file))) `(:position ,pos))) (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)) (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 80) ; should be enough for everyone (header-length (+ (length source-pathname-string) position-form-length-bound)) (position-form `(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) ;; NOTE: requires lldb. jt -- don't know the meaning of ;; this note. ;; #+(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.18.orig/swank/ecl.lisp0000644000175000017500000007047312720104623014425 0ustar pdmpdm;;;; -*- 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") ;;;; TCP Server (defimplementation preferred-communication-style () ;; While ECL does provide threads, some parts of it are not ;; thread-safe (2010-02-23), including the compiler and CLOS. nil ;; ECL on Windows does not provide condition-variables ;; (or #+(and threads (not windows)) :spawn ;; 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, 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))) ;;;; Unix Integration ;;; 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. (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 () (ext: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)) #-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))) (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 *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))))) ;;;; Documentation (defimplementation arglist (name) (multiple-value-bind (arglist foundp) (ext:function-lambda-list name) (if foundp arglist :not-available))) (defimplementation function-name (f) (typecase f (generic-function (clos:generic-function-name f)) (function (si:compiled-function-name f)))) ;; FIXME ;; (defimplementation macroexpand-all (form &optional env) ;; (declare (ignore 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 () ,form)))) (values macro-forms nil))) (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* 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* '()) ;;; 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 ECL'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* (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* (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))) (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))) (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 ;;; FIXME: Would be nice if it was possible to inspect objects ;;; implemented in C. ;;;; Definitions (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))) ;;;; 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 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))))) (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-timedwait (mailbox.cvar mbox) mutex 0.2))))) ) ; #+threads (progn ... slime-2.18.orig/swank/match.lisp0000644000175000017500000002150712720104623014750 0ustar pdmpdm;; ;; 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.18.orig/swank/rpc.lisp0000644000175000017500000001233612720104623014440 0ustar pdmpdm;;; -*- 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.18.orig/swank/clisp.lisp0000644000175000017500000010357212720104623014771 0ustar pdmpdm;;;; -*- 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.18.orig/swank/ccl.lisp0000644000175000017500000007503712720104623014424 0ustar pdmpdm;;;; -*- 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 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:timed-wait-on-semaphore (mailbox.semaphore mbox) 1)))) (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.18.orig/swank/mkcl.lisp0000644000175000017500000007452512720104623014612 0ustar pdmpdm;;;; -*- 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.18.orig/swank/corman.lisp0000644000175000017500000004640012720104623015132 0ustar pdmpdm;;; ;;; 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.18.orig/swank/lispworks.lisp0000644000175000017500000011000712720104623015703 0ustar pdmpdm;;; -*- 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.18.orig/swank/source-path-parser.lisp0000644000175000017500000002206712720104623017402 0ustar pdmpdm;;;; 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))))) slime-2.18.orig/swank/source-file-cache.lisp0000644000175000017500000001207212720104623017127 0ustar pdmpdm;;;; 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) ((#\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.18.orig/swank/cmucl.lisp0000644000175000017500000027470612720104623014772 0ustar pdmpdm;;; -*- 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.18.orig/swank/clasp.lisp0000644000175000017500000006514112720104623014760 0ustar pdmpdm;;;; -*- 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) (defmacro cslime-log (fmt &rest fmt-args) `(format t ,fmt ,@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 () ;; CLASP does not provide threads yet. ;; ECLs swank implementation says that CLOS is not thread safe and ;; I use ECLs CLOS implementation - this is a worry for the future. 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)) (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))) (defimplementation find-definitions (name) (let ((annotations (core: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 source-location (object) (converting-errors-to-error-location (typecase object (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; CLASP does not ;; store debug information for methods yet. (source-location (clos:method-function object)))))) (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 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))))) (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-timedwait (mailbox.cvar mbox) mutex 0.2))))) ) ; #+threads (progn ... slime-2.18.orig/swank/sbcl.lisp0000644000175000017500000023547512720104623014612 0ustar pdmpdm;;;;; -*- 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 (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-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 nil)) (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-string string :emacs-position position) :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))) (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:with-symbol 'debug-source-name 'sb-di) sb-c::debug-source-name #-#.(swank/backend:with-symbol 'debug-source-name 'sb-di) 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) (more-id 0)) (when vars (let ((locals (loop for v across vars do (when (eq (sb-di:debug-var-symbol v) more-name) (incf more-id)) (case (debug-var-info v) (:more-context (setf more-context (debug-var-value v frame loc))) (:more-count (setf more-count (debug-var-value v frame loc)))) 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 more-id :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)) (let ((header (sb-kernel:widetag-of o))) (cond ((= header sb-vm:simple-fun-header-widetag) (label-value-line* (:name (sb-kernel:%simple-fun-name o)) (:arglist (sb-kernel:%simple-fun-arglist o)) (:self (sb-kernel:%simple-fun-self o)) (:next (sb-kernel:%simple-fun-next o)) (:type (sb-kernel:%simple-fun-type o)) (:code (sb-kernel:fun-code-header o)))) ((= header sb-vm:closure-header-widetag) (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 (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 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))))) (defun condition-timed-wait (waitqueue mutex timeout) (macrolet ((foo () (cond ((member :sb-lutex *features*) ; Darwin '(sb-thread:condition-wait waitqueue mutex)) (t '(handler-case (let ((*break-on-signals* nil)) (sb-sys:with-deadline (:seconds timeout :override t) (sb-thread:condition-wait waitqueue mutex) t)) (sb-ext:timeout () nil)))))) (foo))) (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))) (condition-timed-wait waitq mutex 0.2))))) (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)) #-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.18.orig/swank/scl.lisp0000644000175000017500000020370612720104623014440 0ustar pdmpdm;;; -*- 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.18.orig/.travis.yml0000644000175000017500000000254012720104623013745 0ustar pdmpdmlanguage: 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.18.orig/nregex.lisp0000644000175000017500000004736012720104623014026 0ustar pdmpdm;;; ;;; 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.18.orig/doc/0000755000175000017500000000000012720104623012400 5ustar pdmpdmslime-2.18.orig/doc/slime-refcard.pdf0000644000175000017500000012156512720104623015622 0ustar pdmpdm%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.18.orig/doc/Makefile0000644000175000017500000000721112720104623014041 0ustar pdmpdm# 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. # # Explicitly includes Eric Marsden (pre-ChangeLog hacker) # # The gist of this horror show is that the contributor list is piped # into texinfo-tabulate.awk with one name per line, sorted # alphabetically. CHANGELOGS=../ChangeLog ../contrib/ChangeLog contributors.texi: $(CHANGELOGS) Makefile texinfo-tabulate.awk cat $(CHANGELOGS) | \ sed -ne '/^[0-9]/{s/^[^ ]* *//; s/ *<.*//; p;}' | \ sort | \ uniq -c | \ sort -nr| \ sed -e 's/^[^A-Z]*//' | \ 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.18.orig/doc/slime.css0000644000175000017500000000207312720104623014225 0ustar pdmpdmbody { 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.18.orig/doc/texinfo-tabulate.awk0000644000175000017500000000076412720104623016366 0ustar pdmpdm#!/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.18.orig/doc/slime.texi0000644000175000017500000034310312720104623014410 0ustar pdmpdm\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.18 @set SLIMEVER 2.18 @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 find out what's new since the version you're currently running, you can diff the local @file{ChangeLog} against the repository version: @example git fetch origin git diff HEAD origin/master ChangeLog @end example 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.18.orig/doc/slime-small.eps0000644000175000017500000016227012720104623015340 0ustar pdmpdm%!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.18.orig/doc/contributors.texi0000644000175000017500000000616512720104623016040 0ustar pdmpdm@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.18.orig/doc/.cvsignore0000644000175000017500000000031712720104623014401 0ustar pdmpdmcontributors.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.18.orig/doc/slime-small.pdf0000644000175000017500000001635712720104623015326 0ustar pdmpdm%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.18.orig/doc/slime-refcard.tex0000644000175000017500000000605612720104623015646 0ustar pdmpdm\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.18.orig/slime-autoloads.el0000644000175000017500000000225012720104623015256 0ustar pdmpdm;;; 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 '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.18.orig/contrib/0000755000175000017500000000000012720104623013273 5ustar pdmpdmslime-2.18.orig/contrib/slime-repl.el0000644000175000017500000020570712720104623015701 0ustar pdmpdm;;; 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 " (or (slime-changelog-date) "- ChangeLog file not found")))) (insert welcome)))) (defun slime-init-output-buffer (connection) (with-current-buffer (slime-output-buffer t) (setq slime-buffer-connection connection slime-repl-directory-stack '() slime-repl-package-stack '()) (slime-repl-update-banner))) (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 "\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.18.orig/contrib/slime-mrepl.el0000644000175000017500000001211112720104623016037 0ustar pdmpdm;; 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.18.orig/contrib/slime-c-p-c.el0000644000175000017500000003052412720104623015627 0ustar pdmpdm(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.18.orig/contrib/slime-presentation-streams.el0000644000175000017500000000120112720104623021105 0ustar pdmpdm(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.18.orig/contrib/swank-trace-dialog.lisp0000644000175000017500000002135312720104623017644 0ustar pdmpdm(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.18.orig/contrib/swank-presentation-streams.lisp0000644000175000017500000003101012720104623021467 0ustar pdmpdm;;; 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.18.orig/contrib/slime-motd.el0000644000175000017500000000153212720104623015670 0ustar pdmpdm;;; slime-motd.el --- ;; ;; Authors: ;; ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation ;; ;; Add slime-motd to your slime-setup call. (require 'slime) (require 'slime-repl) (define-slime-contrib slime-motd "Message Of The Day in a slime repl" (:authors "Marco Baringer ") (:license "GPL") (:slime-dependencies slime-banner) (:swank-dependencies swank-motd) (:on-load (add-hook 'slime-connected-hook 'slime-insert-motd))) (defcustom slime-motd-pathname nil "The local pathname the motd is read from." :group 'slime-mode :type '(file :must-match t)) (defun slime-insert-motd () (slime-eval-async `(swank::read-motd ,slime-motd-pathname) (lambda (motd) (when motd (slime-repl-insert-result (list :values motd)))))) (provide 'slime-motd) slime-2.18.orig/contrib/swank-jolt.k0000644000175000017500000010026312720104623015542 0ustar pdmpdm;;; 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.18.orig/contrib/slime-scheme.el0000644000175000017500000000237212720104623016174 0ustar pdmpdm;;; 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.18.orig/contrib/swank-util.lisp0000644000175000017500000000517412720104623016271 0ustar pdmpdm;;; 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.18.orig/contrib/swank-presentations.lisp0000644000175000017500000002043012720104623020202 0ustar pdmpdm;;; 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.18.orig/contrib/slime-macrostep.el0000644000175000017500000001153212720104623016723 0ustar pdmpdm;;; 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.18.orig/contrib/slime-media.el0000644000175000017500000000277112720104623016012 0ustar pdmpdm(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.18.orig/contrib/slime-highlight-edits.el0000644000175000017500000000536612720104623020013 0ustar pdmpdm(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.18.orig/contrib/test/0000755000175000017500000000000012720104623014252 5ustar pdmpdmslime-2.18.orig/contrib/test/slime-c-p-c-tests.el0000644000175000017500000000515412720104623017747 0ustar pdmpdm(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.18.orig/contrib/test/slime-parse-tests.el0000644000175000017500000000416712720104623020165 0ustar pdmpdm(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.18.orig/contrib/test/slime-autodoc-tests.el0000644000175000017500000001762712720104623020516 0ustar pdmpdm(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.18.orig/contrib/test/slime-enclosing-context-tests.el0000644000175000017500000000331312720104623022506 0ustar pdmpdm(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.18.orig/contrib/test/slime-presentations-tests.el0000644000175000017500000000410712720104623021743 0ustar pdmpdm(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.18.orig/contrib/test/slime-indentation-tests.el0000644000175000017500000000625612720104623021370 0ustar pdmpdm(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.18.orig/contrib/test/slime-macrostep-tests.el0000644000175000017500000002557112720104623021052 0ustar pdmpdm;; 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.18.orig/contrib/test/slime-repl-tests.el0000644000175000017500000002676512720104623020025 0ustar pdmpdm(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.18.orig/contrib/test/slime-fontifying-fu-tests.el0000644000175000017500000000462712720104623021640 0ustar pdmpdm(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.18.orig/contrib/test/slime-cl-indent-test.txt0000644000175000017500000004372412720104623020766 0ustar pdmpdm;;;; -*- 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.18.orig/contrib/test/slime-mdot-fu-tests.el0000644000175000017500000000216212720104623020417 0ustar pdmpdm(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.18.orig/contrib/swank-motd.lisp0000644000175000017500000000637312720104623016261 0ustar pdmpdm(in-package :swank) (defun parse-changelog (changelog-pathname) (with-open-file (stream changelog-pathname :direction :input) (labels ((entry-line-p (line) (and (<= 10 (length line)) (digit-char-p (aref line 0)) (digit-char-p (aref line 1)) (digit-char-p (aref line 2)) (digit-char-p (aref line 3)) (char= #\- (aref line 4)) (digit-char-p (aref line 5)) (digit-char-p (aref line 6)) (char= #\- (aref line 7)) (digit-char-p (aref line 8)) (digit-char-p (aref line 9)))) (read-next-entry () ;; don't use with-output-to-string to avoid sbcl ;; compiler warnings (with-output-to-string (entry-text) (loop for changelog-line = (read-line stream nil stream nil) when (eq changelog-line stream) do (return-from read-next-entry (values (get-output-stream-string entry-text) nil)) when (entry-line-p changelog-line) do (return-from read-next-entry (values (get-output-stream-string entry-text) changelog-line)) do (write-line changelog-line entry-text))))) (let ((this-author-line (nth-value 1 (read-next-entry))) (entries '())) (loop (multiple-value-bind (text next-author-line) (read-next-entry) (with-output-to-string (text+author) (write-line this-author-line text+author) (write-string text text+author) (push (list (encode-universal-time 0 0 0 (parse-integer this-author-line :start 8 :end 10) (parse-integer this-author-line :start 5 :end 7) (parse-integer this-author-line :start 0 :end 4)) (get-output-stream-string text+author)) entries)) (if (null next-author-line) (return-from parse-changelog entries) (setf this-author-line next-author-line)))))))) (defun read-motd (motd-pathname) (handler-case (let ((entries (mapcar #'second (remove-if (lambda (date/entry-text) (< (first date/entry-text) (- (get-universal-time) (* 60 60 24 7)))) (parse-changelog motd-pathname))))) (when entries (with-output-to-string (motd-for-emacs) (format motd-for-emacs ";; MOTD read from ~S.~%" motd-pathname) (dolist (entry entries) (with-input-from-string (stream entry) (loop for line = (read-line stream nil stream nil) until (eq line stream) do (write-string ";; " motd-for-emacs) do (write-line line motd-for-emacs))))))) (error (c) (format nil ";; ERROR ~S OPENING MOTD ~S.~%" c motd-pathname)))) (provide :swank-motd) slime-2.18.orig/contrib/slime-clipboard.el0000644000175000017500000001363612720104623016674 0ustar pdmpdm(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.18.orig/contrib/swank-sbcl-exts.lisp0000644000175000017500000000514612720104623017217 0ustar pdmpdm;;; 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 (if (arglist-dummy-p instruction) (string-upcase (arglist-dummy.string-representation instruction)) (string-downcase (symbol-name instruction)))) (instr-fn #+#.(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.18.orig/contrib/swank-sprof.lisp0000644000175000017500000001341512720104623016442 0ustar pdmpdm;;; 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.18.orig/contrib/slime-trace-dialog.el0000644000175000017500000010457212720104623017270 0ustar pdmpdm;;; -*- 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.18.orig/contrib/slime-hyperdoc.el0000644000175000017500000000341212720104623016541 0ustar pdmpdm(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.18.orig/contrib/slime-scratch.el0000644000175000017500000000242412720104623016355 0ustar pdmpdm;;; 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.18.orig/contrib/slime-cl-indent.el0000644000175000017500000022007512720104623016607 0ustar pdmpdm;;; 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 'boolean :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.18.orig/contrib/slime-typeout-frame.el0000644000175000017500000000620512720104623017530 0ustar pdmpdm(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.18.orig/contrib/slime-banner.el0000644000175000017500000000243512720104623016175 0ustar pdmpdm(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 " (or (slime-changelog-date) "- ChangeLog file not found")))) (if slime-startup-animation (animate-string welcome 0 0) (insert welcome))))) (provide 'slime-banner) slime-2.18.orig/contrib/swank-quicklisp.lisp0000644000175000017500000000102312720104623017305 0ustar pdmpdm;;; 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.18.orig/contrib/swank-indentation.lisp0000644000175000017500000001332512720104623017625 0ustar pdmpdm(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.18.orig/contrib/swank-asdf.lisp0000644000175000017500000005132212720104623016225 0ustar pdmpdm;;; 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.18.orig/contrib/swank.rb0000644000175000017500000001674412720104623014757 0ustar pdmpdm# 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.18.orig/contrib/slime-tramp.el0000644000175000017500000001043012720104623016045 0ustar pdmpdm(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.18.orig/contrib/slime-autodoc.el0000644000175000017500000001600612720104623016365 0ustar pdmpdm(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 highlight) 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.18.orig/contrib/swank-listener-hooks.lisp0000644000175000017500000000641212720104623020256 0ustar pdmpdm;;; 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.18.orig/contrib/slime-xref-browser.el0000644000175000017500000000744412720104623017362 0ustar pdmpdm(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.18.orig/contrib/swank-fancy-inspector.lisp0000644000175000017500000012452312720104623020420 0ustar pdmpdm;;; 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 ((> f most-positive-long-float) (list "Positive infinity.")) ((< f most-negative-long-float) (list "Negative infinity.")) ((not (= f f)) (list "Not a Number.")) (t (multiple-value-bind (significand exponent sign) (decode-float f) (append `("Scientific: " ,(format nil "~E" f) (:newline) "Decoded: " (:value ,sign) " * " (:value ,significand) " * " (:value ,(float-radix f)) "^" (:value ,exponent) (:newline)) (label-value-line "Digits" (float-digits f)) (label-value-line "Precision" (float-precision f))))))) (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.18.orig/contrib/slime-fancy.el0000644000175000017500000000225612720104623016031 0ustar pdmpdm(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.18.orig/contrib/slime-presentations.el0000644000175000017500000011521112720104623017623 0ustar pdmpdm(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.18.orig/contrib/swank-media.lisp0000644000175000017500000000211412720104623016362 0ustar pdmpdm;;; 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.18.orig/contrib/bridge.el0000644000175000017500000004150712720104623015060 0ustar pdmpdm;;; -*-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.18.orig/contrib/swank-fuzzy.lisp0000644000175000017500000010162012720104623016474 0ustar pdmpdm;;; 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.18.orig/contrib/slime-fuzzy.el0000644000175000017500000006063712720104623016127 0ustar pdmpdm(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.18.orig/contrib/swank-clipboard.lisp0000644000175000017500000000417012720104623017246 0ustar pdmpdm;;; 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.18.orig/contrib/slime-editing-commands.el0000644000175000017500000001610712720104623020153 0ustar pdmpdm(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.18.orig/contrib/README.md0000644000175000017500000000132212720104623014550 0ustar pdmpdmThis 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.18.orig/contrib/swank-c-p-c.lisp0000644000175000017500000002765712720104623016225 0ustar pdmpdm;;; 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.18.orig/contrib/swank-snapshot.lisp0000644000175000017500000000456412720104623017155 0ustar pdmpdm (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.18.orig/contrib/swank-mrepl.lisp0000644000175000017500000001113412720104623016424 0ustar pdmpdm;;; 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.18.orig/contrib/slime-fancy-inspector.el0000644000175000017500000000306012720104623020027 0ustar pdmpdm(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.18.orig/contrib/swank-mit-scheme.scm0000644000175000017500000006301312720104623017156 0ustar pdmpdm;;; 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.18.orig/contrib/slime-enclosing-context.el0000644000175000017500000003021712720104623020372 0ustar pdmpdm(require 'slime) (require 'slime-parse) (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))) (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-parse-extended-operator-name (user-point forms indices points) "Assume that point is directly at the operator that should be parsed. USER-POINT is the value of `point' where the user was looking at. OPS, INDICES and POINTS are updated to reflect the new values after parsing, and are then returned back as multiple values." ;; OPS, INDICES and POINTS are like the finally returned values of ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order, ;; i.e. the leftmost operator comes first. (save-excursion (ignore-errors (let* ((current-op (first (first forms))) (op-name (upcase (slime-cl-symbol-name current-op))) (assoc (assoc op-name slime-extended-operator-name-parser-alist)) (entry (cdr assoc)) (parser (if (and entry (listp entry)) (apply (first entry) (rest entry)) entry))) (ignore-errors (forward-char (1+ (length current-op))) (skip-chars-forward "[:space:]")) (when parser (multiple-value-setq (forms indices points) ;; We pass the fully qualified name (`current-op'), so it's the ;; fully qualified name that will be sent to SWANK. (funcall parser current-op user-point forms indices points)))))) (values forms indices points)) (defun slime-parse-extended-operator-name (user-point forms indices points) "Assume that point is directly at the operator that should be parsed. USER-POINT is the value of `point' where the user was looking at. OPS, INDICES and POINTS are updated to reflect the new values after parsing, and are then returned back as multiple values." ;; OPS, INDICES and POINTS are like the finally returned values of ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order, ;; i.e. the leftmost operator comes first. (save-excursion (ignore-errors (let* ((current-op (first (first forms))) (op-name (upcase (slime-cl-symbol-name current-op))) (assoc (assoc op-name slime-extended-operator-name-parser-alist)) (entry (cdr assoc)) (parser (if (and entry (listp entry)) (apply (first entry) (rest entry)) entry))) (ignore-errors (forward-char (1+ (length current-op))) (skip-chars-forward "[:space:]")) (when parser (multiple-value-setq (forms indices points) ;; We pass the fully qualified name (`current-op'), so it's the ;; fully qualified name that will be sent to SWANK. (funcall parser current-op user-point forms indices points)))))) (values forms indices points)) (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)) '(?\ ?>))) (incf arg-index)) (ignore-errors (backward-sexp 1)) (while (and (< arg-index 64) (ignore-errors (backward-sexp 1) (> (point) (point-min)))) (incf arg-index)) (backward-up-list 1) (when (member (char-syntax (char-after)) '(?\( ?')) (incf level) (forward-char 1) (let ((name (slime-symbol-at-point))) (cond (name (save-restriction (widen) ; to allow looking-ahead/back in extended parsing. (multiple-value-bind (new-result new-indices new-points) (slime-parse-extended-operator-name initial-point (cons `(,name) result) ; minimal form spec (cons arg-index arg-indices) (cons (point) points)) (setq result new-result) (setq arg-indices new-indices) (setq points new-points)))) (t (push nil result) (push arg-index arg-indices) (push (point) points)))) (backward-up-list 1))))))) (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 '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.18.orig/contrib/slime-parse.el0000644000175000017500000003500312720104623016037 0ustar pdmpdm(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.18.orig/contrib/slime-snapshot.el0000644000175000017500000000220112720104623016556 0ustar pdmpdm(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.18.orig/contrib/slime-fancy-trace.el0000644000175000017500000000575212720104623017131 0ustar pdmpdm(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.18.orig/contrib/ChangeLog0000644000175000017500000054626412720104623015066 0ustar pdmpdm2016-04-09 W. David Jarvis * contrib/swank-mit-scheme.scm: changed compilation result filename to not explicitly look for `.com` extensions and instead allow the compiler to do its own extension lookup. 2016-02-11 Stas Boukarev * swank-sbcl-exts.lisp (compute-enriched-decoded-arglist): Properly handle instruction macros and instruction functions. 2016-02-07 Stas Boukarev * swank-sbcl-exts.lisp (compute-enriched-decoded-arglist): Adjust for the changes in SBCL. 2016-02-02 Jon Oddie Add `slime-macrostep' contrib (fancy in-place macroexpansion). * slime-macrostep.el: New file. * swank-macrostep.lisp: New file. * test/slime-macrostep-tests.el: New file. * slime-fancy.el (slime-fancy): Add `slime-macrostep'. 2016-01-29 Sergey Kostyaev * swank-kawa.scm (request-breakpoint, init-global-field): Handle new class names. 2016-01-29 Luís Oliveira * swank-presentation-streams.lisp: Don't monkey patch various stream printing internals unconditionally. Instead wait for init-presentation-streams, if it happens. 2016-01-13 Stas Boukarev * swank-fancy-inspector.lisp (inspect-type-specifier): (sb-int:info :type :expander symbol) not always returns a list. Also print an empty lambda-list as () not NIL. 2016-01-11 Stas Boukarev * swank-repl.lisp (*globally-redirect-io*): move the definition before its usage. * swank-fancy-inspector.lisp (inspect-type-specifier): Avoid calling (sb-int:info :type :translator) as it now produces a style-warning, guard it through #., not just with swank/sbcl::sbcl-version>=. 2015-11-29 Stas Boukarev * swank-fancy-inspector.lisp (inspect-type-specifier): The latest SBCL doesn't have :type :translator info anymore. 2015-11-26 Luís Oliveira * swank-repl.lisp (create-repl): Let the global redirection mechanism handle the stream redirection instead of binding output and io streams in the REPL thread. This lets redirect REPL output in subsequent connections that request global redirection. (See for discussion and a use case.) 2015-11-10 Stas Boukarev * swank-fuzzy.lisp (fuzzy-find-matching-packages): match package local nicknames. 2015-10-18 Helmut Eller Stop using slime-complete-symbol-function. Use slime-completion-at-point-functions instead. * slime-c-p-c.el (slime-c-p-c-completion-at-point): New. Set slime-completion-at-point-functions accordingly. 2015-10-17 Helmut Eller * slime-repl.el (slime-repl-mode): Use slime--completion-at-point. * inferior-slime.el (inferior-slime-mode): Idem. 2015-10-11 Helmut Eller * slime-repl.el (slime-repl-mode): Delete remaining use of slime-setup-command-hooks. 2015-10-11 Helmut Eller Don't rebind TAB is slime-repl-mode. That works no longer as Emacs' completion framework overrides TAB with a transient keymap. * slime-repl.el (slime-repl-mode): Set completion-at-point-functions and tab-always-indent to get a similar behavior to slime-indent-and-complete-symbol. * inferior-slime.el (inferior-slime-mode): Idem. 2015-08-06 Luís Oliveira Some contribs did not invoke SWANK-REQUIRE when the lisp file was LOADed directly. It's yet not clear why that happens, but this should fix GitHub issue #247. * swank-presentations.lisp: Invoke SWANK-REQUIRE at :EXECUTE-time too. * swank-presentation-streams.lisp: Ditto. 2015-08-06 Luís Oliveira Fix LOOP warning. Reported by Jerome Ibanes. * swank-c-p-c.lisp (make-compound-prefix-matcher): Move declaration of TPOS up so that it precedes the iteration clause. (Strict LOOP implementations, namely Lispworks's, complain about it.) 2015-07-31 Stas Boukarev * slime-media.el (slime-dispatch-media-event): now works when image is just a pathname. 2015-07-17 Helmut Eller * swank-kawa.scm: Minor addition to installation instructions. 2015-07-09 Russ Tyndall * swank-presentation-streams.lisp: updated sb-impl::%print-unreadable-object wrapper to accept body optionally, as per new SBCL. 2015-07-08 Peter Feigl Base64-decode literal image data. This fixes problems with sending actual binary data over the wire. * slime-media.el (slime-media-decode-image): New function. (slime-dispatch-media-event): If image data is passed as :data, assume it is base64-encoded and decode it using slime-media-decode-image. If there is no :data, don't change anything. 2015-06-14 Luís Oliveira Fix github issue #249 reported by egarrulo. * slime-autodoc.el (slime-fontify-string): Obsolete function alias for slime-autdoc--fontify. 2015-06-13 Luís Oliveira Fix github issue #248 reported by egarrulo. * slime-asdf.el (slime-find-asd-file): Use cl-return rather than return since, in recent versions of Emacs, the latter does not see the cl-block established by cl-loop. 2015-06-01 Luís Oliveira * slime-fancy.el (slime-fancy): Depend on slime-mdot-fu. 2015-05-27 Luís Oliveira * swank-c-p-c.lisp (completion-output-case-converter): Take a better guess at symbol case when only a package prefix is provided. 2015-05-03 Luís Oliveira * slime-fontifying-fu.el (slime-reader-conditional-face): Remove calls to slime-face-inheritance-possible-p. * slime-repl.el (slime-repl-prompt-face, slime-repl-output-face): Ditto. * slime-presentations.el (slime-repl-output-mouseover-face): Ditto. 2015-05-01 Stas Boukarev * swank-fancy-inspector.lisp (inspect-type-specifier): Adapt for newer SBCL. Patch by Douglas Katzman. 2015-03-04 Luís Oliveira * slime-enclosing-context.el (slime-variable-binding-ops-alist): Also look at LET*. 2015-03-01 Charles Zhang * doc/slime.texi: Add documentation for mdot-fu contrib. 2015-02-19 Charles Zhang * slime-enclosing-context.el: Restore some long dead functions in order to make the slime-mdot-fu contrib work again. slime-edit-local-definition and meta-point on local variable and function definitions work as a result. 2015-02-15 Helmut Eller More updates for Kawa backend. * swank-kawa.scm: Use define-library to control namespace and enable --r7rs. 2015-02-11 Helmut Eller Update Kawa backend for version 2.0. * swank-kawa.scm: Replace @ with \@ as @ is now a reader macro. Also use #:foo instead if foo: as syntax for keywords, in preparation to turn the --r7rs switch on. (, ): New aliases. 2015-01-27 Luís Oliveira Make slime-asdf no longer depend on cl which has been deprecated in favor of cl-lib. * slime-asdf.el (slime-find-asd-file): Add cl- prefix to loop. (slime-asdf-operation-finished-function): Use slime-curry instead of lexical-let. 2015-01-27 Helmut Eller * swank-mlworks.sml (Rpc.call.getpid): Limit scope. 2015-01-21 Luís Oliveira Fix bitrot in slime-typeout-frame. * slime-typeout-frame.el (slime-typeout-frame): Use slime-autodoc-mode-hook. (slime-typeout-wrap-autodoc): New function. 2015-01-05 Stas Boukarev * swank-arglists.lisp (class-from-class-name-form): ignore all errors from FINALIZE-INHERITANCE, not just PROGRAM-ERROR. 2014-12-24 Stas Boukarev * slime-autodoc.el (slime-autodoc-mode): Don't bother with "Slime autodoc mode enabled" unless it's called interactively. 2014-12-23 Stas Boukarev * swank-fuzzy.lisp(make-fuzzy-matching): Simplify, no need to define a wrapper function. 2014-12-11 Luís Oliveira Fix bug reported by Rodrigo Correia. * swank-repl.lisp (package): Import SOCKET-QUEST. (open-dedicated-output-stream): Fix call to SOCKET-QUEST. 2014-12-07 Ivan Shvedunov Add *FUZZY-DUPLICATE-SYMBOL-FILTER*. * swank-fuzzy.lisp: Add *FUZZY-DUPLICATE-SYMBOL-FILTER* variable that controls the removal of symbol name duplicates occurring during fuzzy matching. 2014-12-02 Luís Oliveira * swank-presentation-streams.lisp: Don't load sbcl-pprint-patch since it's dangerous and breaks with recent versions of SBCL. 2014-11-30 Luís Oliveira * slime-fuzzy.el (slime-when-complete-filename-expand): Tentatively mention `comint-filename-completion'. (slime-fuzzy-complete-symbol): Avoid calling comint-dynamic-complete-as-filename since it's been obsoleted in Emacs 24.1. 2014-11-30 Luís Oliveira Restore some of slime-cl-indent's custom indentations. * slime-cl-indent.el (common-lisp-indent-function-1): fix reference to undefined variable `containing-sexp'. 2014-11-30 Leo Liu * slime-package-fu.el (slime-export-symbols): Handle strings. (slime-defpackage-exports): Use `slime-export-symbols' and strip double quotes. (slime-frob-defpackage-form): Don't skip package name in case (:export ...) is immediately following. (slime-determine-symbol-style): Support double quoted styles. (slime-search-exports-in-defpackage): Handle strings. (slime-remove-export): Avoid trailing whitespace. (slime-find-possible-package-file): Use cl-dolist to catch cl-return. * slime-fuzzy.el (slime-fuzzy-completions) (slime-fuzzy-complete-symbol) (slime-fuzzy-insert-completion-choice) (slime-fuzzy-fill-completions-buffer) (slime-fuzzy-insert-from-point, slime-fuzzy-select): Use cl-lib. 2014-11-30 Ivan Shvedunov Revive swank-listener-hooks. * swank-listener-hooks.lisp: updated to use repl-related symbols from SWANK-REPL package, export *SLIME-REPL-EVAL-HOOKS*. 2014-11-25 Ivan Shvedunov Fix history behavior in REPL when using both presentations and paredit. * slime-presentations.el: don't ignore until-point-p in slime-presentation-current-input. 2014-11-16 Robert Brown * slime-fontifying-fu.el: Do not byte compile functions that are already compiled. 2014-11-12 Mark H. David Accept (function (function +)) as Lisp printer output for (function #'+). * contrib/swank-arglists.lisp: changed function test-print-arglist -- to provide two alternative accepted outputs -- and changed its inner flet function test to accept multiple outputs. 2014-10-24 Helmut Eller Experimental support for MLWorks * swank-mlworks.sml: New file. 2014-10-10 Luís Oliveira * slime-repl.el (sldb-copy-down-to-repl): Use SWANK/BACKEND. (sldb-insert-frame-call-to-repl): Likewise. 2014-10-04 Helmut Eller * slime-autodoc.el (slime-retrieve-arglist): Renamed back from slime-autodoc--retrieve-arglist as it's still used in slime-c-p-c.el 2014-10-01 Helmut Eller Some updates for the MIT-Scheme backend. * swank-mit-scheme.scm (accept-connections): Use the built-in open-tcp-server-socket. In recent releases it seems to set SO_REUSEADDR and lately we used a hardcoded port number even with netcat. (swank:connection-info): Include the :encoding for create-repl. (swank-repl:listener-eval): Renamed from swank:listener-eval. (swank-repl:create-repl): Renamed from swank:create-repl. Return the name of the nearest repl env. (hack-quotes): New helper. (emacs-rex): Use it, as swank-repl:create-repl is called with a keyword argument. 2014-10-01 Helmut Eller Update Kawa backend for separate swank-repl package. * swank-kawa.scm (|swank-repl:create-repl|): Renamed from create-repl. (|swank-repl:listener-eval|): Renamed from listener-eval. (defslimefun, %defslimefun, lookup-slimefun): Put "qualified" symbols in *slime-funs* 2014-09-12 Helmut Eller Rewrite slime-autodoc. Fixes github issue#188 along the way. Cleaned up and simplified. I think most of functionality was perserved. There was a "multiline cache" feature which I was not able to understand--despite my best efforts. So I deleted that. * slime-autodoc.el (slime-autodoc): Use helper functions to make this one shorter. Also remove some of the comments that explained rather obvious things. Test slime-background-activities-enabled-p before sending something on the wire. (slime-autodoc--parse-context): Mostly replaces the old make-autodoc-rpc-form. (slime-autodoc--parsing-safe-p): New helper. (slime-autodoc--async, slime-autodoc--async%): The asynchronous code without lexical-let. (slime-autodoc-manually): Use eldoc-add-command to tell eldoc that it's OK to clobber the echo area. (slime-autodoc-space): New command. Bound to SPC by the minor mode. That's simpler than messing around with slime-echo-arglist-function. (slime-autodoc-mode): Use define-minor-mode with :keymap keyword to bind keys. Shorter modeline indicator: "adoc" instead of "Autodoc". (slime-autodoc--doc-map-prefix): New helper. (slime-use-autodoc-mode): Deleted. Seems completely redundant now that slime-autodoc is a minor mode that can be turned on/off. (slime-autodoc-use-multiline-p): Deleted. Use eldoc-display-message-no-interference-p instead. (slime-autodoc-delay): Deleted. Use eldoc-idle-delay instead. (slime-autodoc--cache-get, slime-autodoc--cache-put): Renamed from slime-get-cached-autodoc and slime-store-into-autodoc-cache. (slime-autodoc--cache-last-context): Renamed from slime-autodoc-last-buffer-form. (slime-autodoc--cache-last-autodoc): Renamed from slime-autodoc-last-autodoc. (slime-autodoc-cache-car, slime-autodoc-multiline-cached) (slime-autodoc-cache-multiline): Deleted because I couldn't figure out what the purpose of this "multiline cache" was. (slime-autodoc--canonicalize-whitespace): Renamed from slime-canonicalize-whitespace. (slime-autodoc--format): Renamed from slime-format-autodoc. (slime-autodoc--fontify): Renamed from slime-fontify-string. (slime-autodoc--on, slime-autodoc--off) (slime-autodoc--enable, slime-autodoc--disable) (slime-autodoc--relevant-hooks): New. (slime-autodoc-maybe-enable): Deleted. (eldoc-display-message-no-interference-p): No advice used any more. * test/slime-autodoc-tests.el (autodoc-space): New. (slime-autodoc-to-string): Use new names. (slime-check-autodoc-at-point): Replace cl-getf with plist-get. 2014-09-12 Helmut Eller Fix tests. * Makefile (check-fancy): Make explicit target for slime-fancy. Needed because there is no file for it in test/ otherwise. * test/slime-presentations-tests.el (pretty-presentation-results): Specify :right-margin because CCL uses 70 not 75 as default. 2014-09-10 Helmut Eller * swank-repl.lisp: Import *globally-redirect-io* from swank. 2014-09-10 Helmut Eller Make the test filename for presentations match the contrib. * test/slime-presentations-tests.el Renamed from slime-presentation-tests.el. 2014-09-10 Helmut Eller Make presentations work, well compile, with swank-repl package. * swank-repl.lisp: Export *send-repl-results-function*. * swank-presentations.lisp (init-presentations): Move to function so that *send-repl-results-function* is not clobbered as side effect of compiling swank-presentation-streams.lisp * swank-presentation-streams.lisp (init-presentation-streams): Move to function so that *send-repl-results-function* is not clobbered as side effect of compiling. * slime-presentations.el (slime-presentations-on-connected): New. * slime-presentation-streams.el (slime-presentation-streams-on-connected): New. 2014-09-10 Helmut Eller Only test contribs that actually have tests. * Makefile (CONTRIB_TESTS): New variable. 2014-09-10 Helmut Eller * test/slime-parse-tests.el (form-up-to-point.1): Don't hardcode swank::%cursor-marker% use the slime-cursor-marker constant instead. 2014-09-10 Helmut Eller * swank-repl.lisp: Put swank-repl into its own package. * slime-repl.el, test/slime-repl-tests.el: Use swank-repl: instead of swank: where needed. 2014-09-10 Helmut Eller Fix some fallout of the new package structure. * swank-presentation-streams.lisp: Use swank-sbcl:: instead of swank-backend::. 2014-09-01 João Távora * slime-autodoc.el (eldoc-display-message-no-interference-p): Always activate advice. 2014-08-25 João Távora * test/slime-parse-tests.el (form-up-to-point.1): Remove spurious "e" characters that were apparently the cause of the test failures. 2014-08-23 João Távora * slime-fuzzy.el (slime-fuzzy-complete-symbol): Use `cl-defun` not `defun*` 2014-08-22 João Távora * slime-repl.el (slime-repl-input-line-beginning-position): Use `inhibit-field-text-motion'. 2014-08-04 Luís Oliveira * slime-c-p-c.el: fix compilation errors due to missing cl- prefixes for some functions/macros. 2014-07-29 Helmut Eller Avoid some compiler warnings. * swank-asdf.lisp: Avoid unreachable code for version check. (unique-string-list): Avoid unreachable code warnings. * swank-fuzzy.lisp (*all-chunks*): Defvar it and declaim the type to avoid type uncertainty warnings. * swank-presentations.lisp (*send-repl-results-function*): Defvar it to avoid unknown var warning. * swank-package-fu.lisp (export-structure): Suppress warning about unknown function list-structure-symbols with #+. 2014-07-02 Jan Moringen Make fancy inspector more robust w.r.t. unexpected logical PATHNAME-HOST While CLHS seems to guarantee PATHNAME-HOST to return a string, this is not always the case in practice (e.g. SBCL returns a SB-IMPL:LOGICAL-HOST instance). * swank-fancy-inspector.lisp (emacs-inspect logical-pathname): wrap the return value of PATHNAME-HOST in a (:value ...) in case it is not a string 2014-06-28 Helmut Eller Make swank-kawa.scm work with Kawa 1.14. * swank-kawa.scm (connection-info): Return :encoding options to make slime-repl work. (listener): Set current-output-port. Also add a version check at the beginning and update the compilation instructions. 2014-06-11 Jan Moringen * swank-fancy-inspector.lisp (method-specializers-for-inspect): in SBCL use `sb-pcl:unparse-specializer-using-class' instead of simply `class-name' (specializer<): only use CPL-based method for `class' specializers 2014-04-29 Christophe Rhodes * slime-references.el (slime-lookup-reference-at-point): change format for lookup in SBCL manual to match current all-in-one-page publication. 2014-04-29 Christophe Rhodes * slime-references.el (slime-references-properties): Support `:type' and `:system-class' `:ansi-cl' references. 2014-04-26 João Távora * swank-repl.lisp (*listener-saved-value*): New thread-global variable. (listener-save-value): Save values produced by slimefuns. (listener-get-value): Get values saved by LISTENER-SAVE-VALUE. (*last-repl-form*, *last-repl-values*, set-repl-variables): Deleted. (repl-eval): Don't call SET-REPL-VARIABLES. * slime-repl.el (slime-repl): Return the REPL buffer switched to. (slime-repl-copy-down-to-repl): New function. (slime-inspector-copy-down-to-repl): Use `slime-repl-copy-down-to-repl' (sldb-copy-down-to-repl): Use `slime-repl-copy-down-to-repl' 2014-04-20 Christophe Rhodes * swank-presentations.lisp (lookup-and-save-presented-object-or-lose): new slimefun, to take temporary presentations (e.g. from sldb or slime-inspector) and turn them into permanent presentations in the global presentation-id-object tables. * slime-presentations.el (slime-copy-presentation-to-repl): rewrite, including use of lookup-and-save-presented-object-or-lose, but also restoring insertion of the presentation into the repl editing stream. 2014-04-17 Olof-Joachim Frahm * slime-clipboard.el: Require `cl-lib`/`cl` for `lexical-let` and `cl-` prefix. (slime-clipboard-insert-entries, slime-clipboard-insert-ref) (slime-clipboard-ref-modified): Use `cl-` prefix. 2014-04-15 Phil Hargett * test/slime-autodoc-tests.el: Mark several tests as failing for CCL 1.9 2014-04-02 Stas Boukarev * slime-repl.el (slime-repl-add-to-input-history): Fix whitespace clean up. Reported by Robert Brown. 2014-03-29 João Távora * slime-trace-dialog.el (slime-trace-dialog--insert-trace): Set trace entry's marker-insertion-type to T to avoid text later being inserted before the marker from entering its protected region. 2014-03-27 João Távora The previous technique for setting *, ** and friends just-in-time didn't work, especially when the inspector was called from the REPL buffer to inspect *. The problem this was fixing was fixed in a different manner, by making slime-repl.el ensure that these variables are set in the swank side. * swank-repl.lisp (set-repl-variables): New slimefun. (repl-eval): Call SET-REPL-VARIABLES *after* evaluating region. * slime-repl.el (sldb-copy-down-to-repl): Call new SWANK:SET-REPL-VARIABLES just after copying down to REPL. 2014-03-09 João Távora * slime-trace-dialog.el (slime-trace-dialog--open-detail): Restore `:mode' argument to `slime-with-popup-buffer'. * slime-sprof.el (slime-sprof-report): idem * slime-compiler-notes-tree.el (slime-list-compiler-notes): idem * slime-clipboard.el (slime-clipboard-display-entries): idem 2014-03-08 Luís Oliveira slime-autodoc: avoid adding a newline after things like with-open-file when doing multiline display. * swank-arglists.lisp (print-decoded-arglist): Don't pprint-newline when adding a space after the operator. 2014-03-07 João Távora * slime-trace-dialog.el (slime-trace-dialog--open-detail): Fix "read-only" error when navigating to the trace details. (slime-trace-dialog--insert-trace): Nudge non-parent trace entries one "-" to the right to line up with others at the same level. When toggling trace on a definition, automatically update the trace dialog if it is open already. Idea by Luís Oliveira. * slime-trace-dialog.el (slime-trace-dialog--get-buffer): split into reusable functions. (slime-trace-dialog--buffer-name): new function (slime-trace-dialog--live-dialog): new function (slime-trace-dialog--ensure-buffer): new function (slime-trace-dialog--update-existing-dialog): new function for added to `slime-trace-dialog-after-toggle-hook' by default. (slime-trace-dialog): Use `slime-trace-dialog--ensure-buffer'. 2014-03-03 Helmut Eller * slime-presentations.el: Require 'cl for case, return-from etc. 2014-03-03 João Távora * test/slime-indentation-tests.el: New file. Defines ERT indentation tests from specs in `slime-cl-indent-test.txt'. * slime-indentation.el (slime-cl-indet): `require' instead of `load'. * test/slime-cl-indent-test.txt: Moved to from previous file and changed test names from numbers to symbols. * slime-cl-indent.el: Moved tests to test/slime-indentation-tests.el. In file comments, explain the legacy cl-indent.el situation. Provide `slime-cl-indent'. 2014-03-02 João Távora The contrib's Makefile now works as the top-level Makefile, byte-compiling files separately, uncovering errors when trying to byte-compile files in isolation. Fixed almost all such problems in contrib's el files and remove uses of the "xemacs compability layer", in preparation of its removal. For most files this amounted to moving some definitions around, requiring the needed libs at the top, and prefixing cl-lib functions with "cl". `cl' is required at compile-time only for macros which aren't found in cl-lib. All (minor) exceptions are listed below.o * Makefile (%.elc): Do as in root-makefile and compile each el file separately. This reveals more warnings. * slime-typeout-frame.el (slime-typeout-autodoc-message): Don't set inexistent `slime-autodoc-last-message' var. * slime-compiler-notes-tree.el (slime-list-compiler-notes): Don't pass :mode to `slime-with-popup-buffer' * slime-clipboard.el (slime-clipboard-display-entries): Don't use :mode arg to `slime-with-popup-buffer'. (slime-clipboard-redisplay): Don't use `slime-save-coordinates' as that's probably going away, use simpler approach. * slime-indentation.el (slime-indentation): Correct description. * slime-fontifying-fu.el (slime-beginning-of-tlf): Simplify, conditional definition not needed. * slime-enclosing-context.el (slime-enclosing-context): Explain why contrib doesn't work. * slime-cl-indent.el (require): Require needed libraries, including `slime'. (common-lisp-active-style): use proper defvar. (common-lisp-current-package-function): Make it a variable, which is how it's used. (common-lisp-run-indentation-tests): Use `insert-file-contents'. (slime-cl-indent): provide `slime-cl-indent' as well as `cl-indent' * slime-autodoc.el (slime-autodoc-maybe-enable): move to solve compilation warnings. (slime-autodoc-mode): Replace `interactive-p' call with new `interactive' arg. * slime-asdf.el (slime-open-system): Don't use `called-interactive-p'. * slime-presentations.el (slime-presentation-on-stream-open): Use `bridge-insert-function'. * bridge.el (bridge-insert-function): new variable to solve redefinition hack in slime-presentations.el (bridge-insert): use it. 2014-02-25 João Távora * slime-trace-dialog.el (slime): Remove redundant `eval-and-compile' (slime-trace-dialog-mode): Don't also activate `slime-trace-dialog-minor-mode'. (slime-trace-dialog--menubar): Define same menu for both minor and major modes. 2014-02-24 João Távora * slime-trace-dialog.el (slime-trace-dialog): simplify contrib definition. (slime-trace-dialog-mode): Also activate `slime-trace-dialog-minor-mode'. (slime-trace-dialog-minor-mode): New minor mode. (slime-trace-dialog--menubar): New single top-level menu for `slime-trace-dialog-minor-mode'. (slime-trace-dialog-after-toggle-hook): New hook. (slime-trace-dialog-toggle-trace): Run hooks. (slime-trace-dialog-toggle-complex-trace): New interactive function for calling from the menu. (slime-trace-dialog--easy-menu): Delete it. (my-menu): Delete it. 2014-02-24 Marco Baringer * slime-hyperdoc.el (slime-hyperdoc): Remove :slime-dependencies on emacs libraries, these should be loaded via a simple require. * slime-tramp.el (slime-tramp): idem for tramp. 2014-02-23 João Távora * Makefile (check-%): Remove redundant `slime-setup' call and call `slime-contrib-all-dependencies'. Closes #9: New output respects existing REPL results or presentations. * slime-repl.el (slime-repl-emit-result): After emitting a result, update `slime-output-end' marker. * slime-presentations.el (slime-presentation-write-result): Idem, but for presentation results. * test/slime-repl-tests.el (mixed-output-and-results): New test. 2014-02-23 Luís Oliveira Canonicalize 'nil to nil when displaying default optional and keyword arguments via slime-autodoc. On SBCL this turns (error 'simple-condition &rest arguments &key (format-arguments 'nil) (format-control 'nil)) into (error 'simple-condition &rest arguments &key format-arguments format-control) which should be more readable. * swank-arglists.lisp (canonicalize-default-arg): New function for canonicalizing optional and keyword arguments. (make-optional-arg, make-keyword-arg): Use it. 2014-02-21 João Távora * test/slime-presentations-tests.el: New file. * test/slime-parse-tests.el: New file. * test/slime-mdot-fu-tests.el: New file. * test/slime-fontifying-fu-tests.el: New file. * test/slime-enclosing-context-tests.el: New file. * test/slime-c-p-c-tests.el: New file. * test/slime-autodoc-tests.el: New file. * slime-repl.el: Split off tests. Don't use `eval-and-compile' * slime-presentations.el: Idem. * slime-parse.el: Idem. * slime-mdot-fu.el: Idem. * slime-fontifying-fu.el: Idem. * slime-enclosing-context.el: Idem. * slime-c-p-c.el: Idem. * slime-autodoc.el: Idem. * inferior-slime.el: cleanup whitespace. * Makefile: Fix whitespace. (check-%): Look for tests under /contrib/tests. Explicitly require all needed test libs. 2014-02-19 Helmut Eller * slime-repl.el: Load 'bytecomp before binding byte-compile-warnings. * slime-scratch.el: eval-and-compile is redundant around require. * inferior-slime.el: Whitespace cleanup. 2014-02-19 Helmut Eller * inferior-slime.el: Require 'slime for macros at compile time. 2014-02-18 Helmut Eller * Makefile: New file (elpa-%, check-%): Moved to here from core. 2014-02-10 João Távora * slime-autodoc.el (define-autodoc-tests): Use `define-slime-ert-test' to automatically set the correct test tags. 2014-02-07 João Távora * slime-presentations.el: Don't set `slime-inspector-insert-ispec-function' by default, it makes the blue slots in the inspector go away which some users were used to. 2014-02-06 João Távora * slime-repl.el: Prefix all cl-functions with "cl-" 2014-02-05 João Távora * swank-repl.lisp (set-repl-variables): Deleted. (*repl-set-variables-function*): Deleted, not needed for now. (repl-eval): Set *, + and / variables saved from last call just before the EVAL-REGION that might use them. * slime-repl.el (slime-repl-eval-string): simplify change of 2014-01-30; don't remotely call SWANK:SET-REPL-VARIABLES on acknowledgement. 2014-02-03 João Távora * slime-trace-dialog.el (slime-trace-dialog-mode-map): Bind M-RET to new `slime-trace-dialog-copy-down-to-repl'. (slime-trace-dialog-copy-down-to-repl): New function, in-line with slime-repl.el's functions. (slime-trace-dialog--format-part): Two extra text properties to find the trace part at point. * swank-trace-dialog.lisp (find-trace-part): new exported function. (inspect-trace-part): rewrite in terms os FIND-TRACE-PART. 2014-01-31 João Távora * slime-trace-dialog.el: Reworked. Now works with multiple connections. Use `slime-trace-dialog-hide-details-mode' and `slime-trace-dialog-autofollow-mode' instead of buttons. New menu. 2014-01-30 João Távora * swank-repl.lisp (*last-repl-form*, *last-repl-values*): new variables. (*repl-set-variables-function*): new variable. (set-repl-variables): new function, extracted from REPL-EVAL, switches to *REPL-SET-VARIABLES-FUNCTION* if that is non-nil. (repl-eval): don't set auto variables here, defer that for later. * slime-repl.el (slime-repl-eval-string): slime-eval SWANK:SET-REPL-VARIABLES when SWANK acknowledges with OK. * slime-repl.el (slime-inspector-copy-down-to-repl): Use only first return value of SWANK:INSPECTOR-NTH-PART. * slime-presentations.el (slime-copy-presentation-to-repl): Unbreak. Use same `slime-repl-send-string' strategy as slime-repl.el. * slime-repl.el (sldb-mode-map): Bind M-RET to `sldb-copy-down-to-repl' in `sldb-mode-map'. (sldb-copy-down-to-repl): New function, much like `slime-inspector-copy-down-to-repl' 2014-01-27 João Távora * slime-repl.el (slime-repl-emit): Bind `inhibit-read-only' to t when inserting output. Might clash with read-only parts left over from previous REPL session. Reported by Paul Bowyer. (slime-repl-history-pattern): Allow M-p in any part of the REPL buffer. Reported by Attila Lendvai. (slime-sync-package-and-default-directory): Use `buffer-live-p', don't just check that `buffer' is non-nil. Fails when the slime process buffer has already been killed but connection lives on. 2014-01-23 João Távora * slime-presentations.el (pretty-presentation-results): new tests, should be more stable, except on allegro. * slime-repl.el (slime-repl-emit): Propertize the output text with a `slime-repl-output' boolean property. (slime-repl-test-markers): More powerful macro for testing repl text. (slime-check-buffer-contents): Simplified with `slime-repl-test-markers'. (repl-test): tests with no output don't expect these markers. (repl-type-ahead): tests with no output don't expect these markers. (slime-repl-emit-result): Use `insert-before-markers-and-inherit', and do it before saving `slime-output-end'. (slime-repl-write-string): Fix failing tests by passing `eol' as t to `slime-repl-emit-result'. (slime-repl-test-markers): Friendlier test assertions. (repl-test-2): Skip for now, unstable without slime-presentations. 2014-01-22 João Távora * slime-presentations.el (slime-menu-choices-for-presentation): slightly friendlier pop-up menu title, could be friendlier maybe if object type were displayed instead. * swank-presentations.lisp (lookup-presented-object): No longer reference *inspectee-parts* removed a long time ago. 2014-01-19 João Távora * slime-autodoc.el (cerror "Foo"): test no longer fails for sbcl. (foo-inside-labels-2): test also fails on cmucl. * swank-arglists.lisp (print-decoded-arglist): for already provided args, print strings literally. (print-arg): New keyword arg LITERAL-STRINGS 2014-01-12 João Távora * slime-parse.el (form-up-to-point.1): Skip for now, then analyse. * slime-repl.el (move-around-and-be-nasty): Skip it. Causes other tests to become unstable. (interrupt-in-blocking-read): Skip for now, then analyse. 2014-01-10 João Távora * slime-trace-dialog.el (slime-trace-dialog--open-specs): Use cl-labels instead of cl-flet (safer on emacs 23). * slime-repl.el (slime-repl-return): Pass `end-of-input' to hooks run. * slime-presentations.el (pick-up-presentation-at-point): New test by Attila Lendvai. (slime-presentation-start): Don't go beyond (point-min) when looking for presentation. Adapted from patch by Attila Lendvai. (slime-presentation-on-return-pressed): Use `end-of-input'. * slime-presentations.el: cleanup compilation warnings. * slime-repl.el (slime-repl-delete-from-input-history): Correctly calculate merged history. Patch by Attila Lendvai. 2014-01-09 Luís Oliveira Move "," binding back to slime-repl-mode-map and disable it when in slime-repl-read-mode. * slime-repl.el (slime-repl-read-mode-map): Don't bind ",". (slime-repl-mode-map): Bind ",". 2014-01-09 João Távora * README: Renamed to README.md. * README.md: New file. Don't mention setup technique. * slime-repl.el (slime-repl-read-mode): Closes #17: ignore slime completion `slime-repl-read-mode-map'. (slime-repl-read-mode-map): Put keymap in its own var. 2014-01-07 João Távora * slime-trace-dialog.el (slime-trace-dialog): Change advertised protocol, doesn't fetch traces automatically, just specs and progress. (slime-trace-dialog-fetch-specs): New interactive function. (slime-trace-dialog-fetch-progress): New interactive function. (slime-trace-dialog-fetch-status): Fetch local control, specs and progress. (slime-trace-dialog--clear-local-tree): Simplified. (slime-trace-dialog--update-progress): "[refresh]" button degates to `slime-trace-dialog-fetch-progress'. "[clear]" button always shows if there is something to clear. Simplified. (slime-trace-dialog--on-new-results): Adapt to new `slime-trace-dialog--update-progress' (slime-trace-dialog--mode-map): Bind 'g' to `slime-trace-dialog-fetch-status'. * swank-trace-dialog.lisp (dialog-trace): Don't set RETLIST-OF to a symbol here, backends are responsible for that. 2014-01-06 João Távora * slime-repl.el (slime-repl-insert-prompt): Reset `buffer-undo-list' after inserting a new prompt. * Changelog: Use utf-8 coding. 2014-01-05 João Távora * slime-presentations.el (slime-presentation-write-result): Remove spurious debug line. 2014-01-01 João Távora * slime-presentations.el Remove trailing whitespace. (slime-presentation-write-result): Fix REPL test `repl-type-ahead' when this contrib is active. 2013-12-31 João Távora * *slime-*.el: require 'slime when loading and byte-compiling (Closes #42). 2013-12-30 João Távora * slime-autodoc.el (slime-check-autodoc-at-point): not needed anymore. (define-autodoc-tests): new macro for defining autodoc-specific tests. (top-level): fix tests based on swank functions and add some :fails-for specifications for sbcl * slime-repl.el: Remove trailing whitespace. (slime-repl-mode-map): Don't clobber C-a and home. (slime-save-marker): Add edebug spec. (slime-repl-insert-prompt): Use same text properties as comint.el. `slime-repl-bol' is no longer needed. (Closes #43) (slime-repl-bol): Remove it. (slime-eval-last-expression-in-repl): Use `with-current-buffer' instead of `save-excursion+set-buffer' combo (slime-tests): Require it. (with-canonicalized-slime-repl-buffer): Add edebug spec. Add inline ident spec. (repl-test): Conform (brittle) tests to latest "Evaluation aborted on" output. (repl-test-2): New test containing two tests that fail only on allegro. (repl-type-ahead): Also conform to latest "Evaluation aborted on" output. (move-around-and-be-nasty): New repl test. * slime-enclosing-context.el: require 'slime-tests. Remove trailing whitespace. * slime-fontifying-fu.el: require 'slime-tests. Remove trailing whitespace. * slime-mdot-fu.el: require 'slime-tests. Remove trailing whitespace. * slime-parse.el: require 'slime-tests. Remove trailing whitespace. 2013-12-21 João Távora * slime-presentations.el (slime-M-.-presentation): As in previous patch, must return nil on failure so as not to break the `run-hooks-until-success' logic of `slime-edit-definition-hooks'. 2013-12-21 João Távora * slime-fancy-inspector.el (slime-edit-inspector-part): Since this lives in `slime-edit-definition-hooks', return nil when not in an inspector buffer. 2013-12-21 Samuel Freilich * slime-cl-indent-test.txt: New tests 91-95. * slime-cl-indent.el (lisp-loop-clauses-indentation) (lisp-loop-indent-body-forms-relative-to-loop-start) (lisp-loop-body-forms-indentation): New. ("basic"): Bind new variables. (common-lisp-body-introducing-loop-macro-keyword): Handle DOING. (common-lisp-accumlation-loop-macro-keyword): New. (common-lisp-indent-indented-loop-macro-keyword): More subclauses. (common-lisp-indent-loop-macro-1): Use new variables. 2013-11-20 João Távora * swank-trace-dialog.lisp: New file, new :swank-trace-dialog package, uses new wrapping interface in swank-backend.el to trace fspecs. Report the trace tree to emacs. * slime-trace-dialog.el: New file, collect and render a interactive tree of traces collected from the Lisp backend. Inspect trace arguments and return values. * slime-fancy.el: Enable new contrib slime-trace-dialog. Call slime-fancy trace init function. 2013-05-11 Marco Baringer * slime-repl.el (slime-repl-sexp-at-point): New function; similar to slime-sexp-at-point but ignore repl prompt text. (slime-repl-inspect): New function; similar to slime-inspect but default value is computed via slime-repl-sexp-at-point and not slime-sexp-at-point. (slime-repl-mode-map): Bind slime-repl-inspect it C-c I 2013-04-13 Stas Boukarev * swank-asdf.lisp (asdf-component-output-files): Use the correct variable in typecase. Patch by Max Mikhanosha. 2013-02-13 Helmut Eller * swank-kawa.scm (listener-loop): Use close-port instead of close-output-port. close-output-port startet to signal errors in recent versions. (listener): Stop taking stack-snapshots on caught exceptions as it's too slow. It was always expensive and in Java7 it's unbearably slow. 2013-02-10 Stas Boukarev * slime-repl.el (slime-open-stream-to-lisp): Use current connection host instead of slime-lisp-host. 2013-02-03 Stas Boukarev * swank-sprof.lisp (pretty-name): Better frame names. 2013-02-02 Stas Boukarev * swank-util.lisp (symbol-classification-string): Use type-specifier-p. * swank-fuzzy.lisp: Allow NIL to be completed, don't confuse with it package: 2013-02-01 Stas Boukarev * slime-asdf.el (slime-determine-asdf-system): Don't call slime-to-lisp-filename on NIL. Reported by Tamas Papp. * swank-asdf.lisp (asdf-determine-system): Return the name of a system. Reported by Tamas Papp. 2013-01-29 Francois-Rene Rideau * swank-asdf.lisp: Better upcoming ASDF3 support. 2013-01-20 Stas Boukarev * swank-asdf.lisp: Better compatibility with newer ASDF. Patch by Francois-Rene Rideau and Stelian Ionescu. Remove auto-upgrading. Rename *asdf-directory* to *asdf-path*, to be a full path to asdf.lisp. Remove #+gcl and #+genera. 2013-01-10 Helmut Eller * slime-autodoc.el (slime-autodoc): Remove :gnu-emacs-only. Suggested by Raymond Toy. (slime-autodoc): Fix long lines. 2013-01-04 Stas Boukarev * slime-fancy-inspector.el (slime-edit-inspector-part): New function, tries to find a definition of the part at point. Hooks into `slime-edit-definition-hooks'. 2013-01-03 Stas Boukarev * slime-cl-indent.el (define-common-lisp-style "basic"): Don't set `comment-column' to NIL, it only can accept integers. 2012-12-26 Francois-Rene Rideau * swank-asdf.lisp: Better support for different versions of ASDF. 2012-12-16 Helmut Eller * swank-repl.lisp (thread-for-evaluation): Override some cases. 2012-11-28 Stas Boukarev * swank-asdf.lisp (asdf-system-directory): Return a namestring, not a pathname. 2012-11-23 Stas Boukarev * slime-repl.el (slime-repl-auto-right-margin): New variable, defaults to NIL. (slime-repl-eval-string): Respect the above variable. * swank-repl.lisp (listener-eval): New keyword parameter, window-width, if supplied binds *print-right-margin* to its value. Based on a patch by Marco Baringer. 2012-11-22 Stas Boukarev * slime-package-fu.el (slime-determine-symbol-style): Fix the default case when no :export symbols are present. Because of (every anything nil) => T. 2012-11-13 Francois-Rene Rideau * swank-asdf.lisp: Better ASDF support. 2012-10-19 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-choices-buffer): Don't move position in the current buffer, call (slime-fuzzy-next) after switching to the completion buffer. 2012-10-14 Helmut Eller * swank-kawa.scm: Various tweaks. 2012-08-13 Stas Boukarev * swank-arglists.lisp (extra-keywords/slots): Check for slot-definition-initfunction being present before calling slot-definition-initform. 2012-08-04 Stas Boukarev * swank-arglists.lisp (test-print-arglist): bind *print-right-margin* to 1000 instead of NIL, because the default value on ABCL is less than the length of the tested arglist. 2012-05-23 Christophe Rhodes * swank-media.lisp: add provide. 2012-05-04 Stas Boukarev * swank-fancy-inspector.lisp (emacs-inspect symbol): On SBCL, show information about type specifiers. 2012-04-20 John Smith Prettier arglists. * swank-mit-scheme.scm (swank:operator-arglist): Remove trailing newlines. 2012-04-13 Nikodemus Siivola * slime-cl-indent.el (lisp-indent-259): If we are expecting a lambda-list, but don't have a list in the position, indent as if it was &body instead. * slime-cl-indent-test.txt (Test 89-90): Tests. 2012-04-13 Nikodemus Siivola * slime-cl-indent.el (common-lisp-lambda-list-initial-value-form-p): Handle &AUX as well, and don't signal an error if the we don't have a list where expected. * slime-cl-indent-test.txt (Test 88): Test for indenting &AUX value form. 2012-04-13 Nikodemus Siivola Wrap long lines. * slime-cl-indent.el 2012-04-06 Stas Boukarev * swank-fancy-inspector.lisp (format-iso8601-time): Add 1 to the time-zone if DST value of decode-universal-time is T. 2012-04-04 Nikodemus Siivola * slime-cl-indent.el (common-lisp-lambda-list-initial-value-form-p): New function. Identifies initial-value-forms from lambda-lists, allowing them to be indented as regular code. (lisp-indent-259): Use the previous when indenting using &lambda to punt to normal indentation when approriate. * slime-cl-indent-test.txt (Test 87): Test indentation of initial-value forms. 2012-03-19 Stas Boukarev * swank-arglists.lisp (compute-enriched-decoded-arglist): Add arglist display for MULTIPLE-VALUE-CALL, the same as with APPLY. 2012-03-09 Stas Boukarev * swank-motd.lisp, swank-clipboard.lisp, swank-hyperdoc.lisp: Add provide. 2012-03-08 Stas Boukarev * swank-arglists.lisp (print-decoded-arglist): When the source of the arglist is a local definition from FLET, some parts may be represented as ARGLIST-DUMMY, handle them. 2012-03-14 Helmut Eller * swank-kawa.scm (%macroexpand): Use Kawa's syntaxutils. 2012-03-06 Helmut Eller * swank-kawa.scm (module-method>meth-ref): Slightly better heuristic for vararg functions. 2012-03-06 Helmut Eller Add missing provide. * swank-repl.lisp * swank-util.lisp * swank-mrepl.lisp * swank-snapshot.lisp 2012-03-06 Stas Boukarev * slime-package-fu.el (slime-export-save-file): New variable, when set to T saves package.lisp after each modification. Defaults to NIL. 2012-01-06 Helmut Eller * swank-mrepl.lisp (send-prompt): Fix use of OR. Reported by Mark H. David. 2012-03-30 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-function-1): Fix indentation of (and ;; Foo\n...). Previously following lines were indented by one, instead of using normal indentation. * slime-cl-indent-test.txt (tests 84-86): Tests. 2011-12-30 Nikodemus Siivola * slime-cl-indent.el (common-lisp-looking-at-keyword): New function. Looks past #+foo expressions. (common-lisp-backward-keyword-argument): New function. Semi-aware of #+foo expressions. (common-lisp-indent-function-1): 1. Use `common-lisp-indent-parse-state-start'. 2. Move #+/- cleavernes outside the cond: it is always a default, and shouldn't trump other indentation logic. Also make it use the column of the first feature expression, not the last. 3. Make keyword alignment somewhat feature-expression aware. 4. Make heuristics not force remaining forms to be indented at the same line. (common-lisp-indent-test): Leave one leading whitespace on comment lines when messing up indentation. * slime-cl-indent-test.txt (tests 77-83): Tests for feature-expression and keyword alignment interaction. 2011-12-24 Stas Boukarev * slime-tramp.el (slime-find-filename-translators): Don't signal an error if there's no translators for a hostname, just use 'identity. 2011-12-23 Stas Boukarev * slime-repl.el (slime-change-repl-to-default-connection): New function. Changes the current REPL to the REPL of the default connection. If the current buffer is not a REPL, don't do anything. Put it into `slime-cycle-connections-hook', so that when connections are cycled through it will change the currently displayed REPL. 2011-12-10 Helmut Eller Don't call init-global-stream-redirection in *after-init-hook*. *after-init-hook* may be called before the contrib was loaded. * swank-repl.lisp (maybe-redirect-global-io): Call init-global-stream-redirection here instead. 2011-12-08 Nikodemus Siivola * slime-cl-indent.el (lisp-indent-maximum-backtracking) ("basic"): Increase default backtracking level to 6, so that at least mildly nested macrolet-lambda lists can be identified as such. * slime-cl-indent.el (common-lisp-init-standard-indentation): Fix FLET indentation spec, which caused local function lambda-lists to be indented as part of the body. * slime-cl-indent-test.txt (tests 72-76): New tests. * slime-cl-indent.el (common-lisp-init-standard-indentation): New function, wraps initialization of the common-lisp-indent-function properties. 2011-12-06 Didier Verna * slime-asdf.el (slime-asdf): New custom group. * slime-asdf.el (slime-asdf-collect-notes): Put this variable in. 2011-12-05 Helmut Eller Drop flow control from repl-output-stream. That's now done at a lower level. * swank-repl.lisp (make-output-function): Use :write-string directly. (send-user-output, *maximum-pipelined-output-chunks*) (*maximum-pipelined-output-length*): Deleted. * swank-repl.lisp (create-repl, open-streams, find-repl-thread): Use accessors for multithreaded-connection where needed. 2011-12-04 Helmut Eller * swank-repl.lisp: New file. * slime-repl.el (slime-repl): Add swank-dependecy. 2011-12-03 Didier Verna * slime-cl-indent.el (common-lisp-loop-type) (common-lisp-loop-part-indentation) (common-lisp-indent-body-introducing-loop-macro-keyword) (common-lisp-indent-prefix-loop-macro-keyword) (common-lisp-indent-clause-joining-loop-macro-keyword) (common-lisp-indent-indented-loop-macro-keyword) (common-lisp-indent-indenting-loop-macro-keyword) (common-lisp-indent-loop-macro-else-keyword) (common-lisp-indent-loop-macro-1): Match not only KEYWORD but also :KEYWORD and #:KEYWORD in the LOOP macro. 2011-12-03 Didier Verna * slime-cl-indent.el (lisp-indent-lambda-list-keywords-regexp): Match empty string after a word consitituent (\>) instead of a symbol constituent (\_>) because XEmacs doesn't have that syntax, and here, it doesn't hurt anyway. 2011-12-03 Helmut Eller * swank-mrepl.lisp (package-prompt): Use <= instead of < to give package-name priority over nicknames. 2011-12-02 Stas Boukarev * slime-repl.el (slime-repl-send-input): Don't put `read-only' property on an overlay, overlays don't support it. 2011-12-02 Helmut Eller * swank-kawa.scm (inspect-obj-ref): Use for instead of iter. 2011-12-02 Helmut Eller * slime-mrepl.el: Drop dependency on slime-repl. Use comint instead. 2011-12-02 Helmut Eller * swank-mrepl.lisp: New file. 2011-12-01 Helmut Eller * swank-kawa.scm (mangled-name): Try to deal unnamed lambdas. (inspect): Split up into inspect-array-ref and inspect-obj-ref. (inspect-array-ref): New. (inspect-obj-ref): New. Include methods in result. 2011-11-29 Helmut Eller * swank-util.lisp: New file. * swank-c-p-c.lisp: Use it. * swank-fancy-inspector.lisp: * swank-fuzzy.lisp: 2011-11-28 Nikodemus Siivola * slime-cl-indent.el (common-lisp-trailing-comment): New function. Returns the column of a trailing comment. (common-lisp-loop-part-indentation) (common-lisp-indent-loop-macro-1): fix indentation of multiline comments starting from a trailing position. * slime-cl-indent-test.txt: Add tests 68 and 69. 2011-11-28 Nikodemus Siivola * slime-cl-indent.el: fix DEFCLASS and DEFINE-CONDITION superclass-list indentation. * slime-cl-indent-test.txt: Add tests 66 and 67. 2011-11-27 Helmut Eller * slime-repl.el (slime-repl-choose-coding-system): New. (slime-repl-connected-hook-function): Use it. 2011-11-23 Stas Boukarev * slime-repl.el (slime-open-stream-to-lisp): Convert "utf-8-unix" to 'utf-8-unix. 2011-11-19 Nikodemus Siivola * slime-cl-indent.el ("sbcl"): Add indentation alias for !def-debug-command. 2011-11-16 Stas Boukarev * slime-repl.el (slime-open-stream-to-lisp): Set the process coding system to the right coding system. 2011-11-12 Nikodemus Siivola Fix DEFMETHOD indentation when the name is a SETF-name, and qualifiers are present. * slime-cl-indent.el (lisp-beginning-of-defmethod-qualifiers): Renamed from `lisp-beginning-of-defmethod'. Skip the method name as well, since unlike qualifiers it can be list -- eg. (setf foo). (lisp-indent-defmethod): Use the above to get the number of skips right. * slime-cl-indent-test.txt: Tests 64 and 65. 2011-11-11 Anton Kovalenko * swank-fancy-inspector.lisp (make-pathname-ispec): Use :position instead of :charpos, according to slime-ed interface. Add :bytep t, telling slime-ed to interpret it as byte offset. 2011-10-31 Nikodemus Siivola * slime-cl-indent.el (common-lisp-run-indentation-tests): Make it possible to run only a specific test. 2011-10-31 Nikodemus Siivola Improve indentation of comments inside LOOP. * slime-cl-indent-test.txt: New tests 54-63. * slime-cl-indent.el (common-lisp-loop-type): Deal with comments at the start of the loop, add simple/split type. * slime-cl-indent.el (lisp-indent-loop): Use common-lisp-loop-part-indentation for simple loops regardless of the value of lisp-loop-indent-subclauses. * slime-cl-indent.el (common-lisp-loop-part-indentation): Handle the new simple/split type, improve comment indentation logic. 2011-10-31 Nikodemus Siivola * slime-cl-indent.el (style "sbcl"): Indentation for !DEF-TYPE-TRANSLATOR. 2011-10-29 Nikodemus Siivola Two patches by Tomohiro Matsuyama . * slime-cl-indent.el (define-common-lisp-style): Fix handling of :documentation option, which accidentally threw out the docstring. (lisp-indent-lambda-list-keywords-regexp): Handle trailing &allow-other-keys correctly. * slime-cl-indent-test.txt: Tests 50-53. 2011-10-07 Stas Boukarev * slime-repl.el (slime-repl-clear-output): Fix clearing output when there's something entered after the prompt. 2011-10-05 Stas Boukarev * slime-autodoc.el (slime-autodoc): Don't cache variable values. (slime-autodoc-global-at-point): Remove, unused. 2011-10-05 Stas Boukarev * slime-repl.el (slime-clear-repl-variables): New function, clears *, /, and + variables. (slime-repl-clear-buffer-hook): Add `slime-clear-repl-variables' to it, now C-c M-o clears variables, allowing bound objects to be GCed. 2011-10-05 Anton Kovalenko * swank-asdf.lisp (asdf-system-directory): preserve pathname-device and use NAMESTRING for final conversion, so both device and directory are passed to SLIME. It is required e.g. on MS Windows with implementations using PATHNAME-DEVICE for drive letters (SBCL); intended to be portable and useful on every platform where DEVICE is important. 2011-10-01 Stas Boukarev * slime-repl.el (slime-repl-set-package): Don't redisplay the prompt if it doesn't change. 2011-10-01 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-done): Fix completion in the minibuffer. 2011-10-01 Stas Boukarev * swank-asdf.lisp (xref-doit): Guard against using on things other than symbols and strings. slime-edit-uses may call it on (setf function), and it'll pop into the debugger. Report by Bart Botta. 2011-09-12 Christophe Rhodes * slime-media.el (slime-dispatch-media-event): allow swank to popup a buffer with a given name, mode and contents. Intended to support display of information formatted by the inferior process as a return value: in particular, R help_files_with_topic objects. 2011-09-01 Anton Kovalenko * slime-c-p-c.el (slime-complete-symbol*-fancy-bit): "imitate" a close-paren, or a space, with exec-kbd-macro instead of inserting them. Makes slime-complete-symbol*-fancy compatible with paredit and probably other smart or "electric" stuff that could be bound to these keys. 2011-08-30 Nikodemus Siivola * slime-repl.el (slime-repl-suppress-prompt): New variable. Bind to T to temporarily suppress the prompt. (slime-eval-last-expression-in-repl): New command. Sends form from another buffer to REPL for evaluation. (slime-mode-map): Bind slime-eval-last-expression-in-repl to C-c C-j. 2011-08-05 Nikodemus Siivola * swank-indentation.lisp (macro-indentation): Tweak so that things that could be bindings are indented by 1, not 4. 2011-07-27 Nikodemus Siivola * slime-cl-indent.el: Tweak COND indentation. * slime-cl-indent-test.txt: Tests 48 and 49. 2011-06-21 Nikodemus Siivola * slime-cl-indent.el (lisp-loop-indent-forms-like-keywords): Fix type error. (common-lisp-style-default): Fix type error, move to after styles have been defined so as to be able to offer a menu for picking the predefined styles. ("sbcl"): Oops! It's (as ...) not (:as ...). Also add couple of missing defining forms. 2011-06-16 Nikodemus Siivola * swank-indentation.lisp (macro-indentation): More complex version than the default. Fixes some of the misbehaviour of the previous complex version. 2011-06-15 Stas Boukarev * slime-scheme.el (slime-scheme-indentation-update): `slime-indentation-update-hooks' now requires functions to accept three arguments. Add `packages' parameter. 2011-06-14 Nikodemus Siivola WITH-COMPILATION-UNIT indentation. * slime-cl-indent.el: Add indentation method. * slime-cl-indent-test.txt: Test 47. Fix indentation of incomplete destructring. * slime-cl-indent.el (lisp-indent-259): If there's a level of destructuring specified in a tail, but we're looking at a word, indent to sexp instead. * slime-cl-indent-test.txt: Test 46. Don't consider DEFINER and DEFINITION as tentative defuns. * slime-cl-indent.el (common-lisp-indent-function-1): Don't consider "definition" or "definer" to be tentative defuns. * slime-cl-indent-test.txt: Tests 44-45. Better DEFMETHOD and :METHOD indentation. * slime-cl-indent.el (lisp-beginning-of-defmethod): New function. (lisp-indent-defmethod): Extend to work with non-toplevel defmethods, and method definitions inside defgenerics. * slime-cl-indent-test.txt: Tests 40-43. 2011-06-11 Nikodemus Siivola * slime-cl-indent.el (common-lisp-style-names): XEmacs doesn't like lists either in completing-read -- need an alist. XEmacs compatibility. * slime-cl-indent.el (common-lisp-style-names): New function. (common-lisp-set-style): Call common-lisp-style-names instead of using the hashtable directly: XEmacs doesn't like hash-tables in completing-read. (common-lisp-looking-back): New function. (common-lisp-indent-function-1): Use common-lisp-looking-back instead of looking-back: XEmacs doesn't have looking-back. Refactoring named styles. * slime-cl-indent.el (define-common-lisp-style): Not a list of hooks anymore, but just a single hook. Document the fact that code in :eval option may get called multiple times over the lifetime of a buffer. (common-lisp-style-name, common-lisp-style-inherits) (common-lisp-style-variables, common-lisp-style-indentation) (common-lisp-style-hook, common-lisp-style-docstring) (common-lisp-make-style, common-lisp-find-style): New functions. Convenience accessors, locator, and constructor. (common-lisp-add-style): Don't precompute inheritance. (common-lisp-safe-style-p): For use with safe-local-variable. (common-lisp-activate-style): Now handles inheritance. (common-lisp-active-style-methods): New function, computes and caches inheritance. (common-lisp-set-style): Changes to match others. (common-lisp-get-indentation): Use common-lisp-active-style-methods. 2011-06-10 Nikodemus Siivola Boa-constructor indentation. * slime-cl-indent.el: Give :constructor the appropriate indentation method. * slime-cl-indent-test.txt: Test-case 39. * slime-cl-indent.el (common-lisp-indent-function-1): Missing paren. Teaches me to to paredit. Take , and ,@ into account properly. * slime-cl-indent.el (common-lisp-indent-function-1): Adjust normal-indent to take , and ,@ into account * slime-cl-indent-test.txt: Test case 36-38. Better handling of complex indentation specs. * slime-cl-indent.el (common-lisp-run-indentation-tests): Add a style with complex specs for testing. (lisp-indent-259): fix handling of nested &whole. Hopefully. slime-indentation: Comment indentation in styles. * slime-cl-indent.el ("basic"): Hack comment indentation to avoid inserting spaces where they don't belong. slime-indentation: More adjustment to the fallback method. * slime-cl-indent.el (common-lisp-indent-function-1): handle case of empty or comment line following the opening paren of the containing expression. * slime-cl-indent-test.txt: new test case. slime-indentation: Test refactoring. * slime-cl-indent.el (common-lisp-indent-test): replaces test-lisp-indent. (common-lisp-run-indentation-tests): replaces run-lisp-indent-tests. * slime-cl-indent-test.txt: new file, contains all the indentation tests. 2011-06-09 Nikodemus Siivola * slime-cl-indent.el (lisp-lambda-list-keyword-parameter-alignment): fix docstring: key1 and key3 were aligned in source, but not in *Help*. (common-lisp-delete-style): Missing function, needed by tests. (common-lisp-indent-function-1, run-lisp-indent-tests): Fix fallback to handle case of first function argument on its own line. Support for per-package derived indentation. * slime-cl-indent.el (common-lisp-system-indentation) (common-lisp-guess-current-package) (common-lisp-current-package-function) (common-lisp-symbol-package): New variables and functions. (common-lisp-get-indentation): Adjust to use system derived information when available. (common-lisp-indent-function-1): Adust to provide `common-lisp-get-indentation' with the full symbol incl. package prefix. * slime-indentation.el (common-lisp-current-package-function): set to `slime-current-package'. Support for named styles. * slime-cl-indent.el (common-lisp-style) (common-lisp-style-default, common-lisp-active-style) (common-lisp-lisp-mode-hook, common-lisp-styles) (common-lisp-add-style, define-common-lisp-style) (common-lisp-set-style, common-lisp-set-style-history) (common-lisp-activate-style, common-lisp-get-indentation): New functions and variables. Setting `common-lisp-style' buffer local variable in a file picks a style -- or use `common-lisp-set-style" to do it. Indentation from style takes precedence. Indirect indentation specs. * slime-cl-indent.el (common-lisp-indent-function) (common-lisp-get-indentation, common-lisp-indent-function-1) (lisp-indent-defmethod): Indirect using (as foo) -style specs. 2011-06-08 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-function-1): fallback method to deal with trailing expressions on the previous line. 2011-06-04 Nikodemus Siivola * slime-cl-indent.el (toplevel): (run-lisp-indent-tests): Better named-lambda and destructuring-bind indenation. 2011-05-31 Stas Boukarev * slime-package-fu.el (slime-export-symbol-representation-auto): New variable. Default value is 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'. 2011-05-26 Stas Boukarev * slime-package-fu.el (slime-add-export): Add :export to the end of a defpackage form when there's no :export present. 2011-05-21 Helmut Eller * slime-snapshot.el: License is GPL. 2011-05-21 Helmut Eller * swank-indentation.lisp: Provide :swank-indentation. Reported by Robert Brown 2011-05-19 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-function-1) (lisp-align-keywords-in-calls): Support for aligning keyword arguments in calls. (lisp-lambda-list-indentation, lisp-indent-lambda-list) (run-lisp-indent-tests): Support for turning off the fancy lambda-list indentation. 2011-05-18 Nikodemus Siivola * slime-cl-indent.el (lisp-indent-defsetf, run-lisp-indent-tests): Better DEFSETF indentation: support both long and short forms. 2011-05-17 Nikodemus Siivola * slime-cl-indent.el (run-lisp-indent-tests, lisp-indent-loop): Fix indentation of function calls, etc, inside loop forms. 2011-05-16 Nikodemus Siivola * slime-cl-indent.el (lisp-loop-indent-forms-like-keywords) (common-lisp-loop-part-indentation, run-lisp-indent-tests): Cater to loop indentation style that prefers to align forms with keywords. Activated by setting lisp-loop-indent-forms-like-keywords to t, and lisp-loop-indent-subclauses to nil. 2011-05-15 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-function-1): Better #+ support. (common-lisp-loop-part-indentation): Make newline-and-indent work better with non-subclause-aware loop indentation. 2011-05-15 Didier Verna * slime-cl-indent.el (test-lisp-indent): Make sure indent-tabs-mode is nil in the test buffer. Otherwise, spaces may be converted into tabs which would make the tests fail. 2011-05-15 Didier Verna * slime-cl-indent.el (lisp-indent-tagbody): (lisp-indent-lambda-list): Use back-to-indentation. 2011-05-14 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-if*-keyword): (common-lisp-indent-if*, common-lisp-indent-if*-1): (common-lisp-indent-if*-advance-past-keyword-on-line): IF* indentation code from Gabor Melis. It should be noted that this should not be considered an endorsement on IF* by the commiter, but rather an act of compassion to all who labor under its shadow. (run-lisp-indent-tests): Test-case for IF* indentation. 2011-05-12 Nikodemus Siivola * slime-cl-indent.el (lisp-indent-lambda-list): Use sexp-based traversal instead of regular expressions to figure out how to indent lambda-lists. Allows indenting destructuring lambda-lists correctly: previously we could align to a keyword in a previous sublist, instead of the sublist itself. (lisp-indent-lambda-list-keywords-regexp): Add support for non-standard &more. (test-lisp-indent, run-lisp-indent-tests): Rudimentary tests. (lisp-indent-259): Use lambda-list-indentation even if the CDR of the path isn't null: this allows correct indentation of destructuring sublists. (run-lisp-indent-tests): More test-cases. 2011-05-11 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-function-1): Handle #+ and #-. Also support the SBCL idiom of #!+ #!-. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el: whitespace cleanup. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el: subclause aware loop indentation, adapted from cl-indent-patches.el. (lisp-indent-loop-subclauses): New customization. (common-lisp-indent-function): Trampoline directly to common-lisp-indent-function-1 -- loop indentation is now picked up by the normal machinery instead of being special cased here. (lisp-indent-loop): New function. Chooses between the old naive indentation and new subclause-aware version based on lisp-indent-loop-subclauses. (common-lisp-indent-body-introducing-loop-macro-keyword): (common-lisp-indent-prefix-loop-macro-keyword): (common-lisp-indent-clause-joining-loop-macro-keyword): (common-lisp-indent-indented-loop-macro-keyword): (common-lisp-indent-indenting-loop-macro-keyword): (common-lisp-indent-loop-macro-else-keyword): Regular expressions for identifying loop parts. (common-lisp-indent-parse-state-depth): (common-lisp-indent-parse-state-start): (common-lisp-indent-parse-state-prev): Parse state accessors. (common-lisp-indent-loop-macro-1): Subclause aware loop indentation. (common-lisp-indent-loop-advance-past-keyword-on-line): Utility used by the above. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el (common-lisp-loop-type): New function, replaces extended-loop-p. (common-lisp-loop-part-indentation): Use common-lisp-loop-type to decide how to indent, supporting both "split" and "unsplit" styles. (lisp-loop-keyword-indentation, lisp-loop-forms-indentation): Deleted: pointless now that both split and unsplit styles work automatically. (extended-loop-p): Deleted. (lisp-simple-loop-indentation): Change default to 2. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el (common-lisp-loop-part-indentation): Return ( ) instead of for non-simple loops. This lets calculate-lisp-indent know that the following lines of the loop might be indented differently -- fixing indent-sexp for loops. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-function-1): Remove bogus special casing of ,(...) and ,@(...). Even if backquote was being indented as data, the escaped forms are evaluated, and hence should be indented as lisp code. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el (lisp-indent-259): Don't throw to exit with normal-indent if processing a tail that isn't a cons. Doing that breaks (... &rest foo) specs. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el (common-lisp-indent-function-1): Don't take `default' for a tentative defun, unlike anything else starting with `def'. 2011-05-10 Nikodemus Siivola slime-indentation: indentation improvements on defmethod and lambda-lists for cl-indent.el by Didier Verna, from emacs-devel. * slime-cl-indent.el: Advertise the changes and remove obsolete TODO entries. * slime-cl-indent.el (lisp-lambda-list-keyword-alignment): * slime-cl-indent.el (lisp-lambda-list-keyword-parameter-indentation): * slime-cl-indent.el (lisp-lambda-list-keyword-parameter-alignment): New customizable user options. * slime-cl-indent.el (lisp-indent-defun-method): Improve docstring. * slime-cl-indent.el (extended-loop-p): Fix comment. * slime-cl-indent.el (lisp-indent-lambda-list-keywords-regexp): New variable. * slime-cl-indent.el (lisp-indent-lambda-list): New function. * slime-cl-indent.el (lisp-indent-259): Use it. * slime-cl-indent.el (lisp-indent-defmethod): Support for more than one method qualifier and properly indent methods lambda-lists. * slime-cl-indent.el: Provide a missing common-lisp-indent-function property for defgeneric. 2011-05-10 Nikodemus Siivola * slime-cl-indent.el: New file. Copy of cl-indent.el from current GNU Emacs HEAD. Replaces the ancient copy previously kept as part of slime-indentation.el. * slime-indentation.el (slime-handle-indentation-update): Deleted. Since we now directly replace the previous version of cl-indent.el, the normal version defined in slime.el works fine. ALSO DELETED: the inline copy of 1995 vintage cl-indent.el. 2011-03-14 Stas Boukarev * swank-sprof.lisp (swank-sprof-get-call-graph): Don't call serialize-call-graph when there's no samples. That prevents it from crashing. 2011-03-13 Stas Boukarev * slime-sprof.el(abbreviate-name): Rename to slime-sprof-abbreviate-name (no package system, oh well...). 2011-03-09 Helmut Eller * slime-editing-commands.el (slime-beginning-of-defun): Call beginning-of-defun with call-interactively so that the mark gets pushed. 2011-01-22 Stas Boukarev * slime-repl.el (slime-repl-shortcut-help): Don't make ? an alias for help, ? is bound to minibuffer-completion-help, and you can't enter it. 2011-01-20 Helmut Eller * swank-mit-scheme.scm (swank:load-file): Print the result instead of returning it which breaks the protocol. * swank-mit-scheme.scm: Require release 9. 2011-01-12 Helmut Eller Some more MIT Scheme fixes. * swank-mit-scheme.scm (swank:compile-string-for-emacs) (swank:compile-file-for-emacs): Use new result format. (swank:disassemble-form): Added with the needed kludgery for quoted forms. (swank:swank-require): Define this as nop. 2011-01-11 Helmut Eller Some upgrades for MIT Scheme backend. * swank-mit-scheme.scm (netcat, netcat-accept): Use netcat-openbsd syntax. This version doesn't print the port number anymore defeating the original purpose of using netcat. (start-swank): Hardcode portnumber to 4055 until somebody cares enough to write proper server ports. (emacs-rex): Include a nonsense message with the :abort reply. 2010-12-10 Stas Boukarev * slime-sprof.el (slime-sprof-browser): Rename to `slime-sprof-report', leave `slime-sprof-browser' as an alias. 2010-12-09 Stas Boukarev * swank-fancy-inspector.lisp (emacs-inspect): Work on methods without associated generic function. 2010-10-28 Stas Boukarev * swank-package-fu.lisp (list-structure-symbols): Include the name of the structure too. 2010-10-17 Helmut Eller Some updates to the Kawa backend. * swank-kawa.scm (%%runnable): Use standard gnu.mapping.RunnableClosure but print the stacktrace on exceptions. (listener-loop): Invoke debugger on unhandled exceptions. The debugger will use stacksnapshots if the exception matches. (invoke-debugger, break, breakpoint, request-breakpoint): New. Used to "invoke" the debugger from normal code. (process-vm-event, debug-info, event-stacktrace): Handle breakpoint events. (interrupt-thread, throwable-stacktrace, breakpoint-condition): New. (throw-to-toplevel): For breakpoint events use Thread#forceEarlyReturn. (typecase): Add support for or and eql types. (bytemethod>src-loc): New. (src-loc>elisp): Use stratum "java" as this seems to work better. (print-object, print-unreadable-object): New (pprint-to-string): Use it. 2010-09-26 Stas Boukarev * slime-repl.el (slime-repl-history-pattern): Match \t too, besides \ and \n. 2010-09-22 Stas Boukarev * slime-repl.el: Handle (:abort condition) message from lisp. 2010-09-18 Tobias C. Rittweiler * slime-parse.el (slime-parse-form-upto-point): Fix lp#627308. * slime-autodoc.el (slime-canonicalize-whitespace): New helper. Extracted out of `slime-format-autodoc'. (slime-autodoc-to-string): New helper. (slime-check-autodoc-at-point): Use it. (autodoc.1): Add test case for above fix. 2010-09-18 Tobias C. Rittweiler * swank-arglist.lisp (function-exists-p): Renamed from FUNCTION-EXISTS-P. Uses new SWANK-BACKEND:VALID-FUNCTION-NAME-P underneath. (valid-operator-name-p): Unused, hence deleted. (boundp-and-interesting): Renamed from INTERESTING-VARIABLE-P. 2010-09-17 Stas Boukarev * swank-sprof.lisp (filter-swank-nodes): Filter other swank packages too, not only SWANK. 2010-09-16 Stas Boukarev * swank-arglists.lisp (print-variable-to-string): Use without-printing-errors when printing the value. Reported by Tobias C. Rittweiler on lp#628945. 2010-09-16 Christophe Rhodes Image display support for the REPL. * slime-media.el: New file. * swank-media.lisp: New file. 2010-09-09 Stas Boukarev * swank-c-p-c.lisp (longest-compound-prefix): Wrong arguments for longest-common-prefix. Reported by Peter Stirling. 2010-09-07 Stas Boukarev * swank-c-p-c.lisp: s/delimeter/delimiter/, correct spelling. 2010-09-07 Stas Boukarev * swank-c-p-c.lisp (untokenize-completion): Take an optional argument "delimiter". (longest-compound-prefix): Pass delimiter to untokenize-completion. 2010-09-04 Stas Boukarev * swank-fuzzy.lisp (*fuzzy-completion-...*): Change defparameter to defvar for easier customization. 2010-09-03 Stas Boukarev * slime-repl.el (slime-search-property-change): XEmacs may return nil on previous/next-single-char-property-change, don't pass it to goto-char. 2010-09-03 Stas Boukarev * slime-repl.el (slime-repl-mode-end-of-defun) (slime-repl-mode-beginning-of-defun): Take an optional argument which specifies how many defuns it should move. GNU Emacs catches wrong-number-of-arguments condition and does this by itself, but XEmacs doesn't. 2010-09-03 Helmut Eller * swank-kawa.scm (%%runnable): Update for changes in SVN version. 2010-08-21 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-choices-buffer): XEmacs compatibility. 2010-08-21 Helmut Eller * slime-repl.el: Specify :on-unload action. 2010-08-21 Anton Kovalenko Add support to save snapshots in backround. * swank-snapshot.lisp (background-save-snapshot): New. (resurrect): Initialize repl streams. * slime-snapshot.el (slime-snapshot): With prefix-arg perform saving in background. Also ask before overwriting existing files. 2010-08-13 Helmut Eller Fix slime-restore. * swank-snapshot.lisp (swank-snapshot::resurrect): Adapted to new MAKE-CONNECTION. 2010-07-29 Stas Boukarev * slime-c-p-c.el (slime-complete-form): Limit `looking-back' too. 2010-07-28 Stas Boukarev * slime-presentations.el (slime-copy-presentation-to-repl): Limit looking-back to one character before point. Solves long freeze on a large buffer. 2010-07-27 Stas Boukarev * slime-sprof.el (slime-sprof-start): change defun to defun*, elisp doesn't understand default values for &optional. 2010-07-24 Stas Boukarev * slime-package-fu.el (slime-frob-defpackage-form): Accept a symbol or a list of symbols. Optimize inserting several symbols at a time. (slime-search-exports-in-defpackage): Search forward until nothing is found, otherwise it searching for FOO will stop after encountering FOO-B. (slime-export-class): Rename from slime-export-structure. * swank-package-fu.lisp (export-symbol-for-emacs): Fix typo. (export-structure): Add support for CCL and for exporting standard-class accessors using MOP. * slime-sprof.el (slime-sprof-start-alloc) (slime-sprof-start-time): New functions to start profiling in :alloc and :time mode. The default slime-sprof-start is :cpu. * swank-sprof.lisp (swank-sprof-start): Accept :mode keyword. 2010-07-24 Stas Boukarev * slime-package-fu.el (slime-export-structure): New function, export all constructors, accessors, etc. * swank-package-fu.lisp (export-structure): Lisp side of the above function, works only on SBCL for now. 2010-07-23 Stas Boukarev * swank-arglists.lisp (arglist-dispatch): Export it, so it may be extended more easily. * slime-fancy-inspector.el (slime-fancy-inspector): Add slime-parse dependency. 2010-07-16 Stas Boukarev * slime-repl.el (slime-call-defun): Handle setf-functions. 2010-07-04 Stas Boukarev * swank-asdf.lisp (asdf:operation-done-p): Fix reloading on ASDF2. ASDF2 no longer has `asdf:around' method combination. 2010-07-02 Stas Boukarev * swank-fancy-inspector.lisp (docstring-ispec): Don't insert an unnecessary space. (emacs-inspect): Delete unnecessary "it" in [... it] buttons. Don't capitalize every word in some messages. 2010-06-15 Stas Boukarev * swank-asdf.lisp (asdf-central-registry): Use an exported interface for ASDF2. 2010-06-14 Stas Boukarev * swank-asdf.lisp (asdf-central-registry): ASDF2 compatibility. Patch by Leo Liu. 2010-06-04 Helmut Eller * inferior-slime.el (inferior-slime-show-transcript): Update window point 2010-05-29 Stas Boukarev * swank-fancy-inspector.lisp (emacs-inspect): Add [finalize] button for not finalized classes. 2010-05-28 Helmut Eller Call provide at the end of the file. * slime-asdf.el slime-banner.el slime-clipboard.el slime-compiler-notes-tree.el slime-enclosing-context.el slime-highlight-edits.el slime-hyperdoc.el slime-indentation.el slime-mdot-fu.el slime-motd.el slime-mrepl.el slime-presentation-streams.el slime-sbcl-exts.el slime-snapshot.el slime-sprof.el slime-tramp.el slime-typeout-frame.el slime-xref-browser.el: 2010-05-28 Helmut Eller * slime-c-p-c.el slime-fancy-inspector.el slime-fancy.el slime-fontifying-fu.el slime-fuzzy.el slime-package-fu.el slime-parse.el slime-presentations.el slime-references.el slime-repl.el slime-scratch.el: Call provide at the end of the file. 2010-05-28 Helmut Eller * swank-kawa.scm (wrap-compilation): Set Compilation.explict flag. (list-file): Add cast to resolve overloaded parse method. (disassemble-form): Update for change from 2010-05-18. 2010-05-19 Stas Boukarev * slime-repl.el (slime-list-repl-short-cuts): Don't scroll to the bottom, don't error if a shortcut has no documentation. 2010-05-16 Stas Boukarev * swank-arglists.lisp (decode-arglist): Handle (x . y) macro arglists. 2010-05-14 Tobias C. Rittweiler * slime-highlight-edits.el, slime-hyperdoc.el, slime-mrepl.el, slime-snapshot.el: Fix typo. 2010-05-13 Tobias C. Rittweiler Perform PATHNAME on file-streams safely. * swank-fancy-inspector.lisp (make-visit-file-thunk): Deleted. (make-pathname-ispec): New helper. (make-file-stream-ispec): New helper. (emacs-inspect file-stream): Use them. (emacs-inspect stream-error): Ditto. 2010-05-13 Tobias C. Rittweiler * slime-autodoc.el, slime-c-p-c.el, slime-compiler-notes-tree.el, slime-enclosing-context.el, slime-fancy.el, slime-fuzzy.el, slime-hyperdoc.el, slime-mdot-fu.el, slime-mrepl.el, slime-parse.el, slime-presentations.el, slime-repl.el, slime-snapshot.el, slime-tramp.el, slime-xref-browser.el: Use newly added `define-slime-contrib' macro to specify slime and swank dependencies, and to specify what should happen on contrib load/unload. 2010-05-13 Stas Boukarev * slime-asdf.el (slime-asdf-collect-notes): New variable. Collect and display notes produced by the compiler. Defaulted to T. 2010-05-08 Stas Boukarev * slime-presentations.el (slime-presentation-write-result): Do slime-repl-show-maximum-output at the end. This really solves jumping. 2010-05-07 Stas Boukarev * slime-presentations.el (slime-presentation-write): Reuse functions from slime-repl. This fixes spurious point jumps. * slime-repl.el (slime-repl-show-maximum-output): Don't search for a window of the buffer if the current window already displays it. (slime-with-output-end-mark): Removed, unused. 2010-05-05 Stas Boukarev * slime-tramp.el (slime-tramp-to-lisp-filename): Check if slime is connected, because slime-to-lisp-filename is now used for establishing connection. 2010-05-05 Helmut Eller * slime-editing-commands.el: Fix typo. 2010-05-01 Stas Boukarev * slime-fuzzy.el(slime-fuzzy-dehighlight-current-completion): instead of creating new overlays, move one overlay around. (slime-mimic-key-bindings): Renamed from mimic-key-bindings. Patch by Leo Liu. 2010-05-01 Stas Boukarev * slime-repl.el (slime-repl-update-banner): Use slime-move-point instead of goto-char alone, ensuring that the point is moved even if the window isn't currently selected. 2010-04-18 Stas Boukarev * slime-presentations.el (slime-repl-grab-old-output) (slime-copy-or-inspect-presentation-at-mouse): If the presentation at point is no longer available, remove presentation properties from the object. * swank-presentations.lisp (lookup-presented-object): defun->defslimefun. 2010-04-06 Stas Boukarev * slime-c-p-c.el (slime-complete-symbol*-fancy-bit): There is no slime-space-information-p variable anymore. Patch by Steven H. Margolis. 2010-04-06 Stas Boukarev * slime-sprof.el (slime-sprof-format): Remove references to the removed code. 2010-04-05 Stas Boukarev * slime-repl.el (slime-repl-inside-string-or-comment-p): New function, when in the REPL prompt, narrow the search to the prompt, otherwise stray " from the previous prompts or outputs may confuse slime-inside-string-or-comment-p. * slime-autodoc.el (slime-autodoc): Use slime-repl-inside-string-or-comment-p when fbound. 2010-04-05 Stas Boukarev * slime-autodoc.el (slime-autodoc-manually): Rename from slime-autodoc-full. Like slime-autodoc, but when called twice, or after slime-autodoc was already automatically called, display multiline arglist. 2010-04-05 Stas Boukarev * slime-autodoc.el (slime-autodoc-full): New command, displays multiline arglists. Bound to C-c C-d a. (slime-make-autodoc-rpc-form): Don't send :print-lines to autodoc, always use the actual width for :print-right-margin, remove newlines on formatting when needed. (slime-autodoc): Add optional parameter multilinep defaulted to slime-autodoc-use-multiline-p, pass it to slime-format-autodoc. * swank-arglists.lisp (autodoc, decoded-arglist-to-string): remove print-lines parameter, it's not used anymore. 2010-04-05 Stas Boukarev * slime-sprof.el (slime-sprof-browser): Use slime-with-popup-buffer for buffer creation. 2010-04-03 Stas Boukarev * swank-arglists.lisp (print-decoded-arglist): prin1-arg -> print-arg. 2010-04-03 Stas Boukarev * swank-arglists.lisp (print-decoded-arglist): Print keywords using princ again. 2010-04-03 Stas Boukarev * swank-arglists.lisp (arglist-dispatch): Handle method qualifiers. (print-arg): Renamed from princ-arg. (prin1-arg): Removed. * slime-autodoc.el (autodoc.1): Add test-case for method qualifiers 2010-03-30 Stas Boukarev * swank-arglists.lisp (*arglist-show-packages*): New customization variable, when non-nil show qualified symbols. (with-arglist-io-syntax): new macro for respecting the above variable. (decoded-arglist-to-string, decoded-arglist-to-template-string): Use the macro above. 2010-03-23 Tobias C. Rittweiler Do not do an unnecessary autodoc RPC request in case we're not actually inside a form. * slime-autodoc.el (slime-make-autodoc-rpc-form): Return nil if not inside a form. (slime-autodoc): Adapted accordingly to propagate nil to eldoc. 2010-03-20 Stas Boukarev * slime-c-p-c.el, slime-fuzzy.el: Don't define keys on slime-repl-mode-map if slime-repl isn't loaded. * slime-presentations.el: Refuse to load if slime-repl isn't loaded. Reported by Robert Goldman. 2010-03-13 Stas Boukarev * slime-asdf.el: use slime-from-lisp-filename so that slime-tramp can work. Reported by Peter Stirling. 2010-03-12 Stas Boukarev * swank-arglists.lisp (extract-local-op-arglists (eql 'labels)): Fix (labels ((name |))). 2010-03-09 Stas Boukarev * swank-arglists.lisp (arglist-ref): Don't error if a &key name isn't a :keyword symbol. And also handle non-:keyword keyword parameters. 2010-03-09 Stas Boukarev * swank-presentations.lisp (inspect-presentation): Throw an error when trying to access unrecorded object. (lookup-presented-object-or-lose): Rename from `get-repl-result'. 2010-03-09 Stas Boukarev * slime-repl.el (slime-call-defun): When on defclass insert (make-instance 'name). 2010-03-08 Stas Boukarev * swank-fancy-inspector.lisp (all-slots-for-inspector): Sort class names when grouping by inheritance the same way as slots are sorted. 2010-03-08 Stas Boukarev * slime-repl.el (slime-call-defun): Work also on defvar/defparameter. 2010-03-07 Stas Boukarev * swank-fancy-inspector.lisp (stable-sort-by-inheritance): Remove copy-seq, unnecessarily put in the previous commit. 2010-03-07 Stas Boukarev * swank-fancy-inspector.lisp: Add buttons for selecting default sorting order and default grouping method of slots of a class. (all-slots-for-inspector): Implement the above feature. Move the default method from :method option of the GF to a separate defmethod, this method is quite large and :method eats space for indentation. (*inspector-slots-default-order*): New variable, accepts :unsorted and :alphabetically (*inspector-slots-default-grouping*): New variable, accepts :all and :inheritance. 2010-03-07 Tobias C. Rittweiler * swank-arglists.lisp (extract-local-op-arglists): Fix for `(labels ((foo (x) ...)|'. * slime-autodoc.el (autodoc.1): Add test cases. 2010-02-20 Tobias C. Rittweiler * slime-fancy.el: Call init function for fancy inspector. Necessary due to 2010-02-15. 2010-02-19 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-choices-buffer): Make connection buffer-local, otherwise `swank:fuzzy-completion-selected' will be sent to the default connection. 2010-02-17 Helmut Eller Fix bugs when *inferior-buffers* doesn't exist. * inferior-slime.el (inferior-slime-start-transcript) (inferior-slime-stop-transcript): Make sure the buffer exists. 2010-02-15 Tobias C. Rittweiler * slime-asdf.el, slime-autodoc.el, slime-c-p-c.el, slime-clipboard.el, slime-fancy-inspector.el, slime-fuzzy,el, slime-indentation.el, slime-motd.el, slime-presentation-streams.el, slime-presentations.el, slime-sbcl-exts, slime-snapshot.el, slime-sprof.el: Make sure that contrib code does not try to load in swank code asynchronously but use `slime-require' instead; also make sure to move the `slime-require' into the contribs' init function. 2010-01-31 Stas Boukarev * slime-repl.el (slime-repl-mode): Don't do (use-local-map slime-repl-mode-map) because it will be used through slime-repl-map-mode minor mode. This fixes double entries in the menu bar. Reported by RaceCondition from #lisp. 2010-01-25 Stas Boukarev * slime-package-fu.el (slime-goto-next-export-clause): Use " \n\t" for `skip-chars-forward' instead of [:alpha:], because it doesn't work for some reason. (slime-search-exports-in-defpackage): take #:symbol and :symbol into account too. 2010-01-14 Stas Boukarev * slime-repl.el: Revert the previous change because it didn't work in some cases. (slime-repl-map-mode): New minor mode which sole purpose is to enable `slime-repl-mode-map'. (slime-repl-mode): Enable `slime-repl-map-mode' after enabling `slime-editing-map'. This will finally allow `slime-repl-mode-map' to take precedence of `slime-editing-map'. 2010-01-14 Stas Boukarev * slime-repl.el (slime-repl-mode-map): Use both `slime-editing-map' and `lisp-mode-map' as parent keymaps. (slime-repl-mode): Don't use `slime-editing-mode' because its keymap is already used above. That way `slime-repl-mode-map' takes precedence of `slime-editing-map'. 2010-01-08 Stas Boukarev * swank-asdf.lisp: 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 fs caches. 2010-01-06 Tobias C. Rittweiler * swank-arglists.lisp (interesting-variable-p): Exclude keywords from being candidates for "display variable content" autodoc feature. (print-decoded-arglist): Slightly better arglist printing if `slime-autodoc-use-multiline-p' is true. (parse-raw-form): Make it able to parse strings. * slime-autodoc.el (autodoc.1 [test]): Add more cases. 2010-01-06 Tobias C. Rittweiler * slime-autodoc.el (slime-check-autodoc-at-point): Bind `slime-autodoc-use-multiline-p' to nil for normalized test results. 2010-01-06 Tobias C. Rittweiler * swank-arglists.lisp (extract-cursor-marker): Make sure to recurse only if the form, to be recursed into, is a cons. Reported by Johannes Grødem. 2010-01-06 Tobias C. Rittweiler * swank-arglists.lisp (arglist-dispatch ['declare]): Normalize `vars' to `variables'. (arglist-for-type-declaration): Ditto. * slime-autodoc (autodoc.1 [test]): Reorganize test, add comments, add cases to test declarations. 2010-01-05 Stas Boukarev * slime-asdf.el (slime-save-system): New function for saving system's files. 2010-01-05 Helmut Eller Fix "other window" selector in inferior-slime-mode. * inferior-slime.el ([selector-method] r): Return the buffer instead of switching directly. 2010-01-03 Tobias C. Rittweiler * slime-autodoc.el (slime-autodoc-mode): Only display "enabled"/"disabled" message if called interactively. 2010-01-03 Tobias C. Rittweiler * slime-autodoc.el (slime-autodoc): Renamed from `slime-compute-autodoc'; now also interactive. (slime-autodoc-mode): Implement toggling properly. Make modeline string "Autodoc" rather than "Eldoc". (slime-autodoc-maybe-enable): Adapted accordingly. 2010-01-03 Stas Boukarev * slime-repl.el (sldb-insert-frame-call-to-repl): New function for inserting a call to a frame into the REPL. Bound to C-y in SLDB. 2010-01-03 Tobias C. Rittweiler * swank-arglists.lisp (arglist-index): Return NIL if more arguments were provided than are allowed. (form-path-to-arglist-path): Adapted accordingly. * slime-autodoc.el (autodoc.1 [test]): Add relevant test cases. 2010-01-03 Tobias C. Rittweiler * slime-indentation-fu.el, swank-indentation-fu.lisp: Delete contrib. Never worked quite right, and the necessary infrastructure has since been gone. 2010-01-03 Stas Boukarev * swank-asdf.lisp (asdf-system-loaded-p): Don't return a generalized boolean, because numbers may be too large for Emacs. 2009-12-30 Tobias C. Rittweiler * slime-c-p-c.el (complete-form [test]): Set `slime-buffer-package' after changing to lisp-mode because changing major-mode kills buffer-local variables. 2009-12-30 Tobias C. Rittweiler * swank-arglists.lisp (extract-cursor-marker): Fix typo. (autodoc): Do not try to display variable content for T and NIL. (interesting-variable-p): New helper. 2009-12-29 Tobias C. Rittweiler * slime-autodoc.el (slime-compute-autodoc): Revert last change. We must return nil to decline. 2009-12-29 Tobias C. Rittweiler More cleanup. The RP swank:arglist-for-echo-area is now called swank:autodoc. * swank-arglists.lisp (autodoc): Renamed from arglist-for-echo-area. (variable-desc-for-echo-area): Deleted. Above function subsumes this functionality now. (print-variable-to-string): Extracted from variable-desc-for-echo-area. * slime-autodoc.el (slime-retrieve-arglist): Change RPC. (slime-make-autodoc-rpc-form): Ditto. (slime-autodoc-cache-type): Deleted. (slime-autodoc-cache): Deleted. (slime-autodoc-last-buffer-form): Replacement. (slime-autodoc-last-autodoc): Replacement. (slime-get-cached-autodoc): Adapted accordingly. (slime-store-into-autodoc-cache): Adapted accordingly. (slime-compute-autodoc): Simplified slightly. (autodoc.1 [test]): Extended. 2009-12-29 Tobias C. Rittweiler Some cleanup of arglist code. * swank-arglists.lisp (remove-from-tree-if): Deleted. (remove-from-tree): Deleted. (maybecall): Deleted. (arglist-path-to-parameter): Deleted. (arglist-path-to-nested-arglist): Deleted. (last-arg): Deleted. (compute-arglist-index): Deleted. (form-path-to-arglist-path): New. (arglist-index): New. (extract-cursor-marker): New. (find-subform-with-arglist): Adapted. (find-immediately-containing-arglist): Adapted. (arglist-for-echo-area): Adapted. 2009-12-29 Tobias C. Rittweiler * slime-parse.el (slime-parse-form-until): Properly deal with #' prefix. (form-up-to-point.1 [test]): Extend. 2009-12-25 Tobias C. Rittweiler * swank-arglists.lisp (delete-given-args): Make sure to properly delete provided-args. * slime-c-p-c.el (complete-form [test]): Extend. Succeeds now. 2009-12-23 Tobias C. Rittweiler * slime-parse.el (form-up-to-point.1 [test]): Fix test case. 2009-12-23 Tobias C. Rittweiler * slime-c-p-c.el (complete-symbol* [test]): Fix test case. 2009-12-23 Tobias C. Rittweiler * slime-autodoc.el (autodoc.1 [test]): Add a test case involving DEFMETHOD. * slime-c-p-c.el (complete-form [test]): New test. Fails for the moment. Reported by Matthias Koeppe. 2009-12-22 Helmut Eller Commands to save&restore image files without disconnecting. * slime-snapshot.el: New file. * swank-snapshot.lisp: New file. 2009-12-21 Tobias C. Rittweiler * swank-arglists.lisp (completions-for-keyword): Return nil instead of :not-available because the function is supposed to return a list of available completions. Adapted from patch by Ariel Badichi. 2009-12-21 Tobias C. Rittweiler Today's cleanup day. * slime-parse.el (slime-incomplete-form-at-point) (slime-parse-sexp-at-point) (slime-has-symbol-syntax-p) (slime-incomplete-sexp-at-point) (slime-parse-extended-operator-name) (slime-extended-operator-name-parser-alist) (slime-make-extended-operator-parser/look-ahead) (slime-parse-extended-operator/proclaim) (slime-parse-extended-operator/declare) (slime-parse-extended-operator/check-type) (slime-parse-extended-operator/the) (slime-nesting-until-point) (slime-make-form-spec-from-string) (slime-enclosing-form-specs) (slime-ensure-list) (slime-beginning-of-string) (slime-check-enclosing-form-specs) (enclosing-form-specs.1 [test]): Deleted. The new arglist code made all this superfluous. * slime-autodoc.el (slime-autodoc-accuracy-depth): New defcustom. (slime-retrieve-arglist): Return :not-available if appropriate. (slime-arglist): Use `slime-retrieve-arglist'. Delete reference to undefined variable. (slime-autodoc-thing-at-point): Deleted, not needed anymore. (slime-autodoc-hook): Deleted. (slime-autodoc-worthwhile-p): Deleted. (slime-make-autodoc-rpc-form): Simplified. (slime-compute-autodoc-internal): Merged with `slime-compute-autodoc'. (slime-compute-autodoc): Removed usage of old infrastructure. Simplified. * swank-arglists.lisp (print-decoded-arglist): Print ((:foo bar) quux) &key parameters correctly. (variable-desc-for-echo-area): Return :not-available, not nil. * slime-c-p-c.el (slime-complete-symbol*-fancy-bit): Adapted for new return value of `slime-retrieve-arglist'. * slime-fancy.el: Disable `slime-mdot-fu' contrib because that has to be adapted to new infrastructure. * slime-sbcl-exts.el (slime-enable-autodoc-for-sb-assem:inst): Deleted. Used old infrastructure. 2009-12-21 Tobias C. Rittweiler * slime-parse.el (slime-parse-form-upto-point): Rewritten to make it more performant. (slime-parse-form-until): New helper. 2009-12-21 Tobias C. Rittweiler * slime-package-fu.el (slime-at-expression-p): Moved from slime.el. (slime-goto-next-export-clause): Replace `slime-forward-blanks'. * slime-parse.el (slime-parse-sexp-at-point) (slime-parse-extended-operator-name): Replace `slime-forward-blanks'. 2009-12-19 Stas Boukarev * swank-asdf.lisp (asdf:operation-done-p): ASDF included with some implementations doesn't have AROUND method combination, so guard against its usage. This will prevent swank:reload-system from working, but it will let load swank-asdf. Reported by Mark Evenson. 2009-12-19 Tobias C. Rittweiler * slime-asdf.el (slime-query-replace-system-and-dependents): Renamed from `slime-query-replace-system-and-dependencies' because that's what it actually does. 2009-12-18 Tobias C. Rittweiler Add 'M-x slime-query-replace-system-and-dependencies' which is like `slime-query-replace-system' but also runs query-replace on all files of systems _depending on_ the user-queried system. * slime-asdf.el (slime-read-query-replace-args): Factored out from `slime-query-replace-system'. (slime-query-replace-system): Use it. (slime-query-replace-system-and-dependencies): Add. * swank-asdf.lisp (who-depends-on): `asdf:system-definition-pathname' may return NIL, guard against that. 2009-12-17 Tobias C. Rittweiler * swank-asdf.lisp (who-depends-on): Make defslimefun. (xref-doit [:depends-on]): New method to make :depends-on valid xref request. * slime-asdf.el (slime-who-depends-on-rpc): New. (slime-who-depends-on): New interactive function. (slime-asdf-init): Make `slime-edit-uses' perform a :depends-on request, and bind `C-c C-w d' to `slime-who-depends-on'. 2009-12-15 Tobias C. Rittweiler * swank-asdf.lisp (who-depends-on): Add. 2009-12-15 Tobias C. Rittweiler * swank-asdf.lisp (map-defined-systems): Factored out. (list-all-systems-known-to-asdf): Use it. (asdf-determine-system): Use it, too. (reload-system): Reuse `operate-on-system-for-emacs'. 2009-12-15 Stas Boukarev * slime-asdf.el (slime-reload-system): New command for reloading a system without recompiling recursively its dependencies. REPL shortcut for it is `reload-system'. * swank-asdf.lisp (reload-system): New function. 2009-12-14 Tobias C. Rittweiler Take recursiveness of LABELS into account for displaying local arglists. I.e. make the following work: (labels ((iseven (x) ...) (isodd (y) (if (zerop y) nil (iseven <>))))) ; Point is here ...) As we only have information to look backward, we cannot show arglist for ISODD within ISEVEN, though. * swank-arglists.lisp (extract-local-op-arglists): Handle LABELS specially. (find-subform-with-arglists): Adapted accordingly. Plus: Small refactoring, and fix comparasion of local ops to properly deal with arglist dummies. 2009-12-14 Stas Boukarev * slime-asdf.el (slime-delete-system-fasls): New command with a shortcut `delete-system-fasls'. * swank-asdf.lisp (delete-system-fasls): New function. (asdf-module-output-files): New function for finding fasls. 2009-12-12 Matthias Koeppe * slime-presentations.el (slime-reify-old-output): Revert change of 2009-12-11, which introduced spurious quotes in non-evaluated contexts like here: '(1 2 # 3 4) Presentations do not change standard quoting rules; users just need to remember this. 2009-12-11 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-choices-buffer): Don't show cursor in *Fuzzy Completions*. Patch by Tobias C. Rittweiler. 2009-12-11 Stas Boukarev * slime-presentations.el (slime-reify-old-output): Quote the CL expession behind presentations, so _(1 2 3)_ (representing a presentation) is not tried to be evaluated. (slime-copy-presentation-to-repl): Use `looking-back' for looking back. Apply De Morgan's law to conditions. Patch by Tobias C. Rittweiler. 2009-12-11 Stas Boukarev * swank-asdf.lisp (find-operation): New function for finding asdf operations independent of readtable case sensitivity (read Allegro Modern Mode). (operate-on-system): Accept symbols instead of strings for operation-name, and use the above function. * slime-asdf.el: Replace strings with operation names for `slime-oos' with symbols. 2009-12-11 Tobias C. Rittweiler * swank-arglists.lisp (*swank-debug-arglists*): Removed. (arglist-for-echo-area): Use DEBUG-ON-SWANK-ERROR instead. 2009-12-04 Stas Boukarev * swank-arglists.lisp (find-subform-with-arglist): Return (values nil :not-available), not just NIL, when operator is `quote' or `function'. Fixes bug reported by Mark Harig. 2009-12-03 Tobias C. Rittweiler http://common-lisp.net/project/hyperdoc/ * slime-hyperdoc.el, swank-hyperdoc.lisp: New contrib. 2009-12-03 Tobias C. Rittweiler * swank-arglists.lisp (arglist-available-p): New helper. (arglist-dispatch [eql 'declaim]): New. (arglist-dispatch [eql 'declare]): First try to lookup arglist of a typespec if it's a type-declaration, if not default to looking up arglist of declaration specifier. (arglist-for-type-declaration): Extracted out. (decoded-arglist-for-type-specifier): Make sure not to call TYPE-SPECIFIER-ARGLIST with an ARGLIST-DUMMY. 2009-12-03 Tobias C. Rittweiler * slime-asdf.el (slime-query-replace-regexp): Quote `from' argument because `tags-query-replace' actually uses `query-replace-regexp' internally. Reported by David O'Toole. 2009-12-01 Stas Boukarev * swank-asdf.lisp (asdf-system-files): Include the .asd file too. (asdf-module-files): Include non-cl files too. 2009-11-30 Helmut Eller * slime-repl.el (slime-repl-mode-map): Don't copy slime-parent-map. Instead ... (slime-repl-mode): ... enable slime-editing-mode. * slime-presentations.el (slime-presentation-init-keymaps): Replace slime-define-both-key-bindings with slime-bind-keys. (slime-presentation-init-keymaps): Use slime-init-keymap. 2009-11-24 Tobias C. Rittweiler Fix a few edge cases in new arglist code. * slime-parse.el (slime-parse-form-upto-point): Regard beginning-of-line as whitespace, and DTRT. * swank-arglists.lisp (empty-arg-p): Input may not only be an arglist-dummy. (print-decoded-arglist-as-template): Do not print superfluuous newline before &body. (arglist-for-echo-area): Catch errors. (find-subform-with-arglist): Deal properly with NIL as argument. (find-immediately-containing-arglist): Do not erroneously complete form with an unsuited arglist of the parent form. (last-arg): New helper. (arglist-path-to-nested-arglist): Use it. Reported by Ariel Badichi. 2009-11-23 Tobias C. Rittweiler * slime-asdf.el (slime-rgrep-system): Conditionalize on whether `rgrep' is available (it isn't on Emacs 21.) Also make sure to call `grep-compute-defaults' before `grep-read-regexp' because the former does some necessary setup. (Seems to be of a problem on Emacs from CVS.) 2009-11-23 Tobias C. Rittweiler * slime-repl.el (slime-repl-previous-matching-input) (slime-repl-next-matching-input): Read input by means of `slime-read-from-minibuffer' so TAB will complete symbols for us. 2009-11-23 Tobias C. Rittweiler * swank-asdf.lisp (operate-on-system-for-emacs), (operate-on-system): Muffle ASDF:COMPILE-ERROR because we reuse Slime's compilation error reportery anyway, and sldb popping up is just annoying. 2009-11-23 Tobias C. Rittweiler * swank-asdf.lisp (system-contains-file-p): Previous definition didn't properly propagate positive return value of recursive call. Fix that. 2009-11-22 Stas Boukarev * slime-repl.el (slime-repl-history-remove-duplicates): New variable, if set to T previous matching history entries are removed before appending a new item. Default value is NIL. (slime-repl-history-trim-whitespaces): New variable, when T remove whitespaces at the beginning and end of a new history item. Default value is NIL. (slime-repl-add-to-input-history): Implement behaviour of the variables above. (slime-string-trim): New function, works like cl:string-trim. 2009-11-22 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-compute-region-for-font-lock): Set an upper limit for the starting point of searching for suppressed forms. * slime-parse.el (slime-make-form-spec-from-string): Minor optimizations. (slime-parse-form-upto-point): Refactored to not use `reduce' but bultins. (slime-make-form-spec-from-string, slime-parse-form-upto-point) (slime-compare-char-syntax): Byte-compile. 2009-11-21 Tobias C. Rittweiler * swank-asdf.lisp (asdf-determine-system): Also try to determine the current system by looking at the buffer-package. * slime-asdf (slime-read-system-name): Adapted accordingly. 2009-11-20 Stas Boukarev * slime-repl.el (slime-repl-position-in-history): Add new optional parameter `exclude-string'. (slime-repl-history-replace): Don't replace history item if it's exactly matching the current input, search for the next match instead. 2009-11-19 Tobias C. Rittweiler * slime-asdf.el (slime-query-replace-system): Enable TAB completion of symbol names. * slime-fuzzy.el (slime-fuzzy-completions): Do not use `slime-find-buffer-package' it's an internal operation of `slime-current-buffer'. 2009-11-17 Tobias C. Rittweiler M-x slime-isearch-system will run `isearch-forward' on all files pertaining to an ASDF system. M-x slime-query-replace-system will run `query-replace' on all files pertaining to an ASDF system. * slime-asdf.el (slime-read-system-name): Refactored so callers have choice over how the default value is computed. (slime-find-asd-file): Renamed from `slime-find-asd'. (slime-determine-asdf-system): New helper. (slime-isearch-system): New function. Depends on functionality only available on GNU Emacs 23.1.x. (slime-query-replace-system): New function. 2009-11-17 Stas Boukarev * swank-asdf.lisp (asdf-determine-system): Rewritten to be much faster and to cons less (and look ugly). 2009-11-16 Stas Boukarev * swank-asdf.lisp (asdf-determine-system): New function for determining to what system a file belongs. * slime-asdf.el (slime-rgrep-system): New function. 2009-11-13 Tobias C. Rittweiler * swank-arglists.lisp (extra-keywords/make-instance) (extra-keywords/change-class): Wrap call to CLASS-PROTOTYPE in an IGNORE-ERRORS because computing a class-prototype involves evaluating initforms which may be calls to ERROR. 2009-11-07 Stas Boukarev * slime-package-fu.el (slime-find-package-definition-regexp): Go one sexp backward to the defpackage beginning. 2009-11-06 Tobias C. Rittweiler * slime-autodoc.el (slime-arglist): Adapted to new code. (slime-retrieve-arglist): New. * slime-c-p-c.el (slime-get-arglist): Deleted. (slime-complete-symbol*-fancy-bit): Use `slime-retrieve-arglist'. 2009-11-05 Tobias C. Rittweiler * swank-arglists.lisp (print-decoded-arglist): Fix printing of &any and &key parameters. (test-print-arglist): Slightly adapted. * slime-autodoc.el ([test] autodoc.1): Slightly adapted. 2009-11-02 Tobias C. Rittweiler * swank-arglists.lisp (do-decoded-arglists): Remove L-V-T. 2009-11-02 Tobias C. Rittweiler * slime-parse.el (slime-make-form-spec-from-string): Break out of the loop if we're at unbalanced parentheses. (slime-compare-character-syntax): New helper. (slime-parse-form-upto-point): Use it. (slime-incomplete-form-at-point): Revert change. ([test] form-upto-point.1): New test case. 2009-11-02 Stas Boukarev * slime-parse.el (slime-incomplete-form-at-point): Concatenate " )" not just ")", because the form's last char may be \, and the parenthesis will be escaped. That fixes a bug reported by Ariel Badichi. 2009-10-31 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-suppressed-forms-internal): Wrap form in `ignore-errors' again. People have been guinea pigs long enough. Suppression of reader-conditionalized forms seems to work pretty reliably now. 2009-10-31 Tobias C. Rittweiler * slime-autodoc.el, swank-arglists.lisp: Large parts were rewritten. Autodoc is now able to highlight &key parameters, and parameters in nested arglists. * slime-parse.el, slime-c-p-c.el, slime-highlighting-edits.el: Adapted to changes. 2009-10-31 Tobias C. Rittweiler * slime-autodoc.el (slime-autodoc-worthwile-p): New helper. (slime-compute-autodoc-internal): Use it to only perform an RPC request if it's worthwhile to do so. For example, don't do it if the user only typed a single opening parenthesis. * swank-arglists.lisp (variable-desc-for-echo-area): Bind *PRINT-READABLY* to NIL as global variables may contain objects which can't be printed readably. 2009-10-31 Tobias C. Rittweiler * swank-c-p-c.lisp (completion-set): Split into `symbol-completion-set', and `package-completion-set'. (completions): Updated accordingly. Also: complete packages "hyphenated" by dots. (find-matching-packages): Heed readtable-case. (make-compound-prefix-matcher): Make it possible to pass list of delimeters. (compound-prefix-match): Deleted. * swank-arglists.lisp (completions-for-keyword): Adapted so it does not use `compound-prefix-match'. * slime-c-p-c.el (complete-symbol* [test]): New test case. 2009-10-31 Tobias C. Rittweiler * swank-arglists.lisp (extra-keywords :around): Sort keyword parameters such that implementation-internal stuff is shown last. (compose): New helper. (make-package-comparator): New. (sort-extra-keywords): New. 2009-10-31 Tobias C. Rittweiler `M-x slime-visit-sbcl-bug' will open a browser to visit SBCL's bug tracker at Launchpad that describes the bug number at point (#nnnnnn). * slime-sbcl-exts.el (slime-visit-sbcl-bug): New. (slime-read-sbcl-bug): New. (slime-sbcl-bug-at-point): New. 2009-10-21 Stas Boukarev * slime-asdf.el (slime-browse-system): Open the parent directory of an .asd file, not just files defined in it. (slime-open-system): Open files in another window. * swank-asdf.lisp (asdf-system-files): Put file with the same name as a system at the first place. 2009-10-21 Stas Boukarev * slime-asdf.el (slime-browse-system): New command for browsing files in asdf using Dired. * swank-asdf.lisp (asdf-system-loaded-p): New function. 2009-10-20 Stas Boukarev * slime-parse.el (slime-parse-sexp-at-point): Remove unused flet. Check for existence of a sexp before trying to parse, not after. 2009-10-19 Stas Boukarev * slime-asdf.el (slime-open-system): New command for opening all files in a system. * swank-asdf.lisp (asdf-system-files): New function for listing all files in a system. 2009-10-15 Helmut Eller * slime-repl.el (slime-repl-find-buffer-package): New function. (slime-repl-init): Initialize slime-find-buffer-package-function. 2009-10-14 Tobias C. Rittweiler * slime-sprof.el (slime-sprof-browser-mode-map): Make `slime-parent-map' its parent. 2009-10-12 Stas Boukarev * slime-repl.el (slime-repl-set-package): Don't double unfinished input and don't move point if it's inside the input area. 2009-10-10 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-suppressed-forms): Add clause for new condition `slime-incorrect-feature-expression'. ([test] font-lock-magic): Add new test case. 2009-10-09 Stas Boukarev * swank-sprof.lisp: Add ability to exclude functions which symbols are from swank package. * slime-sprof.el (slime-sprof-toggle-swank-exclusion): New function. Bound to s in the slime-sprof buffer. * slime-sprof.el (slime-sprof-exclude-swank): New variable for controlling exclusion of swank functions. * slime-sprof.el: Slightly factor code, add menu entries. 2009-09-29 Stas Boukarev * slime-repl.el (slime-sync-package-and-default-directory): Better checking for packages. 2009-09-28 Stas Boukarev * slime-repl.el (slime-sync-package-and-default-directory): Do not try to set package if it doesn't exists. 2009-09-25 Tobias C. Rittweiler * swank-sbcl-exts.lisp: Add EVAL-WHEN to prevent subtle dependency problem. 2009-09-21 Stas Boukarev * slime-sprof.el, swank-sprof.lisp: New contrib for integration with SBCL's sb-sprof profiler, adopted from Juho Snellman's code. 2009-09-17 Stas Boukarev * slime-repl.el (slime-repl-clear-buffer): Don't change cursor position if is already at the prompt. 2009-09-16 Tobias C. Rittweiler * slime-references.el: Largely refactored: decoupled code from SLDB; add references to the compilation log. 2009-09-15 Stas Boukarev * slime-autodoc.el (slime-fontify-string): setup *slime-fontify* buffer without calling (lisp-mode) to avoid turning slime-mode there, which may cause interference. 2009-09-13 Stas Boukarev * slime-autodoc.el (slime-fontify-string): do not call (slime-autodoc-mode -1), there is no reason to do so. And it won't mess slime-echo-arglist-function, which fixes bug reported by Stanislaw Halik. 2009-09-04 Stas Boukarev * slime-repl.el (slime-sync-package-and-default-directory): Don't change package if it's unknown. Use existing functions for changing package and directory. 2009-09-02 Stas Boukarev * swank-arglists.lisp (decode-required-arg): Move LispWorks specific code into swank-lispworks.lisp. 2009-09-01 Stas Boukarev * swank-arglists.lisp (decode-required-arg): Arglists for some forms in LispWorks, e.g. flet, contain strings, so handle strings too. Reported by Nick Levine. 2009-08-28 Stas Boukarev * slime-c-p-c.el (slime-contextual-completions): Remove debugging code. 2009-08-27 Stas Boukarev * slime-c-p-c.el (slime-contextual-completions): Detect characters properly. (slime-completions-for-character): Append #\ to the character names. This fixes character completion, reported by Nick Levine. 2009-08-24 Helmut Eller * inferior-slime.el (inferior-slime-stop-transcript): Switch to the right buffer. 2009-08-21 Helmut Eller * inferior-slime.el (inferior-slime-show-transcript) (inferior-slime-stop-transcript, inferior-slime-start-transcript): New functions. (inferior-slime-init): Install transcript hooks. 2009-08-15 Helmut Eller * slime-typeout-frame.el (slime-typeout-message): Don't call slime-autodoc-stop-timer which no longer exists since 2009-01-01. (slime-typeout-frame-init): Don't create a frame in a tty-only session. (slime-typeout-tty-only-p): New predicate. 2009-08-15 Helmut Eller Disable slime-autodoc for XEmacs. * slime-autodoc.el, slime-fancy.el: XEmacs's version of eldoc doesn't have the neccessary hooks. 2009-08-11 Tobias C. Rittweiler * slime-autodoc.el (slime-arglist): Pass properly formed argument in the rpc call. 2009-08-09 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-complete-symbol): change `comint-completion-addsuffix' to not add space after completing a filename. 2009-08-05 Stas Boukarev * swank-fancy-inspector.lisp (emacs-inspect): add buttons for removing compiler-macros and unbinding variables. 2009-07-22 Stas Boukarev * swank-fuzzy.lisp (fuzzy-convert-matching-for-emacs): format floats on the lisp side, because Emacs doesn't accept d0 or s0, which could get there as a result of *read-default-float-format* modification. * slime-fuzzy.el (slime-fuzzy-insert-completion-choice): ditto. 2009-07-15 Tobias C. Rittweiler * swank-sbcl-exts.lisp (compute-enriched-decoded-arglist): Filter uninteresting arguments for SB-ASSEM:INST. 2009-07-21 Helmut Eller * swank-goo.goo, swank-jolt.k (create-repl): Implemented. 2009-07-19 Helmut Eller * swank-kawa.scm (operator-arglist): Implemented, at least for some kind of function. 2009-07-12 Helmut Eller * swank-kawa.scm (swank-writer): Use set! for now, as the svn version has problems to resolve setLength. (:init): Don't forget the self slot. 2009-07-12 Helmut Eller * swank-mit-scheme.scm (swank:create-repl): Implement it. * swank-kawa.scm, swank-goo.scm, swank.rb (frame-source-location): Renamed from frame-source-location-for-emacs. 2009-07-11 Stas Boukarev * slime-parse.el (slime-make-form-spec-from-string): set syntax table to lisp-mode-syntax-table in a temporary buffer. Necessary for some parsing functions to work correctly. 2009-07-04 Tobias C. Rittweiler Fix font-lock magic for s-code.lisp in the series package. * slime-fontifying-fu.el (slime-beginning-of-tlf): Use `syntax-ppss-toplevel-pos' on GNU Emacs. Old definition is retained for systems where it's not available. Also wrap an `ignore-errors' around the call to `up-list' in the old definition to guard against unbalanced parentheses. Reported by Stelian Ionescu, Raymond Toy. 2009-07-02 Stas Boukarev * slime-repl.el (slime-repl-delete-current-input): Make it interactive. 2009-06-28 Stas Boukarev * slime-fuzzy.el (slime-fuzzy-complete-symbol): show message in the minibuffer after showing completion list, because completion itself can take place in the minibuffer. (slime-fuzzy-choices-buffer): if completion was started in the minibuffer, don't switch to minibuffer in the other window, but select minibuffer window instead. 2009-06-23 Helmut Eller * swank-ikarus.ss, swank-larceny.scm, swank-r6rs.scm: New files. 2009-06-16 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-suppressed-form): Additional exit constraint for the loop; make sure we'r still in the limit. (slime-compute-region-for-font-lock): Simplify. 2009-06-14 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-suppressed-form): Retry the search differently; handlers are not active anymore inside a handler in `condition-case'. 2009-06-12 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-compute-region-for-font-lock): Fix for `#+foo (... #+bar (... |) ...)'. ([test] font-lock-magic): Moved here. 2009-05-28 Tobias C. Rittweiler * slime-repl.el (slime-repl-disconnect): Disconnect current connection. (slime-repl-disconnect-all): New; disconnect all connections. Patch by Stas Boukarev. 2009-05-20 Tobias C. Rittweiler * swank-arglists.lisp (arglist-dispatch [define-compiler-macro]): guard against when we're in the body of a compiler-macro definition for a function not yet compiled into the image. 2009-05-20 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-for-suppressed-forms): Retrieve match data early now that `slime-current-parser-state' does not save it anymore. 2009-05-17 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-for-suppressed-forms): Shadow SBCL-specific #!+, #!- conditionals correctly. (slime-compute-region-for-font-lock): Fix small thinko. 2009-05-16 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-beginning-of-tlf): Make sure to skip outside of comments and strings first. 2009-05-16 Tobias C. Rittweiler Optimize font-lock-magic. * slime-fontifying-fu.el (slime-search-suppressed-forms-match-data): New var, to inhibit consing. (slime-search-suppressed-forms-internal): Use it. (slime-extend-region-for-font-lock): Do not call `slime-connected-p', it's not needed in this place. (slime-search-directly-preceding-reader-conditional): Do not use `values', and `multiple-value-bind'. (slime-beginning-of-tlf): When we know the current paren depth, use it to jump directly over all parens rather than jumping to each open paren in turn. (slime-compute-region-for-font-lock): Use it. 2009-05-15 Tobias C. Rittweiler * slime-fontifying-fu.el (slime-search-suppressed-forms-internal): Use `slime-reader-conditionals-regexp'. (slime-search-directly-preceding-reader-conditional): Catch scan errors due to improper feature expressions. 2009-05-15 Tobias C. Rittweiler * slime-repl.el (with-canonicalized-slime-repl-buffer): XEmacs chokes on symbol-names with an initial dot. Patch by François-René Rideau. 2009-05-15 Tobias C. Rittweiler Moved font-lock-magic from slime.el to slime-fontifying-fu.el. N.B. slime-fontifying-fu is automatically loaded by slime-fancy. I.e. if you use slime-fancy, font-lock-magic will be enabled for just like before. * slime-fontifying-fu.el (slime-highlight-suppressed-forms), (slime-reader-conditional-face), (slime-search-suppressed-forms-internal), (slime-search-suppressed-forms), (slime-search-directly-preceding-reader-conditional), (slime-extend-region-for-font-lock), (slime-compute-region-for-font-lock), (slime-activate-font-lock-magic): Moved here. 2009-05-14 Tobias C. Rittweiler Optionally sort slots displayed for STANDARD-OBJECTS not alphabetically, but by inheritance. That is group the slots according to the class they're direct slots of. * swank-fancy-inspector.lisp ([struct] inspector-checklist): New slot `count'. (make-checklist-button): Adapted accordingly. (reinitialize-checklist): New. (box, ref, (setf ref)): New. (all-slots-for-inspector): Add button to group slots by inheritance rather than alphabetically. Adapted accordingly. (list-all-slots-by-inheritance): New. Does the bulk work. (make-slot-listing): Factored out from `all-slots-for-inspector'. (slot-home-class-using-class): New helper. (stable-sort-by-inheritance): Also new. 2009-05-08 Tobias C. Rittweiler The inspector page for standard-objects does not append "[set value]" and "[make unbound]" buttons after each entry anymore. Instead we use a checklist. * swank-fancy-inspector.lisp ([struct] inspector-checklist): New. (make-checklist-button): New. (do-checklist): New. (slot-value-for-inspector): Previously `inspect-slot-for-emacs'. (query-and-set-slot): New. (all-slots-for-inspector): Adapted for changes described above. 2009-05-02 Tobias C. Rittweiler * slime-autodoc.el (slime-fontify-string): Deactivate autodoc itself in the temporary help buffer. And deactivate slime's font-lock magic. 2009-05-01 Tobias C. Rittweiler * slime-parse.el (slime-parse-extended-operator/check-type): Forgot to delete debugging code. 2009-04-30 Tobias C. Rittweiler * slime-parse.el (slime-parse-extended-operator/check-type): New. (slime-parse-extended-operator/the): New. (slime-extended-operator-name-parser-alist): Add entries for CHECK-TYPE, TYPEP, and THE. ([test] enclosing-form-specs.1): Add tests for the new entries. Adapted from patch by Stas Boukarev. 2009-04-30 Tobias C. Rittweiler * slime-parse.el (slime-parse-extended-operator/proclaim): New. (slime-extended-oprator-name-parser-alist): Adapt the entry for PROCLAIM. Adapted from patch by Stas Boukarev. 2009-04-21 Tobias C. Rittweiler * slime-indentantion-fu.el (slime-update-local-indentation): Save original global indentation spec in another symbol because we cannot reuse 'slime-indent. Make sure that later redefinition of global macros (which may affect the indentation spec) is taken into consideration. 2009-04-03 Tobias C. Rittweiler * slime-repl.el (slime-inspector-mode-map): Add binding for M-RET. (slime-inspector-copy-down-to-repl): Moved here from slime.el. 2009-03-27 Tobias C. Rittweiler * slime-indentantion-fu.el (slime-indent-fu): Correctly deal with MACROLETs that define macros without &BODY in their arglists. ([test] local-indentation.1): Updated to test against this case. 2009-03-25 Helmut Eller * slime-repl.el (slime-repl-event-hook-function): Handle :read-abort. Reported by Stas Boukarev. (slime-repl-remove-hooks): New function. 2009-03-22 Tobias C. Rittweiler * swank-arglists.lisp ([method] arglist-dispatch): Forgot to remove debugging code when adding extended arglist display for DEFINE-COMPILER-MACRO. Reported by Bart Botta. 2009-03-09 Tobias C. Rittweiler * slime-autodoc.el (slime-compute-autodoc-rpc-form): New. Extracted from `slime-autodoc-thing-at-point'. (slime-compute-autodoc-internal): New. Extracted from `slime-compute-autodoc'. (slime-compute-autodoc): Explicitly save match data. (slime-autodoc-hook): New. Run everytime autodoc is computed. * slime-enclosing-context.el (slime-enclosing-bound-macros): New. (slime-find-bound-macros): New, too. * slime-indentation-fu.el, swank-indentation-fu.lisp: New contrib to properly indent &BODY arguments of local macro definitions. Suggested by Lorenz Moesenlechner. 2009-03-09 Helmut Eller * swank-kawa.scm: Use foo: style keywords because :foo is now a symbol. (copy-stack): Use null to mark absent src-loc information. 2009-03-08 Tobias C. Rittweiler * slime-repl.el ([test] interrupt-in-blocking-read): Wrap `with-canonicalized-slime-repl-buffer' around the whole test. Otherwise the changed repl prompt doesn't extend to the actual `slime-test-expect'. 2009-03-08 Tobias C. Rittweiler * swank-fancy-inspector.lisp (make-visit-file-thunk): New helper; extracted from emacs-inspect [file-stream]. ([method] emacs-inspect file-stream): Use it. ([method] emacs-inspect stream-error): Use it, too. 2009-03-04 Tobias C. Rittweiler * slime-asdf.el: Really do the commit from entry 2009-02-28. 2009-03-04 Tobias C. Rittweiler * slime-repl.el (slime-check-buffer-contents): Fix typo. (with-canonicalized-slime-repl-buffer): Refactored from test cases. A lot of test cases implemented this somewhat wrongly. Making them fail when not called from the SWANK package. ([test] repl-test): Use above. ([test] repl-return): Ditto. ([test] repl-read): Ditto. ([test] repl-read-lines): Ditto. ([test] repl-type-ahead): Ditto. ([test] interrupt-in-blocking-read): Ditto. 2009-02-28 Stas Boukarev * slime-asdf.el (slime-read-system-name): Display default value as part of the prompt, instead of inserting it as an input candidate. (slime-find-asd): Do not call `file-name-sans-extension' twice. 2009-02-28 Stas Boukarev * swank-arglists.lisp (variable-desc-for-echo-area): Print values of special variables with ~S, not with ~A. 2009-02-27 Tobias C. Rittweiler * swank-arglists.lisp (read-conversatively-for-autodoc): Make it understand sharpquote forms, so contextual autodoc will work for `(apply #'foo ...)'. * slime-autodoc.el ([test] autodoc.1): New test case, for the above and more. (slime-check-autodoc-at-point): New helper. 2009-02-27 Tobias C. Rittweiler * slime-parse.el (slime-check-enclosing-form-specs): Use `slime-test-expect' rather than `slime-check'. ([test] enclosing-form-specs.1): Add two more cases. 2009-02-27 Tobias C. Rittweiler * bridge.el: Replace old-style backquoting. * slime-presentations.el (slime-presentation-sldb-insert-frame-variable-value): Fix typo. Patch by Stelian Ionescu. 2009-02-27 Tobias C. Rittweiler * slime-autodoc.el, slime-c-p-c.el, slime-enclosing-context.el * slime-package-fu.el, slime-parse.el, slime-presentations.el * slime-xref-browser: Rename `slime-symbol-name-at-point' to `slime-symbol-at-point' 2009-02-27 Tobias C. Rittweiler * slime-parse.el (slime-make-extended-operator-parser/look-ahead): If there's no closing paren (no paredit!) we cannot determine the end of the list. Check for this. ([test] enclosing-form-specs.1): Extend test case. (slime-check-enclosing-form-specs): New helper. 2009-02-26 Tobias C. Rittweiler * swank-fancy-inspector.lisp (emacs-inspect (stream-error)): Do not run FILE-POSITION on a closed stream. 2009-02-26 Tobias C. Rittweiler * slime-parse.el (slime-parse-symbol-name-at-point): Removed. Superfluous due to recent changes on `slime-symbol-name-at-point'. (slime-parse-sexp-at-point): Simplified; use `slime-sexp-at-point'. (slime-inside-string-p, slime-beginning-of-string): Use `slime-current-parser-state'. ([test] enclosing-form-specs.1): Add some simple cases. * slime-enclosing-context.el (slime-find-bound-names): Replace `slime-parse-symbol-name-at-point' with `slime-symbol-name-at-point' (slime-find-bound-functions): No need for `slime-ensure-list' anymore. ([test] enclosing-context.1): Adapted due to the changes. 2009-02-25 Luís Oliveira * slime-compiler-notes-tree.el: Fix typo in the `provide' form. 2009-02-21 Tobias C. Rittweiler * slime-package-fu.el: Removed misplaced comma, deleted some end-of-line whitespace, added newline to the end of the file. Patch by Robert Brown. 2009-02-17 Helmut Eller * slime-repl.el (slime-repl-connected-hook-function): Bind slime-current-thread to avoid problems with killed threads. 2009-02-14 Helmut Eller * swank.rb: New file. 2009-02-02 Tobias C. Rittweiler * swank-arglists.lisp (arglist-for-echo-area): Bleh, can't use WITH-AVAILABLE-ARGLIST because we're supposed to return NIL, not :NOT-AVAILABLE, in the failure case. 2009-02-02 Tobias C. Rittweiler * slime-parse.el ([test] enclosing-form-specs.1): Fix test case. 2009-02-01 Tobias C. Rittweiler Add DEFMETHOD-style extended arglist display for DEFINE-COMPILER-MACRO. (defun foo (x y &key k1 k2)) (define-compiler-macro foo |) * swank-arglists.lisp ([method] arglist-dispatch): Specialize on (EQL 'DEFINE-COMPILER-MACRO). * slime-parse.el (slime-extended-operator-name-parser-alist): Add entry for DEFINE-COMPILER-MACRO. (slime-make-extended-operator-parser/look-ahead): Collect up /at most/ N sexps. Previously `(defmethod |)' would lead to a form spec of ``("defmethod" ("defmethod"))''. ([test] enclosing-form-specs.1): Test for this. 2009-02-01 Tobias C. Rittweiler * swank-arglists.lisp (parse-form-spec): Moved most part of its docstring into a comment. (arglist-for-echo-area): Some minor code reorganization. The autodoc stuff in general could need some fair bit of refactoring. 2009-01-27 Tobias C. Rittweiler * slime-repl.el ([shortcut] quit): Quit the connection before killing the REPL buffer; otherwise the default connection is selected rather than the connection of the REPL buffer. Reported by Stas Boukarev. 2009-01-23 Tobias C. Rittweiler * slime-repl.el (slime-repl-mode-map): Use the key bindings from `slime-editing-keys'. 2009-01-18 Tobias C. Rittweiler Local M-. and local arglist display didn't work for (flet ((foo () ...)) (some-form) |) * slime-enclosing-context.el (slime-enclosing-bound-names), (slime-enclosing-bound-functions): Correctly test for when point is in scope of an FLET/LET/etc. ([test] enclosing-context.1): Test for this. 2009-01-16 David Reitter * slime-repl.el (slime-repl-clear-buffer): Call recenter with t as argument (to avoid erasing the entire frame). 2009-01-10 Tobias C. Rittweiler * swank-fancy-inspector.lisp (emacs-inspect [package]): Also display link to show all inherited symbols of a package. 2009-01-07 Helmut Eller * slime-repl.el (slime-mode-map): Bind C-c~ not ~. Reported by James Wright. (slime-repl-mode-map): Bind M-TAB. Remove C-c C-k: compiling the REPL buffer doesn't work anyway. Remove C-cC-b, C-c:, C-cE, C-cC-d, C-cC-w, C-M-x, C-cC-t, C-cC-l: those are already bound in slime-parent-map. 2009-01-04 Helmut Eller * slime-repl.el, slime-mrepl.el: Byte-compile the output functions. 2009-01-02 Helmut Eller * slime-mrepl.el: New file. 2009-01-01 Tobias C. Rittweiler * slime-autodoc.el: Autodoc is now implemented on top of ElDoc. (Suggested by Madhu.) 2008-12-31 Tobias C. Rittweiler * swank-arglists.lisp (format-arglist-for-echo-area): Catch errors and die gracefully. 2008-12-31 Tobias C. Rittweiler * swank-sbcl-exts.lisp: Wrap file in a big #+sbcl (PROGN ...), so users can use the `slime-sbcl-exts' contrib in their .emacs nevermind what implementation they actually use. (Reported by Stas Boukarev) 2008-12-31 Helmut Eller * inferior-slime.el (inferior-slime-change-directory): New function. (inferior-slime-init): Hook it in. 2008-12-30 Tobias C. Rittweiler * slime-repl.lisp (slime-repl-set-package): Set `slime-buffer-package' to the new package name. Otherwise, a ,!p repl command is not properly taken into account resulting in misbehaviour of completion and arglist display. 2008-12-30 Tobias C. Rittweiler * slime-sbcl-exts.el, swank-sbcl-exts.lisp: New contrib. This is the place for SBCL specific extensions and customizations that can't go into SBCL's swank-backend. At the moment, it contains code to display arglist of instructions, as in `(sb-assem:inst mov |'. 2008-12-30 Tobias C. Rittweiler * swank-arglists.lisp (defstruct arglist-dummy): Remove :PRINT-OBJECT which made an arglist dummy look like a normal symbol. This is just confusing. If an ARGLIST-DUMMY appears in an arglist, the relevant code should deal with this explicitly. (with-availability): Renamed to WITH-AVAILABLE-ARGLIST. * slime-parse.el (slime-parse-extended-operator-name): Pass the fully qualified symbol (not just the name) to the parser function. (slime-make-extended-operator-parser/look-ahead): Do not take the operator name as first argument if point is located at the operator name. 2008-12-27 Helmut Eller * slime-repl.el (slime-repl-event-hook-function): Handle :new-package events here. (slime-output-buffer): Initialize slime-buffer-package. (slime-repl-connected-hook-function): Initialize slime-lisp-package. 2008-12-27 Helmut Eller * slime-repl.el (slime-repl-quit): Kill the repl buffer before quitting. Reported by Volkan YAZICI. 2008-12-27 Helmut Eller * slime-asdf.el: Require slime-repl. 2008-12-26 Helmut Eller * slime-repl.el (slime-repl-connected-hook-function): Create a repl thread before creating a repl buffer. 2008-12-25 Helmut Eller * inferior-slime.el (inferior-slime-switch-to-repl-buffer): New function. (inferior-slime-init): Bind it to a selector key. 2008-12-23 Helmut Eller * slime-repl.el (slime-repl-connected-hook-function): Create a repl at startup. Well, initialize stream redirection. 2008-12-23 Helmut Eller Move i/o related event handlers to slime-repl.el. * slime-repl.el (slime-repl-event-hook-function): Handle some events here. 2008-12-23 Helmut Eller * slime-editing-commands.el (slime-editing-commands-init): Bind slime-close-all-parens-in-sexp. 2008-12-23 Helmut Eller * inferior-slime.el (inferior-slime-hook-function): New function. (inferior-slime-init): Automatically enable it in the *inferior-lisp* buffer. 2008-12-23 Helmut Eller * slime-fancy.el: Add slime-repl. 2008-12-09 Helmut Eller * swank-kawa.scm (mif): Avoid assignments because that triggers a bug/regression in the compiler. (getpid): Don't use the -n with echo. It's not standard and also not needed here. 2008-11-29 Tobias C. Rittweiler * slime-package-fu.el (slime-goto-package-source-definition): `(slime-pop-to-location loc 'excursion)' no longer exists; use `(slime-goto-source-location loc)' instead. 2008-11-22 Geoff Wozniak * swank-c-p-c.lisp (parse-completion-arguments): Change the package identifier from the string "KEYWORD" to the form (symbol-name :keyword) for ACL's "modern" mode. 2008-10-31 Nikodemus Siivola * swank-presentation-streams.liso (slime-stream-p): delete references to SB-IMPL::INDENTING-STREAM, which is unused in SBCL and liable to go away. 2008-10-30 Ivan Shvedunov * swank-listener-hooks.lisp (%listener-eval): Return nil. 2008-10-23 Helmut Eller * swank-jolt.k: New backend. 2008-10-23 Helmut Eller * swank-asdf.lisp (operate-on-system-for-emacs): Always T to collect-notes. Reported by Mark Evenson. 2008-10-21 Helmut Eller * slime-editing-commands.el (slime-end-of-defun): Use 'major-mode instead of 'major. Reported by S.P.Tseng. 2008-10-19 Helmut Eller * swank-mit-scheme.scm (swank:frame-locals-and-catch-tags) * swank-kawa.scm (dispatch-events) * swank-goo.goo (frame-locals-and-catch-tags): Update backends for the new swank:frame-locals-and-catch-tags. 2008-10-16 Helmut Eller * swank-kawa.scm (swank-require): Add a dummy definition to avoid errors at startup. 2008-10-11 Nikodemus Siivola * slime-scratch.el (slime-scratch-file): New variable. (slime-scratch-buffer): If *slime-scratch* does not exist and slime-scratch-file is set, use 'find-file' instead of `get-buffer-create' to obtain the buffer. 2008-10-11 Helmut Eller * swank-kawa.scm (compile-file-for-emacs, wrap-compilation) (compile-string-for-emacs): Return a :compilation-result as expected by Emacs. 2008-09-13 Tobias C. Rittweiler * slime-parse.el (slime-has-symbol-syntax-p): New. (slime-parse-symbol-name-at-point): New; works on top of `slime-parse-sexp-at-point'. (slime-enclosing-form-specs): Use it. * slime-enclosing-context.el (slime-find-bound-names): Use `slime-parse-symbol-name-at-point'. (slime-find-bound-functions): Ditto. (def-slime-test enclosing-context.1): New test case. Thanks to John Pallister for reporting this bug. 2008-09-11 Tobias C. Rittweiler * swank-asdf.lisp (operate-on-system-for-emacs): Adapted to recent changes wrt. swank-compilation-unit. 2008-09-07 Tobias C. Rittweiler * slime-autodoc.el (slime-make-autodoc-swank-form): Do not highlight operator in local arglist display. 2008-09-07 Tobias C. Rittweiler Slime-autodoc now also displays arglists of local functions. * swank-arglists.lisp (defslimefun format-arglist-for-echo-area): New RPC. * slime-autodoc.el (slime-make-autodoc-cache-key): New; extracted from slime-autodoc-thing-at-point. (slime-make-autodoc-swank-form): New; partially extracted from slime-autodoc-thing-at-point. Use `slime-autodoc-local-arglist'. (slime-autodoc-local-arglist): New function. (slime-autodoc-thing-at-point): Use the two new functions. 2008-09-07 Tobias C. Rittweiler * slime-enclosing-context.el: New utility contrib on top of `slime-parse' to extract some context around point, like bound variables or bound functions. * slime-mdot-fu.el: Move context stuff out to the new contrib. 2008-08-27 Helmut Eller * swank-arglists.lisp (variable-desc-for-echo-area): Limit the length to one line to avoid (some) problems with big or circular values. Reported by Stas Boukarev. 2008-08-22 Stelian Ionescu * swank-listener-hooks.lisp: Add missing IN-PACKAGE. 2008-08-20 Tobias C. Rittweiler * slime-fontifying-fu.el: New contrib; fontify with-foo and do-foo like standard macros. * slime-fancy.el: Add slime-fontifying-fu. 2008-08-20 Luís Oliveira * contrib/slime-indentation.el: fix indentation of IF forms. 2008-08-18 Ariel Badichi * slime-fuzzy.el: Rename `add-local-hook' to `slime-add-local-hook'. * slime-presentations.el: Ditto. 2008-08-12 Helmut Eller * slime-clipboard.el (slime-clipboard-insert-ref): Set read-nonsticky to t to work better with kill/yank. * swank-clipboard.lisp (:swank-clipboard): List exports to avoid compiler warnings. 2008-08-12 Helmut Eller Add a simple object clipboard. * swank-clipboard.lisp: New file. * slime-clipboard.el: New file. 2008-08-07 Tobias C. Rittweiler * slime-fancy.el: Add slime-mdot-fu and slime-package-fu. 2008-08-07 Tobias C. Rittweiler * slime-mdot-fu.el: Works for LET bindings now also. (def-slime-test find-local-definitions.1): New test case. 2008-08-05 Michael Weber * slime-typeout-frame.el (slime-typeout-message-aux): prevent typeout messages from scribbling into any buffer which happens to be in the typeout window (slime-typeout-buffer): new function; changed buffer name to "*SLIME Typeout*" (slime-make-typeout-frame): use it (slime-ensure-typeout-frame): ensure typeout buffer is visible 2008-08-04 Adam Bozanich * slime-asdf.el: Load swank-asdf. This should avoid the rude disconnect if asdf wasn't loaded. 2008-08-03 Tobias C. Rittweiler * slime-presentations.el (slime-presentation-around-or-before-point): Guard against the case being used at the start of a buffer. 2008-07-31 Tobias C. Rittweiler * slime-mdot-fu.el: New contrib. Makes M-. work on local definitions. 2008-07-31 Tobias C. Rittweiler * slime-package-fu.el (slime-find-package-definition-regexp): Use new constructor `make-slime-file-location'. (slime-frob-defpackage-form, slime-export-symbol-at-point): Now always display a message regarding success of the operation. (slime-package-fu-init-undo-stack, slime-package-fu-unload): New. 2008-07-19 Tobias C. Rittweiler * slime-package-fu.el, swank-package-fu.lisp: New contrib to automatically add symbols to the relevant DEFPACKAGE forms. You can use `C-c x' to export the symbol at point, and `C-u C-c x' to unexport it. 2008-07-19 Tobias C. Rittweiler * slime-asdf.el (slime-oos): Use `slime-repl-shortcut-async'. 2008-07-16 Tobias C. Rittweiler * swank-asdf.lisp (operate-on-system-for-emacs): Wrapped in WITH-SWANK-COMPILATION-UNIT. 2008-06-07 Tobias C. Rittweiler * slime-parse.el (slime-cl-symbol-name), (slime-cl-symbol-package), (slime-qualify-cl-symbol-name): Moved back to `slime.el' as they're still used there. 2008-04-17 Gábor Melis * swank-fancy-inspector.lisp (inspect-slot-for-emacs): slime-read-object has been gone for a long time, replaced with slime-read-from-minibuffer. 2008-04-15 Marco Baringer * slime-indentation.el (cl-indent::line-number): new function. (cl-indent:indent-cond): Custom indentation method for cl:cond. (cl-indent-body-introducing-loop-macro-keyword) (cl-indent-indented-loop-macro-keyword): more loop keywords. (cl-indent-loop-advance-past-keyword-on-line): deal with comments after loop keywords. (#'define-cl-indent): Fix indentation of handler-case; give cond it's custom indentation method; change indentation of defclass; add methods for do-all-symbols, do-symbols, do-external-symbols, restart-case, with-accessors, with-compilation-unit, with-hash-table-iterator, with-output-to-string, with-input-from-string, with-open-file, with-open-stream, with-package-iterator, with-simple-restart, with-slots. 2008-04-14 Marco Baringer * swank-arglists.lisp (decode-arglist): Arglists can be dotted lists. 2008-04-06 Tobias C. Rittweiler * slime-presentations.lisp: (slime-maybe-M-.-presentation-at-point): Renamed to `slime-edit-presentation'. Now makes sure to decline if user gave a name explicitly. 2008-03-24 Helmut Eller * swank-kawa.scm: Save stacktraces with locals on throw events. This is quite costly but makes debugging easier. 2008-03-14 Tobias C. Rittweiler * swank-fancy-inspector.lisp (add-slots-for-inspector): Remove IGNORE declaration of non-existing argument. 2008-03-14 Tobias C. Rittweiler * swank-fuzzy.lisp (fuzzy-convert-matching-for-emacs): Return a string representation of the classifications rather than the classifications themselves. (Notice this propagates up to (and consequently changes the return value of) the RPC function FUZZY-COMPLETIONS. (incompatible api change.) Rationale: The number of supported classification can be changed without having to adapt its display at the client. * slime-fuzzy.lisp (slime-fuzzy-insert-completion-choice): (slime-fuzzy-fill-completions-buffer): Adapted to API change. 2008-03-14 Tobias C. Rittweiler * swank-fancy-inspector.lisp (make-symbols-listing :classification): Add support for typespec and constant classification; don't silently ignore symbols that can't be usefully classified, but group them under "MISC". 2008-03-14 Helmut Eller Move filename translation code to contrib. * slime-tramp.el (slime-find-filename-translators) (slime-filename-translations): Move from slime.el. (slime-tramp-from-lisp-filename, slime-tramp-to-lisp-filename): New functions. 2008-03-08 Helmut Eller Don't blindly override the inspect method for functions. * swank-fancy-inspector.lisp (emacs-inspect function): Define this method only if the backend hasn't defined one. (inspect-function): New function. 2008-03-02 Tobias C. Rittweiler M-. now works on presentations. Additionally, a Find Definition entry is presented in the menu appearing on right clicking on a presentation. * slime-presentations.lisp (slime-M-.-presentation): New function. (slime-M-.-presentation-at-mouse): New function. (slime-M-.-presentation-at-point): New function. (slime-maybe-M-.-presentation-at-point): New function. (slime-menu-choices-for-presentation): New entry "Find Definition". (slime-presentation-easy-menu): New entry "Find Definition". (slime-presentations-init): Hook into `slime-edit-definition-hooks'. 2008-03-02 Helmut Eller * swank-mit-scheme.scm: New file. 2008-02-21 Tobias C. Rittweiler Having the `slime-presentations' contrib enabled, (princ 10) resulted in "1010" rather than "10\n10". (This also caused a regression in the `repl-test' test case.) * swank-presentations.lisp (present-repl-results): Emit fresh-line as the original SEND-REPL-RESULTS-TO-EMACS does. 2008-02-18 Helmut Eller Update Kawa backend to the changed inspector protocol. * swank-kawa.scm (inspect-object): Return a list (content len start end). (): New field: content. (content-range, subseq): New functions. 2008-02-15 Matthias Koeppe * slime-presentations.el (slime-previous-presentation) (slime-next-presentation): Accept a standard prefix argument. 2008-02-13 Helmut Eller * slime-c-p-c.el (slime-c-p-c-init): Use slime-require instead of a connected-hook. 2008-02-13 Helmut Eller Track tree-widget change: :dynarg is now called :expander. * slime-xref-browser.el (slime-expand-class-node) (slime-browse-classes, slime-expand-xrefs, slime-browse-xrefs): :dynargs is obsolete, it is now called :expander. 2008-02-10 Helmut Eller Fix some bugs introduced by the recent reorganization. * swank-fancy-inspector.lisp (emacs-inspect pathname): Fix it again. * slime-fancy-inspector.el: Use slime-require. * slime-fancy.el: slime-fancy-inspector-init no longer exists, so don't call it. Once loaded, it's also no longer possible to turn the fancy inspector off. 2008-02-04 Marco Baringer * swank-presentation-streams.lisp (presenting-object-1): Add declare special *record-repl-results* to silence compiler warnings. * swank-arglists.lisp (arglist-dispatch): Specialize operator-type so openmcl doesn't warn about unused arguments. (arglist-dispatch): add declare ignore form. 2008-02-04 Helmut Eller Move some functions to swank-arglist.lisp. * swank-arglist.lisp (length=, ensure-list, recursively-empty-p) (maybecall, exactly-one-p, read-softly-from-string) (unintern-in-home-package, valid-function-name-p): Moved from swank.lisp. to contrib/swank-arglist.lisp. 2008-02-03 Marco Baringer * swank-motd.lisp, slime-motd.el: Message Of The Day printing for slime. * slime-indentation.el: Integrate cl-indent.el into slime's contrib infrastructure. Fix bug in &rest. * swank-indentation.lisp: Allow an application runnig under slime to update emacs' indentation notes. 2008-01-27 Helmut Eller Make autodoc use the correct width of the typeout-window. * slime-autodoc.el (slime-autodoc-dimensions-function): New variable. (slime-autodoc-message-dimensions): Use it. * slime-typeout-frame.el (slime-typeout-autodoc-dimensions): New function. (slime-typeout-frame-init): Use it. 2008-01-27 Helmut Eller Use slime-require instead of a connected-hook. * slime-autodoc.el (slime-autodoc-on-connect): Deleted. 2008-01-20 Matthias Koeppe Hook presentations into debugger and inspector, restoring features that were removed on 2007-08-27. * slime-presentations.el (slime-presentation-add-easy-menu): Install presentation menu also in the debugger and inspector. (slime-presentation-inspector-insert-ispec): New. (slime-presentation-sldb-insert-frame-variable-value): New. (slime-presentations-init): Install these functions as slime-inspector-insert-ispec-function and sldb-insert-frame-variable-value-function. 2008-01-19 Helmut Eller * swank-goo.goo: New file. * swank-kawa.scm: New file. 2008-01-11 Stelian Ionescu * slime-presentations.el (slime-copy-or-inspect-presentation-at-mouse): Call slime-copy-presentation-at-mouse-to-repl rather than slime-copy-presentation-at-mouse. 2008-01-10 Tobias C. Rittweiler * slime-parse.el (slime-make-form-spec-from-string): Correctly handle quoted things and other non-proper "(...)" forms. * swank-arglist.lisp (read-form-spec): Added assertion against receiving junk form specs from Emacs. 2008-01-10 Tobias C. Rittweiler * slime-editing-commands.el (slime-close-all-parens-in-sexp): Use new portability function `slime-delete-and-extract-region'. 2008-01-10 Tobias C. Rittweiler * swank-parse.lisp (slime-incomplete-form-at-point): Hopefully better fix than before. 2008-01-10 Matthias Koeppe Add keyboard commands (starting with C-c C-v) and a top-level menu for presentation-related commands. Add a command (C-c C-v M-o) to forget all objects associated with presentations, without clearing the REPL buffer. * slime-presentations.el (slime-presentation-around-or-before-point-or-error): New function. (slime-inspect-presentation): New function, factored out from slime-inspect-presentation-at-mouse. (slime-inspect-presentation-at-mouse): Use it here. (slime-inspect-presentation-at-point): New command. (slime-copy-presentation-to-repl): New function, factored out from slime-copy-presentation-at-mouse. (slime-copy-presentation-at-mouse-to-repl): Renamed from slime-copy-presentation-at-mouse; use the new function slime-copy-presentation-to-repl. (slime-copy-presentation-at-point-to-repl): New command. (slime-copy-presentation-to-kill-ring): New function, factored out from slime-copy-presentation-at-mouse-to-kill-ring. (slime-copy-presentation-at-point-to-kill-ring): New command. (slime-describe-presentation): New function, factored out from slime-describe-presentation-at-mouse. (slime-describe-presentation-at-mouse): Use it here. (slime-describe-presentation-at-point): New command. (slime-pretty-print-presentation): New function, factored out from slime-pretty-print-presentation-at-mouse. (slime-pretty-print-presentation-at-mouse): Use it here. (slime-pretty-print-presentation-at-point): New command. (slime-mark-presentation): New command. (slime-previous-presentation, slime-next-presentation): New commands. (slime-presentation-command-map, slime-presentation-bindings): New variables. (slime-presentation-init-keymaps): New function. (slime-presentation-around-or-before-point-p): New function. (slime-presentation-easy-menu): New variable. (slime-presentation-add-easy-menu): New function. (slime-clear-presentations): Make interactive, remove presentation markup from all presentations in the REPL buffer. (slime-presentations-init): Call slime-presentation-init-keymaps and slime-presentation-add-easy-menu. 2008-01-10 Tobias C. Rittweiler * swank-parse.lisp (slime-incomplete-form-at-point): Take the arglist index the user's point is located at correctly into account. Previously `C-c C-s' on `(defun |foo' would have inserted `args body...)', now it inserts `name args body...)' 2008-01-10 Tobias C. Rittweiler * swank-arglists.lisp (read-form-spec): Changed "cons" clause to "list" clause in etypecase. Fix for error on arglist display on `(declare (ftype (|)))', | being point. 2008-01-10 Tobias C. Rittweiler * slime-fuzzy.el (slime-fuzzy-completion-time-limit-in-msec): Update docstring: Its value isn't rounded to nearest second, but is really interpreted as msecs. * swank-fuzzy.el: Updated some comments. (fuzzy-generate-matchings): Sort package matchings before traversal, such that they're traversed in the order of their score. (Important when time limit exhausts during traversal.) 2008-01-09 Matthias Koeppe Restore support for Scheme programs that was removed from core SLIME on 2007-09-19, as a "slime-scheme" contrib. * slime-scheme.el: New file. 2007-12-30 Tobias C. Rittweiler * swank-arglists.lisp: Fix for `(cerror "FOO" 'type-error ...)' (*arglist-dummy*): Removed. (arglist-dummy): New structure. Wrapper around whatever could not be reliably read. The clue is that its printing function does only print the object this structure contains. (read-conversatively-for-autodoc): Return such a structure if conversative reading fails. 2007-11-27 Tobias C. Rittweiler * swank-arglists.lisp (arglist-dispatch 'defmethod): Use VALID-FUNCTION-NAME-P. Fixes error on certain `(defmethod (setf ...))' forms. 2007-11-27 Tobias C. Rittweiler * swank-arglists.lisp (print-arglist): Print initforms in &optional and &key lambda list specifiers as if by PRIN1 instead of PRINC. Reported by Michael Weber. 2007-11-24 Helmut Eller * slime-fuzzy.el: Use slime-require instead of a connected-hook. 2007-11-20 Helmut Eller * swank-fancy-inspector.lisp (inspect-for-emacs function t): Don't specialize the second argument, so that backend methods take precedence. Reported by Maciej Katafiasz. 2007-10-24 Tobias C. Rittweiler * swank-arglist.lisp (decode-arglist): Fix incompatibility with ACL's modern reader mode. Thanks to Andreas Fuchs for stumbling over this. 2007-10-22 Tobias C. Rittweiler * swank-arglist.lisp (read-softly): Renamed to READ-SOFTLY-FROM-STRING and moved to `swank.lisp'. (unintern-in-home-package): Moved to `swank.lisp'. 2007-10-01 Tobias C. Rittweiler * slime-autdoc.el (slime-autodoc-message-ok-p): Don't display an arglist when the minibuffer is active. 2007-10-01 Tobias C. Rittweiler * slime-typeout-frame.el: Messages in the typeout frame were too easily overwritten by `slime-autodoc'. Fix that. Reported by Geoff Wozniak. (slime-typeout-message-aux): Split out from `slime-typeout-message'. (slime-typeout-message): Wrapper around it. Additionally disable the autodoc timer temporarily. 2007-09-30 Geoff Wozniak * slime-typeout-frame.el (slime-typeout-frame-init): Fix quoted FUNCTION forms in literal. 2007-09-28 Tobias C. Rittweiler * README: Updated. * slime-fancy.el: `slime-highlighting-edits' is not enabled by default anymore, as its functionality is controversial, and it's easier to explicitly enable it than to disable it once it got globally activated. Better to be conservative. * slime-fancy.el: Not only load, but also enable `slime-scratch'. 2007-09-21 Helmut Eller * slime-asdf.el (slime-asdf-init, slime-asdf-unload): Fix typos. Reported by Ariel Badichi. 2007-09-20 Helmut Eller Separate loading from initialization for many contribs. * slime-asdf.el * slime-autodoc.el * slime-banner.el * slime-c-p-c.el * slime-editing-commands.el * slime-fancy-inspector.el * slime-fuzzy.el * slime-highlight-edits.el * slime-presentations.el * slime-references.el * slime-scratch.el * slime-typeout-frame.el * swank-fancy-inspector.lisp * slime-fancy.el: As an exception, call the respective init function when loading. 2007-09-19 Helmut Eller * slime-c-p-c.el (slime-complete-symbol*-fancy): Move defcustom from slime.el to contrib/slime-c-p-c.el. 2007-09-16 Tobias C. Rittweiler * swank-fuzzy.lisp: Fix regression that would not allow to fuzzy complete on inputs without package qualifier like "app". Reported by David J. Neu. (%make-duplicate-symbols-filter): Return complement. (fuzzy-find-matching-symbols): Treat passed filter as an acceptor predicate, not as a rejector. 2007-09-15 Helmut Eller Add the necessary hooks when loading some contribs, so that those contribs can be easily loaded with slime-setup. * slime-highlight-edits.el (slime-highlight-edits-mode-on): New function. Add this to slime-mode-hook by default. * slime-autodoc.el (slime-use-autodoc-mode): Change default to t. 2007-09-15 Ariel Badichi * swank-fancy-inspector.lisp (inspect-for-emacs package): When inspecting a package, the links in the use list and the used-by list lead to inspecting package names, rather than the packages themselves. Fix that. 2007-09-15 Tobias C. Rittweiler * slime-parse.el: Fix extended arglist display on misbalanced expressions like `(defun foo | ... (defun bar () 'bar)' Reported by Ariel Badichi. (slime-inside-string-p): Use `beginning-of-defun' directly than relying on `slime-region-for-defun-at-point' (as this one uses `end-of-defun' which signals an error on misbalanced expressions.) 2007-09-15 Tobias C. Rittweiler * swank-fuzzy.lisp: Code reorganization and cleanup; making it compute less and couple of other minor issues fixed on the way. Thanks to Stelian Ionescu for testing and providing feedback! (defstruct fuzzy-matching): New `package-name' slot. (make-fuzzy-matching): Updated for new slot. (format-completion-result): Renamed to `fuzzy-format-matching'. (%fuzzy-extract-matching-info): Helper for `fuzzy-format-matching'. (fuzzy-completion-set): Convert the matchings after they got truncated to the passed completion-set limit from Emacs. I.e. `slime-fuzzy-completion-limit' This means a huge computational reduction. (fuzzy-create-completion-set): Renamed to `fuzzy-generate-matchings'. (fuzzy-generate-matchings): Returns the fuzzy matchings themselves, do not yet convert them for Emacs. Do not perform two sorts on the generated matchings (first alphabetically, then per score), but just one with an appropriate predicate that sorts per score, unless matchings are equal, then sort alphabetically. Prune matchings with symbols which are found in a differenta package than their home package when the home package is among the matched packages. Try to take the time needed to sort the generated matchings into account for the time-limit. (%guess-sort-duration): Helper. Tries to guess how long the sort will take. (%make-duplicate-symbols-filter): Helper. Used for pruning of matchings. (fuzzy-matching-greaterp): New testing predicate for sorting. (fuzzy-find-matching-symbols): Now takes a :filter keyarg; only considers symbols that pass through the filter. (fuzzy-find-matching-packages): Do not return matchings for all nicknames of package, but just the one that matches best. 2007-09-11 Tobias C. Rittweiler * slime-editing-commands.el: Automatically bind the editing commands when this module is required. (Previously, one had to enable them explicitly, but this is inconsistent to, for instance, the `slime-c-p-c' module which also sets up its bindings automatically.) (slime-bind-editing-commands): Renamed to `slime-editing-commands-init'. (slime-editing-commands-init): Evaluated at toplevel. 2007-09-11 Tobias C. Rittweiler * slime-parse.el (slime-enclosing-form-specs): Now also works even when point is inside a string. (slime-inside-string-p): New function. (slime-beginning-of-string): New function. 2007-09-11 Tobias C. Rittweiler * swank-arglist.lisp (read-conversatively-for-autodoc): Also parse quoted symbols explicitly. This fixed extended arglist display for `(make-instance 'foo'. Reported by: Johannes Groedem. 2007-09-11 Tobias C. Rittweiler * slime-fancy.el: Require `slime-references'. 2007-09-10 Helmut Eller * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package): Move from slime.el to contrib/slime-parse.el. 2007-09-10 Helmut Eller * inferior-slime.el: Fix installation comment. 2007-09-10 Helmut Eller Fix some of the bugs introduced with the last change. * slime-references.el (sldb-reference-face): Add missing quote. (sldb-reference-properties): We are lucky and can use keywords instead of strings. (sldb-maybe-insert-references): Insert newlines differently. 2007-09-10 Helmut Eller Move SBCL doc references to contrib. * slime-references.el: New file. 2007-09-10 Attila Lendvai * slime-fuzzy.el: Fixed some race condition that prevented a proper closing of the *Fuzzy Completions* buffer in some circumstances. (slime-fuzzy-save-window-configuration): Removed. Hooking up `window-configuration-change-hook' via `run-with-timer' was racy and lead to this bug; we now set the hook explicitely at the necessary place instead. (slime-fuzzy-window-configuration-change-add-hook): Removed. (slime-fuzzy-choices-buffer): Explicitly save the window-configuration, and explicitly set the hook. (slime-fuzzy-done): Explicitely remove the hook. 2007-09-10 Tobias C. Rittweiler * slime-parse.el (slime-cl-symbol-name, slime-cl-symbol-package): Moved back into slime.el. 2007-09-08 Stelian Ionescu * slime-banner.el: Fixed typo to provide `slime-banner', not `slime-startup-animation'. 2007-09-06 Matthias Koeppe * slime-presentations.el (slime-presentation-write): Use case, not ecase, for dispatching targets. Should fix XEmacs compatibility. Reported by Steven E. Harris. 2007-09-05 Tobias C. Rittweiler * swank-c-p-c.el: This file incorrectly provided the module `:swank-compound-prefix'; changed that to `:swank-c-p-c'. This gets rid off the nasty redefinition warnings that were previously signalled when loading SWANK with SBCL. * swank-arglist.lisp (arglist-for-echo-area): Locally declare `*arglist-pprint-bindings*' to be special, as the variable is defined later in the file. (Gets rid of warnings during loading.) 2007-09-05 Tobias C. Rittweiler * slime-c-p-c.el (slime-c-p-c-init): Bind `slime-complete-form' to `C-c C-s' in `slime-repl-mode-map'. 2007-09-05 Tobias C. Rittweiler Added extended arglist display for DECLAIM and PROCLAIM. * slime-parse.el (slime-extended-operator-name-parser-alist): Added entries for "DECLAIM", and "PROCLAIM". (slime-parse-extended-operator/declare): Provide information about the operator the arglist is requested for. (slime-make-form-spec-from-string): Fixed for "()" as input. * swank-arglists.lisp (valid-operator-symbol-p): Explicitly allow the symbol 'DECLARE. (arglist-dispatch): New method for `DECLARE'. We have to catch this explicitly, as DECLARE doesn't have an arglist (in the `swank-backend:arglist' sense.) (*arglist-pprint-bindings*): New variable. Splitted out from `decoded-arglist-to-string'. (decoded-arglist-to-string): Use `*arglist-pprint-bindings*'. (parse-first-valid-form-spec): Rewritten, because function signature had to be changed: doesn't take arg-indices anymore; returns position of first valid spec as second value to remedy. (arglist-for-echo-area): Accomodated to new signature of `parse-first-valid-form-spec'; now searchs for contextual declaration operator name, to prefix a declaration arglist by "declare", "declaim", or "proclaim" depending on what was used at user's point in Slime. Use `*arglist-pprint-bindings*' for printing the found declaration operator name. (%find-declaration-operator): New helper to do this search. (completions-for-keyword): Accomodated to new signature of `parse-first-valid-form-spec'. Also fixed to correctly provide keyword completions in nested expressions like: `(defun foo (x) (let ((bar 'quux)) (with-open-file (s f :|' [`|' being point] 2007-09-04 Helmut Eller * swank-arglists.lisp (parse-first-valid-form-spec): Rewrite it for ABCL. 2007-09-04 Helmut Eller Some bug fixes for slime-complete-symbol*. Patches by Mr. Madhu * slime-c-p-c.el (slime-c-p-c-unambiguous-prefix-p): New variable. (slime-expand-abbreviations-and-complete): Use it. Also add a workaround for XEmacs issues. 2007-09-04 Helmut Eller Move asdf support to contrib: * slime-asdf.el: New file. * swank-asdf.lisp: New file (operate-on-system, asdf-central-registry) (list-all-systems-known-to-asdf): Use the asdf package in the source code, i.e. write asdf:operate instead of (find-symbol "OPERATE" "ASDF"). 2007-09-04 Helmut Eller * slime-tramp.el: New file. * slime-banner.el: New file. * inferior-slime.el: New file. 2007-09-01 Matthias Koeppe * slime-fancy.el: New meta-contrib. 2007-09-01 Matthias Koeppe * slime-presentations.el (slime-dispatch-presentation-event): Explicitly return t to indicate the events have been handled, rather than relying on the return values of the called functions. 2007-09-01 Matthias Koeppe * slime-typeout-frame.el (slime-typeout-autodoc-message): Fix for messages that contain "%". Reported by Martin Simmons. 2007-09-01 Tobias C. Rittweiler Makes `slime-complete-form' work on `(eval-when |'; doesn't work on `(eval-when (|' yet. * slime-parse.el (slime-parse-sexp-at-point): Guard against `(char-after)' being NIL at end of buffer (especially important for use on the REPL.) * swank-arglist.lisp (arglist-dispatch 'eval-when): Fix typo. (print-decoded-arglist-as-template): Print keywords with PRIN1. 2007-08-31 Tobias C. Rittweiler Added extended arglist display for EVAL-WHEN, viz: (eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) Notice that completion works as expected on these keywords. Die, EVAL-ALWAYS, die! * swank-arglist (arglist-dispatch): New method for EVAL-WHEN. (print-arglist): Print keywords with PRIN1 rather than PRINC, to get a result as shown above for the EVAL-WHEN case. (completions-for-keyword): Add support for &ANY args. 2007-08-31 Tobias C. Rittweiler * swank-arglist.lisp: Do not fall back to READ when interpreting the ``raw form specs'' comming from Slime's autodoc stuff. But still do so for those comming from `slime-complete-form'. (unintern-in-home-package): New. (*arglist-dummy*): New. (read-conversatively-for-autodoc): New function. Doesn't READ anything that comes from Slime's autodoc. Just tries to parse symbols. If that's not successfull, returns the dummy placeholder datum stored in `*arglist-dummy*'. (arglist-for-echo-area): Parse form-specs using `read-conversatively-for-autodoc'. Use `unintern-in-home-package'. (read-softly): New. Splitted out from `read-form-spec'. This function tries to keep track of newly interned functions before READing. (read-form-spec): Parametrized to take a function to read the elements of the passed ``raw form spec''. Uses `read-softly' as default reader. (complete-form, completions-for-keywords): Use `unintern-in-home-package'. 2007-08-31 Helmut Eller * slime-autodoc.el: Add installation notes. * slime-editing-commands.el: Add installation notes. * slime-c-p-c.el (slime-c-p-c-init): Fix typos. 2007-08-31 Helmut Eller Move compound prefix completion and autodoc to contrib. Interdependencies made it almost necessary to move parsing code and editing commands in the same patch. * slime-c-p-c.el: New file. * swank-c-p-c.el: New file. * slime-parse.el: New file. * swank-arglists.el: New file. * slime-editing-commands.el: New file. * slime-autodoc.el: New file. 2007-08-28 Matthias Koeppe * slime-presentations.el (slime-last-output-target-id) (slime-output-target-to-marker, slime-output-target-marker) (slime-redirect-trace-output): Moved back into SLIME core. * swank-presentation-streams.lisp: Require swank-presentations. (present-repl-results-via-presentation-streams): New. (*send-repl-results-function*): Set this variable rather than overriding send-repl-results-to-emacs. 2007-08-28 Helmut Eller * slime-presentations.el (slime-clear-presentations): New function. Add it to slime-repl-clear-buffer-hook. 2007-08-28 Helmut Eller * swank-listener-hooks.lisp: New file 2007-08-28 Helmut Eller Move the rest of the presentation related code. * swank-presentations.lisp (present-repl-results): Renamed from send-repl-results-to-emacs. 2007-08-28 Matthias Koeppe * swank-presentations.lisp (send-repl-results-to-emacs): Override core defun to mark up REPL results as presentations. * swank-presentations.lisp: New file. * slime-presentations.el: Load it. * slime-presentations.el (slime-presentation-write): Remove id argument. * slime-presentation-streams.el: Require slime-presentations contrib. 2007-08-27 Helmut Eller Move presentations to contrib. (ELisp part) * slime-presentations.el: New file. * slime-scratch.el (slime-scratch-buffer): Ignore presentations. 2007-08-24 Matthias Koeppe Some fixes to the presentation-streams contrib. * swank-presentation-streams.lisp [sbcl]: Load the pretty-printer patch only at load time. Add some trickery so that SBCL does not complain about the changed layout of the pretty-stream class. * swank-presentation-streams.lisp (slime-stream-p): Using special return values, indicate whether we are printing to the REPL-results stream, or a dedicated stream. (presentation-record): New slot "target". (presentation-start, presentation-end): Use it (rather than the global variable *use-dedicated-output-stream*) to decide whether to use the bridge protocol or the :presentation-start/-end protocol. Also use it as the TARGET argument of :presentation-start/-end messages. (presenting-object-1): Use the new return values of slime-stream-p. * swank-presentation-streams.lisp (slime-stream-p) [cmu]: Use the return value of slime-stream-p rather than the global variable *use-dedicated-output-stream* to decide whether printing through pretty streams is safe for the layout. 2007-08-24 Matthias Koeppe Make the fancy "presentation streams" feature a contrib. Previously, it was only available if "present.lisp" was loaded manually. * slime-presentation-streams.el: New file. * swank-presentation-streams.lisp: New file, moved here from ../present.lisp 2007-08-24 Helmut Eller * slime-typeout-frame.el: New file. * slime-xref-browser.el: New file. * slime-highlight-edits.el: New file. * slime-scratch.el: New file. 2007-08-23 Helmut Eller Move Marco Baringer's inspector to contrib. * swank-fancy-inspector.lisp: New file. The only difference to the code is that inspect-for-emacs methods in this file are specialized to the new class `fancy-inspector'. (fancy-inspector): New class. * slime-fancy-inspector.el: New file. 2007-08-19 Helmut Eller Moved fuzzy completion code to contrib directory. * slime-fuzzy.el: New file. (slime-fuzzy-init): New function. Load CL code on startup. * swank-fuzzy.lisp: New file. Common Lisp code for fuzzy completion. ;; Local Variables: ;; coding: utf-8 ;; End: slime-2.18.orig/contrib/slime-indentation.el0000644000175000017500000000207512720104623017244 0ustar pdmpdm(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.18.orig/contrib/swank-macrostep.lisp0000644000175000017500000001764212720104623017314 0ustar pdmpdm;;; 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.18.orig/contrib/swank-kawa.scm0000644000175000017500000025605312720104623016056 0ustar pdmpdm;;;; 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)))) (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.18.orig/contrib/swank-package-fu.lisp0000644000175000017500000000440712720104623017315 0ustar pdmpdm (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.18.orig/contrib/slime-listener-hooks.el0000644000175000017500000000054412720104623017675 0ustar pdmpdm(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.18.orig/contrib/slime-package-fu.el0000644000175000017500000003166212720104623016737 0ustar pdmpdm(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 '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.18.orig/contrib/swank-mlworks.sml0000644000175000017500000002215112720104623016630 0ustar pdmpdm(* 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.18.orig/contrib/slime-sprof.el0000644000175000017500000001671612720104623016070 0ustar pdmpdm(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.18.orig/contrib/swank-hyperdoc.lisp0000644000175000017500000000137412720104623017127 0ustar pdmpdm(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.18.orig/contrib/inferior-slime.el0000644000175000017500000001107412720104623016544 0ustar pdmpdm;;; 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.18.orig/contrib/slime-mdot-fu.el0000644000175000017500000000224712720104623016304 0ustar pdmpdm(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.18.orig/contrib/swank-ikarus.ss0000644000175000017500000000464512720104623016272 0ustar pdmpdm;; 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.18.orig/contrib/Makefile0000644000175000017500000001007512720104623014736 0ustar pdmpdm### 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.18.orig/contrib/slime-asdf.el0000644000175000017500000003060012720104623015640 0ustar pdmpdm(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.18.orig/contrib/slime-sbcl-exts.el0000644000175000017500000000234212720104623016631 0ustar pdmpdm(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.18.orig/contrib/swank-r6rs.scm0000644000175000017500000002776312720104623016033 0ustar pdmpdm;; 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.18.orig/contrib/swank-goo.goo0000644000175000017500000007466712720104623015732 0ustar pdmpdm;;;; 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.18.orig/contrib/slime-fontifying-fu.el0000644000175000017500000002253412720104623017516 0ustar pdmpdm(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.18.orig/contrib/swank-larceny.scm0000644000175000017500000001151512720104623016560 0ustar pdmpdm;; 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.18.orig/contrib/swank-arglists.lisp0000644000175000017500000020526412720104623017146 0ustar pdmpdm;;; 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.18.orig/contrib/swank-repl.lisp0000644000175000017500000003771612720104623016265 0ustar pdmpdm;;; 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.18.orig/contrib/slime-references.el0000644000175000017500000001251012720104623017044 0ustar pdmpdm(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-glossary-fun 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.18.orig/contrib/slime-quicklisp.el0000644000175000017500000000324112720104623016730 0ustar pdmpdm(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.18.orig/contrib/slime-compiler-notes-tree.el0000644000175000017500000001466512720104623020635 0ustar pdmpdm(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.18.orig/Makefile0000644000175000017500000000465512720104623013305 0ustar pdmpdm### 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 ChangeLog 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.18.orig/README.md0000644000175000017500000000543212720104623013116 0ustar pdmpdm[![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. [Setup 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". When SLIME is loaded it loads the contribs you set up before in `slime-contribs`. You can use the command `slime-setup` to reload contribs. 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.18.orig/metering.lisp0000644000175000017500000014671512720104623014354 0ustar pdmpdm;;; -*- 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.18.orig/ChangeLog0000644000175000017500000324455212720104623013424 0ustar pdmpdm2016-04-19 Stas Boukarev * swank/clasp.lisp (frame-locals): list function arguments. (call-with-debugging-environment): Use core:*stack-top-hint* 2016-04-02 Stas Boukarev * swank/sbcl.lisp (lisp-source-location): qualify the package of swank:*swank-debugger-condition*. * swank/abcl.lisp: import mop:slot-makunbound-using-class into swank-mop. 2016-03-21 Luís Oliveira * swank/sbcl.lisp (sbcl-with-setf-inverse-meta-info): Backwards compatibility test for :setf :inverse info that takes special care not to trip on package locks due to interning SB-C::META-INFO on older SBCLs. (setf-expander): Use it. 2016-03-21 Luís Oliveira * swank/backend.lisp (boolean-to-feature-expression): New function. (with-symbol): Use it. * packages.lisp (swank/backend): Export it. 2016-03-19 Stas Boukarev * swank/sbcl.lisp (describe-symbol-for-emacs): Adjust for new SBCL, (sb-int:info :setf :inverse) is no longer present. 2016-03-09 Tomas Zellerin * swank/rpc.lisp (simple-read): We did not gain anything by custom string reader. * swank/rpc.lisp (simple-read): Fix handling of symbols. 2016-03-04 Stas Boukarev * swank.lisp (xref-doit): translate :sets to who-sets. 2016-02-10 Stas Boukarev * swank/backend.lisp: Squash a couple compilation warnings. 2016-02-03 Matthew Kennedy * contrib: Add `slime-quicklisp' contrib. * swank-loader.lisp (*contribs*): Add `swank-quicklisp`. 2016-02-02 Jon Oddie Add `slime-macrostep' contrib. * slime.el: Depend on macrostep 0.9. * lib/macrostep.el: New file. This is a bundled version of the library developed at http://github.com/joddie/macrostep and also available via MELPA. The bundled copy will be used as a fallback if it is not installed separately. * swank/backend.lisp (collect-macro-forms): New backend helper used by `slime-macrostep', and a generic implementation. (with-collected-macro-forms): New macro to ease implementing `collect-macro-forms' by let-binding *MACROEXPAND-HOOK* * swank/sbcl.lisp (collect-macro-forms): SBCL implementation using a code-walker. * swank/abcl.lisp (collect-macro-forms): ABCL implementation using WITH-COLLECTED-MACRO-FORMS. * swank/clisp.lisp (collect-macro-forms): CLISP implementation using WITH-COLLECTED-MACRO-FORMS. * swank-loader.lisp (*contribs*): Add `swank-macrostep'. 2016-01-29 Stas Boukarev * swank/source-path-parser.lisp (sexp-in-bounds-p): Don't fall victim to dotted lists and atoms. * swank/clasp.lisp (frame-source-location): Properly locate functions by calling SOURCE-LOCATION. * swank/clasp.lisp: remove tags support, no longer used. 2015-12-13 Luís Oliveira * swank/ccl.lisp (toggle-trace): Really toggle rather than trace unconditionally, parse defmethod specs properly, return a string as swank-toggle-trace expects. (parse-defmethod-spec): New utility function. 2015-12-13 Luís Oliveira * doc/slime.texi (Macro-expansion): Make it clear that the cursor should be positioned where the sexp starts before invoking a macroexpansion command. (Suggested by Mirko Vukovic.) Document slime-expand-1. * slime.el (slime-expand-1): Update docstring to reflect that compiler macros are handled. (slime-macroexpand-1, slime-macroexpand-all) (slime-macroexpand-all-inplace, slime-compiler-macroexpand-1) (slime-compiler-macroexpand-1-inplace): Make it clear that cursor should be positioned where the sexp starts. 2015-12-11 Luís Oliveira Avoid Lisp errors when we fail to identify the sexp at point in the during slime-expand-1 and friends. * slime.el (slime-eval-macroexpand): Use slime-sexp-at-point-or-error. (slime-eval-macroexpand-inplace, slime-sexp-at-point-or-error): Use user-error. 2015-12-09 Stas Boukarev * swank/sbcl.lisp (feature-in-list-p): Don't fall on :host-feature. 2015-12-08 Stas Boukarev * swank/clasp.lisp (source-location): clasp now uses the same method for c-function source location as for lisp functions. 2015-12-06 Stas Boukarev * swank-loader.lisp (compile-files): Don't abort on errors, otherwise it's impossible to debug them. 2015-11-23 Luís Oliveira * swank.lisp (indentation-cache-loop): Marginally robustify the indentation cache thread by adding an abort restart, so that errors during the handling of one request don't kill the whole thread as easily. (update-indentation/delta-for-emacs): Don't attempt to iterate over deleted packages. 2015-11-18 Stas Boukarev * swank/sbcl.lisp (sigio-handler): run handlers with interrupts enabled. 2015-11-10 Stas Boukarev * swank/abcl.lisp (package-local-nicknames): Support local nickname completion on ABCL too. * swank/backend.lisp (package-local-nicknames): New interface. * packages.lisp: New file, put swank, swank/backend and friends there. The SWANK package depends on SWANK/BACKEND, but some swank/backends want to use functions from SWANK and accomplish that by using (funcall (find-symbol x :swank)), which is not really nice. package.lisp is loaded before swank.lisp and swank/backend.lisp 2015-11-09 Jan Moringen Complete symbols in locally-nicknamed packages * contrib/swank-c-p-c.lisp (parse-completion-arguments): additionally call guess-locally-nicknamed-package * swank/backend.lisp (definterface guess-locally-nicknamed-package): new interface for package-local nicknames * swank/sbcl.lisp (defimplementation guess-locally-nicknamed-package): implementation for SBCL 2015-10-18 Jack Pugmire Fixed some documentation bugs for the mrepl contrib. * doc/slime.texi (Contributed Packages) : Replace reference to slime-open-listener with slime-new-mrepl * contrib/slime-mrepl.el: Fixed outdated header comment 2015-10-18 Helmut Eller Minor factorization. * slime.el (slime-setup-completion): New. Use it where approriate. 2015-10-18 Helmut Eller * slime.el (slime-complete-symbol-function) (slime-indent-and-complete-symbol): Mark as obsolete. 2015-10-17 Helmut Eller Set completion-at-point-functions in slime-mode buffers. Related to github issue #272. * slime.el (slime--completion-at-point): New function that tries to be backward-compatible. (slime--on, slime--off): New. Set/reset completion-at-point-functions. (slime-mode): Use slime--on, slime--off (slime-complete-symbol): Make obsolete. (slime-minibuffer-setup-hook): Set completion-at-point-functions. (slime--completion-at-point-functions): Deleted. 2015-10-17 Stas Boukarev * swank.lisp (eval-in-emacs): wrap unreadable results in a structure. Should make it easier to work with than signalling an error. 2015-10-12 Helmut Eller Fix github issue#273. * swank/sbcl.lisp (sexp-in-bounds-p, sexp-ref): Don't define in older SBCLs. 2015-10-11 Helmut Eller Deal with SBCL's sb-c::comma-expr * swank/source-path-parser.lisp (sexp-in-bounds-p) (sexp-ref): New generic functions. (source-path-source-position): Use them. * swank/sbcl.lisp (sexp-in-bounds-p): Define methods for sb-c::comma-expr. 2015-10-11 Helmut Eller Remove slime-pre-command-actions; apparently not needed anymore. * slime.el (slime-pre-command-hook, slime-setup-command-hooks) (slime-post-command-hook, slime-pre-command-hook): Deleted. 2015-09-30 Stas Boukarev * swank-loader.lisp (*architecture-features*): Add :arm64. 2015-08-24 Luís Oliveira * slime.el (slime-next-connection, slime-prev-connection): Reverse the ordering so that slime-next-connection moves down in the slime-connection-list. 2015-08-18 Stas Boukarev * swank/clasp.lisp (print-frame): Print arguments on newer Clasp versions. 2015-08-14 Stas Boukarev * swank/source-path-parser.lisp (make-source-recorder): Fix handling of recursive calls to macros producing the same forms. e.g. #+(and) (a) 2015-08-04 Stas Boukarev * swank/sbcl.lisp: make use of the newly provided form number for top-level forms. 2015-08-02 Stas Boukarev * swank/source-path-parser.lisp (skip-whitespace): ignore EOF, there may no non-whitespace characters left. 2015-07-31 Stas Boukarev * slime.el (slime-format-string-expand): When there's no string at point, read a string from the minibuffer. 2015-07-18 Mark Karpov * slime-autoloads.el (hyperspec-lookup): Fix autoload spec of the function. 2015-07-17 Helmut Eller Start using completion-at-point. That saves us the complex code to display the list of completions. Unfortunately, slime-complete-symbol-function doesn't work well to customize it. Had to introduce a replacment: slime-completion-at-point-functions. * slime.el (slime-complete-symbol): Use completion-at-point. (slime-completion-at-point-functions): New. (slime--completion-at-point-functions): New helper. (slime-complete-symbol-function): Obsolete, but have to keep it around for some time. (slime-simple-completion-at-point): Renamed from slime-simple-complete-symbol to avoid confusion. (slime-filename-completion): Renamed from slime-maybe-complete-as-filename. (slime-simple-complete-symbol): Backward compatible replacement. (slime-completions-buffer-name) (slime-complete-saved-window-configuration) (slime-completions-window) (slime-complete-maybe-save-window-configuration) (slime-complete-delay-restoration) (slime-complete-forget-window-configuration) (slime-complete-restore-window-configuration) (slime-complete-maybe-restore-window-configuration) (slime-completion-window-active-p, slime-display-completion-list) (slime-display-or-scroll-completions, slime-scroll-completions) (slime-minibuffer-respecting-message): Move to contrib/slime-c-p-c.el * slime-tests.el (complete-symbol): Update tests. * doc/slime.texi: Update documentation for symbol completion. 2015-07-15 Helmut Eller Use *READ-SUPPRESS* more often while searching source locations. This avoids certain reader errors when the compile-time and load-time state is different and also avoids some unnecessary interning. * swank/source-path-parser.lisp (read-source-form): Use guess-reader-state to setup *package* and *readtable* before using the reader. (guess-reader-state, starts-with-p, extract-package): New helpers. (skip-toplevel-forms): Bind *read-suppress* to t while skipping over top-level forms. (ignore-errors): Shadow cl:ignore-errors so that it can be redefined during debugging. * slime-tests.el (find-definition.2): New test case. 2015-07-09 Stas Boukarev * swank/clasp.lisp (print-frame): Print function names, not function objects. 2015-07-09 Jim Newton * contrib/slime-enclosing-context.el (slime-edit-definition): Use cl-values. 2015-07-09 Luís Oliveira Fix issue #255, reported by rgivan1. * swank/ccl.lisp (function-name-package): Handle traced functions and setf functions. 2015-07-07 YOKOTA Yuki * swank-loader.lisp (list-fasls): New function. 2015-07-07 Stas Boukarev * swank/sbcl.lisp (definition-source-file-location): Stop errors from source-path-parser from producing no locations at all. 2015-06-27 Stas Boukarev * swank.lisp (*pre-reply-hook*): Don't add sync-indentation-to-emacs on CLASP, it takes too much time. * swank/clasp.lisp (assert-source-directory): Uses the SYS logical host, not SRC. 2015-06-24 Angelo Rossi * swank-loader.lisp (*architecture-features*): Add :mips and :mipsel. 2015-06-23 Christian Schafmeister * swank/clasp.lisp: Made it compatible with the upcoming release of clasp and this breaks compatibility with the current "master" release of clasp. Moved some symbols (core:chdir -> ext:chdir). 2015-06-01 Luís Oliveira * swank/sbcl.lisp: Added workaround for a bug in SBCL 1.2.12's SB-EXT:RESTRICT-COMPILER-POLICY. Courtesy of Stas Boukarev. 2015-05-20 Helmut Eller * slime.el (slime-xref-mode-map): Bind . and , for compatibility. 2015-05-07 Attila Lendvai Make the inspector work more like web browsers: bind left click to follow link, and mouse 6/7 for forward and back navigation. * slime.el (slime-inspector-mode-map): Bind [mouse-1], [mouse-6] and [mouse-7]. 2015-05-03 Luís Oliveira Add default values for many SLDB faces as suggested by Attila Lendvai in pull request #107. * slime.el (define-sldb-faces): Add more default values. 2015-05-03 Luís Oliveira Remove obsolete function slime-face-inheritance-possible-p. Face inheritance has been available since Emacs 21.1, released in 2001. * slime.el (slime-face-inheritance-possible-p): Remove it. (slime-inspector-value-face, slime-inspector-action-face) (define-sldb-faces, slime-highlight-face): Remove call to slime-face-inheritance-possible-p. 2015-05-03 Mark Evenson * swank/abcl.lisp (frame-locals frame-var-value): Fix off by one errors in inspecting arguments across stack frames. Attempt to match arguments to parameters recorded at compile time. 2015-04-19 Stas Boukarev * swank/sbcl.lisp (*definition-types*): Add new type, :alien-type. 2015-04-17 Stas Boukarev * swank/sbcl.lisp (*definition-types*): Add new type, :declaration. 2015-04-14 Stas Boukarev * swank/sbcl.lisp (*definition-types*): Add a new type, :ir1-convert. SBCL now handles def-ir1-translator location differently. 2015-04-02 Stas Boukarev * swank.lisp (format-values-for-echo-area): Present a float representation of ratios, i.e. 1/2 will be "=> 1/2 (0.5)" 2015-03-29 Stas Boukarev * swank/source-path-parser.lisp (source-path-source-position): Do what it actually says, return the deepest _possible_, not the deepest subform. 2015-02-19 Luís Oliveira * slime.el (slime-cycle-connections): It's an obsolete function, not an obsolete variable. (slime-prev-connection): Tweak docstring. 2015-02-12 Stas Boukarev * swank/sbcl.lisp (definition-source-buffer-and-file-location): Fix xrefs from C-c C-c. source-file-position may now return NIL, be prepared. 2015-02-08 Adlai Chandrasekhar * slime.el (slime-next-connection, slime-prev-connection): New functions for cycling connections in both directions, deprecating slime-cycle-connections and adding 'C-c C-x p' (and ?p in slime-selector) for cycling in the opposite direction. 2015-01-28 Helmut Eller * swank/source-path-parser.lisp (skip-toplevel-forms): Use the package tracking code; return multiple values instead of a macro. Also remove the error handling; let it crash. (skip-one-toplevel-form): New helper. (call-with-skipping-toplevel-forms, with-skipping-toplevel-forms): Merged into skip-toplevel-forms. 2015-01-27 Gábor Melis * Makefile (clean-fasls): Don't fail if ~/.slime/fasl/ does not exist. * swank/source-path-parser.lisp: Make source parser to honor SWANK:*READTABLE-ALIST* which makes M-. work on SBCL even if skipping over forms requires a special readtable. 2015-01-27 Helmut Eller * lib/hyperspec.el (common-lisp-hyperspec-root): Use file:// in example. 2015-01-02 Luís Oliveira * slime.el (slime-path): Only set slime-path at load-time. Setting at compile time is potentially premature if compilation is not immediately followed by loading. (See gh issue #125 for more discussion.) (slime--changelog-file-name): New function. Computes the location of the SLIME ChangeLog based on byte-compile-current-file at compile time, or based on slime-path at load time when slime.el is not compiled. (slime-changelog-date): Use slime--changelog-file-name. No longer looks at slime-path at compile time. 2015-01-05 Christian Schafmeister * swank/clasp.lisp: New file. * swank-loader.lisp (*sysdep-files*, *implementation-features*) (clasp-version-string, lisp-version-string): Added CLASP backend. 2014-12-23 Daniel Kochmański * swank-loader.lisp (*architecture-features*): Add ARM architectures as reported by ECL (armv5l, armv6l and armv7l) to mentioned variable. 2014-12-17 Luís Oliveira * swank-loader.lisp (delete-packages): Robustify in case some package outside the set returned by LIST-SWANK-PACKAGES uses one of the SWANK packages. Previous version would enter an infinite loop. 2014-12-15 Luís Oliveira Fix deletion of SWANK packages in swank-loader.lisp. Reported by Ruben Vaz. * swank-loader.lisp (list-swank-packages): Catch more SWANK packages. (string-starts-with): Refactored out from LIST-SWANK-PACKAGES. (delete-packages): New function capable of deleting interdependent packages. (init): Use it. 2014-12-12 Luís Oliveira Don't try to save every changed buffer when compiling a file. * slime.el (slime--maybe-save-buffer): New function adapted from slime--save-some-buffers that maybe saves the current buffer rather than potentially every changed buffer. (slime-compile-file): Use it. 2014-12-04 Adlai Chandrasekhar Factor out an "AST-sugar" macro for concisely stating a condition system idiom: restarting an operation after performing one or more changes to its execution state and environment. * swank.lisp (restart-loop, socket-quest): Factor out the macro, and refactor socket-quest with it. 2014-12-04 Adlai Chandrasekhar Factor out the socket-quest function, which also incorporates a default behavior of incrementing the port number by one. * swank.lisp (socket-quest, setup-server): Factor out the former, and call it from the latter. * contrib/swank-repl.lisp (open-dedicated-output-stream): Drop in a call to our new quest-wrapper, for good measure. 2014-12-04 Adlai Chandrasekhar Add a loop around the port number restart to allow multiple tries. * swank.lisp (setup-server): Successful socket creation terminates the loop through the return statement. 2014-12-04 Adlai Chandrasekhar * swank.lisp Delete trailing whitespace. 2014-11-18 Adlai Chandrasekhar Add a restart around socket creation to allow trying other ports should the initially selected number be unavailable. * swank.lisp (setup-server): Offer a use-value restart around the call to backend code, which retries the call on a different port. 2014-11-28 Luís Oliveira Restore workingness for Allegro's modern mode. * swank/allegro.lisp (gray-package-name): Let the reader decide whether the package name is in lower or upper case. 2014-11-26 Luís Oliveira Make sure the contrib directory is pushed to load-path so that package.el succeeds in byte compiling the contribs. * slime.el (slime--setup-contribs): Always push the contrib directory to load-path, even if there aren't any contribs to load. 2014-11-22 Luís Oliveira Avoid compiling a stale slime-path into slime.elc when upgrading SLIME within an Emacs session, e.g. via MELPA. (gh issue #125) * slime.el (slime-path): Use setq. 2014-11-18 Luís Oliveira Regression test for slime-recompile-all-xrefs. * slime-tests.el (slime-recompile-all-xrefs): New test. 2014-11-18 Bart Botta <00003b@gmail.com> * slime.el (slime-all-xrefs): Call forward-line directly instead of slime-next-line/not-add-newlines. (slime-next-line/not-add-newlines): Delete. 2014-11-17 Stas Boukarev * slime.el (slime-all-xrefs): Know when to stop iterating over buffer lines. 2014-11-16 Bart Botta <00003b@gmail.com> Fix source locations when recompiling from an xref buffer. * slime.el (slime-recompile-locations): Pass full filenames to swank:compile-multiple-strings-for-emacs. 2014-11-14 Luís Oliveira * doc/slime.texi (Installation): Reworked to add MELPA instructions. * doc/contributors.texi: Include this auto-generated file so that MELPA is able to build the manual. * README.md: Add instructions on how to use MELPA to install SLIME and move the Git instructions to the manual and other minor tweaks. 2014-10-10 Luís Oliveira * swank-loader.lisp (init): Delete swank/* packages. (dump-image): use SWANK/BACKEND. 2014-10-09 Luís Oliveira * swank/backend.lisp (swank/backend): Add SWANK-BACKEND nickname to ease the migration of external projects. 2014-10-02 Helmut Eller Can't use Gray streams for ABCL * swank/abcl.lisp (make-output-stream, make-input-stream): Use ext:make-slime-output-stream because ABCL's Gray streams don't work well enough. * swank-loader.lisp (*sysdep-files*, *swank-files*): Don't load swank/gray.lisp for ABCL. 2014-10-01 Luís Oliveira * swank-loader.lisp (src-files): inherit src-dir's defaults, otherwise things like the Windows drive won't be picked up. 2014-09-30 Robert P. Goldman * doc/slime.texi (Other configurables): fixed anchor and cross-reference since makeinfo doesn't colons in reference targets. 2014-09-30 Helmut Eller * swank/backend.lisp (codepoint-length): Deleted. No longer used. 2014-09-30 Helmut Eller Fix some compiler warnings. * slime-tests.el (slime-tests--undefine-all): Use cl-remprop instead of remprop. (slime-test--compile-defun): Fix typo. 2014-09-30 Helmut Eller Fix github issue #193. Respect compilation-ask-about-save. * slime.el (slime--save-some-buffers): New helper. (slime-compile-file): Use it. * slime.el (slime-echo-arglist): Renamed from slime-show-arglist as there still users of it. 2014-09-30 Helmut Eller * swank/cmucl.lisp: Require at least version 20c and remove some code that was there only for compatibility with older versions. 2014-09-30 Helmut Eller * swank/cmucl.lisp, swank/sbcl.lisp: Whitespace cleanup. 2014-09-30 Helmut Eller Fix github issue #192 sb-sys:enable-interrupt does not exist on SBCL +win32 so disable it on Windows. * swank/sbcl.lisp (add-sigio-handler, remove-sigio-handlers): Disable it on Windows along with install-sigint-handler. 2014-09-29 Helmut Eller More deadlock workaround workarounds. * swank/sbcl.lisp (stream-force-output): Use swank/gray. 2014-09-26 Helmut Eller * slime-tests.el (compile-defun-with-backquote): Fails for SBCL also on Travis now. (compile-file): Works for LispWorks. 2014-09-26 Helmut Eller Fix github issue#190 * swank/clisp.lisp: Use swank/clisp as package qualifier where needed. 2014-09-13 Helmut Eller Move backend files to new swank/ directory. In the swank/ directory drop the swank- prefix from filenames. To mirror the directory structure in package names use swank/ instead of swank- as prefix. (This will presumably break a lot of code as many people seem to assume that a swank-backend package exists.) * swank-loader.lisp (src-files): Treat lists like (swank foo) as the filename swank/foo.lisp. 2014-09-13 Helmut Eller Add support for MKCL * swank-mkcl.lisp: New file. Mostly the one from MLCL's contrib/ directory. * swank-loader.lisp (*sysdep-files*): Add swank-mkcl and move swank-gray to the shared *swank-files*. 2014-09-13 Helmut Eller Remove no longer needed indirections. * slime.el (slime-echo-arglist-function, slime-echo-arglist): Deleted. slime-autodoc was the only client and the indirection makes the code unnecessary complicated. (slime-space): Call slime-show-arglist directly. 2014-09-12 Douglas Katzman * swank-sbcl.lisp (macroexpand-all): sb-cltl2:macroexpand-all is preferable to using sb-walker directly 2014-09-10 Helmut Eller Fix gray stream issue for SBCL The pretty printer seems to call the non-standard stream-line-length generic function. * swank-sbcl.lisp (sb-gray:stream-line-length): Implement default. 2014-09-10 Helmut Eller * swank-sbcl.lisp (frame-call): Muffle unreachable code warnings. 2014-09-09 Helmut Eller Rename destructure-case -> slime-dcase. That keeps the namespace clean, even though it's unlikely that anybody else would have used that name. Do the analog destructure-case -> dcase renaming on the CL side to keep the names similar. * slime.el (slime-dcase): Renamed from destructure-case. Update users accordingly. * swank.lisp (dcase): Renamed from destructure-case. Update users accordingly. 2014-09-09 Helmut Eller * swank-backend.lisp (gray-package-name): Fix docstring. 2014-09-09 Helmut Eller Make the ugly deadlock workaround even more ugly. * swank-sbcl.lisp (stream-force-output): Create swank-gray package early enough. 2014-09-09 Helmut Eller Remove non-used optional gray stream methods. * swank-gray.lisp (stream-read-char-will-hang-p) (stream-line-length): Deleted. 2014-09-08 Helmut Eller Use a separate package for swank-gray.lisp. Use gray streams also for CMUCL, SCL, and ABCL. * swank-backend.lisp (gray-package-name): New interface function. (import-from): Deleted. No longer used. (*gray-stream-symbols*): Moved to swank-gray.lisp. * swank-abcl.lisp, swank-cmucl.lisp, swank-scl.lisp (gray-package-name): Implemented and delete old implementations of make-input-stream and make-output-stream. * swank-allegro.lisp, swank-ccl.lisp, swank-clisp, swank-ecl.lisp, swan-lispworks.lisp, swank-sbcl.lisp, (gray-package-name): Implemented. * swank-gray.lisp: Make and use swank-gray package for this file. * swank-loader.lisp (*sysdep-files*): Load swank-gray for CMUCL, SCL, and ABCL. 2014-09-07 Helmut Eller Replace cl-values with list because that's shorter. * slime.el (slime-group-and-sort-notes, (slime-insert-compilation-log) (slime-goto-next-xref): Use list. 2014-09-07 Helmut Eller * swank-cmucl.lisp, swank-scl.lisp (*source-snippet-size*): Remove redundant definitions. 2014-09-07 Helmut Eller * Makefile (compile-swank, run-swank): New targets. (clean-fasls): Also remove ~/.slime/fasl/. 2014-09-07 Helmut Eller Clear all tests out at the beginning. * slime-tests.el (slime-tests--undefine-all): New function. 2014-09-07 Helmut Eller Use one package per backend to make interfaces more explicit. * swank-abcl.lisp, swank-allergo.lisp, swank-ccl.lisp, swank-clisp.lisp, swank-ecl.lisp, swank-lispworks, swank-sbcl.lisp, swank-scl.lisp, swank-source-file-cache.lisp, swank-source-path-parser.lisp: Use packages. * swank-backend.lisp: Export some more stuff. 2014-09-07 Helmut Eller Get rid of when-let as it conflicts with a definition subr-x.el * slime.el (when-let): Deleted. Update all uses accordingly. 2014-09-02 Luís Oliveira * doc/slime.texi: use plain rather than typographical quotes in code blocks so that examples from the PDF manual can be copy and pasted directly. 2014-09-02 Helmut Eller Factor out the backquote test. * slime-tests.el (slime-test--compile-defun): New helper. ([test] compile-defun, compile-defun-with-reader-conditionals): Use it. ([test] compile-defun-with-backquote): New. 2014-09-02 Helmut Eller Allow partially visible lines when scrolling. [github issue #186] * slime.el (slime--adjust-window-start) (slime--adjust-window-point): Relax the assertion to allow partially vsible lines. 2014-08-26 Helmut Eller SBCL's reader changed recently. Fix some issues caused by that. * swank-source-path-parser.lisp (make-source-recording-readtable): Wrap the sharp-dot "#." reader before wrapping the dispatch macro "#" because with the new reader get-dispatch-macro-character doesn't work if "#" is wrapped first. Suggested by Paulo Madeira. (skip-whitespace): New helper. (read-source-form): Use it. Skipping over whitespace is a slight improvement and seems fairly conservative. * slime-tests.el ([test] find-definition.2-2): New test. 2014-08-18 Mark Evenson * swank-abcl.lisp: Adjust MOP symbols to publically exported version. * swank-abcl.lisp (frame-locals): Implement inspection of sldb frame args. Thanks to Theam Yong Chew. 2014-08-01 Helmut Eller For CMUCL, make M-. work on condition classes. * swank-cmucl.lisp (pcl-class-location): Renamed from class-location. (class-location): New. (class-definitions): Search condition classes in infodb. 2014-07-29 Helmut Eller * Makefile (clean-fasls): Recognize more file extensions. 2014-07-29 Helmut Eller Avoid some compiler warnings. * swank-backend.lisp (utf8-encode): Avoid unreachable code warnings. (%utf8-encode): New helper. * swank-sbcl.lisp (sbcl-wrap): Add ignore declaration. * swank.lisp (before-init): Don't call warn-unimplemented-interfaces as it confuses first time users. (thread-for-evaluation): Suppress unused var warnings. 2014-07-28 Helmut Eller Fix bug involving stale window-end. Call window-end with update=t. That works better than calling redisplay when we scroll because window-end may be wrong even without scrolling. * slime.el (slime--adjust-window-point): Call window-end with update argument. (slime--adjust-window-start): Remove explicit call to redisplay. Stricter assertion: LAST should be visible as long as REGION-HEIGHT <= WINDOW-HEIGHT not <. * slime-tests.el (display-region): Actually check point ends up as expected. The old code was buggy and only checked for non-nil. 2014-07-27 Helmut Eller Fix another off-by-one bug. * slime.el (slime--adjust-window-start): Scroll one line more. Also handle case when (= start end 1). * slime-tests.el (display-region): Add test. 2014-07-27 Helmut Eller Don't use cl-labels as it is miscompiled in some Emacs versions. * slime.el (define-slime-contrib): Get rid of cl-labels. (slime-contrib--enable-fun, slime-contrib--disable-fun): New helpers. 2014-07-27 Helmut Eller Update modeline more often. The numbers in the modeline can be out of date when all RPCs complete without user input; probably because modeline updating is performed in some lazy way. * slime.el (slime--recompute-modelines): Resurrected. (slime-dispatch-event): Force modeline updates. (slime-modeline-string): Deleted. The variable is no longer needed. 2014-07-27 Helmut Eller Fix display related bugs. * slime.el (slime--adjust-window-start): Consider the END argument exclusive but count trailing newlines normally. Adjust the assertion so that (1- END) is the last visible position. * slime-tests.el (display-region): Add tests for the situation when (1- END) should be visible but not END. 2014-06-17 Stas Boukarev * swank-sbcl.lisp (emacs-inspect sb-kernel:code-component): There's no TRACE-TABLE-OFFSET slot. Don't bother showing it on older SBCLs, since it isn't really useful. 2014-05-16 Helmut Eller Fix display related bugs. * slime.el (slime--display-region): Renamed from slime-recenter. Also work in the case when the condition message takes up the entire window. (slime--adjust-window-start, slime--adjust-window-point): New helpers. (slime-show-source-location): Display buffer in other window, as it always was. Invert no-highlight-p argument to simplify callers. Add recenter-arg to get rid of the heuristic that detected "sldb show source" vs. "show definition". (slime--display-position): Factored out, again. * slime-tests.el (display-region): New test. (slime-test--display-region-line-to-position) (slime-test--display-region-eval-arg): New Helpers. 2014-05-15 Helmut Eller * slime-tests.el: Break long lines. 2014-05-10 Stas Boukarev * swank-rpc.lisp (prin1-to-string-for-emacs): Convert floats into double-floats, when possible. Emacs lisp only has double floats. 2014-05-08 Gábor Melis * swank-allegro.lisp (function-name, find-source-location): New. * swank-backend.lisp (find-source-location): Fix name in error message. 2014-05-06 Stas Boukarev * swank-source-path-parser.lisp (make-source-recorder): Remove FUNCTION type declaration, get-macro-character returns a designator, not a function. Recent changes to SBCL exposed the problem. 2014-04-27 Christophe Rhodes * slime.el (slime-eval-with-transcript): Fix typo in docstring. 2014-04-27 João Távora * slime.el (slime-init-command): Also use `slime-to-lisp-filename' for the port-filename. 2014-04-26 João Távora * slime.el (sldb-exit): An indirect, non-interactive exit from an *sldb* buffer should just kill the buffer. 2014-04-15 João Távora * slime-tests.el (compile-defun-with-reader-conditionals): Renamed from `compile-defun-with-reader-characters'. Break long lines. * .travis.yml (env): Don't overtest on Emacs 23, as per comment. (install): No need for trailing semicolon. 2014-04-15 Phil Hargett * slime-tests.el (compile-defun): Test split into two parts. (compile-defun-with-reader-characters): Split from `compile-defun' as CCL does not pass this part. * .travis.yml (env): added targets to include CCL 1.9 for Travis builds 2014-04-12 João Távora Unbreak CCL and CLISP and cleanup ChangeLog. * metering.lisp ("SWANK-MONITOR"): Enter SWANK-MONITOR package. 2014-04-10 Phil Hargett Using nicknames, especially short terse ones, are more likely to create package name conflicts with othe packages. Since swank is widely used, its better to avoid using nicknames (or at least short ones). All package nicknames removed. Further, the MONITOR package has been renamed SWANK-MONITOR for the same reason: without the extra qualification, the name could conflict with other packages. * contrib/swank-trace-dialog.lisp (defpackage swank-trace-dialog): removed :std nickname * metering.lisp (defpackage "MONITOR"): removed MON nickname, touched up references in comments * swank-ccl.lisp (profile, profiled-functions, unprofile) (unprofile-all, profile-report, profile-reset, profile-package): replaced use of nickname MON with new package name SWANK-MONITOR * swank-clisp.lisp (profile, profiled-functions, unprofile) (unprofile-all, profile-report, profile-reset, profile-package): replaced use of nickname MON with new package name SWANK-MONITOR 2014-04-10 Stas Boukarev * slime.el (slime-trim-whitespace): Handle multiline strings. 2014-04-01 Helmut Eller * swank.lisp (%%condition-message): Bind *print-readably* for good measure. * swank-sbcl.lisp (set-default-directory): Call chdir. 2014-03-29 João Távora * slime.el (slime-describe-function): Be a little more precise and prompt for a symbol naming a function. 2014-03-28 João Távora * slime.el (slime-init-command): Use `slime-to-lisp-filename'. 2014-03-27 João Távora Previous changes broke compilation for definitions in buffers that don't have files(like *slime-scratch*). Finding definitions in buffers that have a file name that doens't exist in the file-system was also broken. Also WHO-CALLS functionality for top-level forms is unreliable in ACL, be it for temp or other loading mechanisms. For the former, note *TEMP-FILE-MAP* might point to dead buffers and for the latter, there is not enough file info in the .fasl annotations. See http://franz.com/support/documentation/ \ current/doc/cross-reference.htm#in-functions-arg-2. Therefore, this change also deletes the previous attempt by FSPEC-DEFINITION-LOCATIONS to reliably follow :TOP-LEVEL-FORM references.. * swank-allegro.lisp (fspec-definition-locations): Don't attempt to interpret :TOP-LEVEL-FORM fspecs, since file info is always unreliable. * swank-allegro.lisp (compile-from-temp-file): Reinstate recording in *TEMP-FILE-MAP* for all compilations. It is still useful if we haven't saved the buffer or are operating from a file-less buffer, like *slime-scratch* 2014-03-27 João Távora * swank-allegro.lisp (write-tracking-preamble): New function, rewritten from previous hunk in COMPILE-FROM-TEMP-FILE for clarity. Also adds PATHNAME call which broke the previous approach. (compile-from-temp-file): In Allegro 9.0, make redefinition warnings trigger only once now that compilation and loading from temp files are separate steps. 2014-03-27 Paulo Madeira Improve source file recording for ACL backend. Finding definitions compiled with SWANK:SWANK-COMPILE-STRING relied on a hash table mapping temporary file names to buffer names, which broke when the original buffer was closed. A new approach imitate's Franz's own ELI/LEP's and writes a preamble to each temp file that sets the correct values for EXCL::*SOURCE-PATHNAME* and *EXCL::*PARTIAL-SOURCE-FILE-P* pointing to the correct spot in the original file. For strings compiled in buffers with no file name, the previous temp-file-to-buffer mapping is kept. * swank-allegro.lisp (compile-from-temp-file): Use same technique as ELI to store source pathname and position when compiling from file buffers. Don't store buffer mapping for file buffers. Don't prevent redefinition warnings for different source pathnames. (buffer-or-file, find-fspec-location) Don't use buffer mapping for file buffers. 2014-03-27 Helmut Eller Make it easier to specify regexps as test selector. * Makefile (check): Use ' instead of " to avoid some of the bizarre shell quoting rules. Don't evaluate SELECTOR. (SELECTOR): Extra quoting no longer needed. * Makefile (test): New target. 2014-03-27 Helmut Eller Fix bug in slime-complete-restore-window-configuration. * slime.el (slime-complete-restore-window-configuration): Don't use a timer. That was only needed for XEmacs and it was accidentally started multiple times. * slime-tests.el (read-from-minibuffer): New test. 2014-03-24 João Távora * slime.el (slime-popup-buffer-mode): A SLIME popup buffer is always read-only. (slime-recenter): New function. (sldb-show-frame-details, sldb-setup): Use `slime-recenter'. 2014-03-19 Paulo Madeira Fix Allegro CL backend problem with temporary files. * swank-allegro.lisp (swank-compile-string): Don't bind *default-pathname-defaults*. 2014-03-09 João Távora Save and restore windows that popped debugger windows. * slime.el (sldb-setup): Save previous window. (sldb-exit): Restore. Corrections after comments from Helmut. * slime.el (slime-with-popup-buffer): Restore `mode' keyword arg, defaults to `fundamental-mode'. Compute package and connection in calling buffer. (slime-with-popup-buffer): Bind q to `quit-window' (slime-popup-buffer-quit): Remove it. (slime-show-compilation-log, slime-edit-value-callback) (slime-show-apropos, slime-with-xref-buffer) (slime-create-macroexpansion-buffer, slime-list-threads) (slime-list-connections, slime-inspector-buffer): Restore mode arg. (slime-goto-note-in-compilation-log): Fix search and recenter (slime-edit-value-commit, slime-goto-xref, sldb-exit) (sldb-close-step-buffer, slime-quit-threads-buffer) (slime-inspector-quit): Use `quit-window' (slime-show-source-location): Fix it. (sldb-show-frame-details): Fix it (sldb-recenter-region was gone). (slime-list-threads): Don't `local-set-key'. (slime-thread-control-mode-map): Bind `q' here. (slime-inspector-mode): Restore docstring. * slime-tests.el (narrowing): Use `quit-window'. 2014-03-07 João Távora * slime.el (slime-popup-restore-data): Delete it. (slime-with-popup-buffer): Remove `mode' arg. Redesign. (slime-make-popup-buffer,slime-init-popup-buffer) (slime-display-popup-buffer, slime-close-popup-window) (slime-save-local-variables): Remove these functions. (slime-popup-buffer-mode-map): Define this existing map separately. (slime-popup-buffer-mode): Don't use :keymap arg. (minor-mode-alist): Remove XEmacs hack (slime-popup-buffer-quit-function): Remove it (slime-popup-buffer-quit): Use `quit-window' (slime-show-compilation-log, slime-edit-value-callback) (slime-show-apropos, slime-with-xref-buffer) (slime-create-macroexpansion-buffer, slime-list-threads) (slime-list-connections, slime-inspector-buffer): Don't pass :mode arg to `slime-with-popup-buffer'. (slime-goto-note-in-compilation-log): Redesign and use `recenter' instead of `slime-show-buffer-position'. (slime-goto-next-xref): Don't use `slime-show-buffer-position' (sldb-setup): Use just `pop-to-buffer' (slime-show-buffer-position): Remove it. (sldb-recenter-region): Remove it. (slime-show-source-location): Use `select-window' and `recenter'. (slime-saved-window-config): Removed. (slime-inspector-quit): Don't use `slime-saved-window-config' (slime-inspector-mode): Enters `slime-popup-buffer-mode' minor mode. (slime-inspector-mode-map): Bind `q' to `slime-inspector-quit'. 2014-03-07 João Távora Removed XEmacs portability layer, fix some FIXME's, simplify indentation specs. * slime.el (require): Don't require features active by default on GNU emacs. (slime-underline-color): Removed (slime-error-face, slime-warning-face, slime-note-face): Don't use `slime-underline-color' (slime-map-alist): Removed it (slime-indulge-pretty-colors): Removed it. Font locking done all in one place. (slime-rex, slime-start, sldb-in-face): Fix indentation. (slime-recompute-modelines, slime-xemacs-recompute-modelines) (slime-run-when-idle) (slime-minibuffer-respecting-message) (slime-push-definition-stack, slime-pop-find-definition-stack) (slime-recompile-bytecode, slime-safe-encoding-p) (slime-connection-port, slime-xref-mode-map) (define-slime-contrib): Remove XEmacs hacks. (slime-define-channel-type, slime-define-channel-method) (when-let, slime-define-keys, with-struct) (slime-propertize-region, slime-with-rigid-indentation) (slime-with-connection-buffer, slime-def-connection-var) (slime-rex, slime-eval-async, slime-point-moves-p): Use`declare' form for indentation. (slime-connection): Use `slime-auto-start'. (slime-auto-connect): Renamed to `slime-auto-start'. Provide obsolete alias. (slime-dispatch-event): Don't use `slime-recompute-modelines' (slime-kill-all-buffers): Moved to contrib/slime-repl.el (slime-compile-file-options): Make `defcustom' (slime-file-name-merge-source-root) (slime-highlight-differences-in-dirname): Don't use `slime-split-string' (slime-complete-delay-restoration,slime-setup-command-hooks): Use `add-hook' (slime-complete-restore-window-configuration) (slime-xref-recompilation-cont): Add FIXME note. note. (slime-xref-mode-map): Don't use interactive lambdas in keymap. (slime-xrefs): Rewrite to not use `slime-map-alist' (sldb-debugged-continuations): Simplify. 2014-03-07 João Távora * doc/slime.texi (SLIME Trace Dialog): Correct typos. 2014-03-05 Helmut Eller * swank-ccl.lisp: Cleanup whitespace. (set-default-directory): Call ccl:cwd which calls chdir so that subprocess pick it up. 2014-03-05 Helmut Eller Use hashtables instead of obarrays; that's less confusing. * lib/hyperspec.el: (common-lisp-hyperspec--symbols): Renamed from common-lisp-hyperspec-symbols. It's now a hashtable. (common-lisp-hyperspec--insert): Renamed from intern-clhs-symbol. (common-lisp-hyperspec--strip-cl-package): Renamed from common-lisp-hyperspec-strip-cl-package. (common-lisp-hyperspec-read-symbol-name): New helper. This one can used by SLIME. (common-lisp-hyperspec): Use helpers and hashtable. (common-lisp-hyperspec--get-one-line): Renamed from hyperspec--get-one-line. (common-lisp-hyperspec--parse-map-file): New helper. (common-lisp-hyperspec--reader-macros): Renamed from common-lisp-hyperspec-reader-macros. (common-lisp-hyperspec--format-characters): Renamed from common-lisp-hyperspec-format-characters. It's also hashtable now. (common-lisp-hyperspec--read-format-character): New helper. (common-lisp-hyperspec-format): Use it, (common-lisp-hyperspec--insert-format-directive): Renamed from intern-clhs-format-directive. (common-lisp-hyperspec--issuex-symbols): Renamed from common-lisp-hyperspec-issuex-symbols event though issue index is not actually used. (hyperspec-lookup, hyperspec-lookup-reader-macro) (hyperspec-lookup-format): Moved to end of file and remove odd-looking (eval-when (load eval) ...) (cl-lib): Load cl-lib from lib/ if needed. * slime.el (slime-hyperspec-lookup): Use common-lisp-hyperspec-read-symbol-name. * Makefile (compile): Seems prudent not to use batch-byte-recompile-directory as it may pollute the compile-time environment. (ELFILES): Include lib/*.el (slime.elc): Compile lib/hyperspec.el first. 2014-03-04 João Távora * slime.el (require): Move some libs out of `eval-when-compile'. 2014-03-03 João Távora * .travis.yml: Check slime-indentation contrib in travis. Notice that tests pass for now (Emacs 24.3), but at least 5 will fail on upcoming Emacs 24.4. 2014-03-02 João Távora Fix remaining byte-compilation warnings. * lib/hyperspec.el: Require `cl-lib' instead of `cl'. * slime-tests.el (require): Add necessary require statements to avoid warnings. Don't use xemacs compatibility layer. * slime.el (slime-require): Move up to avoid byte-compiler warning. (slime-setup, slime--setup-contribs): Use `slime-contribs' directly. (sldb-in-face): Renamed from `in-sldb-face'. Rename in users. 2014-03-02 Luís Oliveira * doc/slime.texi: Use @SLIME{} throughout. Use UTF-8 coding to match the ChangeLog encoding via contributors.texi; requires texinfo >= 4.13. (Git Incantations): remove reference to the FAIRLY-STABLE tag which is hopefully replaced by release management. Tweak the link to CONTRIBUTING.md. Fixed the node sectioning. * doc/Makefile (contributors.texi): Removed ad-hoc TeX-escaping of non-ascii characters. * .gitignore: ignore the temporary output of doc/Makefile's publish target. 2014-03-02 João Távora * slime.el (slime-read-interactive-args): Use `split-string-and-unquote' (closes #116). Spotted by Mirko Vukovic. 2014-03-02 Luís Oliveira Make sure the SWANK port file is an absolute path and free of shell-isms like ~ that not all Lisps know how to parse. Bug reported by Mirko Vukovic. * slime.el (slime-swank-port-file): Use expand-file-name. 2014-03-02 Luís Oliveira * doc/slime.texi: don't use $Date$. * doc/Makefile (publish): Also publish slime.pdf. 2014-03-02 Luís Oliveira * doc/slime.css: make it slimier. * doc/Makefile (html/index.html): use slime.css. * NEWS: Update. (mostly by João Távora) * doc/slime.texi: Update versions. (SLIME Trace Dialog): Small tweak to section intro. 2014-03-01 Stas Boukarev * swank-sbcl.lisp (wrap): Adapt to newer SBCL. 2014-02-28 Helmut Eller * lib/cl-lib.el: Upgrade to cl-lib 0.5. 2014-02-27 João Távora * Makefile (SELECTOR): Same default, but allow regexp selectors. 2014-02-25 João Távora * README.md: Add link to manual in github pages (hosted under capitaomorte.github.io for now). * doc/Makefile (slime.html): Use --css-include=slime.css * doc/slime.css: New file. Simple stylesheet adapted from the one used by Maxima (http://maxima.sourceforge.net/). * doc/Makefile (install-info): only set $section when making "install-info". * doc/slime.texi (SLIME Trace Dialog): New section. 2014-02-25 Helmut Eller * lib/.nosearch: New file. (github issue#115) 2014-02-24 João Távora * slime.el: Call `slime-setup' at the end. * slime-autoloads.el (slime): Don't use `eval-after-load'. * doc/slime.texi (Installation): Make the autoload recipe the default recipe. (Basic customization): New subsection. Mention `slime-load-hook` and techniques for customizing keymaps. 2014-02-23 João Távora When enabling a contrib, dependencies are also enabled recursively. Without this, setting up or testing a contrib dependending on others often fails. Assumes enable functions are quick and idempotent. * slime.el (define-slime-contrib): Call enable functions for dependencies recursively. (slime-contrib-all-dependencies): Renamed from `slime-contrib-all-dependencies' 2014-02-23 Helmut Eller * Makefile (slime.elc): Rebuild .elc if ChangeLog changes. 2014-02-23 Helmut Eller Make safe-condition-message a bit safer. CCL ignores *print-cirlce* when *print-pretty* is t so it's easy to run into endless recursions. * swank.lisp (%condition-message): Renamed from condition-message. Trim whitespace from the result. (%%condition-message): New function. Use with-string-stream. Since the length of the string is limited we can also limit *print-length* without losing anything. Also handle SERIOUS-CONDITIONs instead of ERRORs, which would have handled CCL's VECTOR-SIZE-LIMITATION condition during printing. (safe-condition-message): Just call *sldb-condition-printer*. People who set that will know what they're doing. * swank-backend.lisp (print-condition): Replaces format-sldb-condition. Take a stream as argument so that we can pass in our stream with limited output length. No guarantee of course that this stream will be used in a reasonable way. * swank-clisp.lisp (format-sldb-condition): Deleted. Whitespace is now removed anyway. * swank-sbcl.lisp (print-condition): Use the stream argument. * slime-tests.el (report-condition-with-circular-list): Use with-standard-io-syntax to override settings from init files that any reasonable person would have. 2014-02-21 João Távora Closes #103: loading contribs does not require slime-tests or ERT. Tests are stored separately. * slime-tests.el (defun): Adapt to new contrib-tests location. (readme-recipe, traditional-recipe): Don't use ert macros in recipe tests, since ert might not be loaded. * slime.el (slime-contrib-dependencies): New function. * Makefile (contrib-check-% check-%): Restore the check- target. * .travis.yml (env): Use it. 2014-02-20 Helmut Eller Use *macroexpand-hook* in sbcl-world-lock test. This deadlocks when executed with cold dispatch caches, e.g. with: make SELECTOR=sbcl-world-lock-1 LISP=sbcl check * slime-tests.el (sbcl-world-lock): Use *macroexpand-hook*. 2014-02-19 Helmut Eller The method-combination idea doesn't fly. Can't call generic functions from SBCL compiler because of deadlocks. * swank-backend.lisp ([method-combination] interface): Deleted. (definterface, defimplementation): Restore old implementation. 2014-02-19 Helmut Eller * slime.el: Break long lines. 2014-02-19 Helmut Eller Don't bind byte-compile-warnings while autoloading 'bytecomp. * slime.el (slime--byte-compile): New function. (slime--compile-hotspots): Use it. 2014-02-19 Helmut Eller * Makefile (check): Quote selector. 2014-02-19 Helmut Eller * slime.el (slime-load-hook): Run load-hook the end. 2014-02-19 Helmut Eller Don't try to compile already compile functions. * slime.el (slime--compile-hotspots): New function. 2014-02-18 Helmut Eller Use prin1-to-string instead of with-temp-buffer. * slime.el (slime-prin1-to-string): It's simpler and avoids some of the deactivate-mark issues. 2014-02-18 Helmut Eller Create separate Makefile for contribs. * .travis.yml (env): Use contrib-% targets. (script): Use make variables instead of env vars. * Makefile (EMACS): Renamed from EMACS_BIN. (LISP): Renamed from LISP_BIN. (ELFILES, ELCFILES): New vars. (default, all, help, help-vars): New targets. (compile): Don't compile contribs. (check): Don't put contrib/ into load-path. (contrib-check-%): Renamed from check-%. (contrib-elpa-%): Renamed from elpa-%. (contrib-compile): New. 2014-02-18 Helmut Eller Use a custom method-combination for definterface. This should give better M-. support. * swank-backend.lisp ([method-combinations] interface): New (definterface, defimplementation): Use it. * swank-backend.lisp: Whitespace cleanup. 2014-02-17 Mark Evenson * swank-abcl.lisp (describe-definition): Describe macros. 2014-02-11 João Távora * slime-tests.el (slime-test-recipe-test-for): Simplify and make more powerful. (slime-test-recipe-check-repl): Removed it (readme-recipe-autoload-on-lisp-visit): Adapt to new `slime-test-recipe-test-for'. More readable. (readme-recipe, traditional-recipe): Idem. 2014-02-10 João Távora * slime.el (slime--setup-contribs): Init contribs if they've been required somewhere else and not inserted into `slime-required-modules'. 2014-02-06 João Távora * slime.el: Prefix all cl-functions with "cl-". * lib/cl-lib.el: Upgrade bundled version to 0.4. * Makefile (LOAD_PATH): Closes #101: Don't use new : (colon) feature of upcoming Emacs 24.4. * swank.asd: revert previous change by 2014-01-05 Francois-Rene Rideau until proper swank-loader-less ASDF support can be build it. It exhibits problems on ABCL and SBCL. 2014-01-24 João Távora * README.md (Emacs 23 gotchas): Remove section. * slime-tests.el (slime-test-ert-test-for): Use `define-slime-ert-test'. (slime-tests-auto-tags): Set ert tags automatically. (define-slime-ert-test): Use `slime-tests-auto-tags'. * Makefile ($(CONTRIBS:%=check-%) check): Speed up target, set SELECTOR for for these targets to '(tag contrib). 2014-01-23 João Távora * .travis.yml (env): Test the slime-repl independently from other contribs like slime-presentations. * slime.el (slime-propertize-region): Add edebug spec. 2014-01-22 João Távora * swank.lisp (inspector-nth-part): Don't break if index out of bounds, return second FOUNDP value instead. 2014-01-19 João Távora * .travis.yml (env): check less emacs 23 combinations. Pin tests to sbcl32 for now. 2014-01-13 João Távora * .travis.yml: Cleaner, more LISP combinations, but test only emacs 23 and emacs 24 on debian. * slime.el (require 'arc-mode): Replace cl-eval-when with eval-when-compile, broke in emacs 24.2. (Closes #17). 2014-01-12 Nathan Trapuzzano * .gitignore: Ignore files in top-level dist/ directory. * .gitattributes: Ignore certain files during git-archive. * .gitref: Store commit SHA-1 during git-archive. 2014-01-12 João Távora * .travis.yml (script): Make "check-fancy" to check contribs, not just core. * slime.el (require 'cl-lib): fallback to version bundled under lib/. (require 'hyperspec): look for version bundled under lib/. * slime-tests.el (traditional-recipe): New test, respect tradition. (require 'ert): Fallback to version bundled under lib/. (slime-test-recipe-connect-forms): New var refactored from previous tests. (slime-test-recipe-check-repl): New function refactored from previous tests. (readme-recipe): Refactored. * doc/slime.texi (Installation): Remove subsection "Emacs 23 gotchas". (Loading Contribs): Clarify function name to call for attempting unload and give example. * lib/hyperspec.el: Moved from top-level dir. * lib/ert.el: New file. * lib/ert-x.el: New file. * lib/cllib.el: New file. * Makefile (ensure_ert,ensure_cl_lib): Remove targets since these are bundled. (compile): Don't download cl-lib. (check): Don't download ert. (clean): Look for .elc files everywhere. * .gitignore: Ignore texinfo files. 2014-01-11 João Távora * slime-autoloads.el (lisp-mode-hook): Add `slime-lisp-mode-hook' to it. * slime-tests.el (slime-test-recipe-test-for): More generic, takes `test-forms' and `check-fn' args. Uncomment relevant parts. (readme-recipe): Adapt to new `slime-test-recipe-test-for'. (readme-recipe-autoload-on-lisp-visit): New test. * doc/slime.texi (Git Incantations): Fix typo. * Makefile (SELECTOR, OPTIONS): Respect previous value. 2014-01-10 Nathan Trapuzzano * Makefile: Build distribution under top-level directory prefix, and give it a .tar.gz suffix. 2014-01-10 João Távora * slime.el (slime-inspector-insert-chunk): Use `slime-inspector-insert-ispec-function'. Patch by Attila Lendvai. * slime-tests.el (slime-test-recipe-test-for): new function for testing setup recipes. (readme-recipe): New test; (define-slime-ert-test): New function for defining vanilla ERT tests. * slime.el: don't run `slime-load-hook'. (slime--setup-contribs): Hide from user. Idempotent. (slime-setup): Now a command. (slime-contribs): New variable. (slime-setup-contribs): Obsolete this variable to point to `slime-contribs'. (defun slime-setup-contribs): use `slime-contribs' var. * README.md: show travis build status for master branch only. (Quick setup instructions): mention `slime-autoloads' and suggest adding contribs to load path. Suggest `eval-after-load'. (Contribs): new section. (Emacs 23 gotchas): new section. (Contact): update mailing list info and link to CONTRIBUTING.md. * slime-autoloads.el: simplify with a `eval-after-load'. * slime.el: Bump version to 2.3.2 2014-01-08 João Távora * slime-tests.el (slime-test-ert-for): Use `eval-and-compile' for this function. * Makefile: New file: top level makefile, replaces mkdir.sh and test.sh. Some elpa targets available, still incomplete. * .travis.yml (script): Use "make check". * mkdir.sh: Removed file. * test.sh: Removed file. 2014-01-07 Bozhidar Batsov * CONTRIBUTING.md: Renamed from HACKING and converted to markdown. 2014-01-06 João Távora * slime.el (slime-edit-definition): Fix bug introduced by changes of 2013-12-30. Closes #78. 2014-01-05 Francois-Rene Rideau * swank.asd : Drop the calling of init after loading swank. It was using unsupported (and to-be-removed) operation-forced interface. * contrib/slime-asdf.el : Tweak some docstrings. * contrib/swank-asdf.el : Tweak some comments and docstrings, remove an obsolete #+asdf2, since we don't support ASDF 1 anymore. 2014-01-05 Syohei YOSHIDA * slime.el : Add package headers 2013-12-31 João Távora * slime-tests.el (slime-test-buffer-name): remove it (slime-batch-test): no longer output to results file. Use `ert-run-test-batch' when in batch mode. * slime.el: Fix most compilation warnings. All function-calls calls to cl.el are now correctly prefixed with "cl-". Require 'cl-lib. * test.sh: Always byte-compiles code, -L skips.it. No longer supports screen. No longer supports results and status files. (cmd): don't set `debug-on-quit'. 2013-12-30 João Távora * slime.el: move tests into slime-tests.el. Remove trailing whitespace. `lexical-binding' must appear on first line. Now attempts to work only from emacs 23 onwards. Adjust indentation. Remove trailing whitespace. (sldb-get-default-buffer): Choose default connection's sldb buffer if it exists. (slime-def-connection-var): In defsetf spec, don't evaluate `store' twice, since it may have side effects. This broke some slime-repl.el tests. (slime-edit-definition): No longer use `called-interactively-p' for known problems. (hyperspec): non-erroring `require' instead of `find-library'. (slime-next-line/not-add-newlines): Use `forward-line' instead of `next-line'. * .travis.yml (script): new file. Travis CI integration, combines emacs-23, emacs-snapshot and sbcl. Skip slime-fancy tests for now. * README: Convert to markdown. Use Travis CI badge. * Changelog: Use utf-8 coding. * test.sh (cmd): require 'slime-tests instead of 'slime. Allow regexp selectors. Remove trailing whitespace. Don't remove temp dir if tests fail. Test slime-fancy by default, -C skips it. * slime-tests.el: new file. Use ert.el framework. 2013-12-22 Luís Oliveira * swank-loader.lisp: Don't load ASDF if it's too old. 2013-12-21 João Távora * slime.el (slime-inspector-operate-on-point): allow `slime-inspector-property-at-point' to return nil, which it does when non-interactive parts are "clicked" via RET. 2013-11-20 João Távora * swank-backend.lisp (wrap, unwrap, wrapped-p): new wrapping interface with default implementation. * swank-allegro.lisp (wrap,unwrap,wrapped-p): implement wrapping interface. * swank-sbcl.lisp (wrap,unwrap,wrapped-p): implement wrapping interface * swank.lisp (*after-toggle-trace-hook*): new exported variable, defaults to nil. * swank-loader.lisp (*contribs*): add swank-trace-dialog contrib. 2013-11-17 Helmut Eller * swank-sbcl.lisp (swank-compile-string): Load the fasl file even if there were warnings. Just like the other backends do. 2013-11-10 Helmut Eller * slime.el (slime-delete-package): New command. * swank.lisp (swank-delete-package): The corresponding Swank part. 2013-11-10 Helmut Eller * swank.lisp (swank-profile-package): New wrapper for profile-package that does some input validation. * slime.el (slime-profile-package): Use it. 2013-11-01 Helmut Eller * swank-ccl.lisp (p2-definitions): Check bounds before accessing backend-p2-dispatch. 2013-11-01 Helmut Eller * swank-sbcl.lisp (swank-compile-string): Fix last commit. Honor *trap-load-time-warnings* but without calling LOAD inside WITH-COMPILATION-UNIT. 2013-10-31 Helmut Eller * swank-sbcl.lisp (swank-compile-string): Don't call LOAD inside WITH-COMPILATION-UNIT. 2013-09-29 Helmut Eller For CCL, also search definitions of p2 translators. * swank-ccl.lisp (p2-definitions): New. (find-definitions): Use it. 2013-09-29 Helmut Eller * swank-clisp.lisp (*frame-prefixes*): Update some of the patterns for new layout. (is-prefix-p): Use regexp matching. (boring-frame-p): Also make compiled-tagbody compiled-block boring. (sldb-backtrace, %parse-stack-values): Remove code for versions before 2.44. 2013-09-29 Helmut Eller For CCL, also search nx1-alphatizer definitions. * swank-ccl.lisp (alphatizer-definitions): New (find-definitions): Use it. 2013-06-26 Mark Evenson * swank-abcl.lisp (specializer-direct-methods): Correct symbol definition, allowing SLIME inspector to work again. 2013-05-26 Luís Oliveira * slime-fancy-trace.el: New contrib. * slime-parse.el (slime-trace-query): moved to slime-fancy-trace. * slime-fancy.el: load slime-fancy-trace. 2013-05-14 Martin Simmons * swank-lispworks.lisp (lispworks-severity): Fix error when using the :explain declaration. 2013-05-14 Martin Simmons * swank-lispworks.lisp (find-top-frame): Improve backtraces from swank::safe-backtrace. 2013-04-23 Stas Boukarev * slime.el (slime-draw-connection-list): Make sure not to call goto-char on NIL. 2013-04-02 Luís Oliveira Hide SWANK debugger frames on Allegro also when the error is signalled within threads different from the SLIME REPL's. E.g. (mp:process-run-function nil (lambda () (error "foo"))). * swank-allegro.lisp (find-topframe): look deeper than 11 frames. Still looking no deeper than 30 frames in the unlikely event that this function is invoked out of context with a very large stack. 2013-03-12 Helmut Eller * slime.el (slime-read-interactive-args): Use read-shell-command to enable completion. Patch by Daimrod/Greg. 2013-03-08 Mark Evenson * swank-abcl.lisp: Allow SLIME inspector to perform class finalization. 2013-03-02 Stas Boukarev * slime-autoloads.el: Don't load autoloads when slime is already loaded, there's no sense in doing so. 2013-02-20 Stas Boukarev * slime.el (slime-attempt-connection): Don't run the timer with a repeat argument, slime-attempt-connection will reinstantiate the timer if needed, otherwise it can be a possible source of race conditions. 2013-02-13 Helmut Eller * swank-allegro.lisp (eval-in-frame): debugger:frame-var-name can return nil; ignore those vars. * slime.el (sldb-setup): Allegro somehow managed to enter sldb at the same level twice. Add an assertion that checks that the condition is the same if sldb-level is the same as last time. 2013-02-08 Helmut Eller * swank-lispworks.lisp (frame-package): Implemented. (function-name-package): New. 2013-02-08 Helmut Eller * swank-allegro.lisp (handle-compiler-warning): Ignore "Closure will be stack allocated" notes. Those are harmless and there are too many of them. (pc-source-location, ldb-code-to-src-loc): Handle case when excl::ldb-code-pc returns nil. 2013-02-02 Stas Boukarev * swank-backend.lisp (type-specifier-p): New. Implement it for ACL, ECL, CCL, Clisp, SBCL, LW. 2013-01-12 Stas Boukarev * swank-backend.lisp: Add a couple of ignore declarations. 2013-01-11 Stas Boukarev * swank-ecl.lisp (accept-connection): Fix a typo, line => :line. 2013-01-11 Helmut Eller * swank.lisp (swank-compile-file*): Renamed from compile-file-with-compile-file. 2013-01-10 Helmut Eller * swank-ecl.lisp (frame-var-value): Return the value without name. 2013-01-09 Helmut Eller * swank.lisp (frame-locals-for-emacs): Print variable names in frame-package. 2013-01-09 Helmut Eller * swank-sbcl.lisp (frame-debug-vars): Only include :valid locals. (*keep-non-valid-locals*): New. (frame-package): New. 2013-01-07 Helmut Eller * swank-ccl.lisp (compiler-warning-short-message): Add a method for ccl::shadowed-typecase-clause. Whithout that we only get "Nonspecific warning". (function-name-package): Factored out from frame-package. Add case for standard-method. 2013-01-07 Helmut Eller * swank-ecl.lisp (describe-symbol-for-emacs): Include bound symbols even those without documentation. * slime.el (slime-print-apropos): Do some input validation to detect bugs on the Lisp side. * swank-backend.lisp (describe-symbol-for-emacs): Allow NIL where :NOT-DOCUMENTED was needed. 2013-01-05 Helmut Eller * swank-ccl.lisp (frame-package): Implemented. 2013-01-05 Helmut Eller * swank-loader.lisp (init): Add a :quiet argument. 2012-12-27 Stas Boukarev * swank.lisp (find-definitions-find-symbol-or-package): Rename from `find-definitions-find-symbol'. Packages are not named by symbols and an uninterned string can refer to a package. In case it finds a package, return a new uninterned symbol. 2012-12-17 Stas Boukarev * swank-ecl.lisp (swank-mop): MOP works well now on ECL, import all symbols. * swank.lisp (thread-for-evaluation): Use INTEGER, not FIXNUM, as a specializer, FIXNUM is not a standard class. 2012-12-16 Helmut Eller * swank.lisp (thread-for-evaluation): Make generic. Remove keyword arg. Don't call find-repl-thread. 2012-12-16 Helmut Eller * slime.el (slime-attempt-connection): Show the attempt counter. 2012-12-03 Stas Boukarev * swank-backend.lisp (deinit-log-output): Move from swank-sbcl, use it on CCL in ccl:*save-exit-functions* as well. * swank-allegro.lisp (macroexpand-all): USe walk-form, not walk on >= 8.2. Patch by Utz-Uwe Haus. 2012-11-23 Stas Boukarev * slime.el (slime-edit-definition): Don't ask the user for a name to search if it's missing before running slime-edit-definition-hooks (slime-open-inspector): pop-to-buffer before inserting anything, otherwise the point is not moved into the desired position. 2012-11-13 Francois-Rene Rideau * swank.lisp (*compile-file-for-emacs-hook*): A hook for compile-file-for-emacs, so that ASDF can hook its compilation functions. 2012-11-12 Stas Boukarev * swank.lisp (with-panic-handler): Abort the condition after closing the connection, otherwise it ends up in the slime debugger causing nested errors. 2012-11-11 Stas Boukarev * swank.lisp (interrupt-worker-thread): Solve *send-counter* binding problem. find-worker-thread: Merge with `thread-for-evaluation'. 2012-11-11 Helmut Eller * slime.el ([test] find-definition.3): Mark as expected to fail. ([test] arglist): Adjust regexp so that CCL passes. (slime-execute-tests): Insert summary table at the the end. (slime-check): Don't change counters here, as that would count multiple times per test. Instead to the counting in slime-execute-tests. 2012-11-11 Helmut Eller * swank-allegro.lisp (ldb-code-to-src-loc): Scan backward to the first code point with a non-nil start-char. (frame-package): Also match for ((:internal foo ...)). 2012-11-08 Helmut Eller * slime.el (slime-timer-call): Use debug marker in condition-case. 2012-11-02 Helmut Eller * slime.el (find-definition.3): Fix syntax. 2012-11-02 Helmut Eller * swank.lisp (condition-message): New. Binds *print-cirlce. (safe-condition-message): Move binding of printer vars to condition-message. (*sldb-condition-printer*): Set it to #'condition-message. 2012-11-02 Helmut Eller * swank-allegro.lisp (frame-source-location, ldb-code-to-src-loc): Use function-source-location for some cases that used to cause errors. (frame-package): New. (format-sldb-condition, call-with-syntax-hooks): Deleted. Did just the same as the default implementation. 2012-11-02 Helmut Eller * slime.el ([test] find-definition): Test defstruct and defvar. ([test] find-definition.3): New. 2012-10-30 Helmut Eller * swank-cmucl.lisp (dd-location): Use info db as fallback. (struct-constructor): Return the name not the function. 2012-10-27 Helmut Eller * slime.el (report-condition-with-circular-list): New test. * swank.lisp (safe-condition-message): Bind *print-length* and truncate the string after 64KB. 2012-10-20 Stas Boukarev * slime.el (slime-location-offset): When going to a position causes an error, for example, trying to move beyond the end of the buffer, move the point to 0 and then try to use the hints. 2012-10-14 Helmut Eller * slime.el (slime-insert-threads): Some cleanups. (slime-insert-table, slime-insert-table-row) (slime-transpose-lists) New helpers. (slime-threads-table-properties): Renamed from *slime-threads-table-properties* (slime-thread-index-to-id, slime-longest-lines) (slime-format-threads-labels, slime-insert-thread): Deleted. 2012-10-14 Helmut Eller Avoid some unused variable warnings. * slime.el (slime-xref-group, slime-all-contribs, [selector] ??): Use _ as prefix or in loop-destructuring: (loop for (nil) in ...). 2012-10-14 Helmut Eller * slime.el (slime-goto-source-location-buffer-and-file): Delete unused function. 2012-10-14 Helmut Eller Avoid flet. * slime.el (with-struct, slime-compute-policy) (slime-create-note-overlay, slime-merge-note-into-overlay) (slime-file-name-merge-source-root) (slime-highlight-differences-in-dirname) (slime-check-location-filename-sanity, slime-macroexpand-undo) (slime-read-connection) (slime-inspector-property-at-point): Use macrolet or a comibination of let and funcall as replacement for flet. 2012-10-14 Helmut Eller Avoid labels. * hyperspec.el (hyperspec--get-one-line): New function. 2012-10-14 Helmut Eller * swank.lisp (close-connection%): Let *debugger-hook* be nil across the entire function to that we don't call our own debugger if we ever get some error during CLOSE or somesuch. 2012-09-04 Stas Boukarev * swank-loader.lisp (lisp-version-string): Add "s" to Allegro with SMP support. Patch by Dave Cooper. 2012-08-18 Stas Boukarev * swank-abcl.lisp (find-definitions): Call ext:resolve before finding definitions, for the symbol may be not autoloaded yet. 2012-08-04 Stas Boukarev * swank-sbcl.lisp (call-with-debugging-environment): Use sb-debug::resolve-stack-top-hint instead of just sb-debug:*stack-top-hint*, because now it can contain things other than just frames. * clean up: (signal (make-condition ...)) => (signal ...) 2012-07-13 Helmut Eller * slime.el: Don't compile functions that are now in other files. 2012-06-19 Helmut Eller * swank-ecl.lisp (wait-for-input): Provide implementation that doesn't need serve-event. 2012-06-12 Stas Boukarev * slime.el (slime-changelog-date): Use (expand-file-name "ChangeLog" slime-path) instead of (concat slime-path "ChangeLog"), slime-path may not have a trailing /. Reported by Paul Sexton (lp#1011935). 2012-05-25 Stas Boukarev * slime.el (slime-oneliner): Use minibuffer width instead of the width of the current frame, minibuffer can be in a separate frame with a different width. Patch by Greg Pfeil (lp#1004252). 2012-05-21 Helmut Eller Reduce dependecy on pre-defined faces. * slime.el (slime-apropos-symbol, slime-apropos-label): New faces. (slime-print-apropos): Use them. Reported by: Daimrod 2012-05-12 Helmut Eller * swank-sbcl.lisp (stream-force-output): Undo last few changes. 2012-05-11 Helmut Eller * swank-sbcl.lisp (stream-force-output): Use with-world-lock i.e. with-recursive-lock instead of with-mutex. * slime.el (sbcl-world-lock): New test. 2012-05-11 Helmut Eller * swank-sbcl.lisp (stream-force-output): Don't use with-deadline. Grab the world-lock instead. (condition-timed-wait): Use the :timeout argument for real. 2012-05-11 Helmut Eller * swank-backend.lisp (call-with-io-timeout): Not used. Deleted. * swank-sbcl.lisp (call-with-io-timeout): Deleted. 2012-05-07 Helmut Eller Ignore linebreaks for the macroexpand test. SBCL should now also pass it. * slime.el (slime-test-macroexpansion=): New function. ([test] macroexpand): Use it. 2012-05-06 Helmut Eller * swank-sbcl.lisp (condition-timed-wait): Undo previous change. The :timeout arg doesn't seem ready for production use. 2012-05-06 Helmut Eller * swank-sbcl.lisp (condition-timed-wait): Use the :timeout argument of sb-thread:condition-wait if supported. 2012-05-06 Helmut Eller * swank-sbcl.lisp (with-definition-source): Forgot to commit this one. * swank-allegro.lisp (string-to-utf8): Set the :null-terminate argument of excl:string-to-octets to nil. 2012-05-06 Helmut Eller * swank-backend.lisp (with-struct): Undo damage. * swank-sbcl.lisp (with-definition-source): New macro. 2012-05-06 Helmut Eller * swank.lisp, swank-rpc.lisp: iso-8859-1 is not same as latin-1-unix. 2012-05-06 Cyrus Harmon Helmut Eller * slime.el (slime-pprint-eval-region): New command. No keybinding though. 2012-05-04 Nikodemus Siivola * swank-sbcl.lisp: Remove the SB-C::MERGE-TAIL-CALLS proclamation. It does nothing, and never did, actually. 2012-05-03 Stas Boukarev * slime.el (slime-goto-source-location): Allow for :buffer-and-file locations, prefer buffer if the buffer exists. * swank-sbcl.lisp (definition-source-for-emacs): Send :buffer-and-file when both are available. (quit-lisp): Use sb-ext:exit when it's present. 2012-05-03 Stas Boukarev * swank.lisp (find-definitions-find-symbol): Put back accidentally removed with-buffer-syntax. 2012-05-02 Stas Boukarev * swank.lisp (*find-definitions-right-trim*) (*find-definitions-left-trim*): New variables. ",:." and "#:" default values. (find-definitions-for-emacs): Trim names with using the above variables when a symbol is not found. 2012-05-01 Stas Boukarev * slime.el (slime-xrefs-for-notes): Format location in a proper way. Reported by Max Mikhanosha. 2012-04-27 Nikodemus Siivola * swank-sbcl.lisp (lisp-source-location): How hard can it be to get this right? (3-legged IF, FFS!) 2012-04-24 Douglas Crosher * swank-scl.lisp (create-socket): correct variable name typo. * swank.lisp, swank-rpc.lisp (file options): use #\; to separate the file options. 2012-04-23 Christophe Rhodes * slime.el (slime-operator-before-point-function): new variable. (slime-operator-before-point): use it. (slime-lisp-operator-before-point): default implementation for slime-operator-before-point-function (unchanged from before). 2012-04-20 Nikodemus Siivola * swank-sbcl.lisp (stream-force-output :around): Workaroud for deadlocks between auto-flush-thread buffer write lock and world lock. (slime-output-stream): Dummy forward definition for the benefit of the defmethod. 2012-04-20 Nikodemus Siivola * swank-sbcl.lisp (swank-value): New function, makes it easy to refer to variables in SWANK -- which doesn't exist when the backend is loaded. (lisp-source-location): One of the strings being interned was downcased. Fix using SWANK-VALUE. (make-socket-io-stream): Use SWANK-VALUE instead of INTERN & SYMBOL-VALUE. 2012-04-11 Helmut Eller * slime.el ([test] utf-8-source): Use the encoded byte sequence of the Unicode string. 2012-04-10 Stas Boukarev * slime.el (def-slime-test utf-8-source): Define only when (and (featurep 'emacs) (>= emacs-major-version 23)). 2012-04-10 Stas Boukarev * slime.el (def-slime-test utf-8-source): Another try at fixing utf8 literals in code. 2012-04-09 Stas Boukarev * slime.el (def-slime-test utf-8-source): Remove literal Unicode characters in the form of \xFFFF, it causes problems for some people. 2012-04-07 Helmut Eller Fix long lines. * swank.lisp: * slime.el: * ChangeLog: * swank-cmucl.lisp: * swank-lispworks.lisp: * contrib/ChangeLog * hyperspec.el * metering.lisp * swank-abcl.lisp * swank-allegro.lisp * swank-backend.lisp * swank-clisp.lisp * swank-corman.lisp * swank-ecl.lisp * swank-sbcl.lisp * swank-scl.lisp * swank-source-path-parser.lisp * xref.lisp 2012-04-06 Stas Boukarev * swank.lisp (interrupt-worker-thread): Interrupt the REPL thread if there are no threads found. Send Emacs an error message if no threads are found at all. 2012-03-30 Nikodemus Siivola * swank-sbcl.lisp (lisp-source-location): When processing a STEP-FORM-CONDITION, don't show the initial form from expansion of STEP. (Currently SBCL doesn't give the form at all, but when it does seeing it is distinctly useless.) 2012-03-26 Helmut Eller * slime.el (utf-8-source): XEmacs has no set-buffer-multibyte. (slime-create-test-results-buffer): Set file-coding-system. * swank-lispworks.lisp (swank-compile-string): Don't include the source-string in the dspec::*location*. As LW has the habbit to print the entire *location* on redefinition the source-string would causes troubles for the test case. * swank-sbcl.lisp (swank-compile-string): Use utf8. * swank-cmucl.lisp (swank-compile-file): Use external-format arg. * swank-ccl.lisp (swank-compile-string, compile-temp-file): Use utf8. * slime.el (utf-8-source): New test case. 2012-03-14 Paulo Madeira Use Unix-EOL convention even on Windows. * swank-allegro.lisp (string-to-utf8, utf8-to-string): Use excl:crlf-base-ef. * swank-lispworks.lisp (string-to-utf8, utf8-to-string): Use '(:utf-8 :eol-style :lf) 2012-03-06 Helmut Eller * swank-ccl.lisp: If 'xref is not provided warn about it but continue. 2012-03-06 Helmut Eller Fix SBCL backend for Windows. * swank-sbcl.lisp (fd-stream-input-buffer-empty-p): Restore it. 2012-03-06 Helmut Eller * swank.lisp (swank-require): Ensure that provide as called. 2012-02-12 Stas Boukarev * swank-ecl.lisp (accept-connection): Use the proper element-type for the stream. 2012-02-12 Stas Boukarev * swank-clisp.lisp (c-error): The number of parameters to sys::c-warn was changed, accommodate both versions. 2012-02-07 Martin Simmons * swank-lispworks.lisp (dspec-file-position): Fall back to regexp search if dspec-stream-position gets an error. 2012-01-06 Helmut Eller Add a "sentinel thread" to protect access to global lists. * swank.lisp (start-sentinel, sentinel, send-to-sentinel) (sentinel-serve, sentinel-stop-server, sentinel-maybe-exit): New. (make-connection, close-connection, setup-server, stop-server): Use the sentinel. (close-connection%): Factored out. * swank-backend.lisp (register-thread, find-registered): New. * swank-allegro.lisp: Implement it. * swank-ccl.lisp: * swank-lispworks.lisp: * swank-sbcl.lisp: 2012-01-02 Stas Boukarev * swank-loader.lisp (lisp-version-string): Append -no-threads to SBCL without threads. 2011-12-24 Stas Boukarev * slime.el (slime-init-command): Don't call `slime-to-lisp-filename', the lisp is not yet connected and if there's another connection it will use the wrong translation. 2011-12-24 Stas Boukarev * swank.lisp (throw-to-toplevel): If *sldb-quit-restart* is not found, try to invoke the last restart, which usually is a top-level abort restart. This is useful when the debugger is invoked from a non-slime thread. 2011-12-23 Stas Boukarev * slime.el (slime-cycle-connections): Add `slime-cycle-connections-hook', to be used by slime-repl. 2011-12-21 Stas Boukarev * swank-sbcl.lisp (input-ready-p): Don't use sb-impl::fd-stream-fd-type if it's not present. 2011-12-12 Stas Boukarev * slime.el (slime-compile-region): Run slime-flash-region directly, not from `slime-before-compile-functions', which is run also for C-c C-k. 2011-12-10 Helmut Eller * swank.lisp (auto-flush-loop): Don't use call-with-io-timeout. Removing it had no effect on the number of failed tests. If you want it back, first create a test case to demonstrate the problem. * swank-backend.lisp: Mention that locks should only be used in swank-gray.lisp. 2011-12-10 Helmut Eller * swank.lisp: Move io-redirection to contrib/swank-repl.lisp. 2011-12-10 Helmut Eller Make *active-threads* a slot of the connection struct. * swank.lisp (*active-threads*): Deleted ([struct] multithreaded-connection): New slot active-threads. (find-worker-thread, interrupt-worker-thread) (thread-for-evaluation): Update accordingly. (add-active-thread, remove-active-thread): New helpers. 2011-12-10 Helmut Eller * swank-loader.lisp (delete-stale-contrib-fasl-files): New. (compile-contribs): Use it. 2011-12-09 Helmut Eller Create an extra thread for the indentation cache. * swank.lisp (indentation-cache-loop): New. ([struct] multithreaded-connection): New slot indentation-cache-thread. (control-thread, cleanup-connection-threads): Create/kill it. (send-to-indentation-cache): New function. (update-indentation-information, sync-indentation-to-emacs): Use it. (perform-indentation-update, update-indentation/delta-for-emacs): Add package as argument; that used to be *buffer-package. Can again be simpler as the indentation-cache-thread doesn't share the cache with others. (handle-indentation-cache-request, symbol-packages): New helpers. 2011-12-07 Helmut Eller * swank.lisp (*slime-interrupts-enabled*): Describe the idea behind the interrupt handling code a bit. 2011-12-07 Helmut Eller Make *event-queue* and *events-enqueued* slots of the connection struct. * swank.lisp (*event-queue*, *events-enqueued*): Deleted ([struct] singlethreaded-connection): New slots event-queue and events-enqueued. (poll-for-event, send-event, wait-for-event/event-loop): Update accordingly. 2011-12-07 Helmut Eller * slime.el ([xemacs]): Use (find-coding-system 'utf-8-unix) instead of checking the XEmacs version to decide when 'un-define is required. 2011-12-07 Helmut Eller * swank.lisp (send-to-emacs): Add a without-slime-interrupts to protect send/receive from arbitrary interrupts. 2011-12-07 Helmut Eller Move flow control from dispatch-event to send-to-emacs. * swank.lisp (*send-counter*): New thread local variable. (with-connection): Bind it. (send-to-emacs): Call maybe-slow-down. (maybe-slow-down, ping-pong): Go through dispatch-event instead of writing to the socket directly. (dispatch-event): Re-add thread arg to :ping/:emacs-pong. Also add a :test-delay event. (perform-indentation-update): Use with-connection to bind *emacs-connection* and *send-counter*. (background-message): Remove reference to connection.slowdown. (flow-control-test): New support code for testing flow-control. ([defstruct] connection): Delete send-counter and slowdown slots. * slime.el (slime-dispatch-event): Re-add thread arg to :ping/:emacs-pong and :test-delay event. ([test] flow-control): New test. 2011-12-07 Helmut Eller * slime.el (slime-update-system-indentation): Moved to contrib/slime-indentation.el. 2011-12-07 Helmut Eller * slime.el (slime-batch-test): Forgot to rename slime-run-one-test to slime-run-test here. (slime-net-connect): Remove coding-system argument. (slime-xref-insert-recompilation-flags): Use insert-char instead of (dotimes (i ..) (insert " " ..)) to avoid the compiler warning. ([test] break, slime-forward-sexp): Use _i in dotimes. 2011-12-07 Stas Boukarev * doc/.cvsignore: Add html.tgz 2011-12-07 Didier Verna * doc/.cvsignore: Add more files generated by Texinfo (.kys, .fns and .vrs). 2011-12-05 Didier Verna * slime.el ([xemacs]): Don't require 'un-define in XEmacs 21.5 and later. Mule-UCS is not needed anymore because of internal Unicode support (and conflicts with it). 2011-12-06 Stas Boukarev * slime.el (slime-compile-region): Check connection before running hooks, invoking slime-flash-region doesn't make much sense when there's no connection. 2011-12-05 Helmut Eller Move flow control into dispatch-event. * swank.lisp (maybe-slow-down, ping-pong): New functions. (dispatch-event): Use it. Also require connection argument. Update callers accordingly. ([defstruct] connection): New slots: send-counter and slowdown. * slime.el (slime-dispatch-event): Drop thread from :ping/:emacs-ping messages. Use subclasses of connection. Wasn't neccessary for flow control but seems like a good idea for the future. * swank.lisp (multithreaded-connection) (singlethreaded-connection): New (make-connection): Create multi/single threaded variant depending on style argument. ([defstruct] serve-requests, cleanup): Delete slots. Dispatch on connection type instead. (stop-serving-requests): New. (close-connection): Use it. Can't use *use-dedicated-output-stream* here. * swank.lisp (background-message): Do nothing if connection.slowdown is set. 2011-12-05 Helmut Eller * slime.el ([test] arglist): swank::create-server now has an optional argument. Use swank::compute-backtrace instead. 2011-12-05 Stas Boukarev * start-swank.lisp: Remove :coding-system argument. 2011-12-04 Helmut Eller * swank.lisp (interrupt-worker-thread): Don't use find-repl-thread as fallback. 2011-12-04 Helmut Eller * swank.lisp: Minor cleanups. * swank-rpc.lisp: 2011-12-04 Helmut Eller * swank.lisp (create-repl): Moved to contrib/swank-repl.lisp. (*use-dedicated-output-stream*, *dedicated-output-stream-port* (*dedicated-output-stream-buffering*, open-streams) (make-output-function, send-user-output) (make-output-function-for-target, make-output-stream-for-target) (open-dedicated-output-stream, find-repl-thread) (spawn-repl-thread, repl-loop, initialize-streams-for-connection) (read-user-input-from-emacs, *listener-eval-function*) (listener-eval, *send-repl-results-function*, repl-eval) (clear-repl-variables, track-package, send-repl-results-to-emacs) (redirect-trace-output); * swank-loader.lisp (*contribs*): Add swank-repl. 2011-12-04 Helmut Eller * swank-loader.lisp (*contribs*): Add swank-mrepl. 2011-12-04 Helmut Eller * swank-rpc.lisp (read-chunk): Signal end-of-file we had no input. 2011-12-03 Nikodemus Siivola * swank-sbcl.lisp (wait-for-input): Another go at this. Rip out POLL, build on top of just INPUT-READY-P. (input-ready-p): Outside Windows, use SYSREAD-MAY-BLOCK-P to check. 2011-12-03 Gábor Melis * swank-allegro.lisp (set-default-initial-binding): In 9.0 alpha, *CL-DEFAULT-SPECIAL-BINDINGS* is [soon to be] deprecated. It's otherwise the same EXCL:*REQUIRED-TOP-LEVEL-BINDINGS* (i.e. no change in behavior). 2011-12-03 Helmut Eller * swank-clisp.lisp (wait-for-input): Add a version for windows. 2011-12-02 Stas Boukarev * swank-sbcl.lisp (wait-for-input): Define only if #+os-provides-poll or #+win32. 2011-12-02 Helmut Eller * swank.lisp (listener-channel): Moved to contrib/swank-mrepl.lisp (create-listener, initial-listener-bindings, spawn-listener-thread). 2011-12-01 Helmut Eller * swank-sbcl.lisp (wait-for-input): Call poll(2). * swank-backend.lisp (wait-for-streams, wait-for-one-stream): Deleted. Wouldn't work on binary streams. 2011-12-01 Helmut Eller * swank-loader.lisp (*contribs*): Add swank-util. 2011-12-01 Helmut Eller * swank-cmucl.lisp (method-location): Special case accessors. 2011-11-29 Helmut Eller * swank.lisp (do-symbols*, classify-symbol) (symbol-classification-string): Moved to contrib/swank-util.lisp. 2011-11-29 Helmut Eller * swank.lisp (to-line): Increase default limit to 512. (frame-locals-for-emacs): Let *print-right-margin* override default line width. 2011-11-27 Helmut Eller * swank.lisp (create-server): Add a :backlog argument. (setup-server): Pass it along. * swank-backend.lisp (create-socket): Backlog argument. * swank-abcl.lisp: Implement it. * swank-allegro.lisp: * swank-ccl.lisp: * swank-clisp.lisp: * swank-cmucl.lisp: * swank-corman.lisp: * swank-ecl.lisp: * swank-lispworks.lisp: * swank-sbcl.lisp: * swank-scl.lisp: 2011-11-27 Helmut Eller * swank-cmucl.lisp (make-socket-io-stream): Create character stream if external-format is non-nil. 2011-11-27 Helmut Eller * swank.lisp (create-server): Remove coding-system argument. ([defstruct] connection): Remove coding-system slot. (connection.external-format, *coding-system*): Deleted. (make-connection, start-server, create-server, setup-server) (accept-connections): Drop coding-system arg. (connection-info): Return supported coding systems. (create-repl, open-dedicated-output-stream) (open-streams, initialize-streams-for-connection): Add coding-system arg. * slime.el (slime-init-command): Ignore the coding-system arg. (slime-connection-coding-systems): New connection variable. (slime-set-connection-info): Set it. 2011-11-27 Helmut Eller * swank.lisp (eval-in-frame-aux): Don't bind *package* during eval. 2011-11-21 Helmut Eller * swank-cmucl.lisp: Trigger compilation of utf8 stuff before first real use. 2011-11-21 Helmut Eller * swank.lisp (*sldb-printer-bindings*): Removed. Rather useless since the change from 2009-02-26. It could at best have some influence on the way conditions are printed. *sldb-string-length* and *sldb-bitvector-length* where both nil so *sldb-pprint-dispatch-table* was also not used by default. In summary, spending 3 pages for something that's not used by default was pretty silly. One variable less where we can get the defaults wrong. 2011-11-21 Helmut Eller * slime.el (sldb-eval-in-frame): Try to figure the package out. Ask Lisp if the function for frame was defined in a particular package and use it to read the form. (sldb-read-form-for-frame): New helper. * swank-backend (frame-package): New. * swank-cmucl (frame-package): Implement it. * swank.lisp (frame-package-name, eval-in-frame-aux): New. (eval-string-in-frame, pprint-eval-string-in-frame): Use package argument. 2011-11-19 Nikodemus Siivola * swank-sbcl.lisp (restart-frame): Make it possible to restart frames of anonymous functions -- at least some of the time. 2011-11-16 Stas Boukarev * swank.lisp (open-dedicated-output-stream): Open a stream with the right coding system. Change (:open-dedicated-output-stream port) message to (:open-dedicated-output-stream port coding-system), because Emacs can no longer determine the coding system based on the main network streams since they are binary now. 2011-11-11 Anton Kovalenko * slime.el (slime-ed): add bytep argument to destructure-case. When it's true, position is interpreted as byte offset. 2011-11-08 Helmut Eller Restore old header format. * swank-rpc.lisp (parse-header, write-header) * slime.el (slime-net-decode-length, slime-net-encode-length) 2011-11-06 Helmut Eller * swank-ecl.lisp (accept-connection): Fix buffering arg. * swank-cmucl.lisp (accept-connection): Fix buffering arg. 2011-11-06 Helmut Eller * slime.el (slime-run-test): Renamed from slime-run-one-test. (slime-toggle-test-debug-on-error): New. ([test] break): Longer timeouts. 2011-11-06 Helmut Eller Add portable versions for string-to-utf8 and utf8-to-string. * swank-backend.lisp (default-string-to-utf8) (default-utf8-to-string): New. (string-to-utf8, utf8-to-string): Use default implementations. * swank-lispworks.lisp (make-flexi-stream): Restored. (utf8-stream): Deleted. The utf8 stuff is now used for the default implementation of utf8-to-string and would cause name clashes. 2011-11-06 Helmut Eller * swank-allegro.lisp (swank-compile-string): For reader errors return nil not (values nil nil t). 2011-11-06 Helmut Eller New wire format. Switch from character streams to binary streams. Counting characters was error prone because some Lisps use utf-16 internally and so READ-SEQUENCE can't be used easily. The new format looks so: | byte0 | 3 bytes length | | ... payload ... | The playload is an s-exp encoded as UTF-8 string. byte0 is currently always 0; other values are reserved for future use. * swank-rpc.lisp (write-message): Use new format. (write-header, parse-header, asciify, encoding-error): New. * swank.lisp (accept-connections): Create a binary stream. (input-available-p): Can't read-char-no-hang on binary streams. * slime.el (slime-net-connect): Use binary as coding system. (slime-net-send, slime-net-read, slime-net-decode-length) (slime-net-encode-length, slime-net-have-input-p): Use new format. (slime-unibyte-string, slime-handle-net-read-error): New. (featurep): Require 'un-define for XEmacs. * swank-sbcl.lisp (input-ready-p): Use sb-sys:wait-until-fd-usable. 2011-11-06 Helmut Eller * swank.lisp (close-connection): Fix thinko. 2011-11-06 Helmut Eller * swank-backend.lisp (accept-connection): Improve docstring. In particular say that we want a binary stream if the EXTERNAL-FORMAT argument is nil. * swank-abcl.lisp (accept-connection): Make it so. * swank-clisp.lisp (accept-connection): Make it so. * swank-cmucl.lisp (accept-connection): Make it so. * swank-lispworks.lisp (accept-connection): Make it so. * swank-sbcl.lisp (accept-connection): Make it so. * swank-scl.lisp (accept-connection): Make it so. 2011-11-06 Helmut Eller * swank-backend.lisp (utf8-to-string, string-to-utf8): New. * swank-sbcl.lisp (string-to-utf8, string-to-utf8): Implemented. * swank-lispworks.lisp (string-to-utf8, string-to-utf8): Implemented. * swank-cmucl.lisp (string-to-utf8, string-to-utf8): Implemented. * swank-clisp.lisp (string-to-utf8, string-to-utf8): Implemented. * swank-ccl.lisp (string-to-utf8, string-to-utf8): Implemented. * swank-allegro.lisp (string-to-utf8, string-to-utf8): Implemented. * swank-abcl.lisp (string-to-utf8, string-to-utf8): Implemented. (octets-to-jbytes, jbytes-to-octets): New helpers. 2011-11-03 Helmut Eller * swank.lisp (close-connection): Be more careful with non-ascii. 2011-11-03 Helmut Eller Remove dependecy on FLEXI-STREAMS for Lispworks. * swank-lispworks.lisp (make-flexi-stream): Deleted. (utf8-stream): New class to do the transcoding. (accept-connection): Use it. 2011-10-19 Andrew Myers * swank-allegro.lisp (frob-allegro-field-def): Add missing type to ecase for inspector. 2011-10-13 Helmut Eller * swank.lisp (all-completions): Remove mixed case syms e.g |Foo|. "fo" is not a prefix of "|Foo|" and it would be problematic later. 2011-10-05 Stas Boukarev * swank.lisp (clear-repl-variables): New functions, clears *, /, and + variables. 2011-09-28 Stas Boukarev * slime.el: Remove (require 'hideshow), it's not used anymore. Spotted by Leo Liu. 2011-09-27 Mark Evenson * swank-abcl.lisp (describe-symbol-for-emacs): Differentiate between function, generic function, special forms, and macros by copying SBCL implementation. 2011-09-13 Christophe Rhodes * slime.el (slime-simple-complete-symbol): only display "Complete but not unique" message if the partial completion figures in the completion list. 2011-08-31 Anton Kovalenko * swank-sbcl.lisp (preferred-communication-style): check for :sb-thread before :win32, so :spawn is preferred for threaded Windows builds. 2011-08-31 Nikodemus Siivola * swank-sbcl.lisp (make-socket-io-stream): Backwards compatibility with SBCL < 1.0.42.43 -- and bugfix. 2011-08-26 Mark Evenson * swank-abcl.lisp (class-slots): Use exported symbol allowing classes with non-standard metaobjects to be inspected. 2011-08-18 Helmut Eller Fix line numbers for compiler notes if is narrowing was in effect. * slime.el (slime-canonicalized-location): Widen before calling line-number-at-pos. 2011-08-17 Stas Boukarev * swank-allegro.lisp (with-redirected-y-or-n-p): Fix modern-mode issues. Patch by Andrew Myers. 2011-08-09 Nikodemus Siivola * swank-sbcl.lisp (make-socket-io-stream): Use :SERVE-EVENTS T when using :FD-HANDLER as the communication style. SBCL will soon stop serving events by default on socket streams. 2011-08-08 Helmut Eller * slime.el (slime-unintern-symbol): New command. * swank.lisp (unintern-symbol): Lisp-side implementation. 2011-07-03 Nikodemus Siivola * swank-sbcl.lisp (debug-var-info): New function: calls SB-DI::DEBUG-VAR-INFO when available. (frame-locals, frame-var-value): Treat more-context and more-count vars specially. 2011-06-21 Nikodemus Siivola * swank.lisp (*indentation-cache-lock*): Deleted. (perform-indentation-update): Spawn a new thread to handle the indentation update when using threads. Move cache-clearing to UPDATE-INDENTATION/DELTA-FOR-EMACS. Replace the old cache by the one returned from U-I/D-F-E. (update-indentation/delta-for-emacs): When clearing the cache, allocate a new table. When threads are being used, copy the cache before mutation, to ensure that caches possibly seen by other threads are write-only by then. 2011-06-18 Nikodemus Siivola * swank.lisp (*indentation-cache-lock*): New variable: hash-table updates aren't necessarily thread-safe. (perform-indentation-update, update-indentation/delta-for-emacs): Grab the lock when necessary -- in delta-for-emacs we hold on to it a bit longer than necessary, but the code is easier to read this way. 2011-06-16 Nikodemus Siivola * swank.lisp (macro-indentation): Restore the old simple version. * swank-sbcl.lisp (compiling-from-buffer-p): PROBE-FILE to handle cases there the tmp-directory is a symlink. (compiling-from-file-p): Ditto. 2011-06-14 Nikodemus Siivola * swank-backend.lisp (call-with-io-timeout): New DEFINTERFACE. * swank-sbcl.lisp (call-with-io-timeout): DEFIMPLEMENTATION for it. * swank.lisp (auto-flush-loop): Call FINISH-OUTPUT using CALL-WITH-IO-TIMEOUT to prevent deadlocks. * swank.lisp (macro-indentation): Fix handling of lambda-list keywords other than &rest and &body. * slime.el (slime-update-system-indentation): Remove stale specs from common-lisp-system-indentation when new one arrives. 2011-06-10 Nikodemus Siivola * swank.lisp (macro-indentation): Walk the lambda-list to construct a better indentation spec instead of just looking for &BODY. 2011-06-09 Nikodemus Siivola * swank-sbcl.lisp (execv): Stupid SBCL hackers breaking backwards compatibility again: SB-POSIX:SYSCALL-ERROR has a required argument in 1.0.49, but accepts no arguments in older ones. Use plain ERROR instead. Support for per-package derived indentation, when slime-indentation is used. * swank.lisp (update-indentation/delta-for-emacs): Tell Emacs which packages the symbol is available in. Unless slime-indentation is used, this information is just dropped on the floor. * slime.el (slime-update-system-indentation): New function. Use this to inform indentation about derived specs when `common-lisp-system-indentation' is bound. (slime-handle-indentation-update): Adjust to support per-package derived indentation specs when slime-indentation is available. 2011-05-27 Helmut Eller Fix "wrong number of args" problem with slime-inspector-quit. Reported by Anton Kovalenko. * slime.el (slime-popup-buffer-quit-function) (slime-quit-threads-buffer): Drop the kill-buffer-p argument. 2011-05-24 Helmut Eller * slime.el (destructure-case): Fix "`_' not left unused" warnings. Insert an (ignore) form for empty bodies; this inhibts the compiler transformation that leads to the spurios warning. This has no runtime cost in compiled code, since the compiler recognizes (ignore) and emits no code for it. (slime-flatten-tree): Deleted. No longer used. 2011-05-23 Stas Boukarev * swank.lisp (sdlb-print-condition): New (or old new) function. It was bound by P in sldb-mode, but for some reason it was lost. 2011-05-23 Helmut Eller * slime.el (slime-apropos-label-properties): Deleted. Just auto-load apropos-mode. (slime-print-apropos): Use the variable apropos-label-face which seems to exist in all relevant Emacsen. 2011-05-22 Helmut Eller Turn on lexical-binding for slime.el. This mostly involves prefixing unused variables with underscores to shut up the compiler, but also some less harmless changes. * slime.el (slime-dispatching-connection, slime-current-thread): Add defvars. (slime-connect): called-interactively-p wants 1 arg in Emacs 24 but none in Emacs 22. So we can't use it; instead add an extra optional arg and set that to non-nil in the interactive spec. (slime-read-from-minibuffer): Actually use the history arg. (slime-inspector-quit): Drop the unused kill-buffer arg from the lambda-list. (slime-run-tests): Can't specbind slime-repl-history-file without variable declation. I don't want to declare it here so I just eliminated it and let somebody else fix slime-repl.el. 2011-05-21 Helmut Eller Minor tweaks to avoid some compiler warnings. * slime.el (slime-modeline-string, slime-buffer-connection): Declare variables. (slime-flatten-tree): Helper function. (destructure-case): Use it, and make '_ ignorable if it occurs in some pattern. (slime-connect): Avoid obsolete functions: string-to-int -> string-to-number interactive-p -> called-interactively-p (slime-complete-maybe-restore-window-configuration) last-command-char -> last-command-event completion-base-size -> completion-base-position (slime-xref-mode-map): Use call-interactively when calling the remapped next-line/previous-line commands. 2011-05-09 Nikodemus Siivola * swank-sbcl.lisp (swank-compile-string): Use :SOURCE-NAMESTRING to provide the name of the actual source file, and :ALLOW-OTHER-KEYS for compatibility with pre-1.0.48.1 versions. This allows SBCL to get uninteresting redefinition muffling right. (*trap-load-time-warnings*): Default to T to make the redefinition notes more visible, especially now that redefinition muffling hides the boring ones. 2011-05-08 Nikodemus Siivola * slime.el (slime-intern-indentation-spec): New function. Converts strings in an indentation spec to symbols. (slime-handle-indentation-update): Intern the indentation spec using slime-intern-indentation-spec, so that lisp side can pass complex indentation specs. * contrib/swank-indentation.lisp (application-indentation-hint): Downcase symbol names -- any symbol in an indentation spec is pretty much guaranteed to have a lowecase name on the Emacs side. 2011-04-16 Stas Boukarev * slime.el (slime-load-failed-fasl): New variable. Accepts `ask', `always', and `never' symbols. Loads or not loads fasls produced by compile-file which returned non-nil failure-p. 2011-04-14 Stas Boukarev * swank.lisp (list-threads): Call `use-threads-p' only when *emacs-connection* is non-nil. `use-threads-p' wouldn't work in this case, and there is no need to remove a worker thread from the list if it's not connected. This fixes an issue with calling swank:stop-server when slime isn't connected. 2011-03-13 Stas Boukarev * swank.lisp (format-restarts-for-emacs): Add without-printing-errors around restart printing. 2011-03-09 Helmut Eller Remove slime-sexp-at-point-for-macroexpansion. * slime.el (slime-sexp-at-point-for-macroexpansion): Deleted. (slime-eval-macroexpand): Use slime-sexp-at-point instead. (slime-eval-macroexpand-inplace): Use slime-bounds-of-sexp-at-point directly. 2011-03-09 Helmut Eller Move some of the logic from slime-sexp-at-point-for-macroexpansion into slime-sexp-at-point. * slime.el (slime-bounds-of-sexp-at-point): New. Special case if we are at '( as slime-sexp-at-point-for-macroexpansion does. (slime-bounds-of-symbol-at-point): New. (slime-symbol-at-point, slime-sexp-at-point): Use the above. 2011-02-24 Stas Boukarev * swank-allegro.lisp (find-topframe): Fix excl::int-newest-frame invocation for the latest alpha version of Allegro. Patch by Gábor Melis. 2011-02-18 Stas Boukarev * slime.el (slime-init-popup-buffer): Don't use multiple-value-setq on a list, XEmacs doesn't like it. 2011-02-18 Stas Boukarev * slime.el (slime-insert-threads): Make sure newlines have the same thread-id property as the rest of the line. This fixes confusion when point is at the end of a line. 2011-02-13 Stas Boukarev * slime.el (slime-inspector-operate-on-point): Don't save the point when inspecting a different object. (slime-inspector-operate-on-point): If there is no action property directly at the point, try looking at (1- (point)), many inspectable objects are presented the end of the line, so it's easier to navigate to them by C-e and still being able to activate it. 2011-02-08 Stas Boukarev * slime.el (slime-choose-overlay-region): Don't use `list' instead of `values', GNU Emacs fakes multiple values with lists, but XEmacs uses real multiple values. Reported by Raymond Toy. 2011-02-04 Helmut Eller Be careful with interning. * swank.lisp (find-definitions-for-emacs): Use parse-symbol. 2011-02-04 Helmut Eller Don't double encode results for eval-in-emacs. * slime.el (slime-check-eval-in-emacs-result): New. (slime-eval-for-lisp): Use it. * swank.lisp (unreadable-object): Removed. 2011-02-02 Stas Boukarev * swank.lisp (eval-in-emacs): Return unreadable results from Emacs as an unreadable-object, not as a string. 2011-02-02 Stas Boukarev * slime.el (slime-eval-for-lisp): Return value as a string, because it can be unreadable, e.g. # * swank.lisp (eval-in-emacs): Prevent reader errors. 2011-02-02 Stas Boukarev * swank.lisp (eval-in-emacs): Export it. 2011-01-28 Stas Boukarev * slime.el (slime-check-location-filename-sanity): Guard against target-filename being NIL. 2011-01-26 Helmut Eller Allow tail-merging in call-with-bindings. * swank.lisp (call-with-bindings): Don't use progv if alist is empty alist is empty. 2011-01-20 Stas Boukarev * swank-ecl.lisp (+TAGS+): change (translate-logical-pathname #P"SYS:TAGS") to (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")) because of case conversion the former results in a pathname with a name "tags", which doesn't exist. 2010-12-10 Stas Boukarev * slime.el (slime-with-popup-buffer): Correct the docstring. 2010-12-09 Helmut Eller * slime.el (slime-toggle-break-on-signals): New command. * swank.lisp (toggle-break-on-signals): The corresponding Lisp code. 2010-12-02 Martin Simmons * swank-lispworks.lisp (frame-actual-args): Reimplement to include only the values like on other platforms and deal with, optional key and rest args. (print-frame): Format the frame as a call like in other backends. 2010-11-13 Helmut Eller Improve source locations for compiler messages in Lispworks. * swank-lispworks.lisp (map-error-database) (signal-error-data-base, make-dspec-progenitor-location): Pass the edit-path along. (signal-undefined-functions): No edit-path available so just use nil. 2010-11-12 Helmut Eller Improve frame-source-location for Lispworks. * swank-lispworks.lisp (frame-source-location): Exctract the edit-path from the frame and pass it to Emacs. (edit-path-to-cmucl-source-path): New function. (frame-location): Use it. * slime.el (slime-location-offset): Add a :edit-path property. (slime-search-edit-path): New function. (slime-search-call-site): Fix regexp to match zero arg functions. 2010-11-07 Helmut Eller * swank-backend.lisp (label-value-line): Remove display-nil-value. And the other stuff too. (label-value-line*): Idem. 2010-11-07 Helmut Eller * swank-loader.lisp: ASDF free again. And proud of it! (default-fasl-dir, load-swank): Remove asdf stuff. 2010-11-03 Stas Boukarev * swank-loader.lisp (*architecture-features*): Add :arm for CCL ARM port. 2010-11-02 Martin Simmons * swank-lispworks.lisp (list-callers-internal): Revert to previous low level implementation, fixed for LW6. (list-callees-internal): Reimplement using low level instead of the compiler's xref. 2010-10-23 Stas Boukarev * slime.el (slime-goto-location-position): In case of (:function-name name) go to (point-min) before searching for function. Remove redundant regexp and regexp-quote function name before inserting it into a regexp. 2010-10-21 Helmut Eller In ABCL, try harder to find the source of stack frames. * swank-abcl.lisp (source-location): Now a GF. (source-location [java-stack-frame]): New. (source-location [lisp-stack-frame]): New. (source-location [function]): New. (frame-source-location, find-definitions): Use them. (*source-path*, find-definitions): New. (system-property, pathname-parent, pathname-absolute-p) (split-string, path-separator, search-path-property) (jdk-source-path, class-path, zipfile-contains-p) (find-file-in-path): Noise for filename frobbing. 2010-10-21 Helmut Eller Require ABCL 0.22 and remove obsolete conditionalisation. * swank-abcl.lisp (call-with-debugger-hook) (install-debugger-globally) (call-with-debugging-environment, backtrace, print-frame, spawn): Remove #+/#- stuff. (preferred-communication-style): Return :spawn unconditionally. (sys::break): Removed. 2010-10-20 Stas Boukarev * slime.el (slime-connect): Convert the port number read from minibuffer to an integer, passing it as a string to `make-network-process' isn't portable. Patch by Marko Kocic. 2010-10-19 Stas Boukarev * swank.lisp (invoke-nth-restart): Make sure there is such restart before invoking it. 2010-10-19 Stas Boukarev * swank-sbcl.lisp (deinit-log-output): Use the right symbol for *LOG-OUTPUT*, swank package isn't available at the time swank-backend is compiled. 2010-10-16 Stas Boukarev * swank-loader.lisp (default-fasl-dir): Guard against using :asdf package if it doesn't exist. Patch by Anton Vodonosov. 2010-10-16 Attila Lendvai * swank-fuzzy.lisp: speed up by 2-4 times (on sbcl). * fuzzy.el: Clean up fuzzy completion's keymap code, drop mimic-key-bindings. * slime.el: Added separate host and port history for slime-connect. (slime-lookup-lisp-implementation): better error reporting and allow using a functionp to generate the arguments. * swank.lisp: Smarten up the label-value-line macros: - support a :label emacs font property - added key args: padding-length, display-nil-value, hide-when-nil, splice-as-ispec, value-text - label-value-line* will evaluate and splice the result of the form after a @ character * swank-loader.lisp: Optional integration with ASDF. When ASDF is available, store slime fasl's where ASDF would store them. Also make sure swank.asd is visible to ASDF. 2010-10-09 Raymond Toy * swank-cmucl.lisp (codepoint-length): Implement codepoint-length to return the number of codepoints in cmucl's utf-16 strings. * swank-backend.lisp (:swank-backend): Export codepoint-length. (codepoint-length): definterface codepoint-length. Default is to use LENGTH. * swank-rpc.lisp (write-message): Call swank-backend:codepoint-length to get the correct length for emacs. 2010-10-08 Christophe Rhodes Pass more detailed source location information to swank:compile-string-for-emacs. Motivated by R's source location needs (where srcrefs are line/column based). * slime.el (slime-compile-string): Generate :line location format from start-offset, passing it through to swank:compile-file-for-emacs. (find-definition.2): Use new-style position. * swank.lisp (compile-string-for-emacs): Use only the offset from the position argument. * swank-backend.lisp (swank-compile-string): Fix docstring typo. 2010-10-07 Nikodemus Siivola Hanging on to a *log-output* from a previous image is bad on SBCL at least: it is initialized to an FD-STREAM, which cannot be reused from one image to another. Deal with this by using sb-ext:*save-hooks* to clear the stream. * swank-sbcl.lisp (deinit-log-output): New function. 2010-10-02 Helmut Eller Rename slime-macro/compiler-macro-expand-1 => slime-expand-1 * slime.el (slime-expand-1): Renamed from slime-macro/compiler-macro-expand-1. (slime-expand-1-inplace): Renamed from slime-macro/compiler-macro-expand-1-inplace. * swank.lisp (swank-expand-1): Renamed from swank-macro/compiler-macro-expand-1. (swank-expand): Renamed from swank-macro/compiler-macro-expand. (expand-1): Renamed from macro/compiler-macro-expand-1. (expand): Renamed from macro/compiler-macro-expand. 2010-10-01 Helmut Eller Don't use indent-sexp for macroexpanded code. indent-sexp is potentially slow and usually redundant. * slime.el (slime-initialize-macroexpansion-buffer): Don't use indent-sexp. (slime-eval-macroexpand-inplace): Avoid indent-sexp but use slime-insert-indented. 2010-10-01 Helmut Eller Save result in kill ring for M-- C-x C-e. For C-u C-x C-e set mark before inserting. * slime.el (slime-eval-save): New function. (slime-eval-print): Set mark before inserting. (slime-interactive-eval): Use it. 2010-09-22 Stas Boukarev * swank.lisp (eval-for-emacs): Send (:abort condition) where condition is a condition which was aborted instead of just (:abort). * slime.el: Handle the above change. 2010-09-22 Stas Boukarev * swank-clisp.lisp (*external-format-to-coding-system*): Remove stray :latin-1 argument for ext:make-encoding. Reported by Mirko Vukovic. 2010-09-20 Stas Boukarev * swank-cmucl.lisp (character-completion-set): Implement. Requires recent versions of CMUCL. Patch by Raymond Toy. 2010-09-18 Tobias C. Rittweiler * swank-backend.lisp (valid-function-name-p): New interface. (compiler-macroexpand-1): Use it to guard against type errors from COMPILER-MACRO-FUNCTION. 2010-09-18 Tobias C. Rittweiler * swank.lisp (before-init): push :SWANK to *FEATURES*. (lp#627313) 2010-09-18 Tobias C. Rittweiler Make C-c C-m also expand compiler macros. (lp#638720) * slime.el (slime-macro/compiler-macro-expand-1): New. (slime-macro/compiler-macro-expand-1-inplace): New. (slime-editing-keys): Map `C-c C-m' to first above. (slime-compiler-macroexpand-1): Take prefix-arg like others. (slime-compiler-macroexpand-1-inplace): Ditto. (slime-compiler-macroexpand): Thus deleted. (slime-compiler-macroexpand-inplace): Ditto. * swank.lisp (swank-macro/compiler-macro-expand-1): New defslimefun. (swank-macro/compiler-macro-expand): New defslimefun. (macro/compiler-macro-expand-1): New. (macro/compiler-macro-expand): New. (expand-repeatedly): New helper. 2010-09-03 Stas Boukarev * slime.el (slime-forward-cruft): Use " \t\n" to match whitespaces instead of [:space:], XEmacs compatibility. 2010-09-03 Helmut Eller For C-c C-k, ask before loading possibly broken fasl files. * slime.el (slime-compilation-result): Add 2 slots: loadp and faslfile. (slime-compilation-finished): Use them to load the faslfile. * swank.lisp (:compilation-result): Add 2 slots. Use keyword constructor. (compile-file-for-emacs): Return loadp and faslfile to Emacs. (collect-notes): Pass loadp and falsfile along. 2010-09-02 Stas Boukarev * swank-cmucl.lisp: #-cmu19 -> #+cmu18, cmu18 is allegedly the oldest supported CMUCL. 2010-09-01 Stas Boukarev * swank-sbcl.lisp (background-save-image): add #-win32, because it uses symbols not present on win32. Reported by Holly Styles. 2010-08-31 Stas Boukarev * swank-cmucl.lisp (foreign-frame-p, gdb-exec, frame-ip): Sparc support. Patch by Raymond Toy. 2010-08-31 Nikodemus Siivola * swank-sbcl.lisp (make-dspec): Elide the function name when generating a VOP description, since the VOP name is more useful and is the first part of the source-description list. 2010-08-28 Stas Boukarev * swank-cmucl.lisp (*gdb-program-name*): Determine gdb location from PATH. (gdb-exec): Use *gdb-program-name* instead of "gdb". (gdb-command): Mac OS X compatibility. Patch by Raymond Toy. 2010-08-25 Stas Boukarev * swank-sbcl.lisp (exec-image): Use (car sb-ext:*posix-argv*) if SBCL doesn't have sb-ext:*runtime-pathname*. Reported by Vinay. 2010-08-22 Stas Boukarev * slime.el (slime-xemacs-recompute-modelines): Add `slime-xemacs-recompute-modelines' to `pre-idle-hook', this solves the problem of synchronization of modelines. Thanks to Aidan Kehoe. 2010-08-21 Stas Boukarev * slime.el (slime-recompute-modelines): Recompute modelines only for visible buffers. Kludge: modeline can be out of sync if the buffer becomes visible and no slime/lisp interaction took place yet. Patch by Raymond Toy. (slime-search-buffer-package): Revert, with the above change caching shouldn't be necessary. 2010-08-21 Helmut Eller Add commands to enable/disable contribs. * slime.el (slime-enable-contrib, slime-disable-contrib): New. (slime-contrib): New struct to collect meta-data about contribs. (define-slime-contrib): Store meta-data in 'slime-contribs plist. (slime-all-contribs, slime-find-contrib, slime-read-contrib-name): New helpers. 2010-08-21 Anton Kovalenko Snapshot restore support for SBCL. * swank-backend.lisp (background-save-image): New. * swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image) (make-fd-stream, background-save-image): New. 2010-08-20 Stas Boukarev * slime.el (slime-maybe-complete-as-filename): Limit backward search for #\", it slows down on large buffers. Reported by Raymond Toy. (slime-search-buffer-package): Cache the package, searching every time on large buffers may be slow. 2010-08-15 Stas Boukarev * swank.lisp (setup-server): Check the coding system before doing anything, otherwise it may be eaten by ignore-errors later. 2010-08-13 Helmut Eller Find definition for (def-vm-support-routine NAME ...) * swank-cmucl.lisp (vm-support-routine-definitions): New. (find-definitions): Use it. 2010-08-12 Stas Boukarev * swank-sbcl.lisp (save-image): Fix save-lisp-and-die invocation. Based on a patch by Anton Kovalenko. 2010-08-11 Helmut Eller Bind *print-readably* to nil when printing the title. * swank.lisp (prepare-title): Factored out into new function. (*inspector-printer-bindings*) (*inspector-verbose-printer-bindings*): New. (with-string-stream): New. (emacs-inspect/istate): Renamed from emacs-inspect/printer-bindings. 2010-08-06 Stas Boukarev * swank-ccl.lisp (spawn): Revert the previous change, using :use-standard-initial-bindings nil might be not thread-safe. 2010-08-05 Stas Boukarev * swank-ccl.lisp (spawn): Specify :use-standard-initial-bindings nil, so that *readtable* etc. modifications persist. 2010-08-04 Stas Boukarev * swank-allegro.lisp (fspec-definition-locations): Default &optional position to 0, otherwise it may cause errors later. Reported by: Paulo Madeira. 2010-08-04 Stas Boukarev * slime.el (slime-dispatch-event): :eval-no-wait, lisp sends a form in a string, not a function name and arguments. Add slime-check-eval-in-emacs-enabled. * swank.lisp (defpackage): export eval-for-emacs. 2010-07-30 Helmut Eller Don't get confused by END-OF-FILE on unrelated streams. Fixes bug "slime connection broken on trivial condition..." Reported by Pascal J. Bourguignon. * swank.lisp (end-of-repl-input): New condition. (simple-repl, read-non-blocking): Use it. * slime.el ([test] end-of-file): Test it. 2010-07-30 Helmut Eller * swank.lisp (print-part-to-string): Bind *print-readably* to nil. Useful when debugging broken printer methods. 2010-07-22 Vitaly Mayatskikh * swank-lispworks.lisp (list-callers-internal): Fix for LW6. (list-callees-internal): New function, use it. 2010-07-21 Stas Boukarev * swank-sbcl.lisp (quit-lisp): Use sb-thread:terminate-thread instead of sb-ext:quit :recklessly-p t. This way sb-ext:*exit-hooks* will be run. Reported by Lorenz Mösenlechner. 2010-07-06 Helmut Eller Find definition for (%primitive NAME ...) * swank-cmucl.lisp (template-definitions, primitive-definitions): New functions. (find-definitions): Use them. 2010-06-22 Helmut Eller * swank-loader.lisp (*architecture-features*): ECL uses :x86_64. 2010-06-18 Helmut Eller * slime.el (slime-current-tlf-number,slime-current-form-path): Moved to contrib/slime-parse.el. 2010-06-18 Helmut Eller Don't use goto-line. * slime.el (slime-goto-line): New function as replacement without goto-line's cruft that we don't want. 2010-06-04 Helmut Eller * slime.el, swank.lisp: #'(lambda -> (lambda 2010-06-04 Stelian Ionescu * swank.lisp: Move definition of LCONS before first use. 2010-06-04 Helmut Eller * swank-allegro.lisp (socket-fd): Add support for allegro. 2010-06-04 Helmut Eller Some *sldb-quit-restart* related fixes. * swank.lisp (*sldb-quit-restart*): Set to nil by default. (throw-to-toplevel, debug-in-emacs): Get rid of boundp tests. (format-restarts-for-emacs): Add a mark for *sldb-quit-restart*. (handle-requests): Always bind *emacs-connection*. (with-connection): Get rid of call-with-connection so that compilers can remove the call frame more easily. (repl-input-stream-read): Factored out from make-repl-input-stream. Bind a *sldb-quit-restart* here too; no need to restart the repl and a extra prompt for errors in Emacs requests. 2010-05-28 Helmut Eller Fix last change. * slime.el (define-slime-contrib): Fix names. Remove provide; makes no sense to call provide before file is completely loaded. 2010-05-28 Helmut Eller * slime.el (define-slime-contrib): Use destructuring-bind. 2010-05-28 Helmut Eller Move some var-defs before first use. * slime.el (slime-show-xref-buffer, slime-read-connection) (slime-thread-index-to-id): 2010-05-28 Helmut Eller Move wacky parsing code to contrib. * slime.el (slime-extract-context, slime-parse-context) (slime-in-expression-p, slime-pattern-path) (slime-beginning-of-list, slime-end-of-list) (slime-parse-toplevel-form, slime-arglist-specializers) (slime-definition-at-point, slime-current-parser-state): Moved to contrib/slime-parse.el (slime-inspect-definition, slime-disassemble-definition): Moved to contrib/slime-fancy-inspector.el 2010-05-27 Helmut Eller * slime.el ([test] interactive-eval): Fix test. 2010-05-27 Helmut Eller * swank-ccl.lisp (socket-fd): Implement backend function. 2010-05-27 Helmut Eller Clean up some of the confusion regarding *sldb-quit-restart*. * swank.lisp (top-level-restart-p, *toplevel-restart-available*) (coerce-restart): Deleted. (with-top-level-restart, simple-repl): Simplify. 2010-05-26 Helmut Eller * swank.lisp (swank-error): Unrename from swank-protocol-error. 2010-05-26 Helmut Eller * swank-cmucl.lisp (parse-gdb-line-info): Try working dir first. 2010-05-26 Helmut Eller * slime.el (slime-defun-if-undefined): Renamed from slime-DEFUN-if-undefined. No need to yell. 2010-05-26 Helmut Eller * slime.el (slime-compile-file): Only send non-nil keyword args. (slime-hack-quotes): New function. 2010-05-18 Stas Boukarev * slime.el (sldb-insert-condition): Don't create a mouse tooltip for long error message, tooltip shows the same text and doesn't add any value. (slime-definition-at-point): factor out of `slime-inspect-definition'. (slime-disassemble-definition): New, similar to `slime-inspect-definition'. * swank.lisp (disassemble-form): rename from disassemble-symbol, do the same as before but evaluate the argument. 2010-05-16 Stas Boukarev * slime.el (slime-close-popup-window): Don't kill slime-popup-restore-data local variable in another buffer. 2010-05-13 Tobias C. Rittweiler * slime.el (define-slime-contrib): New macro. 2010-05-13 Tobias C. Rittweiler * swank.lisp (*after-init-hook*, simple-break) (coerce-to-condition, use-threads-p, current-thread-id): Moved around in swank.lisp. (with-temp-package): Deleted; not used anywhere. (ensure-list): Use in SWANK-REQUIRE. 2010-05-11 Stas Boukarev * slime.el (slime-inspect-definition): New function, inspects definition at point. (slime-parse-context): Add :defstruct and :defpackage. 2010-05-10 Mark Evenson * swank-loader.lisp (*architecture-features*): Add Java platforms as features for ABCL. 2010-05-06 Helmut Eller Remove some non-standard file variables. * swank-cmucl.lisp, swank-scl.lisp: Remove pbook vars. * swank-clisp.lisp: Remove indentation settings. Slime does it automatically. 2010-05-05 Stas Boukarev * slime.el (slime-dispatch-event): Fix typo in the previous commit. 2010-05-05 Stas Boukarev * Make buffer names more consistent. Patch by Leo Liu. 2010-05-05 Helmut Eller * swank-cmucl.lisp (gdb-command): Use gdb's MI. 2010-05-05 Mark Evenson Fix for Cygwin Emacs filename problem. * slime.el (slime-init-command): Use slime-to-lisp-filename. 2010-05-05 Helmut Eller * slime.el (sldb-exit): When stepping, close buffer after a delay. (sldb-close-step-buffer): New function. 2010-05-01 Stas Boukarev * slime.el (slime-restart-sentinel): Don't pop to the inferior buffer, since this command is usually run either from *inferior-lisp* buffer or from REPL, it makes sense to reuse current window instead of messing up window configuration. (slime-move-point): New function, moves point in a buffer and its window. 2010-04-29 Stas Boukarev * slime.el (slime-compile-file): Run check-parens after checking that the buffer is associated with a file. 2010-04-27 Stas Boukarev * slime.el (slime-info): New function, opens the manual. 2010-04-24 Stas Boukarev * swank.lisp (format-values-for-echo-area): Also print the length of an integer in bits. 2010-04-23 Stas Boukarev * slime.el (slime-update-threads-buffer): Use slime-eval-async. 2010-04-23 Stas Boukarev * slime.el (slime-inspector-buffer): Use slime-with-popup-buffer, that solves the problem with keybindings shadowed by slime-mode. Reported by Nathan Bird. * README: Better wording. 2010-04-22 Stas Boukarev * swank-backend.lisp (with-symbol): Test for package before doing find-symbol. * swank-sbcl.lisp(Multiprocessing): use with-symbol. (emacs-inspect t): Remove newlines from text returned by sb-impl::inspected-parts, otherwise there will be ".." inserted by the printer due to (*print-lines* 1). 2010-04-21 Stas Boukarev * slime.el (slime-open-inspector): Use forward-line instead of goto-line, since it doesn't result in "Mark set" message. (slime-inspector-buffer): Enable slime-mode after enabling slime-inspector-mode, otherwise the former will be disabled by the latter. 2010-04-20 Tobias C. Rittweiler * swank-sbcl.lisp (condition-timed-wait): New helper. Use WITH-DEADLINE rather than WITH-TIMEOUT because the latter conses a new timer, and this function is called _a lot_. (receive-if): Use it. 2010-04-20 Stas Boukarev * slime.el (slime-update-threads-buffer): Save point position on updates. 2010-04-20 Stas Boukarev * README: advertise additional contribs, especially slime-fancy. 2010-04-19 Stas Boukarev * swank.lisp (symbol-classification-string): New function to replace (symbol-classification->string (classify-symbol symbol)). It's faster and conses much less, while it is called many times by fuzzy completion and fancy inspector. (symbol-classification->string): Removed. (list-threads): Exclude the current thread only if its name is "worker". 2010-04-18 Stas Boukarev * slime.el (slime-threads-update-interval): Add :group and :type parameters to this customization. Thanks to Mark Harig. 2010-04-17 Stas Boukarev * slime.el (slime-threads-update-interval): New customization variable, if set to a number the threads buffer will updated with this interval. (slime-with-popup-buffer): Rename modes option to mode, for a major mode. Enabling minor modes from within the body doesn't cause troubles. End that way it is compatible with XEmacs since it doesn't need to use minor-mode-list to distinguish between minor and major modes. * swank.lisp (list-threads): Delete the current thread from the listing. 2010-04-15 Tobias C. Rittweiler * slime.el (sldb-mode): Include some more commands in its help. (sldb-goto-last-frame): Do not center to the middle but to the bottom of the window. 2010-04-14 Helmut Eller * swank.lisp (compile-file-for-emacs): Actually commit the change described in 2010-04-12. 2010-04-14 Helmut Eller * slime.el ([test] interrupt-encode-message): New test. 2010-04-14 Helmut Eller Handle errors during interrupt processing with SLDB. Bugfix for http://article.gmane.org/gmane.lisp.slime.devel/9641 * swank.lisp (invoke-or-queue-interrupt): When the queue is full, process the interrupt immediately and also handle SERIOUS-CONDITIONs during interrupt processing in SLDB. SLDB should work more likely than the interrupted code is expected to handle the condition. (with-interrupts-enabled%): Don't check for interrupts when toggling interrupts off. (wait-for-event): Add docstring. 2010-04-14 Helmut Eller Move error handling and logging from swank-rpc.lisp to swank.lisp * swank.lisp (log-event, destructure-case, decode-message) (encode-message, decode-message, swank-protocol-error): Moved back to swank.lisp from swank-rpc.lisp. It never belonged there anyway. * swank-rpc.lisp (read-message, write-message): New functions. (swank-reader-error): New condition. 2010-04-12 Helmut Eller * slime.el (slime-doc-bindings): Restore key for slime-apropos. 2010-04-12 Helmut Eller Fix compile-file for various backends. * slime.el (slime-compile-file): Only pass non-nil keyword args to Lisp. (slime-simplify-plist): New helper. (slime-compile-and-load-file): Pass policy parameter directly without using global variables. * swank.lisp (compile-file-for-emacs): Change singature sightly. 2010-04-06 Stas Boukarev * slime.el (slime-create-compilation-log): Enable compilation-mode, which was enabled previously by slime-insert-compilation-log. 2010-04-05 Stas Boukarev * slime.el (slime-doc-bindings): Move slime-apropos to C-c C-d A, C-c C-d a will be bound to slime-autodoc-manually. * doc/slime.texi: Document the above change. 2010-04-05 Stas Boukarev * slime.el: Some further adaptations to the new slime-with-popup-buffer. 2010-04-04 Stas Boukarev * slime.el (slime-insert-threads): Use header-line-format only when it's present (XEmacs doesn't support it). 2010-04-04 Stas Boukarev * slime.el (slime-with-popup-buffer): Make &optional parameters &key parameters, add modes parameter. slime-with-popup-buffer sets up some buffer local variables, but enabling major modes kills all buffer locals, so modes should be enabled before setting them. Adopt changes to slime-with-popup-buffer where needed. This fixes several bugs with popup buffers on non-default connections. 2010-04-03 Stas Boukarev * slime.el (slime-update-threads-buffer): New formatting, with labels and additional information provided by the backend. * swank-allegro.lisp (thread-attributes): Move process-priority from thread-status. 2010-03-29 Helmut Eller * slime.el: Add gud as compile-time dependency. 2010-03-29 Helmut Eller Compile swank-sbcl-exts only for SBCL. * swank-loader.lisp (*contribs*): Add #+sbcl. 2010-03-29 Helmut Eller Minor cleanups * swank.lisp (connection): Make socket-io read-only again. (*connections*): Move declaration before first use. (finish-connection-setup): Merged into make-connection. (accept-connections): Renamed from serve-connection and reorganized so that the socket-io slot can be read-only. (accept-authenticated-connection): Renamed to authenticate-client. Update callers accordingly. 2010-03-29 Tobias C. Rittweiler * swank.lisp (connection-info): Use princ-to-string rather than prin1-to-string as the latter may barf if *print-readably* is nil. 2010-03-27 Stas Boukarev * slime.el (slime-check-location-buffer-name-sanity): Less duplication, reuse slime-check-location-filename-sanity. (slime-check-location-filename-sanity): Do any work only when slime-warn-when-possibly-tricked-by-M-. is non-nil. 2010-03-21 Stas Boukarev * start-swank.lisp: Document options to swank-loader:init. * doc/slime.texi (Miscellaneous): mention `sldb-break-with-system-debugger'. 2010-03-21 Stas Boukarev * start-swank.lisp: New file for starting swank by simply loading sbcl --load start-swank.lisp 2010-03-19 Tobias C. Rittweiler * slime.el (slime-lisp-implementation-program): New connection variable. (slime-set-connection-info): Adapted to set it. (slime-attach-gdb): Use it to invoke gdb so gdb is able to find debugging symbols on non-Linux platforms. * swank.lisp (connection-info): Include lisp-implementation-program. * swank-backend.lisp (lisp-implementation-program): New interface. Default implementation based on command-line-args. * swank-ecl.lisp (command-line-args): Implement. 2010-03-18 Tobias C. Rittweiler Remove attach-gdb restart. Instead add SLDB shortcut `A'. * slime.el (slime-dispatch-event): Remove :gdb-attach. (slime-attach-gdb): Changed API. Takes connection not pid now and lightweight &optional arg. If not lightweight, get the default gdb config from the inferior Lisp. (sldb-break-with-system-debugger): New command, bound to `A' in sldb. Called this way to mimick `sldb-break-with-default-debugger', and because it may make sense to go beyond gdb in future, e.g. to invoke the Java Debugger for ABCL. * swank.lisp (call-with-gdb-restart, with-gdb-restart): Removed. (with-top-level-restart): Remove use of with-gdb-restart. (make-connection, start-server, create-server, setup-server): Remove inferior-lisp flag again. Not needed anymore. 2010-03-18 Tobias C. Rittweiler Add M-x slime-attach-gdb as an interactive function. The ATTACH-GDB restart is nice because it's convenient and the backends can specify customized gdb configuration. Sometimes, if the Lisp is too screwed up, going over a restart involving the SWANK middle layer may not be possible. For that, a manual M-x slime-attach-gdb may come in handy. * slime.el (slime-read-connection): New helper. (slime-attach-gdb): Use it. Make it an interactive function. 2010-03-18 Tobias C. Rittweiler * swank.lisp (call-with-gdb-restart): Forgot to remove trailing T. 2010-03-18 Tobias C. Rittweiler * swank.lisp (open-dedicated-output-stream): Forgot to rename accept-authenticated-connection to accept-authenticated-client here. 2010-03-18 Tobias C. Rittweiler Add an ATTACH-GDB restart to SLDB. * swank.lisp (call-with-gdb-restart): New. Sends the new :gdb-attach event to Emacs. (with-gdb-restart): Sugar. (with-top-level-restart): Also expand to with-gdb-restart. (dispatch-event): Add :gdb-attach event. * swank-backend.lisp (gdb-initial-commands): New interface function so backends can customize how gdb needs to be configured for their implementation. * swank-ecl.lisp (gdb-initial-commands): Implement. * slime.el (slime-dispatch-event): Add clause for :gdb-attach. (slime-attach-gdb): New. 2010-03-18 Tobias C. Rittweiler * swank.lisp (connection): Add socket slot, make socket-io slot not be required to be filled in during object creation. Add inferior-lisp slot so we can know whether a connection belongs to a superior Emacs process. Need for that will come in following commit. (make-connection): Our constructor. (create-connection): Removed; not needed anymore. (finish-connection-setup): Function to fill socket-io slot. (start-server): Results in inferior-lisp slot being T. (create-server): Results in inferior-lisp slot being NIL. (setup-server): Adapted accordingly. Construct connection early so we do not have to pass down all the meta information explicitly. (serve-connection): Adapted accordingly. (accept-authenticated-client): Renamed from accept-authenticated-connection. (dispatch-event): Get rid of unused :%apply and :end-of-stream events. 2010-03-16 Tobias C. Rittweiler * swank-ecl.lisp (source-location): Also return EXT::FOO as candidate to search through the TAGS file because SI and EXT both name the same package, and in ECL's code base, sometimes the former, sometimes the latter is used. 2010-03-10 Tobias C. Rittweiler * swank.lisp (signal-interrupt): Removed. (interrupt-worker-thread): Slurp in definition of signal-interrupt. No need for invoke-or-queue-interrupt twice in case we do not use threads. Thus micro-prettification of backtraces. 2010-03-10 Tobias C. Rittweiler * swank-ecl.lisp (source-location): Move call to TRANSLATE-LOGICAL-PATHNAME from here into MAKE-FILE-LOCATION because locations-via-annotations may now also involve logical pathnames. 2010-03-10 Tobias C. Rittweiler * swank-ecl.lisp (*original-sigint-handler*) (install-sigint-handler): Deleted; we directly implement call-with-user-break-handler instead. (call-with-user-break-handler): New. Correctly interrupt main thread instead of newly spawned handle-signal thread on SIGINT. (make-interrupt-handler): New helper. 2010-03-09 Stas Boukarev * swank-ccl.lisp (emacs-inspect function): Print closed over variables in case of closure. 2010-03-09 Stas Boukarev * slime.el (slime-parse-context): Add defclass. 2010-03-09 Helmut Eller Some more fixes for Allegro * swank-allegro.lisp (function-source-location): Use xref::object-to-function-name which seems to work better for some cases. (fspec-definition-locations): For :top-level-forms return a list of ((fspec loc)) not just (fspec loc). Also deal with the file vs. buffer issue. (ldb-code-to-src-loc): Don't use *temp-file-map* before it is declared. (pc-source-location): Be a bit more fuzzy when searching the code-location for a pc. 2010-03-08 Stas Boukarev * slime.el (slime-extract-context): Add defvar and defparameter. 2010-03-08 Helmut Eller Fix some of the brokeness in the last change. * swank-allegro.lisp (frame-source-location): Deal with frames for undefined functions better. (ldb-code-to-src-loc): Handle temp-files properly. 2010-03-08 Helmut Eller Try to use source-level debugging features in Allegro 8.2 * swank-allegro.lisp (disassemble-frame): Use undocumented debugger::dyn-fd-analyze to figure out the PC and display it. (pc-source-location, ldb-code-to-src-loc, longest-common-prefix) (source-paths-of): New functions. (frame-source-location): Use pc-source-location. Still far from optimal since Allegro rarely records source regions and anonymous functions don't seem to carry source level debug-info at all. (*temp-file-map*, buffer-or-file-location, find-fspec-location): Use a table to map temp-file names back to Emacs buffers instead of putting an eval-when-compile form in the source. The eval-when-compile form messed up source positions. (*temp-file-header-end-position*, find-definition-in-buffer): Deleted. (compile-from-temp-file): Bind excl:*load-source-debug-info* and compiler:save-source-level-debug-info-switch so that Allegro doesn't try to load debug-info from deleted files. Also put the filename in *temp-file-map*. 2010-03-08 Tobias C. Rittweiler * swank.lisp (dispatch-interrupt-event): Take a connection because it boils down to SIGNAL-INTERRUPT which uses USE-THREADS-P which needs a connection. (install-fd-handler): Adapted accordingly. (simple-serve-requests): Adapted accordingly. Additionally, remove superfluous WITH-SWANK-PROTOCOL-HANDLER as that's established by WITH-CONNECTION already. (simple-repl): Show "abort inferior lisp" restart only if not a more appropriate "abort some REX" restart is available. Also make sure to return in case of END-OF-FILE, otherwise there's an infinite loop where we end up in the debugger again and again until the user eventually selects close-connection restart himself. (make-repl-input-stream): Use WITH-TOP-LEVEL-RESTART so `sldb-quit' can be used in SLDB. 2010-03-08 Tobias C. Rittweiler * swank.lisp (close-connection): Include initially passed coding-system in debugging output. 2010-03-08 Tobias C. Rittweiler Make swank:connection-info include information about initially passed coding-system, and the resulting external-format of the socket. Debugging aid. * swank.lisp (connection.external-format): New function. (start-server, create-server): Pass down coding-system, not external-format. (setup-server): Pass down both, coding-system and external-format. (serve-connection): Ditto. (create-connection): Set coding-system slot of CONNECTION. (connection-info): Include coding-system and external-format. 2010-03-07 Helmut Eller * swank-allegro.lisp (count-cr): Deleted. No longer used. 2010-03-07 Helmut Eller Handle src-locs of compiler warnings in Allegro 8.2. Didn't somebody already fix that? * swank-allegro.lisp (location-for-warning) (handle-undefined-functions-warning): In 8.2 src-locs include not only start but also and end positions. 2010-03-07 Stas Boukarev * swank-ecl.lisp (source-location): Don't do (setq file (tmpfile-to-buffer file)) in a COND condition, otherwise next cond clause will get null file. Apply translate-logical-pathname to pathnames. 2010-03-05 Helmut Eller Remove some unused stuff. * swank-ccl.lisp (openmcl-set-debug-switches) (*interesting-internal-frames*) (interesting-frame-p): Unused. Deleted. 2010-03-05 Helmut Eller * swank-ccl.lisp: Indentation fixes. 2010-03-05 Tobias C. Rittweiler * swank-ecl.lisp: Make backend depend on ECL version 10.3.1 which just got released. We do not support older versions. Previous version pretty much didn't work in combination with Slime anyway. 2010-03-05 Tobias C. Rittweiler Ecl: Make M-. work on function interactively compiled via C-c C-c. * swank-ecl.lisp (*tmpfile-map*, note-buffer-tmpfile) (tmpfile-to-buffer): New helpers. (swank-compile-string): Use them. Also use new COMPILE-FILE keywords :SOURCE-TRUENAME and :SOURCE-OFFSET available in ECL HEAD. (find-definitions): Slurp in definition of FIND-DEFINITIONS-BY-NAME. (find-definitions-by-name): Hence not needed anymore. (source-location): Use TMPFILE-TO-BUFFER to get buffer source location of interactively compiled functions. 2010-03-04 Mark Evenson * swank-abcl.lisp (emacs-inspect): Define default method to use the result of SYS:INSPECTED-PARTS if non-nil. 2010-03-03 Stas Boukarev * doc/slime.texi (Inspector): document slime-inspector-eval. Patch by Mark Harig. 2010-03-03 Helmut Eller Don't special case special operators with M-. for CMUCL. * swank-cmucl.lisp (function-definitions): Special operators will have IR1-translators anyway, so no need to mark them "special". (gf-definitions): Renamed from generic-function-definitions. 2010-03-03 Helmut Eller * slime.el (slime-inspector-history): New command. 2010-03-03 Helmut Eller Don't try to bind keywords in inspector-eval. * swank.lisp (inspector-eval): For now, don't bind symbols which are constantp. Maybe something better can be found later. 2010-03-03 Helmut Eller Use @ instead of # to mark object in the inspect history. * swank.lisp (print-part-to-string): Use @. 2010-03-03 Helmut Eller Make eval-in-frame display multiple values; not only the first. * swank.lisp (values-to-string): New macro. (eval-string-in-frame): Use it. 2010-03-02 Stas Boukarev * swank-sbcl.lisp (definition-source-for-emacs): Don't error when source location doesn't contain form position, point emacs to the beginning of a source file and if it's a function provide a snippet "(defun ". 2010-03-02 Stas Boukarev * slime.el (slime-compile-and-load-file): Accept C-u arguments for compilation policy the same way as slime-compile-defun. * swank.lisp (compile-file-for-emacs): Take an additional policy argument. * swank-backend.lisp (swank-compile-file): Ditto. * swank-sbcl.lisp (compiler-policy, (setf compiler-policy)): rename from get/set-compiler-policy. (with-compiler-policy): New macro. (swank-compile-file): Use with-compiler-policy. (swank-compile-string): Ditto. * doc/slime.texi (Compilation): Update. 2010-03-01 Stas Boukarev * swank.lisp (documentation-symbol): Show arglists for functions too. 2010-03-01 Tobias C. Rittweiler Fix that annoying bug that caused being constantly asked to switch connection in case one had multiple connections running and quit from one. * slime.el (slime-modeline-string): Bail out early because `slime-current-package' involves `slime-connection' in case the slime-repl contrib is used, and querying the user in a periodically called function is rather annoying.. 2010-02-26 Stas Boukarev * swank-loader.lisp (ecl-version-string): Check length of the result of ext:lisp-implementation-vcs-id before doing subseq. On CVS it returns "unknown". 2010-02-25 Stas Boukarev * swank-loader.lisp (ecl-version-string): In #+(or) (progn #+#.(cl:print cl:nil) 1) PRINT does run on SBCL, which breaks #+#.(cl:if (cl:find-symbol "SYMBOL" :ext) ...) here, guard it with (find-package :ext) until further investigations. 2010-02-25 Tobias C. Rittweiler * swank-loader.lisp (lisp-version-string): Add git-commit ids for ECL because individual commits do not guarantee fasl compatibility. 2010-02-23 Tobias C. Rittweiler * swank-backend.lisp (when-let): New macro. For backends and swank.lisp. * swank-ecl.lisp: Use it. Also use new location support of ECL git HEAD. 2010-02-23 Tobias C. Rittweiler * slime.el (slime-postprocess-xref): Show a TAGS entry's hints as part of an Xref's dspec for the case of multiple matches. 2010-02-23 Tobias C. Rittweiler * swank-ecl.lisp (preferred-communication-style): Go back to NIL. Some parts (like the compiler and CLOS) of ECL do not seem to be thread-safe yet. Also get rid of non-working implementation of :FD-HANDLER. (poll-streams, wait-for-input): Implement on top of select() for communication-style=NIL. (*descriptor-handlers*, add-fd-handler, remove-fd-handlers): Get rid of. (grovel-docstring-for-arglist): Get rid of it, too. (arglist): ECL now provides an extra accessor to a function's arglist. Use that instead. (emacs-inspect): Get rid of the default method. Don't see its point. 2010-02-22 Tobias C. Rittweiler Make swank-ecl.lisp work with latest ECL Git HEAD. * swank-ecl.lisp (assert-TAGS-file): Simplified. (assert-source-directory): New helper. (c-function-p): New helper. (c-function): Type based on above. (source-location): Move bits from FIND-DEFINITIONS-FOR-TYPE to this function. Use CONVERTING-ERRORS-TO-ERROR-LOCATION. (find-definitions-for-type): Simplified by using it. 2010-02-22 Tobias C. Rittweiler * swank-backend.lisp (converting-errors-to-error-location): Moved here from swank-sbcl.lisp so other backends can make use of it, too. * swank-sbcl.lisp: The above macro was called slightly differently, so update uses accordingly. 2010-02-22 Tobias C. Rittweiler Make M-. be able to jump right into the C source for ECL. Because it's based on TAGS files, M-. and M-* will DTRT once in a .c file. * swank-ecl.lisp (assert-TAGS-file): New helper. (classify-definition-name): Ditto. (find-definitions-for-type): Ditto. Understands Lisp and C functions. (find-definitions): Use them. (source-location): New helper. Extracted from FIND-SOURCE-LOCATION. (find-source-location): Use it. (swank-compile-string): Only try to delete temporary files if they exist. 2010-02-22 Tobias C. Rittweiler Make it possible for SWANK backends to specify locations based on a TAGS file. * slime.el (slime-postprocess-xref, slime-postprocess-xrefs): New functions. They convert TAGS based locations from SWANK into file+position based locations because the rest of Slime expects and works with those. (slime-find-definitions): Call slime-postprocess-xrefs. (slime-xref): Ditto. (slime-etags-to-locations): The function which does the actual conversion. Extracted from `slime-etags-definitions'. (slime-etags-definitions): Use it. * swank-backend (defimplementation): Add implicit BLOCK. (:etags-file, :tag): Mentioned for possible values in :LOCATION. 2010-02-20 Tobias C. Rittweiler More work on ECL's swank-backend. * swank-ecl.lisp (accept-connection): Handle :buffering, and :external-format. (external-format): New helper. (find-external-format): Make sure to only return :default in case ECL was built with --disable-unicode; it'll barf on anything else. (socket-fd): Add two-way-stream case due to recent changes in ECL. (make-file-location, make-buffer-location): New helpers. (condition-location): Use them. (swank-compile-file): Handle :external-format. (compile-from-stream): Deleted. Slurped into swank-compile-string. (swank-compile-string): Call SI:MKSTEMP correctly. Make sure to also remove fasl file, not just source file. (grovel-docstring-for-arglist): Do not look at "Syntax:" entry in docstring because that was a kludge. Upstream ECL should be modified instead. (in-swank-package-p, is-swank-source-p, is-ignorable-fun-p): Commented out. They make debugging ECL's swank-backend harder. 2010-02-20 Tobias C. Rittweiler * swank-loader.lisp (*architecture-features*): Add :PENTIUM3 and :PENTIUM4; they're used by ECL. (handle-swank-load-error): Renamed from HANDLE-LOADTIME-ERROR. Use *FASL-DIRECTORY* rather than (DEFAULT-FASL-DIR). Parametrize context to differentiate b/w compilation/loading. (compile-files): Adapted accordingly. Also make sure that an error is signaled in case COMPILE-FILE returns NIL as primary result. 2010-02-20 Stas Boukarev * swank-ccl.lisp: Remove outdated comment at the beginning since it may be misleading. * slime.el: In minor-mode-alist for slime-popup-buffer-mode, run slime-modeline-string only if slime-mode isn't active, because slime-mode runs slime-modeline-string from minor-mode-alist too resulting in duplicate modeline strings. Reported by Leo Liu. 2010-02-18 Mark Harig The compiler warns about various stuff. Fix some of it. * slime.el (slime-add-local-hook): Remove support for Emacs 20. (sldb-recenter-region): Use forward-line; not next-line. 2010-02-17 Helmut Eller Add a command to eval stuff in the inspector. * slime.el (slime-inspector-eval): New command. (slime-inspector-mode-map): Bind it to 'e'. * swank.lisp (inspector-eval): New function. * swank-backend.lisp (eval-context): New function. * swank-cmucl.lisp (eval-context): Implement it. 2010-02-17 Helmut Eller Point-entered hooks in the xref buffer don't work so well. Use forward/backward commands instead. * slime.el (slime-xref-next-line, slime-xref-prev-line): New commands. (slime-xref-show-location): New aux function. (slime-xref-mode-map): Remap up/down to next/prev location commands. Make SPC and RET do the same. 2010-02-17 Helmut Eller Select the xref buffer. I never could get used to the next/prev cycling. * slime.el (slime-with-xref-buffer): Select the buffer. (slime-insert-xrefs): Add point-entered hook to automatically display the current location. (slime-xref-entered): New function. (slime-show-buffer-position): Don't use reposition-window which seems very slow and doesn't even do a particularly good job. The new heuristic is much cruder but faster. (slime-xref-mode-map): Remove apparently redundant bindings for RET. 2010-02-17 Helmut Eller Get rid or snapshots. * slime.el (slime-narrowing-configuration, slime-emacs-snapshot) (slime-current-narrowing-configuration) (slime-set-narrowing-configuration, slime-current-emacs-snapshot) (slime-set-emacs-snapshot) (slime-current-emacs-snapshot-fingerprint, slime-frame-windows): Deleted. Update call-sites accordingly. 2010-02-17 Helmut Eller Test suite hangs for CCL and CMUCL. * slime.el ([test] compile-defun): Remove those compile-time read errors for which some implementations invoke the debugger. (sexp-at-point.1): Remove failing tests 2010-02-16 Tobias C. Rittweiler * swank-loader.lisp: Compile files on ECL, too. 2010-02-16 Tobias C. Rittweiler Pimp my swank. * swank-ecl.lisp: We depend on ECL 10.2.1 which is not released yet -- you need git/cvs HEAD. Added :spawn, and :fd-handler as communication-style (Thanks to Ram Krishnan), improve compilation hooks so highligting of warnings works, + various cleanup. 2010-02-15 Tobias C. Rittweiler * slime.el (slime-load-contribs): Do not call SWANK-REQUIRE asynchronously, if host Lisp uses :SPAWN that may result in the attempt to load in code concurrently -- the host Lisp may not support that. 2010-02-14 Tobias C. Rittweiler * slime.el (slime-attempt-connection): Fix typo. Thanks to Mark Harig for spotting it. 2010-02-13 Tobias C. Rittweiler * slime.el (slime-attempt-connection): Do not keep on trying to connect if inferior process died. 2010-02-07 Tobias C. Rittweiler * swank-ecl.lisp: Update threading code. ECL doesn't still work with :spawn, though. Work in progress. 2010-02-07 Tobias C. Rittweiler * swank.lisp (xref-doit): Declare eql-specializing parameter ignorable, as some implementations complain about them not being used. 2010-02-01 Mark Harig * slime.el: Added missing pieces to make `slime-cycle-connections' available from keystrokes. (slime-prefix-bindings): Added "\C-xn" entry. (slime-cycle-connections): Corrected grammar in doc string. (def-slime-selector-method): Added menu item `n' to SLIME selector menu. * doc/slime.texi: Added a description for the new key sequence for `slime-cycle-connections' and for the new menu item in the SLIME selector menu. Node slime-selector: Added menu item `n' and cross-references to "Multiple Connections" node. Node Multiple connections: Added C-c C-x n description. Added cross-references to `slime-selector' node. 2010-01-31 Tobias C. Rittweiler * hyperspec.el: When using C-c C-d ~ TAB, 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. RIP, erik. 2010-01-30 Stas Boukarev * slime.el (slime-cycle-connections): Change docstring, it doesn't make connection buffer-local. * doc/slime.texi (Multiple connections): document slime-cycle-connections. * swank.lisp (pathname-as-directory): Treat "/foo/bar" and "/foo/bar/" the same. (compile-file-output): Use the above function. 2010-01-28 Mark Evenson * swank-abcl.lisp (emacs-inspect): Make inspection of Java objects toString() results dependent on explicit user request to avoid potentially computationally expensive operations. 2010-01-27 Stas Boukarev * swank-rpc.lisp: NIL -> nil (for unusual readtable settings). Spotted by Harald Hanche-Olsen. 2010-01-26 Mark Evenson * swank-abcl.lisp: Import MOP::COMPUTE-APPLICABLE-METHODS-USING-CLASSES if it exists in the ABCL implementation. 2010-01-25 Tobias C. Rittweiler * swank-allegro.lisp (redefinition-p, redefinition): New. (handle-compiler-warning): Add :severity for redefinitions, style-warnings, errors. 2010-01-21 Stas Boukarev * swank-ccl.lisp (with-frame): Put this macro before it's used. 2010-01-20 Terje Norderhaug * swank.lisp (with-swank-protocol-error-handler): Refactor using safe-backtrace. * swank-rpc.lisp (make-swank-protocol-error): Delete call to swank:safe-backtrace to eliminate dependency on swank.lisp module. * swank-rpc.lisp (swank-protocol-error): Remove swank-protocol-error.backtrace as the capture of a safe-backtrace is covered by with-swank-protocol-error-handler. 2010-01-20 Stas Boukarev * slime.el (slime-thread-kill): If the region is active, then kill all threads in the region. 2010-01-19 Stas Boukarev * swank-rpc.lisp (:swank-rpc): (:use :cl), SBCL doesn't use it by default. 2010-01-19 Terje Norderhaug * Refactorized parts of swank.lisp into a new swank-rpc module. 2010-01-14 Stas Boukarev * doc/slime.texi (Setting up the lisp image): (swank-loader:init) is also needed for loading swank. Reported by Evgeny Bahvalov. 2010-01-13 Tobias C. Rittweiler * swank.lisp (*swank-state-stack*): Delete. Not needed anymore. (defslimefun state-stack): Delete. (decode-message): Adapted. (debug-in-emacs): Adapted. 2010-01-11 Mark Evenson * swank-abcl.lisp (emacs-inspect): Implementation for Java objects. Fix compiler warning about *ABCL-SIGNALED-CONDITIONS*. 2010-01-06 Tobias C. Rittweiler * swank-backend (declaration-arglist): Normalize declaration specifiers to contain `variables' rather than `vars'. 2010-01-05 Tobias C. Rittweiler * swank-sbcl.lisp (compiler-note-location): Add missing return-from. 2010-01-05 Tobias C. Rittweiler * slime.el (compile-defun [test]): Add two cases. 2010-01-05 Cecil Westerhof * slime.texi (inferior-slime-mode): Fix thinko. 2010-01-05 Terje Norderhaug Provide default implementation for all-threads. * swank-backend.lisp (all-threads): Just return (). 2010-01-05 Helmut Eller Fix M-. bug related to CMUCL's multi-file compilation units. * swank-cmucl.lisp (code-location-stream-position): Require the "root-number" as argument and subtract it from the TLF number. (location-in-file): Pass the root number along. (code-location-string-offset): Use 0 as root number. 2010-01-05 Helmut Eller Slightly better error message when CMUCL fails to find defstructs. * swank-cmucl.lisp (struct-constructor, setf-definitions): Don't use COERCE which gives confusing error message. 2010-01-05 Helmut Eller Add "quit" and "other window prefix" buffer selectors. * slime.el (slime-selector-other-window): New variable. (slime-selector): Bind it as need. (def-slime-selector-method): Use the other window if so indicated. ([selector] 4): New key binding. ([selector] q): New key binding. just abort. 2010-01-05 Helmut Eller Stop the beeping on restart. * slime.el (slime-quit-lisp-internal): Don't kill already dead processes. 2010-01-03 Stas Boukarev * swank-backend.lisp (frame-call): New function. Returns a string representing a call to the entry point of a frame. * swank-ccl.lisp (frame-call): Implementation of the above. * swank-sbcl.lisp (frame-call): Ditto. 2010-01-03 Tobias C. Rittweiler * swank.lisp (with-swank-protocol-error-handler): Remove debugging bits. 2010-01-03 Tobias C. Rittweiler * slime.el (slime-next-read-or-lose): Call `debug' with the error condition, so we can see what actually caused the losage. 2010-01-03 Tobias C. Rittweiler * slime.el (compile-defun [test]): Also test proper notification after reader-error. Additionally: bind font-lock-verbose to nil to prevent annoying font-lock messages during the test. * swank-sbcl.lisp (signal-compiler-condition): Make sure READER-ERROR comes before ERROR in typecase. (swank-compile-file): Remove handling FATAL-COMPILER-HANDLER because a) this handling prevents sbcl from printing the diagnostics to the repl, and b) sbcl itself should handle this and translate it into proper return value for compile-file. 2009-12-23 Tobias C. Rittweiler * slime.el (complete-symbol [test]): Fix test case. 2009-12-22 Helmut Eller Some new backend functions used for loading image files. * swank-backend.lisp (socket-fd, make-fd-stream, dup, exec-image) (command-line-args): New functions. * swank-cmucl.lisp: Impemented. * swank-cmucl.lisp (reset-sigio-handlers): New function. (save-image): Fix quoting bug. * swank.lisp (clear-event-history): New functoin. (interactive-eval, eval-region): Don't use FRESH-LINE. 2009-12-21 Tobias C. Rittweiler * slime.el (slime-at-list-p): Deleted. (slime-at-expression-p): Moved to slime-package-fu. (slime-forward-blanks): Deleted. Use `(skip-chars-forward "[:space:]")' instead. (slime-forward-any-comment): Deleted. (slime-reader-conditionals-regexp): Make a constant so it's inlined. (slime-unknown-feature-expression): Make it an error. 2009-12-19 Stas Boukarev * swank-backend.lisp (defpackage): export with-symbol and replace its fully qualified usage everywhere. 2009-12-17 Tobias C. Rittweiler * slime.el (slime-edit-uses-xrefs): New variable. For contribs to extend. (slime-edit-uses): Use it. * swank.lisp (xref-doit): Now a generic functions. For contribs to extend. 2009-12-17 Tobias C. Rittweiler * swank.lisp (with-top-level-restart): Bind local special. (top-level-restart-p): Check for it; this tells us if we're in the dynamic extent of with-top-level-restart. (handle-requests): Use it. 2009-12-17 Stas Boukarev * swank-match.lisp: Fix formatting and style warnings. 2009-12-17 Stas Boukarev * swank.lisp (handle-requests): Comment out (assert (boundp '*sldb-quit-restart*)) because it's not bound on NIL communication style. It's not a real fix, but at least it lets null communication-style work. 2009-12-16 Tobias C. Rittweiler * swank-sbcl.lisp (categorize-definition-source): New. (definition-source-for-emacs): Use it. Slightly refactored. Renamed from `make-definition-source-location'. (find-definitions, find-source-location) (source-location-for-xref-data, function-dspec): Updated accordingly. (source-file-position): Scratch last argument, not needed anymore. 2009-12-16 Stas Boukarev * swank.lisp (compile-file-output): Use (make-pathname :directory dir :defaults (compile-file-pathname file)) instead of (compile-file-pathname file :output-file dir), because the latter works differently on different implementations. (fasl-pathname): Use the above function. 2009-12-16 Tobias C. Rittweiler * swank.lisp (*sldb-quit-restart*): Export. For users to customize what `q' does in SLDB. (handle-requests): Test differently for recursive invocations as *sldb-quit-restart* may now be globally bound due to user customization. (coerce-restart): Coerces a restart-designator to a restart. (throw-to-toplevel): Use it. * slime.texi (swank:*sldb-quit-restart*): Document it. 2009-12-15 Tobias C. Rittweiler * swank.lisp (collect-notes): Establish new abort restart ("Abort Compilation"); if an error is signaled in EVAL-WHEN, or during macroexpansion -- assuming the backend DTRT --, invoking this restart will result in the normal compilation failure behaviour, including correct reporting of the offending toplevel form. * swank-sbcl.lisp (handle-notification-condition): Use `real-condition' here. (handle-file-compiler-termination): As a result, not needed anymore. (call-with-compilation-hooks): Also signal information about normal errors. 2009-12-14 Stas Boukarev * doc/slime.texi (ASDF): Document new commands. 2009-12-12 Matthias Koeppe * doc/slime.texi (Presentations): Add an example that illustrates quoting necessary with presentations that are lists. 2009-12-11 Stas Boukarev * swank-allegro.lisp: Use new function `make-error-location'. (find-fspec-location): Handle errors. Patch by Tobias C. Rittweiler. 2009-12-11 Tobias C. Rittweiler Add `M-x slime-toggle-debug-on-swank-error'. In "Debug on SWANK error" mode, errors which are normally caught to not annoy the user, will now drop into the debugger. Additionally, the backend won't do any backtrace magic so you'll see the full backtrace with all its glory details. (SBCL only so far.) * slime.el (slime-toggle-debug-on-swank-error): New. * swank.lisp (toggle-debug-on-swank-error): New slimefun. (debug-on-swank-error): New function. SETFable. (invoke-default-debugger): Use CALL-WITH-DEBUGGER-HOOK so we're trapped into the native debugger on SBCL (previously we weren't due to SB-EXT:*INVOKE-DEBUGGER-HOOK*.) * swank.lisp: Rename SWANK-ERROR to SWANK-PROTOCOL-ERROR. 2009-12-11 Tobias C. Rittweiler * swank-sbcl.lisp (call-with-debugger-hook): Oops, removed the binding for *DEBUGGER-HOOK*. Fix that. (make-invoke-debugger-hook): Do nothing if hook is NIL. 2009-12-10 Tobias C. Rittweiler * swank-backend.lisp (*debug-swank-backend*): New variable. If true, backends should not catch internal errors (e.g. during definition finding), and should not perform backtrace magic. (make-error-location): New helper. (find-definitions [interface]): Default to error location. * swank-sbcl.lisp (converting-errors-to-location): New helper macro. Regards new *DEBUG-SWANK-BACKEND*. (find-definitions [implementation]): Use it. (find-source-location [implementation]): Ditto. (functiond-spec): Ditto. (frame-source-location [implementation]): Ditto. (*debug-definition-finding*): Removed. (make-source-location-specification): Removed. (safe-function-source-location): Removed. (safe-source-location-for-emacs): Removed. Not needed anymore. (call-with-debugging-environment): Do not perform stack hinting depending on *DEBUG-SWANK-BACKEND*. 2009-12-10 Tobias C. Rittweiler * swank-sbcl.lisp (set-break-hook): New. (call-with-break-hook): New, too. Both extracted from elsewhere. (install-debugger-globally, call-with-debugger-hook): Use them. (make-invoke-debugger-hook): Adapted not to call *debugger-hook* on its own; it should rather decline because *debugger-hook* is tried after *invoke-debugger-hook* anyway. Previously, a custom *debugger-hook* (which declines itself) would have been executed twice. 2009-12-07 Stas Boukarev * slime.el (slime-parse-toplevel-form): Use `slime-region-for-defun-at-point' instead of `beginning-of-defun'. 2009-12-03 Tobias C. Rittweiler * slime.el (slime-documentation-lookup-function): New hook, defaults to `slime-hyperspec-lookup'. (slime-documentation-lookup): Invoke hook. (slime-prefix-bindings): Bind `C-c C-d h' to it. 2009-12-02 Stas Boukarev * swank-sbcl.lisp (frame-locals): `frame-debug-vars' can return NIL, so check before using it as a vector. Patch by Nathan Bird. 2009-11-30 Helmut Eller Add a slime-editing-map as suggested by Attila Lendvai. The main purpose is to create a keymap that's shared by the REPL and other modes so that adding custom bindings gets a bit easier. * slime.el (slime-editing-map, slime-mode-indirect-map): New variables. (slime-init-keymaps): Clear out any existing bindings before building the new keymaps. (slime-init-keymap): New helper. (slime-bind-keys): Renamed&extended from slime-define-both-key-bindings. * slime.el (slime-editing-mode): New minor mode for use in the REPL. 2009-11-26 Mark Evenson * swank-abcl.lisp (arglist): Fixes for functions with non-nil arglist and for generic functions with empty argument lists. Diagnosed and cured by Matthias Hölzl. 2009-11-23 Stas Boukarev * slime.el (slime-set-connection-info): Set slime-current-thread to t before doing anything. Solves a bug reported by Slawek Zak. 2009-11-21 Tobias C. Rittweiler * swank-sbcl.lisp (who-specializes): Implement. Requires SBCL 1.0.32. 2009-11-19 Tobias C. Rittweiler * slime.el (slime-minibuffer-map): Nee `slime-read-expression-map' (slime-minibuffer-history): Nee `slime-read-expression-history' (slime-minibuffer-setup-hook): Extracted. (slime-read-from-minibuffer): Adapted accordingly. 2009-11-13 Stas Boukarev * swank.lisp (classify-symbol): Check fbound before calling fdefinition, ECL doesn't like (fdefinition nil). * swank-ecl.lisp (swank-mop:compute-applicable-methods-using-classes): Add a dummy function. ECL doesn't have it, but some contribs are using it. Patch by Andy Hefner. 2009-11-13 Stas Boukarev * swank-ecl.lisp (function-name): Use clos:generic-function-name for generic functions. (arglist): Check fro symbol before calling special-operator-p and macro-function. Patch by Andy Hefner. 2009-11-06 Stas Boukarev * swank-ecl.lisp (grovel-docstring-for-arglist): ECL's arglists for macros include macro name at the first place, unlike arglists for functions. cdr arglists only for macros and special operators. Reported by Andy Hefner. (find-source-location): Missing comma before error message formatting. Patch by Andy Hefner. 2009-11-05 Tobias C. Rittweiler Make C-c C-c operate on region if mark is active (and Transient Mark mode is enabled.) * slime.el (slime-compile-defun): Operate on region if transient-mark-mode is active. 2009-11-03 Helmut Eller Ask gdb for source lines of foreign functions. * swank-cmucl.lisp (frame-source-location): Handle foreign frames with gdb. (frame-ip): Handle bogus frames (on x86) (disassemble-frame): Use gdb for foreign frames. (foreign-frame-p, foreign-frame-source-location): New functions. (gdb-command, gdb-exec, parse-gdb-line-info, read-word) (whitespacep, with-temporary-file, call/temporary-file): New helpers. 2009-11-03 Stas Boukarev * slime.el (sldb-setup): Do (set-syntax-table lisp-mode-syntax-table) otherwise functions used by autodoc do not work properly. 2009-11-03 Stas Boukarev * slime.el (sldb-backward-frame): If the point is at the end of the buffer, there is no property, handle this case. * swank.lisp (collect-notes): LOAD returns generalized boolean, not just boolean, but make-compilation-result accepts only booleans for its second argument. Both bugs reported by Derrell Piper. 2009-11-02 Tobias C. Rittweiler * slime.el (slime-end-of-symbol): Make sure not to move on #'foo. ([test] sexp-at-point.1): New test case. 2009-11-02 Helmut Eller * swank.lisp (without-interrupts): Removed. No longer used. * swank-backend.lisp (call-without-interrupts): Removed. Update backends accoringly. 2009-11-02 Helmut Eller CCL's lap-functions don't have source-notes but the name often has. E.g. ccl::%fixnum-truncate. Use names as last resort. * swank-ccl.lisp (function-name-source-note): New function. (pc-source-location): Use it. 2009-11-02 Stas Boukarev * swank.lisp (tokenize-symbol-thoroughly): Return NIL instead of throwing an error. (parse-symbol): Handle null result of tokenize-symbol-thoroughly. This fixes a bug reported by Derrell Piper. 2009-10-31 Tobias C. Rittweiler * slime.el (slime-bug): Deleted. 2009-10-31 Tobias C. Rittweiler * slime.el (slime-inside-string-p, slime-inside-comment-p) (slime-inside-string-or-comment-p): New. * swank-match.lisp: New file. Contains very simple pattern matcher from the CMU AI archive. * swank-loader.lisp: Compile swank-match.lisp. * swank.lisp: Make SWANK package use new SWANK-MATCH package. 2009-10-31 Tobias C. Rittweiler * swank.lisp (find-symbol-with-status): New. (parse-symbol): Use it to correctly parse symbols where only one colon is given. Consequences: Autodoc won't display an arglist on `(foo:bar |' if BAR is not exported from FOO. 2009-10-31 Helmut Eller * swank.lisp (list-threads): Remove thread-description. Wasn't used anymore. * swank-backend.lisp (thread-description, set-thread-description): Deleted. * swank-abcl.lisp: Update accordingly. * slime.el (slime-update-threads-buffer, slime-thread-insert): Update accordingly. 2009-10-31 Helmut Eller * swank-ccl.lisp (kill-thread): Don't signal conditions. * swank-backend.lisp (kill-thread): Update docstring. 2009-10-30 Stas Boukarev * swank-loader.lisp (setup): Use EXT:PROBE-DIRECTORY on Clisp, because PROBE-FILE doesn't want to work on directories. Patch by Dirk Sondermann. 2009-10-30 Helmut Eller * swank-openmcl.lisp: Removed. 1.4 is out so no longer needed. * swank-ccl.lisp: Update accordingly. * test-all.sh: Removed. Not used in ages. 2009-10-28 Helmut Eller Simpler modeline code. * slime.el (slime-modeline-string): Renamed from slime-compute-modeline-string. (slime-modeline-state-string): Renamed from slime-compute-connection-state (slime-modeline-package, slime-modeline-connection-name) (slime-modeline-connection-state) (slime-extended-modeline,slime-compute-modeline-package) (slime-update-modeline-string, slime-shall-we-update-modeline-p) (slime-update-all-modelines, slime-modeline-update-timer) (slime-restart-or-init-modeline-update-timer) (slime-connection-state-as-string): Deleted (slime-stale-connection-p): Deleted. 2009-10-28 Helmut Eller * slime.el (slime-disconnect): Don't reference connection. Left over from last change. ([test] arglist): Update expected results for slightly changed printer settings. ([test] indentation): Install common-lisp-indent-function. ([undefun] display-warning): Fix it. * test.sh: Don't copy contribs. Slime should work without them. * swank-loader.lisp (setup): Compile contribs only if directory exists. 2009-10-28 Helmut Eller * slime.el (slime-format-display-message, slime-display-message) (slime-create-message-window): Deleted. The trick with the pre-command-hook doesn't work in XEmacs 21.5. So use the standard message function. One day XEmacs will learn how to resize the minibuffer, but until then we have to live with one-line messages. 2009-10-27 Helmut Eller * slime.el: Fix some docstrings and comments. 2009-10-26 Tobias C. Rittweiler * test.sh: Shebang on bash, not just on sh. 2009-10-25 Tobias C. Rittweiler Revert the reversed numbering of restarts in sldb. New command `sldb-cycle' ([tab]) in sldb will cycle between restart list and backtrace. Make sldb-invoke-restart-by-name case-insensitive. * slime.el (sldb-mode-map): Bind Tab to `sldb-cycle'. (sldb-restart-list-start-marker): New variable. (sldb-setup): Store marker in it. (sldb-cycle): New command to cycle between restart list and backtrace. (sldb-invoke-restart-by-name): Make completion case-insensitive. (sldb-insert-restarts): Revert to old behaviour. 2009-10-24 Tobias C. Rittweiler * swank-ccl.lisp (who-specializes): Do not signal an error if argument does not name a class. 2009-10-24 Tobias C. Rittweiler * swank.lisp (xref): Deal with non-yet-interned names gracefully. 2009-10-24 Tobias C. Rittweiler * slime.el (slime-search-property): Add parameter to get value at point propery changed. (slime-find-next-note): Use it. (slime-find-previous-note): Ditto. 2009-10-24 Tobias C. Rittweiler New command C-M-, to go to previous xref location. [Old command C-M-. to go to next xref location.] Xref buffers are not automatically selected anymore; it's more ergonomic to cycle through them via C-M-. and C-M-, from within the source buffer. * slime.el (slime-search-property): Simplify slightly. (slime-find-next-note): Use it. (slime-find-previous-note): Use it, too. (slime-find-note): Deleted. (slime-editing-keys): Add C-M-,. (slime-previous-location-function): New variable. (slime-previous-location): New command. (slime-with-xref-buffer): Do not select Xref buffer. (slime-show-xref-buffer): Adapted accordingly. (slime-goto-next-xref): Highlight current item on C-M-. and C-M-,. (slime-goto-previous-xref): New. (slime-highlight-sexp): Renamed from `sldb-highlight-sexp'. (slime-highlight-line): New. 2009-10-24 Helmut Eller * slime.el (sldb-insert-restarts): Insert the proper numbers for the --more-- button. (sldb-restart-number-at-point): Rename back to sldb-restart-at-point. Don't use confisingly-verbose-names-for-no-good-reason. (sldb-restart-number-for-swank): Deleted. 2009-10-23 Tobias C. Rittweiler Restarts in SLDB are now numbered reversely. The rationale is that always-existing restarts are likely to be associated with the same number now. * slime.el (sldb-insert-restarts): Number restart reversely. (sldb-restart-number-for-swank): New; recompute the unreversed number for the swank side. (sldb-restart-number-at-point): Previously `sldb-restart-at-point'. (sldb-invoke-restart): Adapted accordingly. 2009-10-23 Tobias C. Rittweiler When ever Slime seems to get stuck (e.g. after some character encoding confusion), `M-x slime-reset' should hopefully bring it into a functional state again. * slime.el (slime-reset): Erase connection buffer. 2009-10-21 Tobias C. Rittweiler Make M-x slime-changelog-date work. * slime.el (slime-changelog-date): Make the function be callable interactively. 2009-10-21 Stas Boukarev * doc/slime.texi (ASDF): Document new commands. 2009-10-20 Martin Simmons * swank-lispworks.lisp (call-without-interrupts): Discourage use. (interesting-frame-p): Never show open frame bogons. 2009-10-19 Stas Boukarev * swank-sbcl.lisp (thread-description): Remove it and supporting code, because it didn't really work. * swank.lisp (with-thread-description): Remove unused macro. * slime.el (slime-list-threads): Update information before setting the mode, otherwise it messes up current connection. * doc/slime.texi: fix typo. 2009-10-19 Tobias C. Rittweiler * swank.lisp (without-printing-errors): New macro. (to-string): Use it. (to-line): Use it, too. This fixes printing error occuring during inspecting to prevent the inspector from displaying something useful. Reported by xristos@suspicious.org. 2009-10-15 Helmut Eller * slime.el (slime-current-package): Move REPL stuff to contrib. 2009-10-15 Stas Boukarev * slime.el (slime-current-package): Return REPL's package, if other are unavailable and if slime-repl is loaded. 2009-10-12 Tobias C. Rittweiler * slime.el: Update copyright. 2009-10-10 Tobias C. Rittweiler * slime.el (slime-length=): Fix (slime-length= '() 0). (slime-eval-feature-expression): Fix. Couldn't handle (NOT) and (NOT FOO BAR). 2009-10-09 Stas Boukarev * swank.lisp (stop-server): (list-threads) returns threads offset by 1, don't kill the wrong thread. 2009-10-06 Stas Boukarev * swank-ccl.lisp (map-backtrace): Handle null end-frame-number argument. 2009-09-28 Stas Boukarev * swank.lisp (set-package): Provide a more meaningful error message when package doesn't exist. * swank-lispworks.lisp (replace-strings-with-symbols): Didn't work on non-proper lists. Reported by Madhu. 2009-09-27 Tobias C. Rittweiler * swank-sbcl.lisp (call-with-debugger-hook): Correctly deal with case of HOOK being NIL. (make-definition-source-location): Somewhat simplified. (string-path-snippet): Removed, not needed anymore. 2009-09-24 Stas Boukarev * swank-sbcl.lisp (swank-compile-string): Ignore unused variable warningsp. 2009-09-23 Helmut Eller * swank-sbcl.lisp (receive-if): Bind *break-on-signals* to nil before using with-timeout. 2009-09-22 Helmut Eller * swank-ccl.lisp (find-definitions): For fbound symbols also consider source-notes in the function object. Useful if the function slot was set with (setf (symbol-function ..)) and not by defun. 2009-09-21 Stas Boukarev * doc/slime.texi (slime-sprof): document slime-sprof contrib. 2009-09-20 Tobias C. Rittweiler * swank-abcl.lisp (thread-description): Fix typo. (set-thread-description): Ditto. 2009-09-20 Tobias C. Rittweiler Generalize M-? (or M-_ respectively.) It will now list: - call sites for functions, - macroexpand sites for macros, - binding, setting, referencing sites for variables, - specializing methods for classes. * slime.el (slime-xref): Deal with :not-implemented. (slime-xrefs): New. Makes RPC request to XREFS. (slime-edit-callers): Renamed to `slime-edit-uses'. (slime-edit-uses): Use slime-xrefs. * swank-backend.lisp (who-*): Add default implementation which returns :not-implemented. * swank.lisp (xref-doit): Extracted from XREF. (xref): Pass over :not-implemented to Emacs side. (xrefs): New slime fun. To return results of multiple XREF requests at once. 2009-09-20 Mark Evenson Use *INVOKE-DEBUGGER-HOOK* introduced in ABCL by analogy to SBCL (Tobias Rittweiler). * swank-abcl.lisp (sys::break): Conditionally redefine SYS::BREAK only if SYS::INVOKE-DEUBBGER-HOOK is not present. 2009-09-18 Tobias C. Rittweiler * slime.el (slime-parent-bindings): Define M-? as `slime-edit-callers', too. My previous choice of M-_ was warped due to my German layout. 2009-09-18 Tobias C. Rittweiler New binding: M-_ (`slime-edit-callers'). Similiar to `slime-who-calls' but only creates an Xref buffer if needed for disambiguation, and also pushes to the definition stack. Spiritually like M-. but works "in the other direction". * slime.el (sllime-edit-callers): New function. Cross between `slime-who-calls' and `slime-edit-definition'. (slime-parent-bindings): Define M-_ as `slime-edit-callers'. (slime-pop-xref-buffer): New helper. Extracted from `slime-show-xrefs'. (slime-show-xrefs): Use it. (slime-xref): Let callers specify a continuation. 2009-09-17 Tobias C. Rittweiler * swank-abcl.lisp (sys::break): Fix typo. (slot-definition-documentation, slot-definition-type) (class-prototype, generic-function-declarations) (specializers-direct-methods, slot-boundp-using-class) (slot-value-using-class): Add IGNORE declarations. Compiling swank-abcl.lisp is now free of warnings. (swank-compile-file): Load the compiled file even though warnings were signalled during compilation. 2009-09-17 Mark Evenson * swank-abcl.lisp (source-location): Emacs buffers start at 1, whereas CL files start at 0 (Tobias Rittweiler). 2009-09-16 Stas Boukarev * swank.lisp (documentation-symbol): Return more readable information. 2009-09-14 Mark Evenson * swank-abcl.lisp (source-location): Fix typo. 2009-09-12 Mark Evenson Provided by Alan Ruttenberg. * swank-abcl.lisp (source-location): Make edit definition work. * swank-abcl.lisp (arglist): Now works with generic functions. 2009-09-08 Helmut Eller * swank-loader.lisp (lisp-version-string): Include "-ics" for version with extended charsets. Suggested by Scott L. Burson. 2009-09-03 Helmut Eller * slime.el (slime-net-close): set-process-query-on-exit-flag doesn't exist in XEmacs. (slime-make-net-buffer): For now, disable querying here. Could also close the socket before killing the buffer. (slime-buffer-processes): Deleted. 2009-09-02 Stas Boukarev * swank-lispworks.lisp (replace-strings-with-symbols): New function for recursively interning and replacing strings in a list. (arglist): Replace all strings in arglists with symbols. * slime.el (slime-net-close): Do not query for process killing confirmation before killing a connection buffer. (slime-buffer-processes): New function for listing processes associated with a buffer. 2009-08-31 Helmut Eller Don't advice ccl::break-loop. Should not be necessary as we can now use ccl:*break-hook*. * swank-ccl.lisp ([advice] ccl::break-loop): Deleted. 2009-08-31 Helmut Eller Keep note overlays in a global variable. That's simpler and cheaper than scanning all buffers. * slime.el (slime-note-overlays): New variable. (slime-make-note-overlay, slime-remove-old-overlays): Use it. 2009-08-27 Stas Boukarev * slime.el (slime-remove-old-overlays): delete notes at the very beginning of the buffer too. Thanks to Nick Levine. 2009-08-22 Helmut Eller Speed up symbol completion. * swank.lisp (all-completions): Don't call unparse-symbol while matching. That gets very slow in CCL's CCL package. Just use symbol-name and compare with char-equal. (prefix-match-p): Use char-equal. 2009-08-21 Helmut Eller * slime.el (slime-transcript-start-hook) (slime-transcript-stop-hook): New hooks. (slime-eval-with-transcript): Use them. (slime-eval-with-transcript-cont): Deleted. 2009-08-19 Mark Evenson * swank-abcl.lisp: Accommodate the new Java/Lisp stack frame abstraction in the upcoming abcl-0.16. (based on code from Tobias Rittweiler). 2009-08-18 Mark Evenson Add multithreading code for abcl-0.16. (Tobias Rittweiler) * swank-abcl.lisp: A multithread implementation taking advantage of the new synchronization primitives in abcl-0.16. Restore working with abcl-0.15. * swank-abcl.lisp: Remove the warm initialization code for SWANK:COMPILER-CONDITION, as it is no longer needed for the current release of ABCL. 2009-08-16 StanisBaw Halik * swank.lisp (init-global-stream-redirection): Continue even if streams are already redirected. Useful for restarting Swank with M-x slime when a REPL is already present. Will most likeley mess up the input stream in multi threaded setups, tho. 2009-08-15 Helmut Eller XEmacs fixes. * slime.el (slime-editing-keys): Use (kbd "C-M-.") because XEmacs translates [?\C-\M-.] to C-M-n. (next-single-char-property-change) (previous-single-char-property-change): Use next-single-property-change because next-char-property-change gets embarrisingly slow in XEmacs in font-locked buffers. It never felt that slow in Emacs 20 though. 2009-08-15 Helmut Eller * swank-ccl.lisp (definition-name): Special case methods. * slime.el (slime-choose-overlay-region): Don't return zero length regions for :eof. (slime-show-buffer-position): The second argument to display-buffer means something completely different in XEmacs. Don't use it. (slime-severity-face): Handle :redefinition. (slime-temporarily-highlight-note): Use a timer instead of the post-command-hook. 2009-08-13 Stas Boukarev * slime.el (slime-auto-select-connection, slime-auto-connect): Turn them into customizable variables. 2009-08-11 Tobias C. Rittweiler * swank-sbcl.lisp (swank-compile-string): Make sure that it returns NIL on compilation failure. 2009-08-10 Helmut Eller * slime.el (slime-insert-note-group): Factored out from slime-insert-compilation-log. (slime-goto-location-position): Can't use goto-line. 2009-08-10 Helmut Eller Separate context info from compiler message text. * swank-backend.lisp (compiler-condition): Add a new slot :source-context. Remove :short-message. * swank-cmucl.lisp, swank-sbcl.lisp, swank-scl.lisp, swank-openmcl.lisp, swank-ccl.lisp: Update callers. * swank.lisp (make-compiler-note): Use source-context slot. * slime.el (slime-note.source-context): New. (slime-insert-compilation-log): Use it. (slime-note.short-message): Deleted. 2009-08-10 Helmut Eller Don't add linebreaks for one-line messages. (slime-insert-block): New function. (slime-insert-compilation-log): Use it. (slime-indent-rigidly): Use insert-before-markers, otherwise point ends up at before a bunch of inserted spaces. 2009-08-10 Helmut Eller Various compilation related changes. * slime.el (slime-show-note-counts): Don't show 0 values. (slime-severity<): New function. (slime-maybe-show-compilation-log): Always create the log buffer but display it only if the compilation failed. (slime-insert-compilation-log): Disable the stupidly inefficient font-lock-after-change-function. (slime-canonicalized-location-to-string): Use relative filenames. (slime-goto-location-buffer): Disable warnings about symlinks. 2009-08-09 Tobias C. Rittweiler Make C-x ` work again. M-n and C-x ` are now very similiar; but the former operates relative to point in the source buffer, while the latter works relative to the compilation log. * slime.el (slime-insert-compilation-log): No do set `compilation-skip-to-next-location'. 2009-08-09 Tobias C. Rittweiler M-n/M-p in .lisp buffers do not show the note in the minibuffer anymore if a compilation log is displayed to the user. In the compilation log, sort and group the notes by line/column number. * slime.el (slime-insert-compilation-log): Sort the notes by their line/column numbers; group notes of same location and display them as one entry. (slime-compilation-loc): Removed. (slime-canonicalized-location), (slime-canonicalized-location-to-string): Extracted from `slime-compilation-loc'. (slime-group-and-sort-notes): Does the sorting/grouping. (slime-show-note): Do not show note in minibuffer if compilation log is displayed to the user. 2009-08-09 Stas Boukarev * swank.asd (asdf:perform): don't call `swank-loader:init' with :setup nil, because it doesn't get contribs compiled, and some other configuration steps are omitted. * slime.el (slime-profile-by-substring): new function for profiling functions by matching a substring. * swank.lisp (profile-by-substring): ditto. 2009-08-08 Tobias C. Rittweiler M-n / M-p in a .lisp buffer now also jump to the respective note in the compilation-log buffer if one is currently displayed to the user. * slime.el (slime-remove-old-overlays): Simplified. (slime-insert-compilation-log): Add a note-overlay for each note so we can find the right one when user uses M-n/M-p in .lisp buffer. (slime-goto-note-in-compilation-log): New. (slime-make-note-overlay): Extracted from `slime-create-note-overlay'. (slime-next-note, slime-previous-note): Simplified. (slime-show-note): Goto note in compilation-log if available. (slime-note-overlay-p): Call overlay property `slime-note', not just `slime'. (slime-find-note): Likewise; also returns the overlay if found. (slime-show-buffer-position): Optionally recenter position to the top of the window. 2009-08-04 Stas Boukarev * swank-sbcl.lisp (signal-compiler-condition): read sb-kernel:redefinition-warning only if it exists. Some older SBCLs don't have it (particularly included in the stable Debian). 2009-08-02 Tobias C. Rittweiler * swank-backend.lisp (severity [type]): Allow :redefinition. * swank-sbcl.lisp (signal-compiler-condition): Tag redefinitions. * slime.el (slime-maybe-show-compilation-log): Do not show compilation log if each note describes just a redefinition. (slime-insert-compilation-log): Insert notes indented by 2 spaces. Insert some more newlines so the buffer appears more structured. (slime-show-note-counts): Add :redefinition to ecase. (slime-redefinition-note-p): New. (slime-severity-label): Was unused. Adapted to be usable. 2009-07-30 Stas Boukarev * doc/slime.texi (Setting up pathname translations): add that it is in the `slime-tramp' contrib. 2009-07-30 Tobias C. Rittweiler * swank-clisp.lisp: Clisp 2.48 experimentally supports threads. So add infrastructure to use threads in Clisp's swank backend. We do not make it the default, because it's not prime time yet. There are still problems with GC, weak-pointers, and thread objects. 2009-07-28 Stas Boukarev * doc/slime.texi (slime-selector): mention t and c keys. 2009-07-27 Stas Boukarev * swank-ccl.lisp (source-note-to-source-location): keys of *temp-file-map* are pathnames, not namestrings; convert namestrings to pathnames before looking up. 2009-07-27 Geo Carncross * swank-ecl.lisp: Support for older ECL installs from patch by Mark Evenson 2009-07-26 Helmut Eller * slime.el (slime-maybe-show-compilation-log): New function. (slime-compilation-finished-hook): Use it. Now that the compilation buffer gets not selected it's more acceptable to display it more often. (slime-insert-compilation-log): Set compilation-skip-threshold to 0 and compilation-skip-to-next-location to nil. Seems to work better for us. (slime-with-popup-buffer): Synch window-point, otherwise it be at the end of the buffer for reused buffers. (slime-display-popup-buffer): Return the window. 2009-07-26 Helmut Eller * swank-sbcl.lisp (tempnam): Muffle efficiency notes. 2009-07-26 Gail Zacharias * swank-ccl.lisp: New file. An updated version of swank-openmcl.lisp in preparation for a slew of changes to CCL and to honor the new name. * swank-loader.lisp (*sysdep-files*): Use it. 2009-07-21 Stas Boukarev * slime.el (slime-sexp-at-point-for-macroexpansion): use markers for bounds, because in some situations text layout could be modified before bounds would be used, for example, using keyboard macros. 2009-07-15 Stas Boukarev * slime.el (slime-inspector-fetch-all): new command, bound to > in the inspector buffer. * doc/slime.texi (Frame Navigation): add description of `sldb-end-of-backtrace' and `sldb-beginning-of-backtrace'. (Inspector): add `slime-inspector-fetch-all'. 2009-07-12 Helmut Eller * slime.el (slime-editing-keys): Don't override M-*. The default binding should do what Matthias wants. 2009-07-11 Matthias Koeppe * swank-backend.lisp (definterface): Fix typo in error message. 2009-07-11 Stas Boukarev * doc/Makefile (clean): Remove bash extensions. Patch by Teemu Likonen. 2009-07-06 Tobias C. Rittweiler * swank-ecl.lisp (find-external-format): Copied from swank-sbcl.lisp. A lot of backends seem to share the same implementation, perhaps some refactoring is needed. 2009-07-06 Tobias C. Rittweiler * swank.lisp (make-repl-input-stream): Make sure to redirect output from slime requests to the REPL buffer for communication-style=NIL. 2009-07-02 Stas Boukarev * slime.el (slime-beginning-of-symbol): Limit searching to 2000 characters. 2009-07-02 Terje Norderhaug * swank-lispworks.lisp (thread-attributes): Implemented. 2009-07-02 Helmut Eller * swank.lisp (ed-in-emacs): Handle symbols/function-names better. * slime.el (slime-ed): Updated accordingly. 2009-07-02 Terje Norderhaug * swank.lisp (operator-arglist): Don't use pprint-fill for people with wide screens. 2009-07-02 Stas Boukarev * slime.el (slime-net-coding-system): make it customizable. (slime-inspector-operate-on-click): Make --more-- button in the inspector clickable. 2009-06-30 Geo Carncross * swank-ecl.lisp: Package profiling support 2009-06-30 Stas Boukarev * swank-openmcl.lisp (arglist): Return :not-available if the arglist cannot be obtained. Patch by Terje Norderhaug. 2009-06-29 Stas Boukarev * swank.lisp (open-streams): do not create unnecessary output stream when using dedicated output stream. Thanks to Terje Norderhaug. 2009-06-28 Terje Norderhaug Generalize list-threads for implementation-dependent attributes. * swank-backend.lisp (thread-attributes): New function. * swank-openmcl (thread-attributes): Implement it. * swank.lisp (list-threads): Return a table with the attribute names as the first row and the new attributes in the last columns. * slime.el (slime-update-threads-buffer): For now, ignore the extra attributes. 2009-06-28 Stelian Ionescu * slime.el (slime-compiler-macroexpand-inplace) (slime-compiler-macroexpand-1-inplace): New commands. (slime-macroexpansion-minor-mode-map): Bind them. 2009-06-28 Helmut Eller * swank-sbcl.lisp (add-fd-handler): Avoid recursive invocation of the handler, e.g. when read-sequence blocks. 2009-06-28 Stas Boukarev * swank-openmcl.lisp (compiler-warning-short-message): In new versions of CCL `compiler-warning-nrefs' slot of the `compiler-warning' class is now a list, not an integer. 2009-06-25 Geo Carncross * swank-ecl.lisp: Profiling support by Marko Koci? 2009-06-27 Helmut Eller * slime.el (slime-beginning-of-symbol): Skip over #., #-, and #+. ([test] symbol-at-point.15 .. 17): Test it. 2009-06-24 Nikodemus Siivola Add :WAIT keyword argument to support blocking in SWANK:INSPECT-IN-EMACS. * swank.lisp (inspect-in-emacs): added keyword argument :wait. * slime.el (slime-dispatch-event): if swank requests response to :inspect, add a hook to the inspector to signal swank once done. (slime-open-inspector): add optional hook argument to be added as local kill-buffer-hook. 2009-06-21 Helmut Eller * slime.el (slime-initialize-lisp-buffer-for-test-suite): Moved to contrib/slime-fontifying-fu.el 2009-06-21 Helmut Eller Don't try so hard to get symbol-at-point right. The old implementation was complicated and didn't even pass it's own test suite. The new version is less ambitious but simpler. * slime.el (slime-symbol-at-point, slime-beginning-of-symbol) (slime-end-of-symbol): Simplify. (slime-exit-vertical-bars, slime-symbol-constituent-at): Deleted. ([test] symbol-at-point.1 .. symbol-at-point.14): Renamed form fancy-symbol-names and split up into smaller peices. (slime-test-symbols): New. (slime-check-symbol-at-point): Renamed from slime-check-fancy-symbol-name. 2009-06-21 Helmut Eller * swank-backend.lisp (frame-source-location): Renamed from frame-source-location-for-emacs. 2009-06-20 Helmut Eller * slime.el (slime-check-fancy-symbol-name): Don't update the loop index inside the loop body. 2009-06-20 Helmut Eller * swank-openmcl.lisp (emacs-connected): Deleted. Setting ccl::*interactive-abort-process* doesn't seem right. 2009-06-15 Helmut Eller * swank-openmcl.lisp: Explicitly require CCL version 1.3. 2009-06-15 Helmut Eller * swank-openmcl.lisp (emacs-inspect [t]): Honor the type returned by inspector::line-n. (emacs-inspect [compiled-lexical-closure]): Deleted. Let CCL's inpector handle this case. Which does it better and it's less work for us. 2009-06-14 Helmut Eller Some workarounds for SBCL on Windows. * swank-sbcl.lisp (input-available-p): New function. (wait-for-input): Use it. ([win32] handle-listen, has-buffered-input-p): New. (temp-file-name, tempnam): Plain tmpnam(3) is next to useless on Windows use tempnam(3) instead. 2009-06-12 Geo Carncross * swank-ecl.lisp: Support new environment changes in recent ECL/CVS patch largely from ECL maintainer. 2009-06-11 Tobias C. Rittweiler * slime.el ([test] font-lock-magic): Moved to fontifying-fu contrib. 2009-06-05 Helmut Eller Don't clutter compiler messages with source positions. Especially stuff like "In an anonymous lambda form inside an anonymous lambda form inside an anonymous lambda form inside FOO: Undeclared free variable X" is not helpful. * swank-openmcl.lisp (compiler-warning-short-message): New GF. (handle-compiler-warning): Use it. (disassemble-frame): Print current PC. 2009-06-04 Helmut Eller * slime.el (slime-dispatch-event [:emacs-rex]): Don't clutter the main code-path with confusing error handling. 2009-06-04 Helmut Eller * swank-openmcl.lisp (*known-processes*, mailbox): Use a weak hashtable to plug the memory leak. 2009-05-28 Tobias C. Rittweiler * slime.el (def-slime-test): Forgot to remove debugging code. 2009-05-28 Tobias C. Rittweiler * slime.el (slime-dispatch-event :emacs-rex): Make sure that we pop the continuation on erroneous send. Patch by Mark Cox . 2009-05-28 Tobias C. Rittweiler * swank.lisp (tokenize-symbol-thoroughly): Make it work correctly on escaped symbols. 2009-05-28 Tobias C. Rittweiler * slime.el (slime-disconnect): Now only disconnects one connection, current one by default, or given by argument. (slime-disconnect-all): New. What `slime-disconnect' was before. (def-slime-test): Changed: expected failures are now given by (:fails-for ...) clauses. Extended: new clause (:style ...) to have a test run only on a certain communication style. Updated existing test cases accordingly. ([struct] slime-test): New slot `skipped'. (slime-skipped-tests): New var. (slime-execute-tests): Adapted accordingly. ([test] disconnect): Renamed to `disconnect-and-reconnect' ([test] disconnect-one-connection): New. Adapted from patch by Stas Boukarev. 2009-05-24 Tobias C. Rittweiler * slime.el ([test] fancy-symbol-names): Add cases involving #| ... |# style comments. Currently failing. Reported by Madhu. 2009-05-24 Tobias C. Rittweiler * slime.el (slime-goto-location-position): Only go to match-beginning if search succeeded. Patch by Madhu. 2009-05-23 Helmut Eller * swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*. That means that we can't use SIGNAL here and we have to invoke SLDB directly. (condition-for-break): New helper. Reported by Bill St. Clair. 2009-05-19 Tobias C. Rittweiler * slime.el (slime-symbol-at-point): Sometimes we can be too good, e.g. in "|# (defun foo () (getf" the above would return nil because the vertical bar is not terminated. The user probably wants "getf" nontheless. Reported by Madhu. 2009-05-19 Tobias C. Rittweiler * slime.el (sldb-restartable-frame-line-face): Set a default value. (sldb-frame-restartable-p): New. (sldb-compute-frame-face): Use it. (sldb-show-frame-details): Use it, too. 2009-05-19 Nikodemus Siivola * swank-source-path-parser.lisp (read-and-record-source-map): ignore errors during the call to READ, so that we don't the current version of the form we are looking at contains eg. uninternable symbols. 2009-05-19 Helmut Eller * swank-openmcl.lisp (source-note-to-source-location): Always test *temp-file-map* first, because the temp-file might actually exist during compilation but no longer when Emacs tries to open it. (slime-goto-location-buffer): Don't create buffers for non-existent files. 2009-05-18 Nikodemus Siivola * slime.el (slime-description-autofocus): New variable. (slime-show-description): Use it to decide if description buffers should receive focus automatically. * doc/slime.texi: Document it. 2009-05-17 Tobias C. Rittweiler * slime.el (slime-dispatch-event): New event `:read-from-minibuffer'. (slime-read-from-minibuffer-for-swank): New. * swank.lisp (dispatch-event): Pass through :read-from-minibuffer event. (read-from-minibuffer-in-emacs): Now uses new event rather than eval-in-emacs. 2009-05-17 Helmut Eller * swank-openmcl.lisp (compile-temp-file): Remove backward compatibility code. (eval-in-frame, frame-source-location-for-emacs) (return-from-frame, restart-frame) (disassemble-frame, xref-locations): Simplify. (list-callers): Use ccl::caller-functions which gives us more precise src-locs than ccl::callers. (canonicalize-location, remove-filename-quoting) (maybe-method-location): Deleted. No longer used. (who-specializes): Simplify. 2009-05-17 Helmut Eller More precise compiler-message location. * swank-openmcl.lisp (handle-compiler-warning): Use the source-note slot of the condition as source location, which is more precise than the stream-position slot. (compiler-warning-severity): New function. The distinction between warning and style-warning is rather arbitrary but let's try it. (swank-compile-file): Pass the external-format arg down to compile file. (*buffer-name*, *buffer-offset*, condition-source-position): Deleted. No longer used. 2009-05-16 Helmut Eller Minor refactoring. * swank-openmcl.lisp (call/frame, with-frame): New macro. (frame-visible-variables): New helper. (frame-var-value, frame-locals, disassemble-frame): Use it. (frame-catch-tags): Removed. Way to much code for such a rarely used function. 2009-05-16 Helmut Eller * swank-openmcl.lisp (swank-compile-string): Store the source code, by setting CCL:*SAVE-SOURCE-LOCATIONS* to T, for better disassembler output. (function-source-location): Remove the old pre-1.3 version. * swank.lisp (sldb-bitvector-pprint): Oops, all bits are true. 2009-05-16 Tobias C. Rittweiler * slime.el (slime-current-parser-state): Do not save match-data. This function is called so often that it makes a difference. 2009-05-16 Helmut Eller * swank.lisp (*sldb-pprint-dispatch-table*): Be careful when calling WRITE recursively: set :circle to nil which avoids interference with cycle-detection. (escape-string): New helper function. (*backtrace-pprint-dispatch-table*): Use it. 2009-05-15 Tobias C. Rittweiler * swank-allegro.lisp (swank-compile-string): Forgot to remove old definition in changeset 2009-05-12. Patch by Stelian Ionescu. 2009-05-15 Tobias C. Rittweiler Move font-lock-magic into contrib/slime-fontifying-fu.el. * slime.el (slime-highlight-suppressed-forms), (slime-reader-conditional-face), (slime-search-suppressed-forms-internal), (slime-search-suppressed-forms), (slime-search-directly-preceding-reader-conditional), (slime-extend-region-for-font-lock), (slime-compute-region-for-font-lock), (slime-activate-font-lock-magic): Moved. 2009-05-15 Tobias C. Rittweiler Rewrote some parts of the font-lock-magic in face of its fragility over the last days. Hopefully it'll be better now. * slime.el (slime-region-for-tlf-at-point): Removed. Not needed anymore. (slime-region-for-extended-tlf-at-point): Removed. (slime-search-backward-reader-conditional): Removed. (slime-search-directly-preceding-reader-conditional): New. Similiar to the above. (slime-extend-region-for-font-lock): Display bug message when error is caught. (slime-compute-region-for-font-lock): Rewritten. ([test] font-lock-magic): Another test case. 2009-05-14 Tobias C. Rittweiler * slime.el (slime-region-for-tlf-at-point): Use `(end-of-defun) (backward-sexp)' rather than `(end-of-defun) (beginning-of-defun' to go to the start of the current defun. The latter would fail on "() (a\nb\nc)". 2009-05-14 Tobias C. Rittweiler * slime.el (slime-compute-region-for-font-lock): Fix typo. 2009-05-13 Tobias C. Rittweiler * slime.el (slime-search-suppressed-forms): On errors, we have to continue the search, otherwise there's a chance that we miss reader conditionals in the current font-lock region. (slime-search-backward-reader-conditional): New. Extracted from `slime-region-for-extended-tlf-at-point'. (slime-region-for-extended-tlf-at-point): Use it. (slime-font-lock-region): Removed. (slime-font-lock-region-changed-p): Removed. (slime-extend-region-for-font-lock): Simplified. (slime-compute-region-for-font-lock): Make sure that we never return a flag indicating change when there was in fact no change. This should make the explicit guard against infinite loop superfluous. (slime-extend-region-warn-infinite-loop): Removed. ([test] font-lock-magic): More cases. 2009-05-12 Tobias C. Rittweiler Make font-lock-magic test case pass. * slime.el (slime-bug): New function. (slime-search-suppressed-forms): Use it. (slime-extend-region-warn-infinite-loop): Ditto. (slime-search-suppressed-forms-internal): Check whether we're inside a comment, or a string. ([test] font-lock-magic): Add another case. 2009-05-12 Tobias C. Rittweiler Highlight reader-errors in the source buffers on Allegro. * swank-allegro.lisp (*temp-file-header-end-position*): New variable. (call-with-compilation-hooks): Handle reader errors. (handle-compiler-warning): Adapt it accordingly. (location-for-reader-error): New. (compile-from-temp-file): Now takes a header argument explicitly so we can hold of the actual offset of the string we want to compile. This is needed to translate back file-positions reported in reader-errors. (swank-compile-string, swank-compile-file): Adapted accordingly. 2009-05-12 Tobias C. Rittweiler * swank-allegro.lisp (find-topframe): Hide SWANK related cruft from showing up in backtraces in SLDB. 2009-05-12 Tobias C. Rittweiler * slime.el (slime-display-warning): Add `warning' as warning type. (slime-show-note-counts): If compilation failed, fontify the message in red to be more visibly apparant. 2009-05-11 Tobias C. Rittweiler (slime-eval-feature-expression): Guard for more erroneous input (due to refontification while user's typing.) 2009-05-10 Helmut Eller * slime.el ([test] font-lock-magic): Add some hard cases. 2009-05-10 Tobias C. Rittweiler * slime.el (slime-compute-region-for-font-lock): Fix typo. 2009-05-10 Tobias C. Rittweiler Font-lock magic barfed on #+(test). * slime.el (slime-eval-feature-conditional): Renamed to `slime-eval-feature-expression'. (slime-unknown-feature-expression): New error symbol. (slime-eval-feature-expression): Signal it. (slime-search-suppressed-forms): Catch it. (slime-compute-region-for-font-lock): Guard against unbalanced parentheses. (slime-initialize-lisp-buffer-for-test-suite): New helper. ([test] font-lock-magic): New test case. Reported by Kalyanov Dmitry. 2009-05-09 Tobias C. Rittweiler * swank-source-file-cache.lisp (read-snippet-from-string): New. * swank-sbcl.lisp (source-hint-snippet): Use it. (emacs-buffer-source-location): Use it, too. (string-path-snippet): Ditto. Additionally: Make sure the returned string is truncated by *SOURCE-SNIPPET-SIZE*. 2009-05-08 Tobias C. Rittweiler * slime.el (slime-search-suppressed-forms-internal): Not properly factored out by earlier changeset. 2009-05-08 Tobias C. Rittweiler * swank.lisp (read-from-minibuffer-in-emacs): New. ([struct] istate): Add METADATA-PLIST slot. (ensure-istate-metadata): New. To attach arbitrary metadata to an inspector page. (inspect-object): Adapted so methods on EMACS-INSPECT can look at *ISTATE*. 2009-05-08 Tobias C. Rittweiler #+#.foo confused the recent fontification changes. Fix that. * slime.el (slime-search-suppressed-forms-internal): New. Split from `slime-search-suppressed-forms'. (slime-search-suppressed-forms): Catch `invalid-read-syntax' errors. 2009-05-01 Tobias C. Rittweiler * slime.el (slime-line-number-at-pos): Replaced with `line-number-at-pos', and add that to the portability layer. (display-warning): Add to the portability layer. (slime-display-warning): New. * slime.el: Implement a guard against infinite loops during fontification. We detect and prevent those. If we detect one, we emit a big warning to the user. (slime-font-lock-region): New variable. (slime-font-lock-region-changed-p): New helper. (slime-extend-region-warn-infinite-loop): New helper. (slime-compute-region-for-font-lock): Extracted from `slime-extend-region-for-font-lock'. (slime-extend-region-for-font-lock): Use it; add the guard. 2009-04-30 Tobias C. Rittweiler * swank-abcl.lisp: Really commit Vodonosov's patch from 2009-03-09. 2009-04-30 Tobias C. Rittweiler * swank-backend.lisp ([default] declaration-arglist): Add arglist of DECLARATION declaration. * swank-openmcl.lisp ([eql 'optimize] declaration-arglist): Implement it for CCL. (describe-symbol-for-emacs): Add :TYPE. (describe-definition): Add :TYPE. Adapted from patch by Stas Boukarev. 2009-04-29 Tobias C. Rittweiler * slime.el (slime-extend-region-for-font-lock): (nth 0 ) may return negative numbers. 2009-04-29 Tobias C. Rittweiler * slime.el: Fix infinite loop during fontification introduced by yesterday's changeset. (slime-region-for-tlf-at-point): New. Like `slime-region-for-defun-at-point' but tries harder to get the toplevel form right. (slime-region-for-extended-tlf-at-point): Previously `slime-region-for-extended-defun-at-point'. (slime-extend-region-for-font-lock): Use it. (slime-mark-defun-for-font-lock): Ditto. 2009-04-28 Tobias C. Rittweiler * slime.el: Fix fontification of suppressed (by reader conditionals) forms. That is make it reliably and totally work. (slime-region-for-extended-defun-at-point): New. Like `slime-region-for-defun-at-point' but takes preceding reader conditionals into account. (slime-extend-region-for-font-lock): New. Make sure that fontification operates on regions spanning a whole toplevel form only. So we never operate within the context of a reader conditional and we never miss any of those. (slime-search-suppressed-forms): Remove ignore-errors; not needed anymore now as we extend the region for fontification. (slime-mark-defun-for-font-lock): New. (slime-activate-font-lock-magic): Push `slime-extend-region-for-font-lock' onto `font-lock-extend-region-functions'. 2009-04-25 Tobias C. Rittweiler * slime.el (slime-show-description): Put the connection name into the buffer name for description buffers. So we can have multiple description buffers open, one per connection. Useful for comparing the output of DISASSEMBLE across implementations. 2009-04-21 Tobias C. Rittweiler * slime.el (slime-handle-indentation-update): Revert change from 2009-03-09; that was a thinko. ([test] indentation): Some basic test case for correct indentation. 2009-04-03 Tobias C. Rittweiler * swank-sbcl.lisp (swank-compile-file): Return T for the FAILURE-P return value in case of a FATAL-COMPILER-ERROR. Reported by Philipp M. Schäfer 2009-04-03 Tobias C. Rittweiler * slime.el (slime-inspector-mode-map): Remove binding for M-RET. (It'll be added by the slime-repl contrib.) (slime-inspector-copy-down): Removed. 2009-03-27 Helmut Eller * swank.lisp (encode-message): Handle errors during write, e.g. closed sockets. 2009-03-27 Helmut Eller * slime.el (slime-setup-contribs): Moved over from slime-autoloads.el 2009-03-27 Helmut Eller * swank-openmcl.lisp (toggle-trace): Replace ccl::%trace with ccl:trace-function. (kill-thread): Use an implementation that doesn't raise a serious-conditions. 2009-03-27 Helmut Eller * slime.el ([test] macroexpand): Fix more case issues. 2009-03-25 Helmut Eller * slime.el ([test] macroexpand): Ignore case. 2009-03-09 Tobias C. Rittweiler * slime.el (slime-define-channel-type): Indulge in pretty colors. (slime-define-channel-method): You, too! (slime-handle-indentation-update): Always put an indentation update on 'slime-indent; for slime-indentation-fu. 2009-03-09 Anton Vodonosov Use correct encoding and eol conventions for socket streams. * swank-abcl.lisp (accept-connection): Honor external-format argument. (*external-format-to-coding-system*, find-external-format): New. 2009-03-09 Helmut Eller * slime.el (slime-with-xref-buffer): Use buffer-names like "*slime xref...*" so that slime-kill-all-buffers can pick it up easily. 2009-03-09 Helmut Eller * hyperspec.el (common-lisp-hyperspec-lookup-reader-macro): Use case-insensitive completion. (hyperspec-lookup-reader-macro): New alias. Suggested by Stas Boukarev. 2009-03-09 Helmut Eller Make fasl-pathname fully customizable not only the direcrory part. * swank.lisp (*fasl-pathname-function*): New variable. (*fasl-directory*): Deleted. 2009-03-08 Tobias C. Rittweiler * slime.el (slime-choose-overlay-for-read-error): Extracted and extended from `slime-choose-overlay-region'. Differentiate between symbol-related reader-errors (package not found &c) and character-related reader-errors. (slime-choose-overlay-region): Use it. 2009-03-08 Tobias C. Rittweiler * slime.el (make-slime-buffer-location, make-slime-file-location): Do not default to (:hints), but to nil, as expected in the slime-side source-location machinery. 2009-03-08 Tobias C. Rittweiler * slime.el (slime-choose-overlay-region): Special case :read-error notes regardless of position kind. * swank-sbcl.lisp (signal-compiler-condition): Return :READ-ERROR as severity for reader-errors. (compiler-note-location): Fix off-by-one when compiling from buffer. 2009-03-08 Tobias C. Rittweiler * swank-sbcl.lisp (compiling-from-buffer-p), (compiling-from-file-p) (compiling-from-generated-code-p): New helpers; extracted from LOCATE-COMPILER-NOTE. (locate-compiler-note): Use them. (compiler-note-location): Use them, too, to handle reader-errors when compiling from file. This completes 2009-02-27. Reported by Christian Lynbech. 2009-03-07 Tobias C. Rittweiler * slime.el ([portability] getf): Redefine `getf' on Emacs21 to work on malformed plists like it does on later Emacsen. This made the `find-local-definitions' test case fail on Emacs21. 2009-03-04 Tobias C. Rittweiler * slime.el (slime-check-fancy-symbol-name): Use `slime-test-expect' instead of `slime-check'. ([test] fancy-symbol-names): Extend test case; check for "Foo" in #. (slime-symbol-constituent-at-pos): Check for #<. 2009-03-04 Tobias C. Rittweiler * slime.el (slime-wait-condition): Remove `save-excursion'; it made the `repl-test' test case fail because this test tries to set point to the new prompt in vain. 2009-03-03 Helmut Eller * slime.el (slime-pretty-package-name): Simplify. 2009-03-03 Helmut Eller Use a separate key, C-c C-d #, to lookup reader-macros. * hyperspec.el (common-lisp-hyperspec-lookup-reader-macro): New command. (common-lisp-hyperspec-reader-macros): New variable. (common-lisp-hyperspec-reader-macro-at-point): Moved over from slime.el * slime.el (slime-doc-bindings): Bind C-c C-d #. (slime-hyperspec-lookup): Don't consider reader-macros. 2009-03-02 Tobias C. Rittweiler * hyperspec.el (common-lisp-hyperspec-symbols): Add entries for reader macros even when `common-lisp-hyperspec-symbol-table' is bound to some value. 2009-02-27 Tobias C. Rittweiler * slime.el ([test] macroexpand): New test case. (slime-buffer-visible-p): New helper. (slime-execute-as-command): New helper. 2009-02-27 Tobias C. Rittweiler * hyperspec.el (common-lisp-hyperspec-symbols): Add links to reader macros. * slime.el (slime-reader-macro-at-point): New function. (slime-hyperspec-lookup): Call it. Adapted from Stas Boukarev. 2009-02-27 Tobias C. Rittweiler * slime.el: Rename `slime-symbol-name-at-point' to `slime-symbol-at-point'. 2009-02-27 Tobias C. Rittweiler * slime.el ([portability] lisp-mode-syntax-table): On Emacs21, make @ a prefix character like it's from Emacs22 onward. `slime-symbol-name-at-point' was written with that assumption. 2009-02-27 Tobias C. Rittweiler * slime.el (slime-current-parser-state): Wrap `syntax-ppss' in a `save-match-data'. This issue has been reported to the Emacs maintainers. 2009-02-27 Tobias C. Rittweiler * slime.el (slime-defun-if-undefined), (slime-defmacro-if-undefined): Renamed to `slime-DEFUN-if-undefined' and `slime-DEFMACRO-if-undefined' to better differentiate between the two. (slime-indulge-pretty-colors): New function. You can now put a symbol on the plist of `slime-indulge-pretty-colors' to make the symbol be fontified like `defun'. This is done for `slime-def-connection-var', and the two symbols above. 2009-02-27 Tobias C. Rittweiler * slime.el (slime-defmacro-if-undefined): New. Analogous to `slime-defun-if-undefined'. ([portablity]] with-selected-window) Use it. ([portability] with-temo-buffer): Likewise. Patch by Theam Yong Chew. 2009-02-27 Tobias C. Rittweiler C-c C-c on (defun foo () ,bar) did not result in a compiler note overlay on SBCL. * swank-sbcl.lisp (compiler-note-location): Make it take a condition; if the condition is a READER-ERROR, the passed compiler-error-context is very likely NIL---we have not proceeded beyond reading, so we aren't within the compiler yet. In that case, we use the stream position of the stream behind the READER-ERROR instead. 2009-02-26 Tobias C. Rittweiler * doc/slime.texi: Fix typos, and add keybindings not listed there. Patch by Stas Boukarev. 2009-02-26 Tobias C. Rittweiler * slime.el (sldb-backward-frame): Only move backward when we're below the backtrace marker. 2009-02-26 Tobias C. Rittweiler * swank.lisp (debug-in-emacs): Moved (WITH-BINDINGS *SLDB-PRINTER-BINDINGS* ...), from here... (sldb-loop): ... to here. Otherwise results from a user doing an eval-in-frame were truncated. Reported by Jeff Workman. 2009-02-26 Tobias C. Rittweiler * swank.lisp (hash-table-to-alist): New function. ([method] emacs-inspect (hash-table)): Sort keys if they're all numbers, symbols, or strings. Adapted from Willem Broekema. 2009-02-26 Tobias C. Rittweiler * swank-backend.lisp (warn-unimplemented-interfaces): Bind *PRINT-PRETTY* to T. Otherwise no sugar formatting on CCL. 2009-02-26 Tobias C. Rittweiler * slime.el (slime-pretty-package-name): Signalled an error on simple symbols; fix that! Reported by Geoff Wozniak. 2009-02-26 Tobias C. Rittweiler * slime.el (slime-current-form-path): Use `slime-current-parser-state'. 2009-02-26 Tobias C. Rittweiler * slime.el ([test] fancy-symbol-names): New, hopefully comprehensive, test for funky symbol names. (slime-check-fancy-symbol-name): Helper. (slime-exit-vertical-bars): New function to move out from |foo|. (slime-symbol-constituent-at): New predicate to test whether the character at point is a valid symbol constituent. (slime-beginning-of-symbol, slime-end-of-symbol): Rewritten using above two functions and `forward-sexp' that correctly parses escapes etc. (slime-sexp-at-point): Consider thing at point a symbol first. 2009-02-24 Tobias C. Rittweiler * slime.el (slime-forward-cruft): Forward whitespace, reader conditonals, comments. Splitted from `slime-forward-sexp'. (slime-pretty-package-name): Use it. 2009-02-24 Tobias C. Rittweiler Re-checkin my change from 2009-02-14. It seems I didn't actually commit it. 2009-02-22 Tobias C. Rittweiler `M-x slime-format-string-expand' displays the expansion of a format string. * slime.el (slime-string-at-point) New. (slime-string-at-point-or-error): New. (slime-format-string-expand): New; use them. * swank-backend.lisp (format-string-expand): New interface. * swank.lisp (swank-format-string-expand): New; use it. 2009-02-17 Helmut Eller * swank.lisp (dispatch-event [:emacs-rex]): Reply a :invalid-rpc message if the specified thread doesn't exist. * slime.el (slime-dispatch-event): Handle :invalid-rpc. (slime-init-connection-state): Bind slime-current-thread to avoid problems with dead threads. 2009-02-14 Tobias C. Rittweiler * slime.el (slime-reader-conditionals-regexp): New variable. Taken from `slime-forward-reader-conditional'. (slime-pretty-package-name): Fix modeline display for buffer containing forms like (in-package "#+foo :A #-foo :B"). Also do not call `read' on the name; the function does not need to return a symbol, and `read' may choke on non-elisp syntax. 2009-02-14 Helmut Eller Don't signal conditions in interrupt handler to avoid problems with naive code like (handler-case foo (condition bar)) * swank-backend.lisp (*interrupt-queued-handler*): Use a dynamic variable instead. (slime-interrupt-queued): Deleted. * swank-cmucl.lisp, swank.lisp: Ditto. 2009-02-14 Helmut Eller * slime.el (slime-restart-or-init-modeline-update-timer): Don't run the timer repeatedly. (slime-change-directory): Also change the directory in the connection-buffer. 2009-02-11 Tobias C. Rittweiler * slime.el (slime-current-tlf, slime-current-form-path): New functions; can be handy when inspecting source-locations while debugging M-. 2009-02-11 Tobias C. Rittweiler * slime.el: Barf if emacs-major-version <= 20. We support 21 and up. (slime-emacs-20-p): Removed. * slime.el (slime-forward-reader-comment): Removed. (slime-forward-any-comment): New; superset of above. (slime-forward-reader-conditional): Make it understand SBCL's #!+,#!- so it works in source files of SBCL itself, too. (slime-current-parser-state): New. 2009-02-07 Tobias C. Rittweiler In Xref, list IR1-conversion functions with :DEF-IR1-TRANSLATOR as prefix rather than DEFUN. (Test case: M-. on FUNCTION.) * swank-sbcl.lisp (definition-specifier): New function. (make-dspec): New function. Splitted from MAKE-SOURCE-LOCATION-SPECIFICATION. 2009-02-07 Tobias C. Rittweiler * slime.el (slime-initialize-macroexpansion-buffer): Clear the buffer-undo-list, so the user can't get expansions from earlier macroexpansions into the buffer, screwing up badly. 2009-01-30 Tobias C. Rittweiler * swank-clisp.lisp (fspec-location): Fix creation of source-location. Patch by Carsten Blaauw. 2009-01-30 Geo Carncross * swank-ecl.lisp (grovel-docstring-for-arglist): Fix for arglist that reads, but isn't a list 2009-01-27 Tobias C. Rittweiler * swank-backend.lisp (with-symbol): New function, to be used with #+. * swank-sbcl.lisp: Use WITH-SYMBOL and get rid of SBCL-WITH-SYMBOL. * swank-openmcl.lisp (macroexpand-all): Implement it. Patch by Stas Boukarev. 2009-01-23 Tobias C. Rittweiler * slime.el (slime-editing-keys): New variable; splitted from `slime-keys'. Contains key bindings that are useful for buffers where users can edit s-exprs, such as source buffers and the REPL. (slime-keys): Use it. 2009-01-17 Tobias C. Rittweiler Fix C-u C-c C-c in SLDB. * slime.el (sldb-recompile-frame-source): sind `slime-compilation-policy' at the right place. 2009-01-15 Martin Simmons * swank-lispworks.lisp: wrapper functions for swank-mop slot-boundp-using-class, slot-value-using-class and slot-makunbound-using-class to account for MOP differences. 2009-01-16 Helmut Eller * slime.el (slime-keys): Put C-c C-i and M-* back. 2009-01-16 Helmut Eller * swank.lisp (pprint-eval): Also return the output produced during evaluation. 2009-01-16 Helmut Eller * swank-openmcl.lisp (break-in-sldb): Display the argument. 2009-01-16 Helmut Eller * swank-backend.lisp (warn-unimplemented-interfaces): Print the names with pprint-fill. 2009-01-10 Helmut Eller * swank-openmcl.lisp (install-debugger-globally): Set *break-in-sldb*. 2009-01-10 Tobias C. Rittweiler * swank.lisp (do-symbols*): Wrap body in TAGBODY. 2009-01-10 Helmut Eller * slime.el (slime-compile-file-options): New variable. (slime-compile-file): Use it. 2009-01-10 David Reitter * slime.el (slime-space): Declare `slime-space' to `delete-selection-mode' and friends (CUA) so that their behavior is the same as with normal insertion of a space. 2009-01-10 Helmut Eller * swank-backend.lisp (swank-compile-file): Take output-file as additional argument. Update backends accordingly. * swank.lisp (*fasl-directory*): New variable. (fasl-pathname): New function. (compile-file-for-emacs): Use it. 2009-01-10 Helmut Eller * swank-backend.lisp (set-default-initial-binding): New function. * swank.lisp (setup-stream-indirection): Use it 2009-01-09 Helmut Eller * swank-allegro.lisp (swank-compile-string): Don't use the no-longer-existing directory argument. 2009-01-08 Helmut Eller * slime.el: Move the tree widget for compiler notes to contrib/. 2009-01-08 Helmut Eller * swank-backend.lisp (swank-compile-string): Pass the buffer-file-name to Lisp, not only the directory. Update callers accordingly. * slime.el ([test] arglist): Update arglist. 2009-01-08 Helmut Eller * slime.el (slime-popup-restore-data): Renamed from slime-popup-buffer-restore-info. (slime-popup-buffer-saved-fingerprint) (slime-popup-buffer-saved-emacs-snapshot) (slime-popup-buffer-snapshot-unchanged-p) (slime-popup-buffer-restore-snapshot) (slime-xref-quit, slime-xref-retract): Deleted. 2009-01-08 Helmut Eller Remove some customization variables of questionale use. * slime.el (slime-when-complete-filename-expand) (slime-space-information-p, slime-display-compilation-output) (sldb-show-location-recenter-arg, slime-recenter-window) (slime-display-buffer-region): Deleted. 2009-01-07 Helmut Eller Just use find-tag-marker-ring as stack for M-. * slime.el (slime-push-definition-stack) (slime-pop-find-definition-stack): Do whatever Emacs's standard find-tag commands do. 2009-01-07 Helmut Eller Fix the slime-next-location command. * slime.el (slime-xref-last-buffer): New variable. (slime-show-xrefs): Initialize it. (slime-goto-next-xref): Use it. (slime-search-property): New function. (slime-xref-buffer): Delted 2009-01-07 Helmut Eller * swank.lisp (*sldb-pprint-dispatch-table*): Honor *print-escape* 2009-01-07 Helmut Eller * swank-cmucl.lisp (frame-locals, frame-debug-vars): Remove non-valid variables. (debug-var-value): Compute the location from the frame arg. 2009-01-07 Helmut Eller * swank-source-path-parser.lisp (make-source-recorder) (source-path-source-position): Adjust the file-position before entering it in the table. 2009-01-07 Helmut Eller * slime.el (slime-with-xref-buffer): Don't set slime-popup-buffer-quit-function. Use the default. Don't shrink the window because it may have existed before creating the buffer and we need to restore it. (slime-goto-xref): Just use slime-popup-buffer-quit. (slime-edit-definition-cont): Push definition stack here so that we don't need to do anything special in slime-goto-xref. (slime-display-popup-buffer): Also save the buffer that the popup window was displaying before (if the window is not new). (slime-close-popup-window): Restore the old buffer (if any) of the popup window. 2009-01-07 Helmut Eller * slime.el (slime-show-buffer-position): Use reposition-window. 2009-01-07 Helmut Eller * slime.el (slime-keys): Remove the binding for C-c C-i. M-TAB can also be pressed with M-C-i which is probably not taken by the window manager. ESC TAB would also work. Maybe we should reuse C-c C-i for slime-inspect. Move C-c C-y to slime-repl.e. Remove C-c C-f: it's already on C-c C-d f. Remove C-c M-0: slime-restore-window-configuration doesn't exist. Remove M-g: slime-quit doesn't work since ages. 2009-01-05 Helmut Eller Create a compilation-log buffer so that next-error works but don't display the buffer. * slime.el (slime-create-compilation-log): New function. (slime-compilation-finished-hook): Use it. 2009-01-05 Helmut Eller Use keymap inheritance to share bindings in various modes. * slime.el (slime-parent-map): New keymap. (slime-mode-map, slime-popup-buffer-mode-map, sldb-mode-map) (slime-inspector-mode-map): Use it. (slime-parent-bindings, slime-prefix-bindings): New variables. (slime-prefix-key, slime-define-key): Deleted. Update contribs accordinly. 2009-01-05 Helmut Eller * slime.el (slime-with-popup-buffer): New argment: select. If nil (default) buffer will only be displayed but not selected. 2009-01-05 Helmut Eller * slime.el (slime-show-compilation-log): Insert two lines at the beginning. Emacs 21 seems to skip over those two. 2009-01-05 Tobias C. Rittweiler * swank-sbcl.lisp (function-arglist): SB-INTROSPECT:FUNCTION-ARGLIST is deprecated in bleeding edge sbcl. 2009-01-05 Tobias C. Rittweiler Do not truncate error messages in SLDB. * swank.lisp (*sldb-bitvector-length*): Like *PRINT-LENGTH* for bit-vectors. (*sldb-string-length*): Likewise for strings. (*sldb-pprint-dispatch-table*): Truncate bit-vectors / strings according to the above variables. (*sldb-printer-bindings*): Use the new variables. Bind *PRINT-LINES* to NIL so error messages are not truncated. 2009-01-04 Helmut Eller Make it possible to limit the number of displayed restarts. * slime.el (sldb-initial-restart-limit) (sldb-insert-more-restarts): New. (sldb-setup, sldb-insert-restarts): Use it. 2009-01-04 Helmut Eller * slime.el (slime-local-variable-p): New function. XEmacs requires two arguments. 2009-01-04 Helmut Eller * swank-cmucl.lisp (note-error-location): If possible, include the filename. * slime.el (slime-goto-location-position): Add :eof as position kind. 2009-01-03 Helmut Eller * slime.el (slime-goto-location-buffer): Don't goto point-min. (slime-check-location-buffer-name-sanity) (slime-check-location-filename-sanity): Separated from slime-goto-location-buffer. (slime-line-number-at-pos): New compatibility function. 2009-01-03 Helmut Eller By default, show compiler notes in a buffer with compilation-mode. * slime.el (slime-show-compilation-log) (slime-maybe-show-compilation-log): New functions, (slime-compilation-finished-hook): Change the default value to 'slime-maybe-show-compilation-log. 2009-01-03 Helmut Eller * swank.lisp (simple-serve-requests, make-repl-input-stream): Move the call to WITH-CONNECTION to the input stream to pick up stream redirections. 2009-01-03 Helmut Eller * swank-clisp.lisp (wait-for-input): Disable it for win32. 2009-01-02 Helmut Eller Experimental implementation of "channels". The idea is to support arbitrary protocols without changes to the low level event dispatcher. * slime.el (slime-make-channel, slime-close-channel) (slime-channel-send, slime-send-to-remote-channel): New functions. (slime-define-channel-type, slime-define-channel-method): New macros. (slime-dispatch-event): Support channel events. * swank.lisp (channel, listener-channel): New classes. (channel-send, send-to-remote-channel): New functions. (create-listener): New function. Test case for channel code. (process-requests): Process channel events. 2009-01-02 Helmut Eller * slime.el ([test] arglist): Guard against nil. ECL returns nil most of the time. 2009-01-01 Tobias C. Rittweiler Arglists of user-defined types are now displayed by slime-autodoc on SBCL. (deftype foo (x y) `(cons ,x ,y)) (declare (type (foo | * swank-sbcl.lisp ([method] type-specifier-arglist): Make use of recently introduced SB-INTROSPECT:DEFTYPE-LAMBDA-LIST. 2009-01-01 Tobias C. Rittweiler * swank-loader.lisp (*contribs*): Add `swank-sbcl-exts'. 2009-01-01 Tobias C. Rittweiler * slime.el (slime-eval-async, slime-dispatch-event): Canoncalize return value. Previously they returned an arbitrary value which was displayed to the minibuffer due to a bug in slime-autodoc. The arbitrariness of the return value made debugging this a chore. 2009-01-01 Helmut Eller * swank-openmcl.lisp (frame-source-location-for-emacs) (pc-source-location): Fall back to the source-note of the function if there is no source-note for a pc offset. 2009-01-01 Helmut Eller For buffers without filename, map the name of the tempfile back to the buffer name. * swank-openmcl.lisp (*temp-file-map*): New variable. (note-temp-file): New function. (compile-temp-file, source-note-to-source-location): Use it. 2009-01-01 Helmut Eller * swank.lisp (sleep-for): New function * slime.el ([test] break): Use SWANK::SLEEP-FOR to help CCL pass this test. ([test] arglist): Update arglist of swank::compile-string-for-emacs. ([rest] find-definition.2): Allow some whitespace before the actual position. Otherwise, CCL would fail on this test. 2008-12-31 Helmut Eller * swank.lisp (maybe-redirect-global-io): Don't consider connections without streams. (*new-connection-hook*): Don't add MAYBE-REDIRECT-GLOBAL-IO. (create-repl): Call MAYBE-REDIRECT-GLOBAL-IO here. 2008-12-31 Helmut Eller * swank-openmcl.lisp ([method] source-locations (symbol)): Drop the unused _; the compiler dosn't like it. 2008-12-31 Helmut Eller * slime.el (slime-cd, slime-pwd): New commands. (slime-change-directory): New function. (slime-change-directory-hooks): New hook. 2008-12-31 Helmut Eller * slime.el ([test] find-definition.2): Also fails for Lispworks. ([test] interrupt-at-toplevel, [test] interrupt-in-debugger): Those don't work well if there's no REPL thread. * swank-backend.lisp (wait-for-input, wait-for-one-stream): Don't use PEEK-CHAR because we can't interrupt that cleanly. * swank.lisp (simple-serve-requests): Run the REPL inside WITH-CONNECTION. * swank-lispworks.lisp (emacs-connected): Don't install the signal handler here ... (install-sigint-handler): ... use this instead 2008-12-30 Tobias C. Rittweiler As of now, `C-u C-c C-c' compiled a function with maximum debug settings (SBCL only.) Now, `M-- C-c C-c' will compile a function with maximum _speed_ settings (still SBCL only) --- useful to elicit compiler notes. * slime.el (slime-compilation-debug-level): Renamed to `slime-compilation-policy'. (slime-normalize-optimization-level): Renamed to `slime-compute-policy'. * swank.lisp (compile-string-for-emacs): Takes a policy now. (compile-multiple-strings-for-emacs): Ditto. * swank-backend.lisp (swank-compile-string): Change :DEBUG key arg to :POLICY. * swank-scl.lisp, swank-openmcl.lisp, swank-lispworks.lisp * swank-ecl.lisp, swank-corman.lisp, swank-cmucl.lisp, * swank-clisp.lisp, swank-allegro.lisp, swank-sbcl.lisp: Changed accordingly. 2008-12-29 Helmut Eller * swank-openmcl.lisp (find-definitions, source-locations): Use ccl:find-definition-sources. (swank-compile-string, compile-temp-file): Use new parameters to compile-file to adjust source locations. 2008-12-28 Helmut Eller Recent CCLs support much better source location recording. Let's use the new features in SLIME. * swank-openmcl.lisp (function-source-location): Use ccl:function-source-note. (pc-source-location): New function, based on ccl:find-source-note-at-pc. (frame-source-location-for-emacs): Use it. 2008-12-27 Helmut Eller * slime.el: Move slime-lisp-package and slime-lisp-package-prompt-string to slime-repl.el * swank.lisp (create-repl): Return initial package and prompt. 2008-12-25 Helmut Eller Don't restore window configs in sldb. That doesn't work in the native repl, because output may have moved point. * slime.el (sldb-setup, sldb-exit): Use temp buffer code. (slime-display-popup-buffer): Don't overwrite existing variables. (slime-close-popup-window): Factored out from slime-popup-buffer-quit. (slime-save-local-variables): New macro. (sldb-maybe-kill-buffer, sldb-saved-window-configuration): Deleted. 2008-12-23 Helmut Eller * swank.lisp (connection.env): New slot. To hold dynamic variable bindings for this connection. (with-io-redirection): Use it. (create-repl): New function. Currently only redirects IO for the connection. Could potentially be used to create multiple listeners, each with a set of streams and corresponding buffers. (*redirect-io*, maybe-call-with-io-redirection) (call-with-redirected-io): Deleted. 2008-12-23 Helmut Eller Move most of the REPL mode to contrib. Disable some commands that depend on the existence of a REPL buffer. 2008-12-23 Helmut Eller * slime.el (slime-set-connection-info): Don't create a repl buffer. (slime-start-lisp): Bind process-connection-type to nil to avoid problems witht CLISPs readline code. * swank.lisp (read-non-blocking, make-repl-input-stream) (simple-repl): New functions. (simple-serve-requests): Use it. * swank-backend.lisp (wait-for-one-stream, wait-for-streams): New functions. (wait-for-input): Use it to support wainting on multiple streams. * swank-cmucl.lisp (to-fd-stream): New function. (wait-for-input): Use it. 2008-12-23 Helmut Eller * slime.el (slime-run-mode-hooks): Wrapper for Emacs21. (slime-repl-mode): Use it. Reported by Peter Denno. 2008-12-23 Sven Van Caekenberghe * swank.lisp (connection): Add a slot to store the auto-flush-thread. (cleanup-connection-threads): Also kill the auto-flush-thread. (stop-server): list-threads returns the thread name in second position and not in first position. 2008-12-23 Willem Broekema * slime.el (sldb-insert-restarts): Make the space before each restart also propertized, consistent with how each line in the backtrace is fully sensitive. 2008-12-09 Helmut Eller Reset the stream column to 0 after eval requests. * swank.lisp (interactive-eval, eval-region): Use FRESH-LINE to reset the stream column. * slime.el (test repl-test): Adjust test accordingly. 2008-12-09 Helmut Eller Be a bit more careful when computing the toplevel restart. * swank.lisp (throw-to-toplevel): Test *sldb-quit-restart* for nilness. * sldb-quit (sldb-quit): Show the returned value in brackets. 2008-12-09 Helmut Eller Make the modeline a bit shorter. * slime.el (slime-compute-modeline-string): Remove PKG: and CON: to save space. (slime-compute-modeline-connection-state): Don't include zeros. 2008-12-09 David Reitter * slime.el (slime-repl-mode): Use `run-mode-hooks' rather than just `run-hooks'. That way, after-change-major-mode-hook is called automatically. 2008-12-07 Nikodemus Siivola * slime.el (slime-qualify-cl-symbol-name): Clean up the package name using `slime-pretty-package-name', so that packages named with strings are not left with the extra doublequotes. 2008-12-05 Tobias C. Rittweiler * slime.el (slime-macroexpansion-minor-mode-map): Bind keybindings of `undo' to `slime-macroexpansion-undo'. (slime-show-macroexpansion): Renamed to `slime-initialize-macroexpansion-buffer' (slime-initialize-macroexpansion-buffer): Make sure that the user can't undo past the initial insertion. (slime-macroexpand-undo): New function. Tries to undo-only. 2008-12-05 Tobias C. Rittweiler * slime.el (slime-trace-query): SPEC argument can be a symbol. 2008-12-02 Tobias C. Rittweiler * slime.el (slime-compute-modeline-connection-state): Fix computation of debugged requests. 2008-11-30 Gábor Melis * slime.el (slime-compute-modeline-connection-state): Print the number of debugged requests if non-zero. (slime-connection-state-as-string): Removed unused branches. (slime-compute-connection-state): Removed :debugged branch making most likely return :connected instead. 2008-12-02 Tobias C. Rittweiler Modeline wouldn't display {debugged..} after `slime-interrupt'. * slime.el (slime-debugged-connection-p): Can't rely on `sldb-debugged-continuations' to be non-null in every SLDB buffer. 2008-11-23 Helmut Eller `q' in temp buffers should only delete the window if it was newly created for the buffer. * slime.el (slime-display-popup-buffer): New function. Recognize if the window didn't exist before. Save the created window and the selected window in buffer local variables. (slime-make-popup-buffer): Renamed from slime-popup-buffer. (slime-popup-buffer-quit): Delete the created window (if needed) and restore the old selected window. Don't touch other windows. (slime-edit-value-callback): Calling lisp-mode deletes all local variables. We need to that inside with-popup-buffer. 2008-11-22 Helmut Eller * slime.el (slime-update-all-modelines): Only walk through widnow-list not buffer-list. (slime-restart-or-init-modeline-update-timer): Inrease the timer interval to 0.5 seconds. 2008-11-22 Gábor Melis Reincarnate "eval..." (almost) * slime.el (slime-compute-modeline-connection-state): Return the number of outstanding requests if connected. (slime-update-all-modelines): Renamed from slime-update-modelines, loops through all slime buffers. (slime-restart-or-init-modeline-update-timer): New function. (slime-dispatch-event): Arrange for modelines to be updated on :EMACS-REX and :RETURN. 2008-11-22 Helmut Eller * swank.lisp (invoke-default-debugger): New condition type. (swank-debugger-hook): Handle invoke-default-debugger conditions. (sldb-break-with-default-debugger): Signal invoke-default-debugger to transfer control to the default debugger. New argument DONT-UNWIND to invoke the native debugger without unwinding the stack. * slime.el (sldb-break-with-default-debugger): By default, unwind the stack before invoke the native debugger. With prefix argument, run the native debugger in the dynamic environment of SLDB. 2008-11-02 Helmut Eller * slime.el ([test] package-updating): Allegro returns "||" as prompt for the keyword package. I guess that's acceptable. 2008-11-02 Helmut Eller * slime.el (slime-popup-buffer-quit): Always delete windows and bury the buffer. 2008-11-02 Helmut Eller * swank-backend.lisp (slime-interrupt-queued): New condition. * swank.lisp (invoke-or-queue-interrupt): Raise it here. * swank-cmucl.lisp (wait-for-input): Make fd readable in condition handler so that we can call serve-events without timeout. 2008-11-02 Helmut Eller * slime.el ([test] find-definition.2, [test] compile-defun): Expect to fail for CCL. 2008-10-31 Helmut Eller * slime.el (slime-repl-history-pattern): Simplify as suggested by Knut Olav Bøhmer and Michael Weber. 2008-10-31 Helmut Eller * slime.el (slime-eval-with-transcript) (slime-eval-with-transcript-cont): Restore the current buffer, before calling cont. 2008-10-31 Helmut Eller * swank-lispworks.lisp (describe-function): Don't use string-upcase on lambda-list-argruments, because not all elements must be symbols. 2008-10-31 Helmut Eller * swank.lisp (debug-in-emacs): Bind *sldb-quit-restart* here. If necessary, use the current abort retstart. 2008-10-30 Helmut Eller * swank-sbcl.lisp (wait-for-input): Return streams which are at EOF. 2008-10-30 Helmut Eller * slime.el (slime-popup-buffer-quit): Call bury-buffer with explicit argument for compatibility with XEmacs. 2008-10-30 Ivan Shvedunov * slime.el (slime-repl-history-pattern): Use the part of input between its start and (point) as history search pattern. Previously we used the entire input. 2008-10-26 Helmut Eller * test.sh: Return the number of failed tests as exit code. * slime.el: Fix change from 2008-10-20. Use (eval-when (compile)...) instead of (eval-when-compile ...), because the latter is more like (eval-when (compile eval) ...). 2008-10-23 Helmut Eller * slime.el (slime-redirect-inferior-output): New command. 2008-10-21 Helmut Eller * swank-allegro.lisp (frame-restartable-p): Handle errors signaled by debugger:frame-retryable-p. This looks like an Allegro bug, though. Reported by Luke Hope. 2008-10-20 Helmut Eller * slime.el: Require some packages, e.g. apropos, at compile time to suppress some "undefined function" warnings. 2008-10-19 Helmut Eller * swank.lisp (frame-locals-and-catch-tags): New function. Fetch locals and catch tags with a single RPC. * slime.el (sldb-frame-details): Use it. * swank-backend.lisp (frame-catch-tags): Provide a default implementation. Delete the dummy defs in various backends. 2008-10-19 Mark Evenson * swank-abcl.lisp (handle-compiler-warning): Report source location position when we can. Use NAMESTRING for *compile-filename*. 2008-10-19 Helmut Eller * swank-clisp.lisp (filename-to-pathname, parse-cygwin-filename): Accept Windows and Unix filenames when :CYGWIN is in *features*. 2008-10-17 Helmut Eller * swank-sbcl.lisp (swank-compile-file): Fix typo. 2008-10-17 Helmut Eller * swank-backend.lisp (compute-sane-restarts): Deleted. Use plain compute restarts instead. 2008-10-17 Helmut Eller * swank.lisp (call-with-retry-restart): Implement this a little less confusing. 2008-10-17 Helmut Eller * swank-backend.lisp (frame-restartable-p): New function. (swank-frame): Deleted. Update implemenetations accordingly. (print-frame): Renamed back from print-swank-frame. * swank.lisp (backtrace): Don't clutter the backtrace with '(:restartable :unknown). For practical purposes :unknown is the same as nil. * slime.el (sldb-compute-frame-face): Only accept nil or t for the :restartable prop. 2008-10-16 Helmut Eller * swank-backend.lisp (swank-compile-file): Return the same values as COMPILE-FILE. Update backends accordingly. * swank-lispworks.lisp (with-swank-compilation-unit): Return the values of BODY. (compile-from-temp-file) * swank-allegro.lisp (compile-from-temp-file) * swank-clisp.lisp (swank-compile-string) * swank-abcl.lisp (swank-compile-string): Return T on success. * swank.lisp (collect-notes): Check return type of FUNCTION. 2008-10-16 Helmut Eller * swank-openmcl.lisp (frame-catch-tags): Disabled as it prevents FRAME-LOCALS from working in lx8632. 2008-10-10 Nikodemus Siivola * slime.el (slime-inspector-toggle-verbose): New function. (slime-inspector-mode-map): Bind v to slime-inspector-toggle-verbose. (slime-cheat-sheet-table): Add slime-inspector-toggle-verbose. * swank.lisp (*inspector-verbose*): New variable. ([defstruct] istate): New slot called verbose. (istate>elisp): If the current istate is verbose, use untruncated result of TO-STRING as the title. (inspect-nth-part): Use the verbosity of the current istate. * doc/slime.texi: Document slime-inspector-toggle-verbose. 2008-10-07 Nikodemus Siivola * swank.lisp (*backtrace-printer-bindings*): export. 2008-10-05 Helmut Eller * swank-cmucl.lisp (list-callers): Do a full GC before calling map-allocated-objects. That's needed because map-allocated-objects seems to cons even if it's inlined. (emacs-inspect [code-component]): Try to detect byte-code-components. (inspect-alien-record, mv-function-end-breakpoint-values): Avoid compiler warnigns. 2008-10-04 Tobias C. Rittweiler * swank-sbcl.lisp: Add support for WHO-SPECIALIZES. This requires a patch for SBCL's SB-INTROSPECT contrib which I sent upstream a few minutes ago. 2008-10-04 Helmut Eller Some cleanups for compilation commands. * slime.el ([defstruct] slime-compilation-result): Rename result slot as successp. (slime-make-compilation-finished-continuation): Deleted. slime-eval-async preserves the current buffer and preserving the window-configuration was always a questionable feature. (slime-compilation-finished): Simplified. (slime-show-note-counts): Also show the success/failure flag. (slime-recompile-locations): Take a continuation as argument rather than messing around with compilation-finished-hooks. (slime-aggregate-compilation-results): New function. (slime-xref-recompilation-cont): Renamed from slime-make-xref-recompilation-cont. (slime-compiler-results): Deleted. (slime-goto-first-note-after-compilation): Replaced with hook function slime-goto-first-note. (slime-compilation-just-finished): Deleted. (slime-to-lisp-filename-function): Use convert-standard-filename. * swank.lisp ([defstruct] compilation-result): Renamed from swank-compilation-result. (measure-time-interval): Return seconds as float. (collect-notes): Renamed from swank-compiler. Return a single compilation-result. (compile-multiple-strings-for-emacs): Return a list of compilation-results instead of a single result with merged notes. * swank-backend.lisp (filename-to-pathname): Renamed from parse-emacs-filename. Updated callers. (pathname-to-filename): New function. Use it where appropriate. * swank-scl.lisp (pathname-to-filename): Implement it in the backend to get rid of the #+scl in swank.lisp. * swank-cmucl.lisp (swank-compile-file, swank-compile-string): Return t on success. 2008-10-04 Alain Picard UTF-8 support for Lispworks. * swank-lispworks.lisp (accept-connection): Use flexi-streams for utf-8. (make-flexi-stream): New function. (*temp-file-format*): New variable (compile-from-temp-file): Use it. 2008-09-28 Tobias C. Rittweiler * slime.el (slime-list-compiler-notes): Revert change from 2008-08-15 which introduced automatic shrinkage of the compiler-notes buffer. This turned out to be more annoying than worthwhile. On the cases where it's desired, the user can just use `C-x -' himself to shrink the notes buffer. 2008-09-28 Helmut Eller Stop handling events in worker threads after sldb-quit. * swank.lisp (with-top-level-restart): New macro. (handle-requests, spawn-worker-thread): Use it. (process-requests): Drop the just-one argument. (handle-or-process-requests): Deleted. Call handle-requests directly. 2008-09-27 Tobias C. Rittweiler Improve ECL's arglist support somewhat. * swank-ecl.lisp (grovel-docstring-for-arglist): New function. (arglist): Use it. Now also try to find an arglist for special operators, and macros. 2008-09-26 Tobias C. Rittweiler * slime.el (slime-cycle-connections): Do not make the new connection buffer-local if we're currently in a REPL buffer. 2008-09-24 Knut Olav Bøhmer * slime.el (slime-cycle-connections): New command. 2008-09-24 Helmut Eller * slime.el (slime-prefix-map): New keymap. (slime-define-key): Use it. Also drop unused :inferior arg. (slime-inspector-mode-map): Bind C-c to slime-prefix-map. (slime-define-both-key-bindings): New function. Factor of slime-init-keymaps. (slime-init-keymaps): Use it. (slime-control-modified-char): Deleted. 2008-09-23 Douglas Crosher * swank-scl.lisp: update for Scieneer CL 1.3.8. * swank.lisp (ed-in-emacs): customize for the SCL. * swank.lisp (signal-interrupt): fix typo. 2008-09-22 Nikodemus Siivola * swank.lisp (guess-package): Return NIL if string designator is NIL: makes files without IN-PACKAGE forms more *BREAK-ON-SIGNALS* friendly. 2008-09-22 Helmut Eller * swank-sbcl.lisp (wait-for-input): Implement this in backend, since read-char-no-hang doesn't work in fd-handlers. (install-sigint-handler): Go through invoke-interruption and with-interrupts to support nested interrupts. * slime.el (slime-lisp-implementations): Mention :env keyword in docstring. 2008-09-21 Helmut Eller * slime.el (slime-repl-input-end-mark): Deleted. It was always at the end of buffer. Use point-max instead. (slime-repl-eol): Removed. The usual end-of-line does the same. 2008-09-21 Helmut Eller * slime.el (slime-eol-conversion-fixup): Return 0 (not nil) for anyting other than CRLF conventions. 2008-09-21 Helmut Eller * swank-openmcl.lisp: Try to remove the first few internal frames from backtraces. (guess-stack-top): New function. (call-with-debugging-environment): Use it (frame-arguments): Return a list instead of a string. Don't quote symbols. (source-locations): Recognize (:internal FOO) functions. 2008-09-21 Helmut Eller * swank.lisp (*backtrace-pprint-dispatch-table*): Honor *print-escape*. 2008-09-20 Ariel Badichi * slime.el (slime-with-output-end-mark): slime-repl-show-maximum-output no longer accepts any arguments. 2008-09-20 Helmut Eller * test.sh: Parse the -S option as advertized. * slime.el (slime-randomize-test-order): Add the * to the docstring. ([def-slime-test] break2): Also CCL is expected to fail here. 2008-09-20 Helmut Eller Fix some of the bugs that I introduced with the last commits. * swank-openmcl.lisp (call-with-debugging-environment): Fix typo. (call-with-debugger-hook): Bind *break-in-sldb*. (backtrace-context): Return nil, not tcr! (map-backtrace): Remove the stack< test. Only test for nil. (lisp-implementation-type-name): Return "ccl". (emacs-inspect (t)): Fix typo. (kill-thread): Use join-process. Otherwise we get strange "process-reset" errors when disconnecting. (thread-alive-p): Implemented with ccl::process-exhausted-p. (source-locations): Use labels for helper functions. (function-source-location): Now implemented on top of source-locations. 2008-09-20 Helmut Eller Fix frame-source-location-for-emacs for CCL. * swank-openmcl.lisp (source-locations): New function. (create-source-location): New function. (frame-source-location-for-emacs): Use it. 2008-09-20 Helmut Eller Fix inspecting of arrays. * swank-openmcl.lisp (emacs-inspect :around (t)): call-next-method may return a lazy list. Detect that case and only append to ordinary lists. (emacs-inspect (t)): Don't mark labels as inspectable. Just print them. 2008-09-20 Helmut Eller Fix BREAK and backtraces after interrupts. * swank-openmcl.lisp (*sldb-stack-top-hint*): New variable. (call-with-debugging-environment, break-in-sldb) (interrupt-thread): Use it. (*process-to-stack-top*, record-stack-top) (grab-stack-top): Deleted. Use *sldb-stack-top-hint* instead. (backtrace-context): Deleted. Use %current-tcr directly. 2008-09-20 Helmut Eller * swank-openmcl.lisp (call-with-debugging-environment): Don't set *debugger-hook* to nil. 2008-09-19 Helmut Eller * slime.el ([def-slime-test] break): Split it up in two versions to make the debugger-hook issue more explicit. * swank-allegro.lisp (frob-allegro-field-def): There seems to be a new type :func handle it like :lisp. 2008-09-19 Helmut Eller * slime.el (slime-save-marker): New marcro. Use it in combination with insert-before-markers. (slime-check-buffer-contents): Use {} resp. [] to describe the position of output resp. input markers. (slime-repl-emit-result): Update window-point. (slime-randomize-test-order): New variable. (slime-shuffle-list): New function. (slime-run-tests): Use it. (slime-batch-test): Accept test-name and randomize arguments. * test.sh (usage): Accept -n and -S options. 2008-09-18 Tobias C. Rittweiler * swank-ecl.lisp: Forgot to update ECL's backend when introducing swank-frames in commit on 2008-09-12. 2008-09-18 Helmut Eller Some cleanups for the REPL code. * slime.el (slime-show-last-output) (slime-show-last-output-function) (slime-show-last-output-region) (slime-maybe-display-output-buffer) (slime-repl-last-input-start-mark): Delete unused code. (slime-repl-emit-result, slime-repl-insert-prompt) (slime-repl-show-abort, slime-repl-insert-result) (slime-insert-transcript-delimiter) (slime-eval-with-transcript-cont): Consistently use save-excursion and insert-before-markers. We always want to preserve the cursor position in the input region (for type-ahead). (slime-eval-with-transcript): Change order of arguments to make the common case easier to use. (slime-batch-test): Use a timer. (slime-check-buffer-contents): New function to test contents and current position. Use it in various places. (sldb-recenter-region, def-slime-test interactive-eval) (def-slime-test interactive-eval-output): Act slightly differently when the test suite is executed in batch mode (without terminal). * swank.lisp (handle-requests): Flush output. (interactive-eval, interactive-eval): Don't use fresh-line, as that makes it harder to test the REPL code. * test.sh (usage): Add a -T switch to run slime in the current directory without copying (and compiling) everything to a temporary directory. 2008-09-18 Helmut Eller * slime.el (slime-eval-with-transcript): Accept some more arguments so that we can also use it for compile-file. (slime-eval-with-transcript-cont): New. Insert prompt. (slime-compile-file): Use slime-eval-with-transcript. (slime-repl-show-maximum-output): Update window point. (slime-repl-insert-prompt): Don't use insert-before-markers. (slime-repl-emit): No longer use slime-with-output-end-mark. 2008-09-17 Tobias C. Rittweiler * swank-sbcl.lisp (make-definition-source-location): Fix typo introduced with crlf-related commit on 2008-09-16. 2008-09-17 Helmut Eller * slime.el (slime-repl-popup-on-output): New variable. (slime-repl-emit): Honor slime-repl-popup-on-output. (slime-eval-with-transcript): Use slime-repl-popup-on-output. Also remove the function argument, as it was only used once and that was slime-message. 2008-09-17 Helmut Eller (*pre-reply-hook*): Add 'force-user-output. 2008-09-17 Helmut Eller * swank.lisp (send-user-output): Lifted from make-output-function. Make this a top-level function for easier redefinition. 2008-09-17 Helmut Eller * slime.el (slime-test-find-top-level-restart): New function. [def-slime-test] (interrupt-at-toplevel, interrupt-in-debugger): Use it. 2008-09-16 Helmut Eller * slime.el (slime-connection): Optionally select a new default connection. (slime-auto-select-connection): New variable. (slime-auto-select-connection): New function. 2008-09-16 Helmut Eller Adjust positions in files with CRLF style end-on-line markers. * slime.el (slime-eol-conversion-fixup): New function. (slime-goto-location-position): Use it. Also add a new position type :offset, so that we don't adjust offsets in strings that were sent over the wire (which uses LF eol-convention). * swank-abcl.lisp * swank-allegro.lisp * swank-clisp.lisp * swank-cmucl.lisp * swank-corman.lisp * swank-ecl.lisp * swank-lispworks.lisp * swank-openmcl.lisp * swank-sbcl.lisp * swank-scl.lisp: Create :offset style positions where needed. * swank-lispworks.lisp (skip-comments): New function. (dspec-stream-position): Use it. 2008-09-16 Tobias C. Rittweiler * slime.el (slime-end-of-list): `backward-down-list' was used there which is defined by paredit.el. Use `(down-list -1)' instead. 2008-09-15 Helmut Eller * swank-lispworks.lisp (describe-symbol-for-emacs): Revert last change. 2008-09-15 Helmut Eller * swank.lisp (sldb-loop): Send a :sldb-return event to ourselfes to inform the debug session at the lower level. (wait-for-event): Drop the report-interrupt argument. No longer needed. (event-match-p): Add an OR pattern operator. Used to wait for different events simultaneously. (read-packet): Use peek-char to detect EOF. read-sequence wouldn't work. * slime.el (slime-test-interrupt-in-debugger): Call sldb-quit and sldb-continue in the right buffer. * swank-backend.lisp (wait-for-input): * swank-cmucl.lisp (wait-for-input): * swank-clisp.lisp (wait-for-input): Use the idiom "(when (check-slime-interrupts) (return :interrupt))". 2008-09-15 Helmut Eller Interrupt related hacking. * swank-backend.lisp (*pending-slime-interrupts*): Should be thread-local. Leave global value unbound. * swank.lisp (with-interrupts-enabled%): New helper macro. (with-slime-interrupts, without-slime-interrupts): Use it. (call-with-connection): Bind *pending-slime-interrupts* here. (wait-for-event): Add a report-interrupt argument. Currently used by the debugger to detect when a nested debugger session, which was triggered by an interrupt in wait-for-event, returns. Doesn't work well, though. * slime.el (slime-test-interrupt-in-debugger): New test. 2008-09-14 Helmut Eller Introduce a WAIT-FOR-INPUT backend function. CMUCL's blocking input functions READ-CHAR etc. are hard to use with interrupts. In the backend we have a more realistic chance to get interrupts working. * swank-backend.lisp (wait-for-input): New function. * swank-cmucl.lisp, swank-clisp.lisp (wait-for-input): Implement it. * swank.lisp (wait-for-event/event-loop): Use WAIT-FOR-INPUT and rescan the event-queue if WAIT-FOR-INPUT was interrupted. (reader-event): Deleted. Merged into wait-for-event/event-loop resp. dispatch-loop. (decode-message): Drop the timeout argument. (*events-enqueued*): A counter to quickly detect new events after a wait. (call-with-connection): If the argument is already the current connection, don't rebind anything. (without-slime-interrupts, with-slime-interrupts): Don't rebind *pending-slime-interrupts*. Just to be save. * slime.el (sldb-maybe-kill-buffer): New function, to handle the case when the debugger was interrupted in WAIT-FOR-INPUT and we want to return to the previous debug level. 2008-09-12 Helmut Eller For Lispworks, parse the $LWHOME/lwdoc file. * swank-lispworks.lisp (lwdoc, lookup-lwdoc, parse-lwdoc-record): New functions. (describe-symbol-for-emacs): Use it. 2008-09-12 Tobias C. Rittweiler In an SLDB buffer, `C-c C-c' will now recompile the source behind a frame. In particular, `C-u C-c C-c' will recompile the frame with high debug settings. * slime.el (sldb-recompile-frame-source): New function. (sldb-mode-map): Bind `C-c C-c' to it. * slime.el (sldb-overlays, sldb-delete-overlays, slime-xref-cleanup): Removed. Sldb-overlays weren't created anymore since 2008-08-17. 2008-09-12 Tobias C. Rittweiler New faces: `sldb-restartable-frame-line-face', `sldb-non-restartable-frame-line-face'. The former is the face for frames that are surely restartable, the latter for frames that are surely not restartable. If restartability of a frame cannot be reliably determined, the face `sldb-frame-line-face' is used. At the moment, determination of frame restartability is supported by the SBCL backend only. * slime.el (sldb-frame.string): New. (sldb-frame.number): New. (sldb-frame.plist): New. (sldb-prune-initial-frames): Use them. (sldb-insert-frames): Ditto. (sldb-compute-frame-face): New. (sldb-insert-frame): Use `sldb-compute-frame-face' to insert frames with one of the faces described above. * swank.lisp (defslimefun backtrace): Changed return value; each frame is now accompanied with a PLIST which at the moment can contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame is restartable, or not. * swank-backend.lisp (defstruct swank-frame): New structure. (compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs. (print-frame): Renamed to PRINT-SWANK-FRAME. * swank-sbcl.lisp, swank-cmucl.lisp, swank-lispworks.lisp, * swank-allegro.lisp, swank-scl.lisp, swank-openmcl.lisp, * swank-abcl.lisp, swank-clisp.lisp: Adapted to swank-backend changes. 2008-09-11 Helmut Eller * doc/slime-refcard.tex: Fix typos. 2008-09-11 Gary King * swank-allegro.lisp (fspec-definition-locations): add declare ignores to prevent warnings (emacs-inspect): remove first definition on function since it was being overwritten by the next one. Wrap the method on t with a excl:without-redefinition-warnings to prevent warning. 2008-09-11 Helmut Eller * swank-cmucl.lisp (slime-output-stream): Remove last-flush-time slot. (sos/flush): Renamed from sos/misc-force-output. Don't try to be clever: no timestamps and no line buffering. (sos/write-char, sos/write-string): Renamed from sos/out resp. sos/sout. Call output-fn outside without-interrupts. (sos/reset-buffer): New function. 2008-09-11 Tobias C. Rittweiler * slime.el (slime-compilation-unit): Renamed to `slime-compilation-result'. (slime-last-compilation-unit): Renamed to `slime-last-compilation-result'. (slime-compiler-notes, slime-compiler-results): Adapted accordingly. (slime-compilation-finished): Ditto. 2008-09-11 Tobias C. Rittweiler * slime.el (slime-popup-buffer-restore-snapshot): Make sure that the buffer-local variable containing the popup buffer's snapshot is set to nil in the right buffer. 2008-09-11 Tobias C. Rittweiler Reimplement recompilation support. The previous implementation involving specials was subtly broken with the :fd-handler communcation-style, because of serve-event's polite interplay with specials. (Cf. my slime-devel post "Per event bindings" on 2008-08-17.) * swank.lisp (with-swank-compilation-unit): Removed. (record-note-for-condition): Removed. (defstruct swank-compilation-unit): Renamed to `swank-compilation-result'. (swank-compilation-unit-for-emacs): Renamed to `swank-compilation-result-for-emacs'. (swank-compiler): Takes additional argument, the swank-compilation-result where caught notes should be accumulated into. (defslimefun compile-file-for-emacs): Adapted accordingly. (defslimefun compile-string-for-emacs): Ditto. (defslimefun compile-multiple-strings-for-emacs): New RPC call. * slime.el (slime-make-compile-expression-for-swank): Removed. (slime-compile-string): Don't use above function anymore. Adapted. (slime-recompile-locations): Rewritten to use new RPC call above. 2008-09-10 Tobias C. Rittweiler * swank-backend.lisp (*gray-stream-symbols*): Comment out STREAM-FILE-POSITION. 2008-09-10 Tobias C. Rittweiler * swank.lisp (eval-for-emacs): Remove WITH-RETRY-RESTART again for simplicity reasons. (interactive-eval): Add WITH-RETRY-RESTART. (eval-and-grab-output): Ditto. (interactive-eval-region): Ditto. (re-evaluate-defvar): Ditto. (pprint-eval): Ditto. (repl-eval): Ditto. (eval-string-in-frame): Ditto. (pprint-eval-string-in-frame): Ditto. (init-inspector): Ditto. (inspect-in-frame): Ditto. 2008-09-09 Tobias C. Rittweiler A RETRY restart is provided for all Slime evaluation requests. The rationale is that restarting from a frame is mostly only possible for functions compiled with high debug settings; most functions aren't, however. [Alternatively, we could make EVAL-FOR-EMACS be compiled with a high debug level, so it'll become restartable. That would be non-obvious to the user, though, and would only work on those implementations that implement SWANK-BACKEND:RESTART-FRAME.] * swank.lisp (call-with-retry-restart): New function. (with-retry-restart): New macro. (eval-for-emacs): Use WITH-RETRY-RESTART. 2008-09-09 Tobias C. Rittweiler A package "Foo.Bar.1.0" was truncated to "0>" as REPL prompt. It'll now be displayed as "Bar.1.0>". * swank.lisp (auto-abbreviated-package-name): Adapted accordingly. 2008-08-31 Helmut Eller * swank-backend.lisp (*gray-stream-symbols*): Remove stream-file-position because it's called stream-position in CCL. (make-fn-streams): Deleted. Update callers accordingly. 2008-08-30 Helmut Eller * swank-sbcl.lisp (receive-if): Add #+/-linux to avoid yet more WITH-TIMEOUT related problems. * swank-gray.lisp (slime-input-stream): Remove the output stream slot. Most of the time we can just call force-output. * slime.el [test](inspector): New test. * swank.lisp (prepare-part): Also wrap action elements in a list. Reported by Ariel Badichi and Madhu. 2008-08-30 Helmut Eller * slime.el (slime-pop-to-buffer): Drop the norecord argument, since we can't support it easily in Emacs 21. Reported by Christophe Rhodes. 2008-08-30 Michael Weber * swank-gray.lisp (make-input-stream): fixed typos 2008-08-30 Michael Weber * swank-backend.lisp (*gray-stream-symbols*): added symbols stream-peek-char, stream-read-line, stream-file-position 2008-08-30 Mark Evenson * swank-abcl.lisp (make-output-stream, make-input-stream): provide the (trivial) definitions for MAKE-OUTPUT-STREAM and MAKE-INPUT-STREAM for ABCL. 2008-08-27 Helmut Eller * slime.el (sldb-setup): Insert "No backtrace" if the backtrace is empty. 2008-08-27 Anton Vodonosov * swank-ecl.lisp: Add :load-toplevel and :execute to EVAL-WHENs to fix loading. 2008-08-27 Helmut Eller * swank-cmucl.lisp (remove-sigio-handlers): Fix thinko. * swank.lisp (decode-message): Don't ignore EOF. (swank-debugger-hook): Remove the default-debugger restart. 2008-08-25 Tobias C. Rittweiler * slime.el (slime-compute-modeline-package): Used `when-let' before its definition. (slime-compute-modeline-string): Display "PKG:" before "CON:". 2008-08-22 Helmut Eller Some focus handling in multiframe setups. * slime.el (slime-pop-to-buffer): New function. (slime-switch-to-output-buffer): Use it. 2008-08-22 Helmut Eller Use lazy lists in the inspector. * swank.lisp (lcons): New data type. (lcons*, lcons-car, lcons-cdr, llist-range): New functions. (emacs-inspect array): Use lazy lists. (istate>elisp): The istate.content is now be a lazy list. (iline): New utility. (prepare-range, prepare-part): Replaces inspector-content. 2008-08-22 Helmut Eller Implement streams with a length limit. Use them to truncate printer output in backtraces. * swank-backend.lisp (make-output-stream, make-input-stream): Split make-fn-streams up into two functions. * swank.lisp (call/truncated-output-to-string): New function. (backtrace, istate>elisp, to-line): Use it. (frame-locals-for-emacs): Use to-line. 2008-08-22 Helmut Eller In backtraces, escape newlines in strings as \n. * swank.lisp (*backtrace-pprint-dispatch-table*): New. (*backtrace-printer-bindings*): Use it. 2008-08-22 Stas Boukarev * metering.lisp: Add deftypes for time-type and cons-type, which are not defined in newer versions of CCL. 2008-08-22 Stelian Ionescu * swank-ecl.lisp: Add a few EVAL-WHENs to fix compilation. 2008-08-22 Helmut Eller Collect most of the inspector state in a structure. Truncate the printer output more aggressively. * swank.lisp (inspector-state): New structure. (*istate*): New variable holds the current state. (inspect-object, inspector-content, inspector-nth-part) (inspector-range, inspector-call-nth-action, describe-inspectee): Use it. (inspector-pop, inspector-next): Implemented forward/backward a bit differently. (emacs-inspect/printer-bindings, istate>elisp): New functions. (to-line, truncate-string): New functions. 2008-08-22 Tobias C. Rittweiler Compiling a file `let*.lisp' on SBCL via C-c C-k resulted in an error, because it parsed the asterisk to a wild pathname. Fix that. * swank-backend.lisp (definterface parse-emacs-filename): New. PARSE-NAMESTRING by default. * swank-sbcl.lisp (defimplementation parse-emacs-filename): Use SB-EXT:PARSE-NATIVE-NAMESTRING. * swank.lisp (compile-file-for-emacs): Use PARSE-EMACS-FILENAME. (compile-file-if-needed): Ditto. (load-file): Ditto. (swank-require): Ditto. 2008-08-18 Helmut Eller * swank.lisp (install-fd-handler): Bind *emacs-connection* with with-connection, for case when the signal hander is called out of the blue. (swank-debugger-hook): Don't assume that the hook argument is #'swank-debugger-hook itself. * test.sh (usage): Use cat rather not echo for here-documents. 2008-08-17 Helmut Eller * slime.el (slime-inspector-show-source): New command. (slime-inspector-mode-map): Bind it to ".". (sldb-highlight-sexp): Use slime-flash-region rather than a permanent overlay. (slime-popup-buffer-quit): Must call bury-buffer without argument. * swank.lisp (find-source-location-for-emacs): New function. * slime.el (slime-add-local-hook): Renamed from add-local-hook. (slime-switch-to-output-buffer): Drop the connection argument. It was never used. (slime-switch-to-output-buffer-search-all-frames): Deleted. Use display-buffer-reuse-frames instead. (slime-switch-to-output-buffer): Use pop-to-buffer to select the window and frame. 2008-08-15 Tobias C. Rittweiler * slime.el (slime-switch-to-output-buffer): Fix regression discovered by Ariel Badichi. Programmatic invocation of this function expect this function to also set-buffer to the REPL buffer. Even though that's ugly, we do it for now, and declare it to be a FIXME. (slime-dispatch-event): Don't use `message' for the pipelined request message, but `slime-display-oneliner' which will truncate the form to be displayed. 2008-08-17 Helmut Eller * swank-cmucl.lisp (waitpid): Don't use unix::pid-t, it's only defined for Linux. * swank-sbcl.lisp (sb-thread::get-foreground): Don't override. Let SBCL people fix this. 2008-08-17 B.Scott Michel * swank-loader.lisp (dump-image): Move this function to the end of the file to stop SBCL from reporting two times the same false alarm. 2008-08-15 Tobias C. Rittweiler * slime.el (slime-popup-buffer-quit): Fix regression; we have to invoke `bury-buffer' without an argument to make it switch buffers for us (for the case when the snapshot wasn't restored.) 2008-08-15 Tobias C. Rittweiler * slime.el (slime-list-compiler-notes): Only shrink if notes tree isn't displayed as being collapsed. 2008-08-15 Tobias C. Rittweiler * slime.el (slime-popup-buffer-quit): If not kill, then at least bury the buffer. (slime-list-compiler-notes): Shrink the compiler-notes window. 2008-08-14 Tobias C. Rittweiler If another frame is already displaying a REPL, `C-c C-z' will now select this window instead of splitting the current frame, and displaying the REPL in the newly created window. * slime.el (slime-switch-to-output-buffer-search-all-frames): New variable to customize this behaviour, as it may not be optimal for people using multiple screens at once. (slime-switch-to-output-buffer): Adapted accordingly. 2008-08-14 Tobias C. Rittweiler Xref buffers: `M-,' in an Xref buffer will now revert to an Emacs state as of before the Xref command. * slime.el (slime-xref-mode-map): Add `slime-xref-retract' as `M-,' (slime-xref-retract): New. Restores the emacs snapshot unconditionally. (slime-xref-quit): Use it. 2008-08-14 Tobias C. Rittweiler Xref buffers: `q', and `SPC' will push onto the find-definition stack such that M-, will work afterwards. * slime.el (defstruct slime-emacs-snapshot): Also save the point explicitly. It is implicitly stored already in the window-configuration, but inaccessible therein. (slime-current-emacs-snapshot, slime-set-emacs-snapshot): Adapted. (slime-push-definition-stack-from-snapshot): New. Reason for above changes. (slime-with-popup-buffer): Make sure that the current emacs-snapshot is taken, not only when the :emacs-snapshot argument is NIL at expansion time, but also on runtime. (slime-with-xref-buffer): The name of the Xref buffer was created at expansion time, but must be computed at runtime. Fix that. (slime-xref-quit): Use `slime-push-definition-stack-from-snapshot' (sime-xref-goto): Adapted to also push onto the stack. * slime.el (slime-compute-modeline-package): Cleaned up. (slime-update-modeline-string): Ditto. 2008-08-12 Helmut Eller Add a dump-image function to the loader. * swank-loader.lisp (dump-image): New. * swank-backend.lisp (save-image): New interface. * swank-cmucl.lisp, swank-clisp.lisp, swank-sbcl.lisp (save-image): Implemented. 2008-08-12 Helmut Eller * slime.el (slime-repl-send-input): Disable modification hooks when marking old input. (slime-check-version): Use y-or-n-p. 2008-08-12 Helmut Eller Finally handle reader-errors without disconnecting. * swank.lisp (decode-message): Convert reader-error conditions into :reader-error events. (dispatch-event): Send :reader-error events to Emacs. * slime.el (slime-dispatch-event): Display reader-errors. 2008-08-12 Helmut Eller * swank.lisp (with-buffer-syntax): Take package as argument. (defslimefun): Derive the package for exporting from the symbol. 2008-08-12 Helmut Eller Let SIGINT create a synthetic event. * swank.lisp (install-fd-handler,simple-serve-requests): Dispatch a :emacs-interrupt event in the SIGINT handler. * slime.el (slime-interrupt): Send nothing over the wire when SIGINT is used. 2008-08-11 Helmut Eller * test.sh: Use batch mode by default. 2008-08-11 Helmut Eller Improve interrupt safety for single-threaded lisps. * slime.el (slime-interrupt): Send a :emacs-interrupt message together with SIGINT. SIGINT now means "check for new events" instead of "invoke the debugger". * swank-backend.lisp (install-sigint-handler) (call-with-user-break-handler): New functions. * swank.lisp (simple-serve-requests,install-fd-handler): Use it. (read-packet): New function. Check for interrupts. (decode-message): Use it. (wait-for-event/event-loop): Check for interrupts. 2008-08-11 Helmut Eller * swank-abcl.lisp (preferred-communication-style): Return nil until we implement receive-if. * swank-openmcl.lisp (receive-if): Support timeout argument. * swank-allegro.lisp (receive-if): Ditto. 2008-08-11 Helmut Eller * swank.lisp (*global-debugger*): Change default back to t. 2008-08-10 Helmut Eller * swank-ecl.lisp (thread-id): Assign an non-nil id to unknown threads. * slime.el (slime-execute-tests): Call slime-test-should-fail-p before executing the test (which may close the connection). (def-slime-test): Use slime-sync-to-top-level with a timeout. (slime-temp-directory): New function. (slime-run-tests): Save repl-history in /tmp. (slime-repl-mode): Ignore persistent history if slime-repl-history-file is nil. (slime-quit-lisp-internal): New function. (slime-quit-lisp, slime-restart-inferior-lisp): Use it (slime-batch-test): Exit, if the Lisp isn't up and running after 30 secs. 2008-08-10 Helmut Eller * swank.lisp (wait-for-event): Add timeout argument. This is used for :fd-handler and :sigio style where we only process events as long as we don't block. (wait-for-event/event-loop, read-event) (decode-message, receive-if): Ditto. (process-requests): Renamed from read-from-emacs. (handle-requests): Renamed from handle-request. Take timeout argument. Update callers. (process-available-input): Deleted. (with-swank-error-handler): Renamed from with-reader-error-handler. (with-connection): Use it. 2008-08-10 Helmut Eller * swank.lisp (invoke-slime-debugger): New function. Analagous to cl:invoke-debugger. (swank-debugger-hook): Use it. 2008-08-09 Helmut Eller * slime.el (slime-quit-lisp): Optionally send kill signal. (slime-quit-connection-at-point): Disconnect after some timeout. 2008-08-09 Helmut Eller Fixes for heap dumping. * swank.lisp (*log-output*): Don't initialize at load-time, otherwise the stream would end up in a heap image. 2008-08-09 Helmut Eller * swank-lispworks.lisp (defimplementation): Record location. 2008-08-09 Helmut Eller * swank.lisp (*maximum-pipelined-output-chunks*): New variable 2008-08-09 Helmut Eller Display the "Use default debugger" restart more prominently for testing. * swank.lisp (swank-debugger-hook): Bind a user visible restart to invoke the native debugger. (*global-debugger*): Make this nil by default. (sldb-loop): Minor cleanups. (sldb-break-with-default-debugger): Invoke the native debugger on top of the slime debugger. * slime.el (slime-simple-completions): Bind slime-current-thread to t so that completion is peformed in a fresh thread. (sldb-setup): Always pop to the debugger buffer. (sldb-activate): Optionally select the window. * swank-sbcl.lisp (sb-thread::get-foreground): Override this as the default implementation is unusable for Slime. * swank-lispworks.lisp (environment-display-notifier): Just return t. 2008-08-09 Helmut Eller * swank-lispworks.lisp (disassemble-frame): Implemented. 2008-08-09 Tobias C. Rittweiler M-x slime doesn't destroy the window layout anymore when you switch windows/frames while the connection is being set up. * slime.el (slime-hide-inferior-lisp-buffer): Search for the inferior-lisp buffer's window in all frames. (slime-repl-update-banner): Do not pop to the REPL buffer. 2008-08-08 Tobias C. Rittweiler * slime.el: Fixing `q' in Xref buffers. (slime-popup-buffer-snapshot-unchanged-p): New. (slime-popup-buffer-restore-snapshot): New. (slime-xref-quit): Can't use slime-popup-buffer directly. Instead implement its own quit behaviour using the above functions. 2008-08-08 Helmut Eller Use wait-for-event instead of catch/throw where needed. * swank.lisp (read-user-input-from-emacs, y-or-n-p-in-emacs) (eval-in-emacs): Use wait-for-event. (make-tag): Replaces intern-catch-tag. (take-input): Deleted. (dispatch-event): Remove some redundancy. 2008-08-08 Tobias C. Rittweiler * slime.el: Make xref buffers use `slime-with-popup-buffer', nee `slime-with-temp-buffer'. (slime-with-xref-buffer): Rewritten using a popup buffer. (slime-init-xref-buffer): Removed. (slime-display-xref-buffer): Removed. 2008-08-08 Tobias C. Rittweiler * slime.el: Rename slime's temp-buffer to popup-buffer. 2008-08-08 Tobias C. Rittweiler * slime.el (slime-compiler-notes-mode, slime-connection-ist-mode): Add slime-temp-buffer-mode-map to docstring. 2008-08-08 Tobias C. Rittweiler * slime.el (slime-connections-buffer-name): New variable. (slime-list-connections): Use it. (def-slime-selector ?c): Ditto 2008-08-08 Tobias C. Rittweiler * slime.el: Make the threads browser use `slime-with-temp-buffer'. (slime-temp-buffer-quit-function): New buffer-local variable. Defaults to `slime-temp-buffer-quit'. (slime-temp-buffer-mode): `q' invokes above variable now. (slime-threads-buffer-name): New variable. (slime-list-threads): Use slime-with-temp-buffer. (slime-update-threads-buffer): New. Lifted from slime-list-threads. (slime-thread-quit): Renamed to slime-quit-threads-buffer. 2008-08-08 Helmut Eller Unify event dispatching for single and multi-threaded cases. * swank.lisp (send-to-control-thread,read-from-control-thread) (send-to-socket-io,read-from-socket-io): Deleted. (send-event, read-event, send-to-emacs) (signal-interrupt, use-threads-p): New functions. And more random changes. 2008-08-08 Helmut Eller Spawn the auto-flush thread in the front end. This removes some copy&paste code in various backends. * swank.lisp (auto-flush-loop): New function. (open-streams): Use it. * swank-backend.lisp (make-stream-interactive): Deleted. 2008-08-08 Helmut Eller * slime.el (test disconnect): Call slime-inferior-process with explicit connection argument to avoid clashes with buffer-local connections. 2008-08-08 Tobias C. Rittweiler * slime.el (slime-create-macroexpansion-buffer): Make fontifying case insensitive as the result from macroexpansion is most likely printed all upper-case. 2008-08-07 Helmut Eller * slime.el (slime-with-temp-buffer): By default, no longer inherit the current connection. 2008-08-07 Tobias C. Rittweiler Previously, M-p at the REPL deleted the input if no match could be found in the history. Now the input is untouched. * slime.el (slime-repl-history-replace): Ditch delete-at-end-p argument. (slime-repl-next-input, slime-repl-previous-input): Adapted. (slime-repl-forward-input, slime-repl-backward-input): Ditto. 2008-08-07 Helmut Eller * slime.el (slime-with-temp-buffer): Renamed from slime-with-output-to-temp-buffer. Initialize the buffer local buffer variables before and after running BODY, so that we don't need the mode argument. 2008-08-07 Tobias C. Rittweiler * slime.el (def-slime-test narrowing): Adapted to recent changes of `slime-with-output-to-temp-buffer'. 2008-08-07 Tobias C. Rittweiler Mode-Line will now display a buffer's connection, and a buffer's package. Furthermore, stale connections will also be indicated. * slime.el: (slime-update-modeline-package): Renamed to `slime-extended-modeline'. (slime-modeline-string), (slime-modeline-connection-name), (slime-modeline-connection-state): New variables. (slime-update-modeline-package): Renamed to `slime-compute-modeline-package'. (slime-compute-modeline-connection): New. (sime-compute-modeline-connection-state): New. (slime-compute-modeline-string): New. (slime-update-modeline-string): New. (slime-shall-we-update-modeline-p): New. (slime-update-modeline): New. Run periodically by idle timer. (slime-mode, slime-temp-buffer-mode): Install extended mode-line. (slime-stale-connection-p, slime-debugged-connection-p): New. (slime-compute-connection-state): New. (slime-connection-state-as-string): New. (slime-state-name): Removed. (slime-set-state): Removed. (slime-length>): Fix typecase. 2008-08-07 Helmut Eller * swank-allegro.lisp, swank-cmucl.lisp, swank-scl.lisp (receive-if): Periodically check for interrupts. 2008-08-06 Nikodemus Siivola * swank-sbcl.lisp (handle-notification-condition): resignal warnings as-is before replacing with COMPILER-CONDITION so that handlers higher up the stack can muffle them should they choose to. This silences redefinition warnings for definitions inside EVAL-WHEN :COMPILE-TOPLEVEL in newish SBCLs when compiling the file for a second time. (call-with-compilation-hooks): STYLE-WARNINGs are WARNINGs, and don't need a separate handler. 2008-08-06 Helmut Eller * swank-sbcl.lisp (short-backtrace): New function. (thread-description): Use it. * slime.el (slime-show-apropos): Use lisp-syntax-table to make M-. more useful. 2008-08-06 Helmut Eller Queue interrupts in various places. * swank-backend.lisp (*pending-slime-interrupts*): New variable. (check-slime-interrupts): New function. * swank-lispworks.lisp (receive-if): Use it. * swank-sbcl.lisp, swank-openmcl.lisp: Ditto. * swank.lisp (*slime-interrupts-enabled*): New variable. (with-slime-interrupts, without-slime-interrupts): New macros. (invoke-or-queue-interrupt): New function. (interrupt-worker-thread, eval-for-emacs, swank-debugger-hook) (debug-nth-thread, wait-for-event, read-from-emacs): Use them. 2008-08-05 Helmut Eller * slime.el (slime-with-output-to-temp-buffer): Make sure that we don't make the wrong buffer read-only. * swank-lispworks.lisp (make-stream-interactive): Run our own thread to periodically flush streams instead of relying on soft-force-output. * swank.lisp (encode-message): Inhibit interrupts while writing the length and the body. * swank-backend.lisp (make-recursive-lock) (call-with-recursive-lock-held): Deleted. Make the default locks "recursive" instead. (thread-id): Add a default implementation which works with the default implementation of current-thread. * swank-gray.lisp (stream-write-string): New method. * swank-backend.lisp (*gray-stream-symbols*): Include write-string. 2008-08-04 Helmut Eller * swank-gray.lisp (slime-output-stream): Undo last change. Make force-output and finish-output do the same. 2008-08-04 Masayuki Onjo Updates for CLISP-2.46. * swank-clisp.lisp (fspec-pathname, fspec-location): The structure of (documentation symbol 'sys::file) used to be (path . lines) but is now ((type path . lines) ...). 2008-08-04 Helmut Eller * swank-gray.lisp (slime-output-stream): Add a slot "interactive-p" which should be true for streams which are flushed periodically by the Lisp system. Update the relevant backends accordingly. * swank-scl.lisp (receive-if): Implemented. * swank-cmucl.lisp (receive,receive-if): Test for new messages in a loop. * swank.lisp (eval-for-emacs): Don't flush streams here as that may now block. * swank-lispworks.lisp (receive-if): Handle interrupts. * slime.el (slime-repl-clear-buffer): Delete stuff after the prompt too. (slime-with-output-to-temp-buffer): Add read-only argument. (slime-temp-buffer): Renamed from slime-get-temp-buffer-create. Drop noselect argument. 2008-08-03 Helmut Eller Add some flow-control. * swank.lisp (make-output-function): Synchronize with Emacs on every 100th chunk of output. (wait-for-event,wait-for-event/event-loop,event-match-p): New functions. Used to selectively wait for some events and to queue the other events. (dispatch-event, read-from-socket-io): Tag non-queueable events with :call. (read-from-control-thread, read-from-emacs): Process :call events only; enqueue the others. (*log-output*): Don't use synonym-streams here. Dereference the symbol until we get at the real stream. (log-event): Escape non-ascii characters more carefully. * swank-backend.lisp (receive-if): New function. Update backends accordingly. (not yet for ABCL and SCL) * slime.el (slime-dispatch-event): Handle ping event. 2008-08-03 Tobias C. Rittweiler * slime.el: Make code related to temp buffers more consistent. (slime-with-output-to-temp-buffer): Docstring update. New keyarg :connection to specify whether the current connection should be stored buffer-locally. New key arg :emacs-snapshot to explicitly pass the snapshot to be stored. The created buffer is not automatically set to slime-mode anymore. (slime-temp-buffer-mode): Add `C-c C-z', and `M-.' bindings to all temp buffers. (slime-list-compiler-notes): Use `slime-with-output-to-...', rename the buffer from "*compiler notes*" to "*SLIME Compiler-Notes*". (slime-compiler-notes-mode-map): Remove explicit binding of "q", as it's inherited from the temp buffer. (slime-edit-value-callback): Use `slime-with-output-to-...'. (slime-show-apropos): Adapted to above changes. (slime-macroexpansion-minor-mode): Removed "q" binding, as it's inherited. (slime-eval-macroexpand): Adapted. Rename buffer from "*SLIME macroexpansion*" to "*SLIME Macroexpansion*". (slime-list-connections): Use `slime-with-output-to-...', rename buffer from "*SLIME connections*" to "*SLIME Connections*". 2008-07-27 Tobias C. Rittweiler * slime.el (make-slime-buffer-location): New. (make-slime-file-location): New. 2008-07-29 Richard M Kreuter Environment variables for Lisp process. * slime.el (slime-start, slime-maybe-start-lisp) (slime-reinitialize-inferior-lisp-p, slime-start-lisp) (slime-restart-sentinel): Pass new parameter "env" through. 2008-07-29 Richard M Kreuter * swank-sbcl.lisp (add-sigio-handler, add-fd-handler): Be quiet as a workaround for non-properly initialized *debug-io*. 2008-07-29 Richard M Kreuter Fix slime-quit-lisp in non-default REPL buffer. * slime.el (slime-quit-lisp): Killing the REPL buffer also removes the buffer local binding of slime-buffer-connection. Remember the connection before killing the buffer. 2008-07-27 Tobias C. Rittweiler * swank.lisp (swank-compiler): Fix bug when invoking an abort restart on a failed compilation attempt. * swank-sbcl.lisp (swank-compile-string): If a compilation attempt fails, COMPILE-FILE returns NIL which we tried to LOAD. Fix that. * swank-backend.lisp (swank-compile-string, swank-compile-file): Document return value. 2008-07-23 Tobias C. Rittweiler * swank-loader.lisp (*contribs*): Added `swank-package-fu'. 2008-07-23 Tobias C. Rittweiler * slime.el (slime-at-list-p): New. Returns t if point is at a list. (slime-at-expression-p): New. Similiar to `slime-in-expression-p'. (slime-end-of-list): New. Pendant to `slime-beginning-of-list'. 2008-07-19 Tobias C. Rittweiler REPL shortcuts now leave an appropriate Common Lisp form in the REPL history. * slime.el (slime-within-repl-shortcut-handler-p): New global. T if truly inside a repl shortcut handler invoked by ,foo on the REPL. (slime-handle-repl-shortcut): Bind above global appropriatly. (slime-repl-shortcut-eval): New; should be used in repl shortcut handlers instead of `slime-eval'. (slime-repl-shortcut-eval-async): New; should be used in repl shortcut handlers instead of `slime-eval-async'. (defslime-repl-shortcut): Update docstring. (slime-repl-set-package): Use slime-repl-shortcut-eval. (slime-set-default-directory): Ditto. (slime-sync-package-and-default-directory): Ditto. 2008-07-18 Tobias C. Rittweiler * slime.el (slime-recompile-locations): Locations were potentially recompiled within a wrong package. Fix that. 2008-07-18 Tobias C. Rittweiler An explicit numeric value as prefix-arg given to `C-c C-c' will now represent the debug level the defun is compiled with; `C-u C-c C-c' defaults to maximum debug like before. (Now also works for recompilation commands in xref buffers.) * slime.el (slime-compilation-debug-level): Renamed from `slime-compile-with-maximum-debug'. (slime-normalize-optimization-level): New. (slime-compile-defun): Adapted accordingly. (slime-compile-region): Ditto. (slime-recompile-location): Added setting of debug-level. (slime-recompile-locations): Ditto. (slime-recompile-xref): Now takes debug-level prefix-arg. (slime-recompile-all-xrefs): Ditto. * swank-sbcl.lisp (defimplementation swank-compile-string): Adapted accordingly. 2008-07-16 Tobias C. Rittweiler * slime.el (slime-xref-dspec-at-point): Make more robust. (slime-xref-insert-recompilation-flags): Ditto. (slime-column-max): New. 2008-07-16 Tobias C. Rittweiler Recompilation support added to xref buffers. You can now use `C-c C-c' in an xref buffer to recompile the defun represented by the xref at point. Similiarly, you can use `C-c C-k' to recompile all xrefs displayed. For example, if you've changed a macro, and want to recompile all the functions in the image which use that macro, you first call `slime-who-macroexpands' (C-c C-w RET), and then issues `C-c C-k' in the xref buffer that just popped up. [There's no guarantee that this will actually recompile all functions that depend on the changed macro, as this obviously depends on the quality of the backend's WHO-MACROEXPANDS implementation.] * swank.lisp: Introduced the notion of a SWANK-COMPILATION-UNIT, so we're able to compile different stuff comming from Slime one after the other, and have compiler notes &c. collected in a contiguous manner. (defstruct :swank-compilation-unit): New. Contains compilation notes, compilation results, etc. (*swank-compilation-unit*): New. Current Swank Compilation Unit. (with-swank-compilation-unit): New. Like WITH-COMPILATION-UNIT. (swank-compilation-unit-for-emacs): New. (swank-compiler): Adapted; collect compilation stuff into the current swank-compilation-unit. (compile-string-for-emacs): Use WITH-SWANK-COMPILATION-UNIT. (compile-file-for-emacs): Ditto. (*compiler-notes*, clear-compiler-notes): Removed. (compiler-notes-for-emacs): Removed. * slime.el (slime-compilation-unit, slime-last-compilation-unit), (slime-compiler-notes, slime-compiler-results): New/Adapted. (slime-make-compile-expression-for-swank): Factored out from `slime-compile-string'. (slime-recompile-location): New. (slime-recompile-locations): New. (slime-pop-to-location): &optional `where' arg can now also be 'excursion to only reset the current-buffer, but not switch. (slime-xref-mode-map): Add `C-c C-c' and `C-c C-k'. (slime-xref-dspec-at-point): New. (slime-all-xrefs): New. (slime-recompile-xref): New. (slime-recompile-all-xrefs): New. (slime-make-xref-recompilation-cont): New. (slime-xref-inert-recompilation-flags): New. (slime-trim-whitespace): New utility. 2008-07-05 Tobias C. Rittweiler * swank.lisp: Revert Melis' change from 2008-07-04; Global IO redirection seems currently to be broken, and while it's not due to that commit (it seems that it's been broken since longer), I want to be on a safe bet. 2008-07-05 Tobias C. Rittweiler `M-x slime-lisp-threads' will now contain a summary of what's currently executed in a thread that was created by Swank. * swank-backend.lisp (thread-description, set-thread-description): New interface functions to associate strings with threads. * swank-sbcl.lisp (thread-description, set-thread-description): Implemented. * swank.lisp (call-with-thread-description), (with-thread-description): New. (read-from-emacs): Now temporarily sets the thread-description of the current thread to a summary of what's going to be executed by the current request. (defslimefun list-threads): Changed return value to also contain a thread's description. * slime.el (slime-list-threads, slime-thread-insert): Adapted to new return value of LIST-THREADS. 2008-07-04 Gábor Melis * swank.lisp (call-with-redirected-io): Rebind only standard streams if *GLOBALLY-REDIRECT-IO*. Fixes lost output after disconnect, reconnect. 2008-07-04 Willem Broekema * slime-allegro.lisp (fspec-definition-locations): Workaround for the issue that Allegro does not record the source file location for methods defined inside a defgeneric form. The idea is that if the source location of a method is not found, then the defgeneric form is almost certainly the right place. 2008-07-04 Tobias C. Rittweiler * slime.el (slime-call-defun): Properly signal error message when used in a context that is not a function definition. 2008-07-04 Richard M Kreuter * swank-sbcl.lisp (code-location-source-location), (code-location-debug-source-name): Patched for incompatible structure change in SBCL 1.0.18.10. 2008-07-04 Tobias C. Rittweiler * slime.el (slime-call-defun): Broken on DEFMETHOD forms. Fix that. Also, don't insert package qualifier anymore if the inserted qualifier is the same as the current REPL package. 2008-07-02 Martin Simmons * swank-lispworks.lisp (install-debugger-globally): hook into the environment globally to catch BREAK. 2008-06-07 Tobias C. Rittweiler * slime.el (def-slime-test find-definition.2, arglist): SWANK:COMPILE-STRING-FOR-EMACS since recently takes 5 instead of 4 parameters. Fix that. 2008-06-07 Tobias C. Rittweiler * slime.el (slime-extract-context, slime-parse-context): Recognize more toplevel forms, e.g. DEFINE-COMPILER-MACRO &c. Such that `slime-parse-toplevel-form' will also recognize these. (slime-trace-query): Adapted to above changes. Errors if spec is untraceable. (slime-call-defun): Adapted to also support the new toplevel forms. (slime-cl-symbol-name), (slime-cl-symbol-package), (slime-qualify-cl-symbol-name): Resurrected from the `slime-parse' contrib, as they've been used by `slime-call-defun'. 2008-06-02 Raymond Toy Unicode support for CMUCL. * swank-cmucl.lisp (accept-connection, make-socket-io-stream): Handle external-format argument. (find-external-format): Implemented. (*external-format-to-coding-system*): New variable. 2008-05-19 Helmut Eller * swank-sbcl.lisp: Don't require asdf. 2008-05-19 Helmut Eller * swank-sbcl.lisp (swank-compile-string): Add reader-conditionals for sb-ext::restrict-compiler-policy. 2008-05-19 Geo Carncross * contrib/swank-asdf.lisp: Require asdf. 2008-05-17 Helmut Eller * slime.el (slime-prin1-to-string): Bind print-length and print-level. 2008-05-17 Helmut Eller * slime.el (slime-inspector-limit): New variable. (slime-inspector-insert-content): Use it. (slime-inspector-fetch-chunk, slime-inspector-fetch) (slime-inspector-next-range, slime-inspector-join-chunks): New. 2008-05-08 Geo Carncross * swank-ecl.lisp (call-with-debugging-environment) (frame-decode-env): Bugfix: qualify fixnump 2008-05-01 Geo Carncross * swank-ecl.lisp (call-with-debugging-environment) (is-ignorable-fun-p, is-swank-source-p, in-swank-package-p): Trim swank sources from the ECL backtrace. 2008-04-30 Geo Carncross * swank-ecl.lisp (call-with-debugging-environment) (in-swank-package-p): Remove frames from the backtrace that are in a swank package as those are misleading. Fixup locals display. 2008-04-29 Geo Carncross * swank-ecl.lisp: Backtrace and frame/eval improvements 2008-04-24 Tobias C. Rittweiler * swank-backend.lisp: Clarified docstrings of interface functions in the Debugging section. 2008-04-23 Geo Carncross * swank-source-file-cache.lisp (skip-comments-and-whitespace): Include #\Page as whitespace * swank-ecl.lisp (find-source-location): Initial support for find-source-location with functions (flush-streams): Workaround differences in different ECL versions (find-definitions): basic/simple implementation of find-definitions * swank-loader.lisp (*sysdep-files*): Include swank-source-path-parser and swank-source-file-cache for ECL 2008-04-17 Travis Cross * swank.asd: Don't make a compile-op a no-op so that a swank-loader.fasl file gets generated and (require 'swank) can be called multiple times. 2008-04-17 Zach Beane C-c C-c with prefix args now uses the maximal debug level. Only implemented for SBCL. * slime.el (slime-compile-with-maximum-debug): New variable. (slime-compile-defun, slime-compile-region): Use it. * swank.lisp (compile-string-for-emacs): Accept new debug argument. Update backend accordingly. 2008-04-17 Helmut Eller * slime.el (slime-set-default-directory): Send absolute filenames. 2008-04-06 Tobias C. Rittweiler * slime.el (slime-edit-definition): The `slime-edit-definition-hooks' are now invoked with the same args as `slime-edit-definition'. 2008-03-27 Martin Simmons * swank-lispworks.lisp (map-error-database): Make mapping work for LispWorks 5.1 too. 2008-03-26 Tobias C. Rittweiler On SBCL, (block outta (let ((*debugger-hook* #'(lambda (c hook) (declare (ignore hook)) (return-from outta 42)))) (error "FOO"))) would just silently skip over the *DEBUGGER-HOOK*, and pop right into SLDB to handle the error. Fix that. * swank-sbcl (make-invoke-debugger-hook): New function; returns a hook for SB-EXT:*INVOKE-DEBUGGER-HOOK* that checks for the presence of *DEBUGGER-HOOK*, and calls that if available. (install-debugger-globally): Use it. (call-with-debugger-hook): Ditto. (getpid): Declaim return type explicitly, to make SBCL shut up about being unable to optimize %SAP-ALIEN in ENABLE-SIGIO-ON-FD. * slime.el (def-slime-test break): Test additionally that BREAK turns into SLDB even when *DEBUGGER-HOOK* is locally bound. (def-slime-test locally-bound-debugger-hook): New test case; tests that a locally-bound *DEBUGGER-HOOK* is adhered, and not skipped. 2008-03-26 Helmut Eller By default, don't ask if SLIME should be started. * slime.el (slime-auto-connect): New variable. (slime-auto-connect): New function. (slime-connection): Use it. 2008-03-24 Helmut Eller * slime.el (slime-check-version): New function. Make the prompt fit in a single line. * swank-loader.lisp (load-swank): Call swank::before-init. * swank.lisp (before-init): New function. (init): Renamed from setup. 2008-03-24 Tobias C. Rittweiler * HACKING: Updated due to broken links. Reported by Mirko Vukovic. 2008-03-24 Tobias C. Rittweiler * slime.el (slime-set-connection-info): Display SLIME and SWANK versions explicitly in Protocol Mismatch message. Adapted from idea and patch by Jeronimo Pellegrini. 2008-03-24 Tobias C. Rittweiler * swank-source-path-parser.lisp The source parser READs in files, and if such a file contains some nasty #. hackery that results in an error being signalled, M-. would fail on anything that's defined in those files. Fix that by using a special #. reader function that invokes the original #. reader with an IGNORE-ERRORS wrapped around. (make-sharpdot-reader): New function. (make-source-recording-readtable): Use it and install it on #. * slime.el (find-definition.2): New test case to guard against it. 2008-03-18 Geo Carncross * swank-ecl.lisp: ECL moved gray streams into GRAY package. 2008-03-18 Helmut Eller * slime.el (slime-xref-group): Handle :zip files. 2008-03-17 Tobias C. Rittweiler * swank-source-path-parser.lisp: Multibyte characters in files could screw up compiler-notes highlighting on SBCL. Fix that. (skip-toplevel-forms): Abstracted out from READ-SOURCE-FORM. (source-path-file-position): Don't operate on the file stream directly, since CL:FILE-POSITION may not return character but binary offsets on such streams; instead slurp file content into a buffer string, and operate on that. 2008-03-16 Tobias C. Rittweiler * swank.lisp (load-file-set-package): Removed; the function was only used in `slime-load-file-set-package' which invokes `slime-repl-set-package' which set the package for a second time. * slime.lisp (slime-load-file-set-package): Don't call SWANK:LOAD-FILE-SET-PACKAGE, but merely call SWANK:LOAD-FILE, then invoke `slime-repl-set-package' which will set the package. (slime-pretty-find-buffer-package): Removed. (Nowhere used.) (slime-set-package): Ditto. 2008-03-14 Helmut Eller Remove some rarely used code. * slime.el (with-lexical-bindings): Removed. Updated callers accordingly. (slime-make-default-connection, slime-choose-connection) (slime-find-connection-by-name, slime-symbol-at-point): Remove. Unused code. (slime-obsolete-commands, slime-bind-obsolete-commands) (slime-bind-obsolete-command, slime-upgrade-notice) (slime-timebomb, slime-timebomb-progress, slime-timebomb-message): Remove. Obsolete. 2008-03-14 Helmut Eller Move filename translation code to contrib. * slime.el (slime-find-filename-translators) (slime-filename-translations): Move to contrib/slime-tramp.el. (slime-to-lisp-filename-function) (slime-from-lisp-filename-function): New variables. 2008-03-14 Helmut Eller * slime.el (slime-repl-return-behaviour): Deleted. Rebind the key if you don't like what the command does. 2008-03-14 Tobias C. Rittweiler * swank.lisp (classify-symbol, symbol-classification->string): Add classification of symbols denoting type specifier, and denoting constants. 2008-03-13 Tobias C. Rittweiler * slime.el (slime-eval-macroexpand): Indent expansion. 2008-03-13 Tobias C. Rittweiler * slime.el (slime-edit-definition-cont): If no definition could be found, print also the package name in the error message where the definition was tried to be found in. 2008-03-13 Helmut Eller * slime.el (slime-region-for-defun-function): Deleted. (slime-region-for-defun-at-point): Use beginning-of-defun and not beginning-of-sexp. (slime-flash-region): New function. (slime-compile-region): Use it. 2008-03-13 Helmut Eller * slime.el (slime-xref-group): Renamed from slime-location-to-string. Handle source-form locations. 2008-03-12 Helmut Eller * slime.el (slime-find-definitions-function): Renamed from slime-edit-definition-fallback-function. (slime-find-definitions): Use it. (slime-find-tag-if-tags-table-visited): Deleted. 2008-03-12 Helmut Eller * slime.el (slime-inspector-operate-on-point): Signal an error if there is no object to operate on. 2008-03-08 Helmut Eller * slime.el (sldb-toggle-details): Inhibit point-motion-hooks. This is a workaround for problems with the --more-- field. 2008-03-07 Helmut Eller Be GC friendlier when parsing net packets. * slime.el (slime-net-read): Instead of consing a fresh string, use narrow-to-region and read the packet out of the buffer. 2008-03-04 Helmut Eller * test.sh: Updated for Emacs 23. 2008-03-04 Andreas Fuchs * swank.asd (asdf:output-files, asdf:perform): Make compile-op on swank-loader-file a noop. 2008-03-02 Tobias C. Rittweiler * slime.el (slime-edit-definition-hooks): This variable can be used to hook into the M-. machinery. (slime-edit-definition): Run above hooks until one succeeds. By default, try to find a definition for the symbol at point. 2008-02-28 Tobias C. Rittweiler * swank.lisp (find-definition-for-thing): New DEFSLIMEFUN. * swank-backend (find-source-location): New DEFINTERFACE. * swank-sbcl (find-source-location): Implement it. * slime.el (slime-edit-definition-cont): Use `slime-length='. 2008-02-28 Tobias C. Rittweiler Fix regressions in the `find-definition' test case on SBCL: M-. on e.g. SWANK::READ-FROM-EMACS would bring the user to (|defun read-from-emacs ...) and not |(defun read-from-emacs ...) * swank-sbcl.lisp (source-file-position): Don't 1+ the returned position; i.e. return a position usable as a CL /file position/ which start from 0, and not a position usable in Emacs where buffer points start from 1. This is important because the return value is passed to SWANK-BACKEND::READ-SNIPPET which invokes CL:FILE-POSITION on it. (make-definition-source-location): Adapted to 1+ the position passed to Emacs, to reflect above change. 2008-02-25 Helmut Eller Make it easier to prepare core-files. * swank-loader.lisp (init): Two new keyword args: :SETUP and :LOAD-CONTRIBS. :SETUP=nil can be used to suppress init hooks and loading user init files. * swank.asd: Call swank-loader:init with :SETUP=nil. * swank.lisp (init-global-stream-redirection): Guard against redirecting already redirected streams. 2008-02-24 Helmut Eller Work harder to avoid wrong guesses for slime-repl-set-package. * slime.el (slime-repl-set-package): Use slime-pretty-package-name to strip double quotes from slime-current-package before comparing it with slime-lisp-package. Still doesn't deal with nicknames and other reader tricks. 2008-02-23 Ariel Badichi Allow ED-IN-EMACS to edit new files. * swank.lisp (ed-in-emacs): Accept non-existing files. (canonicalize-filename): Merged into ed-in-emacs. 2008-02-23 Nikodemus Siivola If there is no connection, offer the option to start SLIME. * slime.el (slime-connection): Ask and maybe start SLIME. (slime-selector-method: ?r): No need to ask here any more. 2008-02-23 Helmut Eller In the inspector, show one-element lists as list not as pair. * swank.lisp (emacs-inspect cons) 2008-02-23 Zach Beane Add customization variable for the `slime-connect' port. * slime.el (slime-port): New variable. 2008-02-22 Mark Evenson * swank-abcl.lisp (getpid): Return '0' in case of error. Apparently needed bacause $PPID isn't not a standard feature. "[T]his is not a disentanglement from, but a progressive knotting into." 2008-02-22 Mark Harig Fix typos: "contribs" -> "contrib". * slime-autoloads.el (slime-setup-contribs): * slime.el (slime-setup): 2008-02-22 Mark Harig Fixes for CLISP 2.44. * swank-clisp.lisp (sldb-backtrace, %parse-stack-values): sys::frame-up-1 no longer exists; use sys::frame-up instead. 2008-02-22 Helmut Eller * slime.el (slime-pop-to-location): Slight cleanups. (slime-goto-xref, slime-goto-next-xref): Use it. 2008-02-22 Helmut Eller Remove save-restriction-if-possible. * slime.el (save-restriction-if-possible): Deleted. It was only used in one place. (slime-goto-source-location): Obey widen-automatically. (slime-location-offset): New function. 2008-02-21 Tobias C. Rittweiler * slime.el (slime-location-to-string): New function. (slime-analyze-xrefs): Use it; display definitions defined interactively via C-c C-c as comming from # instead of foo.lisp. 2008-02-20 Helmut Eller Better factorization for M-. and xref commands. * slime.el (slime-xref): Renamed from slime-definition. (slime-location, slime-location-p): New ADT def. (slime-xref-has-location-p, slime-analyze-xrefs): New functions. This work used to be done on the Lisp side. (slime-pop-to-location): New function. (slime-edit-definition, slime-edit-definition-cont): Simplified. (slime-find-definitions): New function. (slime-goto-definition, slime-goto-definition-other-window) (slime-pop-to-other-window, slime-show-definitions): Deleted. (slime-insert-xrefs): Simplified. (slime-insert-xref-location): Deleted. No need to show the filename twice. * swank.lisp (find-definitions-for-emacs, xref): Use common representation for "definitions" and "xrefs". (xref>elisp): New helper. (group-xrefs, alistify, parition, location-position<, xref-position) (xref-buffer, location-valid-p): Deleted. This work is now done on the Emacs side. 2008-02-20 Helmut Eller Emit a warning if the SWANK package already exists. * swank-loader.lisp (init): Issue a warning when SWANK will not be reloaded. 2008-02-18 Helmut Eller Minor cleanups for inspector code. * swank.lisp (inspector-content, inspect-list-aux): Slight cleanups. 2008-02-17 Marco Baringer * swank.asd: Update for recent changes to swank-loader.lisp, we need to call swank-loader::init after loading. 2008-02-16 Helmut Eller In the REPL, mark the trailing newline also as input. * slime.el (slime-repl-send-input): Mark the newline with the 'slime-repl-old-input property. (slime-repl-grab-old-input): Strip the newline. 2008-02-16 Helmut Eller Split loading and initialization (again). * swank-loader.lisp (init): New. Delete old packages only if explicitly requested. Also, if the swank package already exists don't load swank again. (setup): New function. * swank.lisp (setup): New function. Moved over here from swank-loader.lisp. * slime.el (slime-init-command): Call swank-loader:init. 2008-02-10 Helmut Eller Remove remaining traces of make-default-inspector. * swank-scl.lisp (make-default-inspector, scl-inspector): Deleted. * swank-lispworks.lisp (make-default-inspector) (lispworks-inspector): Deleted. 2008-02-09 Helmut Eller Drop the first return value of emacs-inspect. * swank.lisp (emacs-inspect): Drop the first return value. It wasn't used anymore. Update all methods and callers. 2008-02-09 Helmut Eller Remove obsolete *slime-inspect-contents-limit*. * swank.lisp (*slime-inspect-contents-limit*): Deleted and all its uses. The new implementation isn't specific to hash-tables or arrays. 2008-02-09 Helmut Eller Limit the length of the inspector content. That's similar to the limitation of the length of backtraces in the debugger. * swank.lisp (*inspectee-content*): New variable. (content-range): New function. (inspect-object): Use it with a length of 1000. (inspector-range): New function. Called from Emacs. * slime.el (slime-inspector-insert-content) (slime-inspector-insert-range, slime-inspector-insert-range-button) (slime-inspector-fetch-range): New functions. (slime-inspector-operate-on-point): Handle range-buttons. 2008-02-09 Helmut Eller Make slime-property-bounds more useful. * slime.el (slime-property-bounds): Remove special casing for whitespace at the end. (slime-repl-send-input): Don't mark the newline with the slime-repl-old-input property. (sldb-frame-region): Use slime-property-bounds. 2008-02-09 Helmut Eller Inspector cleanups. * swank.lisp (emacs-inspect): Renamed from inspect-for-emacs. Changed all method-defs accordingly. (common-seperated-spec, inspector-princ): Moved to swank-fancy-inspector.lisp. (inspector-content): Renamed from inspector-content-for-emacs. (value-part): Renamed from value-part-for-emacs. (action-part): Renamed from action-part-for-emacs. (inspect-list): Renamed from inspect-for-emacs-list. (inspect-list-aux): New. (inspect-cons): Renamed from inspect-for-emacs-simple-cons. (*inspect-length*): Deleted. (inspect-list): Ignore max-length stuff. (inspector-content): Don't allow nil elements. (emacs-inspect array): Make the label of element type more consistent with the others. 2008-02-09 Helmut Eller Cleanup slime-repl-set-package. * slime.el (slime-repl-set-package): Make it fit within 80 columns. 2008-02-05 Marco Baringer * slime.el (slime-search-buffer-package): Ask the lisp to read the in-package form so that we properly deal with #+foo and |WHATEVER| package names. (slime-repl-set-package): Only prompt with a default package if the repl's package is different from the current package. 2008-02-04 Marco Baringer * swank-openmcl.lisp (ccl::advise ccl::break): advise the lower-level ccl::cbreak-loop instead of cl:break. (frame-locals): If the value is a value-cell (a closed over value) show the closed over value and not the value cell. (disassemble-frame): add in x86-64 code. * slime-autoloads.el (slime-setup-contribs): Add contribs directory to load-path. * slime.el (slime-setup): Add contribs directory to load-path. * swank-abcl.lisp, swank-allegro.lisp, swank-backend.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-corman.lisp, swank-ecl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp, swank-scl.lisp, swank.lisp, contrib/swank-fancy-inspector.lisp: Remove second argument from swank:inspect-for-emacs. This functionality, choosing an inspector at runtime, was never actually used and is, now, needless complexity. 2008-02-04 Helmut Eller Simpler code to bind 0-9 in the debugger. * slime.el (sldb-mode-map): When binding the keys 0-9, use eval instead of two macros. 2008-02-04 Helmut Eller Move some functions to swank-arglist.lisp. * swank.lisp (length=, ensure-list, recursively-empty-p) (maybecall, exactly-one-p, read-softly-from-string) (unintern-in-home-package, valid-function-name-p): Moved to contrib/swank-arglist.lisp. 2008-02-03 Marco Baringer * swank.lisp (*sldb-condition-printer*): New variable. (safe-condition-message): Use the current binding of *sldb-condition-printer* to print the condition to a string. * slime.el (sldb-invoke-restart-by-name): New function. Invokes a restart by name, uses completion to read restart's name. (slime-define-keys sldb-mode-map): Bind sldb-invoke-restart-by-name to I in sldb buffers. * swank-loader.lisp: When loading swank delete all swank packages first. This protects the lisp from broken reloads of swank. Leave the swank-loader package so that users can set *fasl-directory* and *source-directory* as per the documentation. (lisp-version-string): On openmcl use the full cl:lisp-implementation-version, ccl::*openmcl-major-version* and ccl::*openmcl-minor-version* aren't sufficently precise to notice changes in openmcl's cvs. 2008-01-27 Helmut Eller Make it easier to start a non-default Lisp from ELisp code. * slime.el (slime): If the argument is a symbol start the corresponding entry in slime-lisp-implementations. Typical use is something like: (defun cmucl () (interactive) (slime 'cmucl)) 2008-01-22 Luís Oliveira * swank-source-path-parser.lisp (make-source-recording-readtable): don't suppress the #. reader macro. (read-and-record-source-map): don't bind *read-eval* to nil. (suppress-sharp-dot): unused, delete it. * slime.el (test compile-defun): test with #+#.'(:and). 2008-01-21 Helmut Eller * slime.el (sldb-mode): Don't throw to toplevel in the kill-buffer-hook, since the buffer can be killed for other reasons too. (test break): Test BREAK and CONTINUE in a loop. (slime-wait-condition): Display the current time. 2008-01-20 Matthias Koeppe New hooks that allow the slime-presentations contrib to hook into the debugger and inspector. * slime.el (sldb-insert-frame-variable-value-function): New variable. (sldb-insert-frame-variable-value): New function, default value for sldb-insert-frame-variable-value-function. (sldb-insert-locals): Use it here. * slime.el (slime-inspector-insert-ispec-function): New variable. (slime-open-inspector): Use it here. 2008-01-20 Matthias Koeppe * doc/slime.texi (Presentations): Improve documentation of presentations. 2008-01-19 Geo Carncross * swank-ecl.lisp (inspect-for-emacs): Make ECL inspection better; should be able to handle all builtin types and CLOS objects now. 2008-01-17 Nikodemus Siivola * swank-sbcl.lisp (sbcl-source-file-p): When a buffer is not associated with any file, M-. for names defined there ends up calling SBCL-SOURCE-FILE-P with NIL -- guard against that. 2008-01-14 Tobias C. Rittweiler * slime.el (sldb-mode): Add `sldb-quit' to `kill-buffer-hook' to close the debugging machinery on swank side when the SLDB buffer is killed. (Notice that killing the SLDB buffer manually will not restore window configuration in contrast to typing `q'.) 2008-01-10 Tobias C. Rittweiler * slime.el (slime-delete-and-extract-region): New function. Portable version of `delete-and-extract-region' which returned NIL instead of "", as experienced by Matthias Koeppe. 2008-01-09 Matthias Koeppe * slime.el (slime-repl-mode-map): Bind C-c C-t to slime-toggle-trace-fdefinition (as in Lisp buffers) instead of slime-repl-clear-buffer. This binding is useful for untracing functions directly from the trace output. Move slime-repl-clear-buffer to the keybinding C-c M-o. 2008-01-04 Juho Snellman * swank-sbcl.lisp (source-file-source-location): Use the debootstrap readtable when appropriate (fixes occasional reader errors when using "v" on debugger frames that point to functions defined in SBCL). Likewise for the debootstrapping packages. (code-location-debug-source-name): Ensure that we always return a physical namestring, Emacs won't like a pathname or a logical namestring. 2008-01-02 Luís Oliveira Use sane default values for slime-repl-set-package. Previously, when typing `,!p' at the REPL, the current package would have been inserted as a default (although the whole intent was to /change/ the current package in the first place), now nothing is inserted anymore. * slime.el (slime-pretty-current-package): rename it to slime-pretty-find-buffer-package and make it use slime-find-buffer-package instead of slime-current-package. (slime-repl-set-package, slime-set-package): use new function. 2008-01-02 Tobias C. Rittweiler * slime.el (slime-print-apropos): Simplified: Don't insert action properties anymore for the symbol; they were ignored anyway, because `apropos-follow' (bound to RET in the resulting *SLIME Apropos* buffer) looks for buttons only. 2008-01-02 Tobias C. Rittweiler * slime.el (slime-apropos): Update docstring: Apropos doesn't match on regular expressions anymore since 2007-11-24. 2007-12-22 Douglas Crosher * swank-scl.lisp (set-stream-timeout, make-socket-io-stream): update for Scieneer CL 1.3.7. 2007-12-21 Geo Carncross * swank-ecl.lisp: try to parse the Args: line in most ecl functions to make modeline/autodoc more interesting 2007-12-20 Tobias C. Rittweiler * swank.lisp (read-softly-from-string): Now actually returns all three values as explained in its docstring. 2007-12-14 Tobias C. Rittweiler * slime.el (slime-insert-xref-location): New function. Tries to either insert the file name a function is defined in, or inserts information about the buffer a function was interactively `C-c C-c'd from. Idea from Knut Olav Bøhmer. (slime-insert-xrefs): Use it. 2007-12-14 Geo Carncross * Add ECL threads implementation to swank 2007-12-04 Helmut Eller Simplify the inspector. * swank.lisp (inspect-object): Ignore the title value returned from backends. * slime.el (slime-open-inspector): Updated accordingly. 2007-12-04 Helmut Eller Fix slime-list-thread selector. * slime.el (slime-list-threads): Wait for the result before continuing. 2007-12-04 Helmut Eller * slime.el (slime-repl-insert-result): Use slime-repl-emit-result since handling of markers has changed. (slime-repl-emit-result): New argument: bol. 2007-12-02 Alan Caulkins Make it possible to close listening sockets. * swank.lisp (stop-server, restart-server): New functions. (*listener-sockets*): New variable. (setup-server): Store open sockets in *listener-sockets*. 2007-12-02 Helmut Eller Add hook to customize the region used by C-c C-c. Useful to recognize block declarations in CMUCL sources. * slime.el (slime-region-for-defun-function): New variable. (slime-region-for-defun-at-point): Use it. 2007-11-30 Helmut Eller Handle byte-functions without debug-info. * swank-cmucl.lisp (byte-function-location): Return an error if the component has no debug-info. 2007-11-30 Helmut Eller Disable the pretty-printer for backtraces. Would be nice if we could print newlines in strings as \n. * swank.lisp (*backtrace-printer-bindings*): New varaible. (backtrace, frame-locals-for-emacs): Use it. 2007-11-29 Tobias C. Rittweiler * swank.lisp (valid-function-name-p): Fixed wrt. setf functions. 2007-11-29 Helmut Eller Prettify package names for slime-repl-set-package. * slime.el (slime-repl-set-package): slime-current-package may have leading colons. Use slime-pretty-package-name to remove them. Reported by Constantine Vetoshev. (slime-pretty-current-package): New function. (slime-set-package): Use it. 2007-11-24 Helmut Eller Drop remaining dependencies on nregex. * swank-lispworks.lisp (unmangle-unfun): Use sys::setf-symbol-p instead of regexp matching. * swank-loader.lisp (*sysdep-files*): Don't include nregex. 2007-11-24 Helmut Eller Mirror *modules* in Emacs. * slime.el (slime-lisp-modules): New connction variable. (slime-set-connection-info): Load requested modules. (slime-required-modules): New variable. (slime-require, slime-load-contribs): New functions. * swank.lisp (connection-info): Include *modules*. (swank-require): Accept a list of modules as argument. 2007-11-24 Helmut Eller * swank.lisp (parse-package): The old version didn't pass the test-suite. Now use the reader directly instead of emulating it half-heartedly. * slime.el (slime-search-buffer-package): Don't remove double quotes or "#:", swank:parse-package takes care of that. 2007-11-24 Helmut Eller * swank.lisp (apropos-symbols): Use simple search instead of regexps. (make-apropos-matcher): Used to be make-regexp-matcher. (*sldb-printer-bindings*): Set *print-right-margin* to most-positive-fixnum. This prints each frame in the backtrace in a single long line. But is suboptimal for other purposes, like eval-in-frame. (setup-server): Initialize multiprocessing here, so that is also done for create-server. 2007-11-23 Tobias C. Rittweiler * swank.lisp (swank-require): Fix typo (:key was used instead of :test.) Reported by Stelian Ionescu. 2007-11-22 Helmut Eller * swank.lisp (swank-require): Don't search the file if the module-name is present in *modules*. That should avoid problems if swank is included in a core file and moved to a different location. Reported by John Wiegley. 2007-11-19 Tobias C. Rittweiler * slime.el (slime-repl-mode-map, slime-repl-read-mode), (slime-compiler-notes-mode-map, slime-xref-mode-map), (sldb-mode-map, slime-connection-list-mode-map), (slime-inspector-mode-map): Added bindings for [return] in addition to (kbd "RET"). The reason is that pressing enter in X is translated to (kbd "RET") only if no binding for [return] is active; if [return] is bound to something, pressing enter is translated to this key binding henceforth, as was explained to me by Pierre Gaston, thanks! This can cause quite confusing behaviour as Andreas Davour faced in his post to comp.lang.lisp. 2007-11-06 Helmut Eller * slime.el (slime-events-buffer, slime-inspector-buffer): Disable undo. 2007-11-01 Tobias C. Rittweiler The inspector page layout has changed slightly. Before the header looked like A proper list. [type: CONS] ------------------- It now looks like #: A proper list. -------------------- Rationale is to have a "presentation link" to the currently inspected object itself, to copy it down to the REPL via `M-RET'. This is mostly useful when trying to get a value from the Slime Debugger to the REPL, which you can do by inspecting the value first by `i', and then using `M-RET' on the object representation in the new header layout. Such a "presentation link" existed already but was removed in 2007-08-23. The old behaviour was to have the title ("A proper list" in the above example) to contain the link. I decided to make the link more explicit. * swank.lisp (inspect-object): Now additionally returns a string-representation of the object itself, and an inspector id for it. Removed returning its type as this is implicit in the new string representation. * slime.el (slime-open-inspector): Adapted for new header layout. 2007-10-22 Tobias C. Rittweiler * swank.lisp (read-softly-from-string, unintern-in-home-package): Moved from `contrib/swank-arglist.lisp'. (parse-package): Use them. (Removes FIXME about interning symbols.) Also changed the logic somewhat to avoid passing :|| to FIND-PACKAGE as ECL chokes on that. 2007-10-22 Steve Smith * swank-loader.lisp (compile-files-if-needed-serially): Added missing `load' argument to function definition on Corman Lisp / ECL. 2007-10-22 Mark Evenson * swank-abcl.lisp (getpid): Implemented. 2007-10-22 R. Matthew Emerson * swank-openmcl.lisp (closure-closed-over-values): Use CCL::NTH-IMMEDIATE instead of CCL::%SVREF. This makes it work on x86-64 OpenMCL. (The %SVREF worked on PPC, but this will work on both.) 2007-09-27 Tobias C. Rittweiler * slime.el (slime-filesystem-toplevel-directory): New function. Windows doesn't have a filesystem that is as hierarchical as the Unix' one. Reported by Carsten Blaauw and Stefan Kluehspies. (slime-file-name-merge-source-root): Use it. (slime-highlight-differences-in-dirname): Use it. 2007-09-26 Utz-Uwe Haus * swank-allegro.lisp (fspec-definition-locations): Allow the POSITION datum of :top-level-form fspecs to be missing. This apparently helpful for Allegro CL 8.1. 2007-09-21 Tobias C. Rittweiler * slime.el (slime-length=, slime-length>): Restore support for vectors, as `slime-length=' was already used with strings in `slime-parse.el'. This broke extended arglist display. 2007-09-20 Helmut Eller * slime.el (slime-setup): Call the respective init functions of contribs. * slime-autoloads.el (slime-setup-contribs): Ditto. 2007-09-19 Helmut Eller Simplify slime-compile-file. * slime.el (slime-compile-file): Don't save window config. (slime-curry, slime-rcurry): New functions. * slime.el (slime-complete-symbol*-fancy): Move defcustom to contrib/slime-c-p-c.el * swank-version.el: Delete file. No longer used. * bridge.el: Moved to contrib. * tree-widget.el: File deleted. Only needed by contribs and is distributed with Emacs 21. * slime.el: Reorder some devfars and menus code so that the compiler doesn't complain about free variables. Fix apropos in Emacs 22. * slime.el (slime-print-apropos): Add button props for Emacs 22. (slime-call-describer): ARG is a marker in Emacs 22. (def-slime-selector-method ?c): Wait until slime-list-threads returns. Remove define-slime-dialect. * slime.el (define-slime-dialect): Deleted. Use slime-lisp-implementations instead. Introduce a slime-start-and-init function. * slime.el (slime-start-and-init, slime-lisp-options): New functions. (slime-start-and-load): Use it. Simplify slime-length=. * slime.el (slime-length=, slime-length>): No need for vectors. Remove explicit support for Scheme mode. * slime.el (slime-scheme-mode-hook, slime-shared-lisp-mode-hook) Deleted. (slime-indentation-update-hooks): New hook. (slime-handle-indentation-update): Use it. Fix close-connection. * swank.lisp (close-connection): Use *log-output* instead of *debug-io* (which could be redirected to the to-be-closed connection). 2007-09-15 Helmut Eller Let slime-setup load contribs. * slime.el (slime-setup): Take a list of contribs to load as argument. * slime-autoloads.el (slime-setup): Ditto, but delay the actual loading until slime is loaded. (slime-setup-contribs): New function. 2007-09-15 Tobias C. Rittweiler * slime.el (slime-maybe-warn-for-different-source-root): Catch returned NIL from `slime-file-name-merge-source-root' if the two filenames don't share a common source root. Reported by Frank Goenninger. 2007-09-15 Tobias C. Rittweiler * slime.el (slime-split-string): New semi-portability function. The behaviour of `split-string' changed between Emacs21 and Emacs22. Thanks to Christophe Rhodes for reporting this. (slime-file-name-merge-source-root): Use `slime-split-string'. (slime-highlight-differences-in-dirname): Likewise. 2007-09-14 Helmut Eller Some cleanups for the REPL. * slime.el (slime-repl-write-string): Split it up into smaller functions. (slime-repl-emit, slime-repl-emit-result) (slime-emit-string): New functions. (slime-repl-save-history): Use prin1 instead of pp. (repl-type-ahead): New test case. 2007-09-12 Christophe Rhodes Make ASDF:LOAD-OP (and SBCL REQUIRE) happy with swank.asd * swank.asd: Define and use a CL-SCRIPT-FILE class for loading as source, even with ASDF:LOAD-OP. 2007-09-11 Tobias C. Rittweiler * swank-loader.lisp: Aways compile-file `contrib/swank-asdf.lisp' on SBCL. This fixes "Undefined function" style-warnings when using `slime-asdf' in combination with SBCL. Reported by Cyrus Harmon. * swank-sbcl.lisp: Explicitly require ASDF. (While this is not strictly necessary, as it's implicitly loaded on requiring the other modules, I think it's better to be explicit about it.) 2007-09-10 Helmut Eller Fix some bugs introduced while moving doc refs to contrib. * swank-sbcl.lisp (condition-references): It's still needed. * slime.el (sldb-dispatch-extras): Add missing quote. (slime-sbcl-manual-root): Move definition to contrib/slime-references.el. (slime-cl-symbol-name, slime-cl-symbol-package): Move to contrib/slime-parse.el. 2007-09-10 Helmut Eller Move SBCL doc references to contrib. * slime.el (sldb-insert-condition): Merge REFERENCES and EXTRAS. (sldb-extras-hooks, sldb-dispatch-extras): New hook. * swank-backend.lisp (condition-references): Removed. Merged with condition-extras. * swank-sbcl.lisp (condition-references): Removed. (condition-extras): Include references. (externalize-reference): New function. Don't return plain symbols. * swank-allegro.lisp (condition-references): Removed. 2007-09-10 Tobias C. Rittweiler * slime.el (slime-cl-symbol-name, slime-cl-symbol-package): Ressurected, as they're still used in this file. Reported by Edward Cant. 2007-09-10 Tobias C. Rittweiler When working on multiple source trees simultaneously, the way `slime-edit-definition' (M-.) works can sometimes be confusing: `M-.' visits locations that are present in the current Lisp image, which works perfectly well as long as the image reflects the source tree that one is currently looking at. In the other case, however, one can easily end up visiting a file in a different source root directory (the one corresponding to the Lisp image), and is thus easily tricked to modify the wrong source files---which can lead to quite some stressfull cursing. If the variable `slime-warn-when-possibly-tricked-by-M-.' is T (the default), a warning message is issued to raise the user's attention whenever `M-.' is about opening a file in a different source root that also exists in the source root directory of the user's _current buffer_. There's no guarantee that all possible cases are covered, but if you encounter such a warning, it's a strong indication that you should check twice before modifying. * slime.el (slime-file-name-merge-source-root): New function. (slime-highlight-differences-in-dirname): New function. (slime-maybe-warn-for-different-source-root): New function. (slime-warn-when-possibly-tricked-by-M-.): New variable (T by default.) (slime-goto-location-buffer): Where appropriate, call `slime-maybe-warn-for-different-source-root' 2007-09-08 Stelian Ionescu * slime.el (save-restriction-if-possible): Place macro definition above use of the macro, to regain ability to byte-compile-file. 2007-09-08 Tobias C. Rittweiler Fix message displaying on XEmacs. Reported by Steven E. Harris, and Ken Causey. * slime.el (slime-display-message): Resurrect secondary `buffer-name' argument which got lost in 2007-08-24. (slime-format-display-message): Resurrect passing "*SLIME Note*" as default buffer-name to `slime-display-message'. 2007-09-08 Matt Pillsbury * swank-backend.lisp (definterface): Updated docstring. 2007-09-06 Matthias Koeppe * slime.el (slime-repl-write-string): Use case, not ecase, for dispatching targets.Should fix XEmacs compatibility. Reported by Steven E. Harris. 2007-09-05 Didier Verna * slime.el (slime-filename-translations): Fix custom type. 2007-09-05 Helmut Eller * slime.el (slime-toggle-trace-fdefinition): Fix typo. The argument for interactive should be "P" not "p". 2007-09-04 Mark Evenson * swank-abcl.lisp: Call accessors of compiler-condition at load time to work around some ABCL problems. 2007-09-04 Helmut Eller Move asdf support to contrib. * swank-backend.lisp (operate-on-system): Moved to swank-asdf.lisp. It wasn't specialized in any backend. * swank.lisp (operate-on-system-for-emacs) (list-all-systems-known-to-asdf, list-asdf-systems): Moved to swank-asdf.lisp. * slime.el: Move asdf commands to contrib slime-adsf.el. * swank-loader.lisp: Load swank-asdf if ASDF is in *FEATURES*. Also add the contrib source directory to swank::*load-path*. 2007-09-04 Helmut Eller * slime.el: Move tramp support to contrib. 2007-09-04 Helmut Eller Move startup animation to contrib. * slime.el (slime-repl-banner-function): New hook. (slime-repl-update-banner): Use it and reset markers after calling it. (slime-set-default-directory): Don't call slime-repl-update-banner here. (slime-repl-insert-prompt): Set slime-repl-input-end-mark to point-max. 2007-09-04 Helmut Eller * slime.el: Move inferior-slime-mode to contrib. 2007-09-04 Helmut Eller * slime.el: Fix the test suite (except for SBCL). 2007-09-04 Helmut Eller Simplify slime-process-available-input. * slime.el (slime-process-available-input): We are called in a process filter, i.e. at arbitrary times and in an aribtrary buffer. So it doesn't make sense to save-and-restore the current buffer here (slime-eval-async): Instead, save and restore the buffer here. (slime-net-read-or-lose): New. 2007-09-04 Helmut Eller Remove request-abort condition. * swank-backend.lisp (request-abort): Removed (abort-request): Removed. Replace all (3) uses with ERROR. * swank.lisp (eval-for-emacs): No special case for request-abort. * slime.el (slime-eval-async): Remove optional arg of :abort. 2007-09-04 Helmut Eller Rename slime-insert-possibly-as-rectangle to slime-insert-indented. * slime.el (slime-insert-indented): Renamed. Update callers. 2007-08-31 Helmut Eller Move compound prefix completion and autodoc to contrib. * swank.lisp (simple-completions): Rewritten for simplicity. (operator-arglist): Rewritten for simplicity. * slime.el (slime-complete-symbol-function): Make simple completion the default. (slime-echo-arglist-function, slime-echo-arglist): New hook. Remove corresponding key bindigs. * slime.el (slime-obsolete-commands): New table. Use it to bind a command with an upgrade notice. 2007-08-31 Andreas Fuchs * slime.el (slime-reindent-defun): Fixed when used in lisp file buffers. (Similiar patch also provided by Gábor Melis; problem also reported by Jeff Cunningham.) 2007-08-31 Jon Allen Boone * swank-cmucl.lisp: CMUCL now has an x86-Darwin port as well as the PPC-Darwin version. Changed to conditionalize on the presence of darwin instead of ppc so that slime works with both Darwin versions of CMUCL. 2007-08-31 Tobias C. Rittweiler * slime.el (slime-sexp-at-point): Explicitely set current syntax table to operate in `lisp-mode-syntax-table' because `thing-at-point' is used which depends on the syntax table. (E.g. keywords like `:foo' aren't recognized as sexp otherwise.) * slime.el (slime-parse-extended-operator/declare): Wrap regexp stuff in `save-match-data' (slime-internal-scratch-buffer): Removed again. Was only introduced as a performance hack; but it turned out that the bad performance was because of unneccessary recursive calls of `slime-make-form-spec-from-string'. (Which was fixed on 2007-08-27 already.) (slime-make-form-spec-from-string): Use `with-temp-buffer' instead of `slime-internal-scratch-buffer'. Removed activation of `lisp-mode' in the temporary buffer, because this made `lisp-mode-hooks' run. This activated autodoc in the temp buffer, although the temp buffer is used to compute an autodoc itself (which resulted in some very mutual recursion which caused the current arglist to be displayed again and again---as could have been witnessed in `*Messages*'.) `Lisp-mode' was activated to get the right syntax-table for `slime-sexp-at-point', but this one sets the correct syntax-table itself now. 2007-08-28 Matthias Koeppe Fix user input type-ahead again (this change from 2007-08-25 got lost). Testcase: Type (dotimes (i 5) (format t "Number ~A~%" i) (sleep 1)) and then type ahead while the command is executing and output arrives. * slime.el (slime-repl-insert-prompt): Don't go to point-max but to slime-repl-input-start-mark if there is one. (slime-repl-write-string): Insert a :repl-result before the prompt, not at point-max. Update markers properly. 2007-08-28 Helmut Eller * swank-cmucl.lisp (safe-definition-finding): Remove whitespace around error messages. (trim-whitespace): New function. 2007-08-28 Helmut Eller Fix some output related bugs. * swank.lisp (send-repl-results-to-emacs): Emit a fresh line. * slime.el (slime-insert-transcript-delimiter): Use insert-before-markers since slime-output-end is no longer left inserting. Reported by Austin Haas . 2007-08-28 Helmut Eller * slime.el (slime-display-or-scroll-completions, slime-scroll-completions): New functions. Factored out of slime-expand-abbreviations-and-complete. 2007-08-28 Matthias Koeppe * slime.el (slime-repl-write-string): Handle arbitrary targets using slime-output-target-marker. (slime-last-output-target-id, slime-output-target-to-marker) (slime-output-target-marker) (slime-redirect-trace-output): Move back here from slime-presentations.el. 2007-08-28 Tobias C. Rittweiler * swank.lisp (classify-symbol, symbol-classification->string): Resurrected in swank.lisp. (I was bitten by cvs-pcl which committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp' where I already removed these functions from.) 2007-08-28 Tobias C. Rittweiler * slime.el (slime-make-form-spec-from-string): Elisp Hacking 101: Don't use `beginning-of-buffer' and `end-of-buffer' in Elisp code. * swank.lisp (read-form-spec): Unintern just newly interned symbols when an reader error occurs. 2007-08-28 Helmut Eller Move presentations to contrib. Part II. * swank.lisp (*listener-eval-function*): New variables. (listener-eval): Use it (repl-eval): Used to be listener-eval. (*send-repl-results-function*): New variable. (eval-region): Simplify. (track-package, cat): New functions. (slime-repl-clear-buffer-hook): New hook. (slime-repl-clear-buffer): Use it. 2007-08-28 Matthias Koeppe Remove the ID argument from :write-string protocol messages. Everything, except for rigid-indentation tricks, can be achieved by using :write-string in conjunction with :presentation-start and :presentation-end. * swank.lisp (present-in-emacs): Unused, removed. * swank.lisp (make-output-function-for-target): Remove id argument from :write-string. (send-repl-results-to-emacs): Don't call save-presented-object. Remove id argument from :write-string. * slime.el (slime-dispatch-event): Change it here. (slime-write-string, slime-repl-write-string): And here. 2007-08-28 Matthias Koeppe * swank-loader.lisp (*contribs*): Add swank-presentations. 2007-08-27 Tobias C. Rittweiler * slime.el (slime-make-extended-operator-parser/look-ahead): Move to end of symbol at point. (slime-make-form-spec-from-string): Fixes unexpected behaviour of `save-excursion'. 2007-08-27 Tobias C. Rittweiler * slime.el (slime-sexp-at-point): Fixes a few edge cases were Emacs' `(thing-at-point 'sexp)' behaves suboptimally. For example, `foo(bar baz)' where point is at the ?\(. (slime-internal-scratch-buffer): New. This variable holds an internal scratch buffer that can be reused instead of having to create a new temporary buffer again and again. (slime-make-extended-operator-parser/look-ahead): Uses `slime-make-form-spec-from-string' to parse nested expressions properly. (slime-nesting-until-point): Added docstring. (slime-make-form-spec-from-string): Added new optional parameter for stripping the operator off the passed string representation of a form. Necessary to work in the context of `slime-make-extended-operator-parser/look-ahead'. Added safety check against a possible endless recursion. * swank.lisp (parse-form-spec): Looses restriction for nesting. 2007-08-27 Helmut Eller * slime.el (slime-eval-feature-conditional): Fix typo. (slime-keywordify): Simplify. 2007-08-27 Helmut Eller Move presentations to contrib. Part I. * slime.el (slime-event-hooks, slime-dispatch-event): New hook. (slime-write-string-function, slime-write-string): New hook. (slime-repl-return-hooks, slime-repl-return): New hook. (slime-repl-current-input-hooks, slime-repl-current-input): New hook. (slime-open-stream-hooks, slime-open-stream-to-lisp): New hook. (sldb-insert-locals, slime-inspector-insert-ispec) (slime-last-expression): Don't use presentations. 2007-08-26 Tobias C. Rittweiler Reduces needless interning of symbols that was introduced by my recent work on autodoc to a minimum. Also fixes this issue for `slime-complete-form' which always interned symbols even before my changes. * slime.el (slime-sexp-at-point): If N is given, but there aren't N sexps available at point, make it return a list of just as many as there are. (slime-make-form-spec-from-string): New. Creates a ``raw form spec'' from a string that's suited for determining newly interned symbols later in Swank. (slime-parse-extended-operator/declare): Uses it. * swank.lisp (parse-symbol): Returns internal knowledge, to provide a means for callers to perform a sanity check. (call-with-ignored-reader-errors): New. Abstracted out from `read-incomplete-form-from-string.' * swank.lisp (read-form-spec): New. Only READs elements of a form spec if necessary. And if it does have to READ, it keeps track of newly interned symbols which are returned as secondary return value. (parse-form-spec): Use it. Propagate newly interned symbols. (parse-first-valid-form-spec): Likewise. (arglist-for-echo-area, complete-form, completions-for-keyword): Adapted to unintern the newly interned symbols. 2007-08-26 Tobias C. Rittweiler * slime.el (current-slime-narrowing-configuration): Renamed to `slime-current-narrowing-configuration'. (set-slime-narrowing-configuration): Renamed to `slime-set-narrowing-configuration'. (current-slime-emacs-snapshot): Renamed to `slime-current-emacs-snapshot'. (current-slime-emacs-snapshot-fingerprint): Renamed to `slime-current-emacs-snapshot-fingerprint'. (set-slime-emacs-snapshot): Renamed to `slime-set-emacs-snapshot'. 2007-08-26 Tobias C. Rittweiler * slime.el (save-restriction-if-possible): Fixed another typo, duh! Thanks again to Matthias Koeppe. 2007-08-26 Tobias C. Rittweiler * slime.el (slime-cl-symbol-name): Handle vertical bars (|) (%slime-nesting-until-point): Renamed to `slime-nesting-until-point'. 2007-08-25 Matthias Koeppe Fix a bug where REPL results would sometimes be indented by a random amount. * slime.el (slime-insert-presentation): Make the rectangle-ification of multi-line presentations, introduced 2006-12-19, optional. (slime-write-string): Use it here only for regular output, but not for REPL results. (sldb-insert-locals): Use it here. (slime-inspector-insert-ispec): Use it here. 2007-08-25 Matthias Koeppe Fix handling of user-input type-ahead in the REPL. Reported by Madhu on 2007-04-24. * slime.el (slime-write-string): Make sure text properties are rear-nonsticky, so typed-ahead user input does not pick up the text properties. Fix up some markers. (slime-reset-repl-markers): Make the marker slime-output-end of insertion type nil (no automatic advances on insertions). (slime-with-output-end-mark): Update the location of slime-output-end here manually. (slime-repl-update-banner): Use insert-before-markers. 2007-08-25 Matthias Koeppe New command slime-redirect-trace-output creates a separate Emacs buffer, where all subsequent trace output is sent. * slime.el (slime-last-output-target-id): New variable. (slime-output-target-to-marker): New variable. (slime-output-target-marker): New function. (slime-write-string): Handle general "target" arguments using slime-output-target-marker. (slime-redirect-trace-output): New command. (slime-easy-menu): Add a menu item for it. * slime.el (slime-mark-presentation-start) (slime-mark-presentation-end): Make "target" argument optional. Use slime-output-target-to-marker. * swank.lisp (make-output-stream-for-target): New function, factored out from open-streams. (open-streams): Use it here. * swank.lisp (connection): New slot "trace-output". (call-with-redirected-io): Use it here. (redirect-trace-output): New slimefun; set the slot to a new target stream. 2007-08-25 Tobias C. Rittweiler * slime.el (save-restriction-if-possible): Fixed typo in macroexpansion. Thanks to Matthias Koeppe for reporting. 2007-08-24 Matthias Koeppe * slime.el (slime-insert-arglist): Removed, superseded by slime-complete-form since 2005-02-20. * swank.lisp (arglist-for-insertion): Now unused, removed. 2007-08-24 Matthias Koeppe Some fixes to the presentation-streams contrib. * slime.el (slime-dispatch-event): Handle new optionals args of messages :presentation-start and :presentation-end. * slime.el (slime-mark-presentation-start) (slime-mark-presentation-end): New arg "target"; record presentation boundaries separately for REPL results and regular process output. This fixes the presentation markup of REPL results when the presentation-streams contrib is loaded. 2007-08-24 Matthias Koeppe Make the fancy presentation-streams feature a contrib. Previously, it was only available if "present.lisp" was loaded manually. Now it can be loaded automatically using: (add-hook 'slime-load-hook (lambda () (require 'slime-presentation-streams))) Note that the normal presentations that are created by REPL results, the inspector, and the debugger are NOT dependent on this code. * present.lisp: Moved to contrib/swank-presentation-streams.lisp. * swank-loader.lisp (*contribs*): Add swank-presentation-streams. 2007-08-24 Helmut Eller Move typeout frame to contrib. * slime.el (slime-message-function, slime-background-message-function) (slime-autodoc-message-function): New variables. (slime-message, slime-background-message) (slime-autodoc-message): Call the function in the respective variable, so that the typeout window can be plugged in. 2007-08-24 Helmut Eller Move xref and class browser to contrib. * slime.el (slime-browse-classes, slime-browse-xrefs): Gone. The Common Lisp part is still there. 2007-08-24 Tobias C. Rittweiler * slime.el (slime-forward-blanks): Wrapped w/ `ignore-errors.' (slime-sexp-at-point): Return results as a list of strings, rather than just one big string if called with arg > 1. (slime-parse-extended-operator-name): Wrapping some movement code in `ignore-errors'. Adapted to new return value of `slime-enclosing-form-specs'. Minor cosmetic changes. (slime-make-extended-operator-parser/look-ahead): Adapted to changes of the ``raw form spec'' format; returns a form of strings, instead of a string of a form. (slime-parse-extended-operator/declare): Simplified. Adapted to changes of the ``raw form spec'' format; passes decl-identifiers, or typespec-operators respectively, along the decl/type-spec. (%slime-in-mid-of-typespec-p): Removed. Replaced by an regexp based approach. (%slime-nesting-until-point): New helper for `slime-parse-extended-operator/declare'. * swank.lisp (parse-form-spec): Adapted to new ``raw form spec'' format. Updated format description in docstring accordingly. The new format allows less interning of wrong symbols names comming from Slime. Thanks to Matthias Koeppe for spotting this. 2007-08-24 Helmut Eller Move slime-highlight-edits-mode to contrib. 2007-08-24 Helmut Eller Move slime-scratch to contrib. * slime.el (slime-scratch): Gone. 2007-08-24 Helmut Eller Various cleanups related to slime-insert-propertized. * slime.el (slime-with-rigid-indentation): Fix evaluation order. (slime-indent-rigidly): New. (slime-insert-possibly-as-rectange): Don't set mark. (slime-insert-propertized): Use plain insert instead of slime-insert-possibly-as-rectange. 2007-08-24 Helmut Eller * swank-sbcl.lisp (sbcl-inspector): Fix typo. 2007-08-23 Matthias Koeppe Repair inspection of presentations. * swank.lisp (inspect-presentation): New slimefun. * slime.el (slime-inspect-presentation-at-mouse): Use it here. 2007-08-23 Helmut Eller Move Marco Baringer's inspector to contrib. * swank.lisp (*default-inspector*): New variable. Set this variable dispatch to different inspectors. (inspect-object): Use it. * swank-loader.lisp (*contribs*): Add 'swank-fancy-inspector. * swank-backend.lisp (backend-inspector): New class. Introduce a named class to give as another way to dispatch to backend methods. * swank-cmucl.lisp: Use backend-inspector class. * swank-sbcl.lisp: Use backend-inspector class. * swank-clisp.lisp: Use backend-inspector class. * swank-lispworks.lisp: Use backend-inspector class. * swank-allegro.lisp: Use backend-inspector class. * swank-openmcl.lisp: Use backend-inspector class. * swank-abcl.lisp: Use backend-inspector class. * swank-corman.lisp: Use backend-inspector class. * swank-scl.lisp: Use backend-inspector class. 2007-08-23 Tobias C. Rittweiler Added arglist display for declaration specifiers and type specifiers. Examples: `(declare (type' will display (declare (type type-specifier &rest vars)) `(declare (type (float' will display [Typespec] (float &optional lower-limit upper-limit) `(declare (optimize' will display (declare (optimize &any (safety 1) (space 1) (speed 1) ...)) &ANY is a new lambda keyword that is introduced for arglist description purpose, and is very similiar to &KEY, but isn't based upon plists; they're more based upon *FEATURES* lists. (See the comment near the ARGLIST defstruct in `swank.lisp'.) * slime.el: (slime-to-feature-keyword): Renamed to `slime-keywordify'. (slime-eval-feature-conditional): Adapted to use `slime-keywordify'. (slime-ensure-list): New utility. (slime-sexp-at-point): Now takes an argument that specify how many sexps at point should be returned. (slime-enclosing-operator-names): Renamed to `slime-enclosing-form-specs'. (slime-enclosing-form-specs): Returns a list of ``raw form specs'' instead of what was called ``extended operator names'' before, see `swank::parse-form-spec' for more information. This is a simplified superset. Additionally as tertiary return value return a list of points to let the caller see where each form spec is located. Adapted callers accordingly. Extended docstring. (slime-parse-extended-operator-name): Adapted to changes in `slime-enclosing-form-specs'. Now gets more context, and is such more powerful. This was needed to allow parsing DECLARE forms. (slime-make-extended-operator-parser/look-ahead): Because the protocol for arglist display was simplified, it was possible to replace the plethora of parsing function just by this one. (slime-extended-operator-name-parser-alist): Use it. Also add parser for DECLARE forms. (slime-parse-extended-operator/declare): Responsible for parsing DECLARE forms. (%slime-in-mid-of-typespec-p): Helper function for `slime-parse-extended-operator/declare'. (slime-incomplete-form-at-point): New. Return the ``raw form spec'' near point. (slime-complete-form): Use `slime-incomplete-form-at-point'. * swank.lisp: New Helper functions. (length=, ensure-list, recursively-empty-p): New. (maybecall, exactly-one-p): New. * swank.lisp (arglist-for-echo-area): Adapted to take ``raw form specs'' from Slime. (parse-form-spec): New. Takes a ``raw form spec'' and returns a ``form spec'' for further processing in Swank. Docstring documents these two terms. (split-form-spec): New. Return relevant information from a form spec. (parse-first-valid-form-spec): Replaces `find-valid-operator-name'. (find-valid-operator-name): Removed. (operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'. (defstruct arglist): Add `any-p' and `any-args' slots to contain arguments belonging to the &ANY lambda keyword. (print-arglist): Adapted to also print &ANY args. (print-decoded-arglist-as-template): Likewise. (decode-arglist): Adapted to also decode &ANY args. (remove-actual-args): Adapted to also remove &ANY args. (remove-&key-args): Split out from `remove-actual-args'. (remove-&any-args): New. Removes already provided &ANY args. (arglist-from-form-spec): New. Added detailed docstring. (arglist-dispatch): Dispatching generic function for `arglist-from-form-spec' that does all the work. Renamed from prior `form-completion'. (arglist-dispatch) Added methods for dealing with declaration and type-specifiers. (complete-form): Adapted to take ``raw form specs'' from Slime. (completions-for-keyword): Likewise. (format-arglist-for-echo-area): Removed. Not needed anymore. * swank-backend.lisp (declaration-arglist): New generic function. Returns the arglist for a given declaration identifier. (Backends are supposed to specialize it if they can provide additional information.) (type-specifier-arglist): New generic function. Returns the arglist for a given type-specifier operator. (Backends are supposed to specialize it if they can provide additional information.) (*type-specifier-arglists*): New variable. Contains the arglists for the type specifiers in Common Lisp. * swank-sbcl.lisp: Now depends upon sb-cltl2. (declaration-arglist 'optimize): Specialize the `optimize' declaration identifier to pass it to sb-cltl2:declaration-information. 2007-08-23 Helmut Eller Some inspector cleanups. * slime.el (slime-inspect): Remove dwim stuff and drop keyword args. (slime-read-object): Killed. (slime-open-inspector): Drop keyword args. Update callers accodordingly, expect presentation related code. Presentations no longer work in the inspector. * swank.lisp (*inspector-dwim-lookup-hooks*) (default-dwim-inspector-lookup-hook): Deleted. (init-inspector): Sanitize arglist. (inspect-object): Don't return an :id for *inspectee-parts*. * swank-backend (type-for-emacs): Removed. No backend implemented it. 2007-08-23 Helmut Eller * slime.el (slime-fuzzy-upgrade-notice): New function. Bound to the key where slime-fuzzy-complete-symbol used to be. 2007-08-22 Tobias C. Rittweiler * slime.el (slime-close-all-parens-in-sexp): Fix interplay with `slime-close-parens-limit'. This should also affect `slime-complete-form' (C-c C-s) in a positive way. 2007-08-19 Helmut Eller * contrib: New directory. Move fuzzy completion code to that directory. * swank.lisp (swank-require): New function to load contrib code. (*find-module*, module-filename, *load-path*, merged-directory) (find-module, module-canditates): New. Pathname acrobatics for swank-require. * swank-loader.lisp: Compile (but don't load) contribs. (*contribs*, contrib-source-files): New. 2007-08-16 Tobias C. Rittweiler * slime.el (slime-process-available-input): Correct yesterday's change: the buffer a request was originally performed in doesn't necessarily exist at this time anymore, so we check for buffer liveness now. The problem arised when quitting in SLDB which would cause Swank to send a `:debug-return' message before the acknowledgement message for `sldb-quit' is sent. So the acknowledgement is received in a context where the sldb-buffer is closed already. 2007-08-15 Tobias C. Rittweiler * slime.el (slime-process-available-input): Make sure that the event received from SWANK is processed in the context of the original buffer the request of the response was performed in. Previously, the clauses of `slime-rex' were processed in the internal *cl-connection* buffer. And as a result the continuations passed to `slime-eval' and `slime-eval-async' ditto. 2007-08-15 Tobias C. Rittweiler Make `M-.' work on definitions outside the current restriction. `M-,' will also properly restore the narrowing as of before the jump. Similiarly for quiting from the compilation notes buffer and the Xref buffers. * slime.el (slime-narrowing-configuration, slime-emacs-snapshot), (current-slime-narrowing-configuration), (set-slime-narrowing-configuration), (current-slime-emacs-snapshot), (set-slime-emacs-snapshot), (current-slime-emacs-snapshot-fingerprint): New. Emacs' window configurations do not restore narrowing, so introduce a snapshot facility that contains the necessary information. * slime.el: Various renaming and adaptions in the Slime temp buffer, xref, goto-definition and compilation notes section to use the newly introduced snapshots instead of mere window configurations. * slime.el: (slime-highlight-notes, slime-remove-old-overlays): Still operate on whole buffer, but restore previous restriction if there was any. (slime-goto-location-position): Now widens the buffer to properly jump to definitions outside of the current restriction. * slime.el (slime-push-definition-stack), (slime-pop-find-definition-stack): Now also stores information about narrowing on the definition stack, in order to properly restore narrowing on `M-,'. * slime.el (def-slime-test narrowing): Test case for properly dealing with narrowing. * slime.el (slime-buffer-narrowed-p): New function, tests whether the current buffer is narrowed or not. (save-restriction-if-possibly): Like `save-restriction', but not as strict---see doc string. * slime.el (slime-length=): New function; semantically the same as (= (length seq) n), but more efficiently implemented for lists. Changed the above pattern into a call to SLIME-LENGTH= where appropriate. 2007-08-05 Matthias Koeppe * swank.lisp (backtrace): Handle printer errors while printing a frame. This makes debugging print-object methods with SLIME easier. Reported by Utz-Uwe Haus. 2007-08-02 Tobias C. Rittweiler * slime.el (slime-kill-all-buffers): Now also kills all buffers beginning with a `*SLIME' prefix (like, for instance, `*SLIME Apropos*', or `*SLIME macroexpansion*'.) 2007-06-28 Helmut Eller * slime.el (def-slime-selector-method): Revert Marco's change from 2007-05-23. BODY can return a buffer name, like "*slime-events*". Handle that and never ignore invalid return values. Force BODY to abort if there's no suitable buffer. Why would you want to switch buffers if the desired buffer doesn't exist? 2007-06-27 Tobias C. Rittweiler Fixing `C-c M-q' at the REPL. Thanks to André Thieme for pointing out that it has been broken since several months. * slime.el (slime-reindent-defun): Use functions `slime-beginning-of-defun' and `slime-end-of-defun' that were introduced in the last changeset. 2007-06-16 Tobias C. Rittweiler * slime.el: Pressing `C-M-a' (beginning-of-defun) in midst of the last REPL prompt directs the cursor to the beginning of the prompt. Pressing it again, would do nothing; now it moves the cursor to the start of the previous prompt (as it's consistent with the behaviour when the cursor was placed midst one of the old prompts.) Likewise for `C-M-e' (end-of-defun) Additionally fixing `C-c C-s' (slime-complete-form) at the REPL. (slime-keys): New bindings for `C-M-a' and `C-M-e' to SLIME-BEGINNING-OF-DEFUN and SLIME-END-OF-DEFUN respectively. (slime-keys): Making `C-c C-q' (slime-close-parens-at-point) obsolete, as it didn't work correctly on the REPL. (slime-repl-mode-map): Removed bindings for `C-M-a' and `C-M-e', as they're now inherited from SLIME-KEYS. (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Jump to the previous (next) prompt if called twice in a row. (slime-close-parens-at-point): Commented out. (slime-close-all-sexp): Renamed to SLIME-CLOSE-ALL-PARENS-IN-SEXP. (slime-close-all-parens-in-sexp): Modified to take SLIME-CLOSE-PARENS-LIMIT into account. (slime-complete-form): Use SLIME-CLOSE-ALL-PARENS-IN-SEXP. 2007-05-24 Tobias C. Rittweiler * swank.lisp: Fixed regression in completion: "swank[TAB]" would previously be completed to "swank-backend:"; "get-internal[TAB]" would be completed to "get-internal-r-time" (instead of simply "get-internal-r"); and "custom:*comp[TAB]" would be completed to "custom:*compiled-" on CLISP, even though there's a "custom:*complile-". Thanks to Ken Causey for helping me find the first two. (completions): Revert changes from 2007-05-11. (longest-compound-prefix): Fixed to properly generate a compound _prefix_. 2007-05-23 Marco Baringer * slime.el (def-slime-selector-method): Allow the selector body to not return a buffer. This means that, instead of being to forced to signal an error when a choosen buffer can't be found (like choosing d when there are no debugger buffers) can simply display a message. Fix handling of auto-flushing on sbcl: * swank-sbcl.lisp (*auto-flush-interval*): New variable controlling how often streams are flushed. (*auto-flush-lock*): New lock guarding access to the shared variable *auto-flush-streams*. (make-stream-interactive): Wrapped access to *auto-flush-streams* in a call-with-recursive-lock-held. (flush-streams): Wrapped in call-with-recursive-lock-held. 2007-05-17 Martin Simmons * swank-lispworks.lisp (lispworks-inspect): Fix hanging caused by mapcan, i.e. nconc, on a constant list returned by label-value-line. 2007-05-17 Tobias C. Rittweiler * slime.el (slime-complete-form): Only insert a closing parenthesis if the form is not already closed. Reported by and adapted from Mac Chan. 2007-05-17 Tobias C. Rittweiler * swank.lisp: Fixed bug in completion as previously "swank:[tab]" would correctly list all the symbols in SWANK, but would simultaneously append a spooky dash to the original string ("swank:-"). (completions): Strip off the package identifier part, and only compute the longest compound prefix for the actual symbol identifiers. (untokenize-symbol): New function. Inverse of TOKENIZE-SYMBOL. (format-completion-result): Use UNTOKENIZE-SYMBOL. 2007-05-17 Dustin Long * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented `slime-compile-defun' from actually compiling a function. 2007-05-17 Tobias C. Rittweiler * swank-loader.lisp (*sysdep-files*): Load the auxiliary files swank-source-*.lisp before swank-sbcl.lisp to avoid undefined-function style warnings. 2007-05-16 Takehiko Abe * swank.lisp (inspect-for-emacs file-stream, stream-error): Fixed typo in keyword arg; it's `:refreshp', not `:refresh'. 2007-05-14 Tobias C. Rittweiler * slime.el: Fixed proper handling of the abortion of a request. (For instance, when calling (SWANK::ABORT-REQUEST "FOO") from the REPL.) (sldb-quit): Updated the DESTRUCTURE-CASE clause for (:abort) to take an argument. (sldb-continue): Likewise. (sldb-invoke-restart): Likewise. (sldb-break-with-default-debugger): Likewise. (sldb-return-from-frame): Likewise. (sldb-restart-frame): Likewise. (slime-repl-eval-string) Likewise. (slime-repl-show-abort): Now also inserts the reason for the abort into the REPL buffer. * swank.lisp (eval-for-emacs): Remove code that would suggest that it's possible to use the rex `(:abort ...)' with more than one argument. 2007-05-14 Tobias C. Rittweiler * swank.lisp: Liberated from unnecessary style-warnings! (eval-for-emacs): Don't use SLOT-VALUE on condition objects! (inspect-bigger-piece-actions): Changed from DEFMETHOD to DEFUN. (inspect-whole-thing-action): Likewise. (inspect-show-more-action): Likewise. (make-symbols-listing): Adds an explicit DEFGENERIC. (menu-choices-for-presentation): Likewise. (make-symbols-listing (eql :classification)): Use `(loop for k being EACH hash-key ...)' rather than `(loop for k being THE hash-key)', to omit the justified style-warning from CLISP. 2007-05-14 Tobias C. Rittweiler * swank.lisp (package-names): Make sure to return a fresh list. (fuzzy-find-matching-packages): Use PACKAGE-NAMES. (list-all-package-names): Use PACKAGE-NAMES. 2007-05-13 Tobias C. Rittweiler * slime.el (slime-pretty-lambdas): Removed. If you really want this, please use one of the external ressources that provide this; for instance, `pretty-lambda.el', `pretty-greek.el', or even `pretty-symbols.el'. For more information, please see http://www.emacswiki.org/cgi-bin/wiki/PrettyLambda 2007-05-11 Tobias C. Rittweiler * swank.lisp (fuzzy-find-matching-symbols): Modified to take package nicknames into account. Previously, fuzzy completing on nicknames did (except for some incidental cases) not work. Thanks to Luís Oliveira and Attila Lendvai for pointing that out. 2007-05-11 Tobias C. Rittweiler Removed support for completing to the longest compound pre- and suffix with the default completion method (C-c TAB, or just TAB on the REPL), because it has been causing trouble all the time, but didn't offer any real advantage besides niftiness. E.g.: previous behaviour: asdf:*com TAB => asdf:*compile-file--behaviour* now simply: asdf:*com TAB => asdf:*compile-file- For discussing on this subject, please see the mail with message-id <87y7l53lch.fsf@freebits.de> that was posted to slime-devel 2007-04-06, or alternatively: http://common-lisp.net/pipermail/slime-devel/2007-April/006087.html * swank.lisp (make-compound-prefix-matcher): New function. Abstracted from COMPOUND-PREFIX-MATCH. (compound-prefix-match): Use MAKE-COMPOUND-PREFIX-MATCHER. (compound-prefix-match/ci/underscores): Removed. (longest-completion): Renamed to LONGEST-COMPOUND-PREFIX. Changed to only return a compound prefix, instead of a concatenation of a compound prefix and a compound suffix. Added an &optional parameter to specify what delimeter the passed string is compounded with. (tokenize-completion): Takes additional parameter to specify the delimeter for tokenization. (longest-completion/underscores): Removed; not needed anymore. (tokenize-completion/underscores): Likewise. (untokenize-completion/underscores): Likewise. (completions): Slight docstring modification, also added an examplary use case; use LONGEST-COMPOUND-PREFIX instead of LONGEST-COMPLETION. (completions-for-character): Use LONGEST-COMPOUND-PREFIX, and MAKE-COMPOUND-PREFIX-MATCHER. (completions-for-keyword): Use LONGEST-COMPOUND-PREFIX. 2007-05-11 Tobias C. Rittweiler * swank.lisp (apropos-symbols): Really use MAKE-REGEXP-MATCHER. 2007-05-10 Tobias C. Rittweiler * swank.lisp: Previously when using SLIME-APROPOS-PACKAGE, only those symbols were considered whose home package matched the given package; this would, however, prevent all those symbols from being listed that are imported from another package, and then exported again in the package they got imported into. (As an example, SWANK:RESTART-FRAME is actually from SWANK-BACKEND.) (apropos-matcher): Renamed to MAKE-REGEXP-MATCHER. (make-regexp-matcher): Changed to only match for a given regexp. (apropos-symbols): Use MAKE-REGEXP-MATCHER. 2007-05-10 Tobias C. Rittweiler * slime.el: Fix macroexpanding on things like ",(loop ...)". (slime-sexp-at-point-for-macroexpansion): New function; like SLIME-SEXP-AT-POINT-OR-ERROR, but fixes up some misbehaviour with respect to macroexpansion. (slime-eval-macroexpand, slime-eval-macroexpand-inplace): Use the new function. 2007-05-10 Tobias C. Rittweiler * slime.el: Within the Slime Inspector, `S-Tab' will now also work on X. Furthermore `Tab' and `S-Tab' will now correctly wrap around the beginning and end of the buffer; priorly it'd hang on the beginning with a message "Beginning of buffer", and would require an additional `S-Tab'. (slime-inspector-mode-map): Attached `[backtab]' to SLIME-INSPECTOR-PREVIOUS-INSPECTABLE-OBJECT, as Emacs translates `S-Tab' to `Backtab' on X. (slime-find-inspectable-object): New function; finds next or previous inspectable object. (slime-inspector-next-inspectable-object): Mostly rewritten. Use SLIME-FIND-INSPECTABLE-OBJECT to make the code clearer. 2007-04-19 Tobias C. Rittweiler * swank-backend.lisp (label-value-line): Add :newline as &key argument; if true (the default) inserts a newline. * swank.lisp (inspect-for-emacs-list): Don't add a newline after the last value of the list. 2007-04-18 Marco Baringer * swank.lisp (log-event): Setup the printer so that, no matter what the global values of the *print-XYZ* variables, this function works as expected. (*debug-on-swank-error*): New variable. (defpackage :swank): Export *debug-on-swank-error*. (with-reader-error-handler): When *debug-on-swank-error* is non-nil drop into a debugger. (dispatch-loop): Idem. 2007-04-17 Tobias C. Rittweiler * swank.lisp: Instead of just having all the symbols of a package listed alphabetically in the inspector page recently introduced for that purpose, add a button to that page to group them by their classification. (%package-symbols-container): New slot GROUPING-KIND. (%make-package-symbols-container): New function; wraps around %%MAKE-PACKAGE-SYMBOLS-CONTAINER, which will actually create the structure. We need this, to make GROUPING-KIND an entirely internal affair. (make-symbols-listing): New generic function to dispatch on GROUPING-KIND. (make-symbols-listing :symbol): Just the stuff that was priorly wired into INSPECT-FOR-EMACS (%PACKAGE-SYMBOLS-CONTAINER). (make-symbols-listing :classification): New; returns the passed symbols grouped by their classification. (inspect-for-emacs %package-symbols-container): Most code split off into MAKE-SYMBOLS-LISTING. 2007-04-17 Tobias C. Rittweiler * swank.lisp (swank-compiler): Fix the return value to always be a list of two elements even if the abort restart is invoked which originally just returned NIL. (Which wouldn't play with the recent change to use DESTRUCTURING-BIND in SLIME-COMPILATION-FINISHED.) 2007-04-17 Tobias C. Rittweiler * swank.lisp (inspect-for-emacs %package-symbols-container): Revert Marco's change from 2007-04-08; he had the good idea of adding a facility to jump to the relevant source line of a symbol, but `M-.' is already bound to SLIME-FIND-DEFINITION in the inspector, which is a nicer way of doing this alltogether. 2007-04-16 Takehiko Abe * swank-openmcl.lisp (accept-connection, find-external-format): utf-8 support. 2007-04-16 Marco Baringer * slime.el (slime-with-xref-buffer): Added missing , 2007-04-16 Tobias C. Rittweiler * slime.el: Pressing `q' in *compiler notes* after a `C-c C-k' or `C-c M-k' would not probably restore the original window configuration. Fix that. (slime-get-temp-buffer-create): New &key arg WINDOW-CONFIGURATION. (slime-with-xref-buffer): Likewise. (slime-compilation-finished): New &optional arg WINDOW-CONFIG. (slime-maybe-show-xrefs-for-notes): Likewise. (slime-show-xrefs) Likewise. (slime-maybe-list-compiler-notes): Likewise. (slime-list-compiler-notes): Likewise. (slime-compilation-finished-continuation): Renamed to SLIME-MAKE-COMPILATION-FINISHED-CONTINUATION. (slime-make-compilation-finished-continuation): Now takes two args, the current buffer and optionally the current window config to be restored. (slime-compile-file): Save current window configuration before popping up the REPL for compilation output, pass it down. (slime-easy-menu): Add entry for SLIME-UNTRACE-ALL. 2007-04-16 Tobias C. Rittweiler * swank.lisp (fuzzy-find-matching-packages): Fix a small typo that prevented interpreting NIL as the argument TIME-LIMIT-IN-MEC to mean an infinite time limit. This bug propagated up to explicit calls to FUZZY-COMPLETIONS, like (swank:fuzzy-completions "mvb" "COMMON-LISP") => (NIL, T) (format-fuzzy-completions): Renamed to FORMAT-FUZZY-COMPLETION-SET (format-fuzzy-completion-set): Accomodated to recent changes of the return value of FUZZY-COMPLETIONS; changed the docstring to make it explicit that this function is supposed to take the return value of FUZZY-COMPLETION-SET. * slime.el (slime-compilation-finished): Don't use MULTIPLE-VALUE-BIND for list destructuring, only because multiple values happen to be implemented via lists in elisp! (slime-fuzzy-completions-mode): Added an detailed explanation to the docstring of how Fuzzy Completion works and how it'ss supposed to be worked with. (slime-fuzzy-explanation): Shortened to reference to SLIME-FUZZY-COMPLETIONS-MODE for help on fuzzy completion. (slime-fuzzy-choices-buffer): Set BUFFER-QUIT-FUNCTION to SLIME-FUZZY-ABORT to make it correctly exit fuzzy completion when pressing `Esc Esc Esc' (`M-Esc Esc'). 2007-04-12 Nikodemus Siivola * swank-sbcl.lisp (emacs-buffer-source-location): Add &allow-other-keys to the descructuring of the source location plist in order to accept :emacs-directory. 2007-04-09 Marco Baringer * swank.lisp (inspector-content-for-emacs): Look for refresh keyword argument in :action links. (inspect-whole-thing-action, inspect-show-more-action): Update for new :action argument handling. (inspect-for-emacs stream, inspect-for-emacs stream-error): Pass :refresh nil on :action links. (action-part-for-emacs): Set both lambda and refresh in the *inspectee-actions* array. (inspector-call-nth-action): *inspectee-actions* now holds both the function and the boolean specifying whether to refresh or not. * swank-backend.lisp (inspect-for-emacs): Docstring update. * slime.el (slime-inspector-operate-on-point): Allow the action calls to return nil. 2007-04-08 Marco Baringer * .cvsignore: Added *.lx64fsl (openmcl on linux fasls). 2007-04-08 Marco Baringer * swank.lisp (inspect-for-emacs): Added 'jump to source' action for symbols in the new package-symbol browser. 2007-04-08 Tobias C. Rittweiler * swank.lisp: Implemented a new special inspector page for displaying internal (external, &c) symbols that display classification flags additionally to each symbol, similiar to the content of a *Fuzzy Completion* buffer. Furthermore, added the possibility to display all symbols that are /present/ in a package. Combined with cleanup of the code parts in question. (symbol-status): New function. Returns the status of a symbol in a given package (:internal, :external &c.) (symbol-external-p): Adapted to use new function SYMBOL-STATUS. (symbol-classification->string): New function. Converts a list of classification flags into a concise string representation. (%package-symbols-container): New struct. We need a unique type to dispatch in INSPECT-FOR-EMACS for the new inspector page, use this as a wrapper structure. (inspect-for-emacs package): Reorganized to not cause too much eye cancer; now with a saner maximum column width. Changed to make use of new SYMBOL-STATUS, for code reuse. Also changed to make use of new %PACKAGE-SYMBOLS-CONTAINER to let a new page pop up in Emacs if the user wants to access the list of symbols of the package. Added such a possibility to access all `present' symbols. (inspect-for-emacs %package-symbols-container): New method. Displays all symbols wrapped up in the container structure combined with their classification flags as determined by CLASSIFY-SYMBOL. 2007-04-08 Luís Oliveira * swank-backend.lisp (compute-sane-restarts): New interface. * swank-clisp.lisp: Fix tabs and trailing whitespace. (compute-sane-restarts): Implement new interface. 2007-04-08 Takehiko Abe * swank-openmcl.lisp (xref-locations): 2007-04-08 Marco Baringer * swank.lisp (fuzzy-completion-set): Use two check-type forms instead of a place like (values limit time-limit-in-msec). While sbcl seems to accept this form openmcl doesn't and it's not clear from the spec that this is allowed. 2007-04-07 Harald Hanche-Olsen * slime.el (sldb-mode-map): Added key definition for follow-link. 2007-04-06 Tobias C. Rittweiler * swank.lisp: Making fuzzy completion regard the time limit correctly. Also make it properly use microseconds as time granularity and inform the Emacs side if the time limit has exhausted. Additionally, over all minor and cosmetic changes: (fuzzy-completions, fuzzy-completion-set): Returns now additionally a flag indicating whether the time limit has exhausted under the hood. Accomodated docstring accordingly. (fuzzy-create-completion-set): Changed to correctly catch and propagate the remaining time limit to the actual match functions, and return once time limit has exhausted. Some aesthetical code reorganization. (get-real-time-in-msecs): New function. (fuzzy-find-matching-symbols, fuzzy-find-matching-packages): Correctly regard the time limit. Use new function GET-REAL-TIME-IN-MSECS for that purpose. Return the remaining time limit as second value. * slime.el (slime-fuzzy-complete-symbol): Accomodated to deal with the additionally returned flag of SWANK:FUZZY-COMPLETIONS. Pass the flag by. (slime-fuzzy-choices-buffer): Pass interruption flag by. (slime-fuzzy-fill-completions-buffer): If time limit has exhausted during completion retrieval, show an informational indication as last entry in *Fuzzy Completion*. (slime-fuzzy-last): New variable. To hold the last real completion choice previous to the (possible) Time Limit Exhausted information. (slime-fuzzy-next): Accomodated to not go beneath SLIME-FUZZY-LAST. 2007-04-06 Tobias C. Rittweiler * swank.lisp (tokenize-symbol, tokenize-symbol-thoroughly): Previously these functions said a string representing a symbol is internal exactly if it contained "::" as substring. Now they say additionally so for symbols without any package identifier, as they are internal to am implicit current package. (Otherwise will break fuzzy completion.) (tokenize-symbol): Added docstring. * swank.lisp (format-completion-result): Fixed formation for the case that PACKAGE-NAME is NIL but INTERNAL-P is T. 2007-04-06 Tobias C. Rittweiler * swank.lisp: Making fuzzy completion semantically right from a user perspective. As an example on SBCL, "sb:with- C-c M-i" will display all exported "with"-style macros in all sb-* packages from now on. :) (parse-completion-arguments): Replacing with a semantically-sound implementation, as the previous one was a bit confused. Clarifying docstring. Adding commentary table of various constellations of returned values for thorough explanation. (carefully-find-package): Removed. Obsolete by above change. (defstruct fuzzy-matching): Introduced to make internally-used datastructure explicit. Distinguishing ``completion chunks'' between those pertaining to the symbol itself and those to the package identifier. (convert-fuzzy-completion-result): Renamed to FUZZY-CONVERT-MATCHING-FOR-EMACS. (fuzzy-convert-matching-for-emacs): Accomodating for the new datastructure. Only the chunks pertaining to the symbol itself are fixed up positionally, the package-chunks are untouched. Necessary for letting package identifiers be highlighted within *Fuzzy Completions* in cases like "sb:with- C-c M-i." (fuzzy-completion-set): Taking out most code to become new function FUZZY-CREATE-COMPLETION-SET. (fuzzy-create-completion-set): Doing all the hard work. Crux of this changeset. so to speak. Largly rewritten to accomodate all different cases of PARSE-COMPLETION-ARGUMENT. (fuzzy-find-matching-symbols, fuzzy-find-matching-packages): Accomodating to new datatstructure FUZZY-MATCHING. Adapting docstring accordingly. * swank-backend.lisp: Export WITH-STRUCT. * swank.lisp (eval-for-emacs, fuzzy-completions): Various trivia like fixing spelling and indentation. 2007-04-06 Tobias C. Rittweiler * slime.el (slime-fuzzy-highlight-current-completion): Fix off-by-one error that causes the currently selected completion in the *Fuzzy Completion* buffer be highlighted one char too far. 2007-04-06 Tobias C. Rittweiler * swank.lisp: Cleanup of parts of the fuzzy completion code. Additionally a couple of enhancements. As follows: (fuzzy-completions, fuzzy-completion-selected): Minor stylistic and clarifying modifications of the docstrings. (fuzzy-find-matching-symbols): Huge code reorganization. Organizing relevant code into local function TIME-EXHAUSTED-P, renaming local function SYMBOL-MATCH to PERFORM-FUZZY-MATCH, making previously required argument EXTERNAL to new &key argument :EXTERNAL-ONLY, clarifying docstring. (fuzzy-find-matching-packages): Making its return value conformant to that of FUZZY-FIND-MATCHING-SYMBOLS, i.e. instead of returning, among others, a package's name as string, it now returns a symbol representing the package. Accomodates the docstring accordingly. (fuzzy-completion-set): Minor typographical fix in docstring. Changing local function CONVERT to use MAP-INTO instead of doing it essentially manually. Accomodating to changes of FUZZY-FIND-MATCHING-SYMBOLS, resp. -PACKAGES. (fuzzy-completion-set): Additional new feature: The returned completions are sorted alphabetically by the matched completion string before sorted by its score. Affects especially the list of all possible completions when the user hits fuzzy-completion on an empty string within Emacs; also makes the potential limitness of the listed completions clearer to the end user of SLIME. (classify-symbol): New function. Returns a list with keywords that classifies a given symbol. (E.g. :BOUNDP, :MACRO &c) Supersedes parts of CONVERT-FUZZY-COMPLETION-RESULT, implementing them in a more straightforward and proper way; removes prior KLUDGE in that part of the original function. (convert-fuzzy-completion-result): The above changes made it possible to simplify this function drastically. Now uses the newly introduced function CLASSIFY-SYMBOL. * slime.el: Minor stylistic changes. Additionally: (slime-fuzzy-insert-completion-choice): (slime-fuzzy-fill-completions-buffer) : Adding use of the :PACKAGE classification flag returned by SWANK:FUZZY-COMPLETIONS. This flag is called "p". 2007-04-06 Neil Van Dyke * slime.el (sldb-insert-frame): Added mouse-face to frame label and expression in Backtrace. (sldb-insert-frames): Added mouse-face to "--more--" label in Backtrace. 2007-04-06 Michael Weber * slime.el (slime-call-defun): insert the closing parenthesis for the form. 2007-04-06 Marco Baringer * swank-openmcl.lisp (package swank-mop): Added slot-makunbound-using-class. 2007-03-29 Nikodemus Siivola * swank-sbcl.lisp (swank-compile-string): save the original directory into the source plist as :emacs-directory. (make-definition-source-location): use the :emacs-directory from the source plist and guess-readtable-for-filename to determine the correct readtable for string-compiled definitions. 2007-03-29 Nikodemus Siivola * swank.lisp (*macroexpand-printer-bindings*): add *print-lines* to defaults (NIL). (find-definitions-for-emacs): use unless instead of cond. 2007-03-25 Douglas Crosher * slime.el (with-selected-window): define for compatibility with Emacs 21. 2007-03-24 Matthias Koeppe * swank.lisp (menu-choices-for-presentation): Offer a "disassemble" menu item for functions. 2007-03-24 Helmut Eller * slime.el (slime-read-port-and-connect): Fix race condition: retry one more time if the port file is empty. Pop up the debugger on other errors. (slime-attempt-connection): Moved to toplevel. (slime-timer-call): New. Used by slime-attempt-connection. (slime-cancel-connect-retry-timer): New. (slime-abort-connection): Use it. (slime-repl-insert-prompt): Use insert-before-markers. This fixes some redisplay problems, but I don't know why. Also: remove the timer for async output. (slime-repl-move-output-mark-before-prompt): Removed. (slime-repl-save-merged-history): Use with-temp-message. (slime-goto-location-buffer): Support Zip files. (sldb-quit): Don't print "Evaluation aborted". 2007-03-22 Matthias Koeppe * slime.el (slime-scratch-buffer): Respect the syntax text properties of presentations. 2007-03-21 Matthias Koeppe * swank.lisp (lookup-presented-object): The presentation id of frame locals now includes the thread id; ignore it for now. * slime.el (slime-copy-presentation-at-mouse-to-point): Manually invoke the after-change function, so that the presentation overlay is created even if we paste to non-REPL buffers. (slime-menu-choices-for-presentation): Evaluate menu-choices-for-presentation-id in the right buffer, thus in the right Lisp thread. Reported by Attila Lendvai. (slime-menu-choices-for-presentation): Show the id of the presentation. (sldb-insert-locals): Include the thread id in the presentation id. 2007-03-21 Helmut Eller * slime.el (slime-repl-eval-string, slime-repl-insert-result): Support the presentation-less old protocol. (slime-goto-location-position): Use column number if available. 2007-03-20 Matthias Koeppe * swank.lisp (completion-output-symbol-converter): Fix completion for mixed-case symbols that need escaping in readtable-case :upcase or :downcase. * slime.el (slime-copy-presentation-at-mouse-to-point) (slime-copy-presentation-at-mouse-to-kill-ring): New commands. (slime-menu-choices-for-presentation): Change interface. New menu options, Copy to kill-ring, Copy to point. (slime-presentation-menu): Change call to slime-menu-choices-for-presentation. 2007-03-20 Takehiko Abe * swank-openmcl.lisp (hash-table-weakness): fix typo 2007-03-14 Christophe Rhodes * slime.el (slime-search-suppressed-forms): handle multiple conditionals on the same line. 2007-02-26 Nikodemus Siivola * swank.lisp (inspect-for-emacs): Add support for inspecting non-decodable float entities like NaNs and infinities. 2007-02-25 Tobias C. Rittweiler * swank-backend.lisp (inspect-for-emacs): Remove reference to inexistent argument from docstring. 2007-02-25 Harald Hanche-Olsen * slime.el (slime-init-keymaps): Use vectors when defining keys, because e.g. (define-key (string ?\C-c) ...) doesn't work in the emacs-unicode-2 branch. Some strings are still there. 2007-02-25 Helmut Eller * slime.el (slime-delete-swank-port-file): Don't use display-warning; that's not available everywhere. (slime-repl-update-banner): Insert the date only if the buffer is empty. (slime-list-compiler-notes): Fetch the notes only if called interactively. (slime-set-query-on-exit-flag): New function, to avoid compiler warnings about obsolete function process-kill-without-query. (slime-defun-if-undefined): Perform the test at runtime not at compile time. Reported by Lennart Staflin. * swank.lisp (guess-package): Renamed from guess-package-from-string. (set-package): Use it. 2007-02-22 Juho Snellman * slime.el (slime-start-lisp): Don't cd if no directory was specified. (slime-maybe-start-lisp): Pass directory argument to slime-start-lisp also in other cond branch. (slime-restart-sentinel): Pass a NIL directory to slime-start-lisp. 2007-02-21 Marco Baringer * slime.el (slime-start): Added :directory argument and pass it to slime-maybe-start-lisp. (slime-maybe-start-lisp): Added directory argument and pass it to slime-start-lisp (but not slime-reinitialize-inferior-lisp-p) (slime-start-lisp): Added directory argument. Used to set buffer's directory before starting the inferior lisp. 2007-02-17 Matthias Koeppe * slime.el (slime-find-tag-if-tags-table-visited): New function. (slime-edit-definition-fallback-function): Offer it as a value for customization. 2007-02-05 Matthias Koeppe * slime.el (sldb-insert-locals): Repair presentation markup of frame locals. 2007-02-04 António Menezes Leitão * swank-lispworks.lisp (dspec-file-position): Bind *compile-file-pathname*, *compile-file-truename*, *load-pathname* and *load-truename* in dspec-file-position. 2007-02-04 Matthias Koeppe * slime.el (slime-write-string): When writing a :repl-result, update the slime-output-end marker for the purpose of asynchronous output (when *use-dedicated-output-stream* is true). Reported by Madhu . 2007-02-03 Marco Baringer * slime.el (slime-delete-swank-port-file): Fix typo in warning message. 2007-02-02 Marco Baringer Warn, as opposed to bailing out with an error, when deleting the port file fails. Patch by: Samium Gromoff <_deepfire@feelingofgreen.ru> * slime.el (slime-delete-swank-port-file): New function. (slime-inferior-connect): Use slime-delete-swank-port-file. (slime-read-port-and-connect): Use slime-delete-swank-port-file. 2007-01-31 Marco Baringer * slime.el (slime-repl-update-banner): Restore animation. (slime-startup-animation): restore. 2007-01-30 Helmut Eller * slime.el (slime-complete-symbol-function): Restore old default. (set-keymap-parents): Deleted. (slime-startup-animation): Deleted. (slime-read-from-minibuffer): Don't use defun*. (slime-repl-terminate-history-search): New. (slime-repl-next-matching-input): Use it. * slime-autoloads.el: New file. 2007-01-29 Sean O'Rourke * slime.el (slime-start): Continue even if the user, after prompting, didn't recompile the stale .elc file. (slime-urge-bytecode-recompile) [xemacs]: Abort immediately if the user doesn't want to continue. (slime-recompile-bytecode): Don't use byte-compile-warning-types; it may not exist in XEmacs. 2007-01-24 Helmut Eller * slime.el (sldb-recenter-region): Use count-screen-lines instead of count-lines. * swank.lisp (unparse-name): New function. (list-all-package-names): Use it. This fixes a bug related to readtable-case and makes package name completions look prettier. Suggested by Harald Hanche-Olsen . 2007-01-24 Bill Clementson * slime.el (slime-call-defun): Put the docstring before the (interactive) form so that "C-h f slime-call-defun" will return it. * slime.el (slime-scratch-mode-map): Changed parent keymap to lisp-mode-map to prevent unnecessary duplication of slime-mode-map bindings and so that lisp-mode-map key bindings are present in the slime scratch buffer. Change identified by Ariel Badichi. 2007-01-20 Luke Gorrie * slime.el (slime): Use COMMAND and CODING-SYSTEM parameters Previously they were ignored. 2007-01-17 Christian Lynbech * slime.el (slime-init-command): Use expanded files when writing the LOAD form for swank. 2007-01-14 Helmut Eller * slime.el: Cleanups for the repl history code. (slime-repl-mode-map): Don't shadow M-C-d. (slime-repl-history-replace): Simplified. (slime-repl-history-search-in-progress-p): New. (slime-repl-position-in-history): If there's no match return out-of-bound positions instead of nil. (slime-repl-add-to-input-history): Never modify the argument. (slime-repl-previous-input): Renamed from slime-repl-previous-input-starting-with-current-input. (slime-repl-next-input): Renamed from slime-repl-next-input-starting-with-current-input (slime-repl-forward-input): Renamed from slime-repl-next-input. (slime-repl-backward-input): Renamed from slime-repl-previous-input. (slime-repl-history-pattern): Renamed from slime-repl-matching-input-regexp. (slime-repl-delete-from-input-history): Simplified. (slime-repl-history-map) (slime-repl-history-navigation-neutral-commands) (slime-repl-jump-to-history-item) (slime-repl-previous-or-next-input) (slime-repl-starting-with-current-input-regexp) (slime-repl-continue-search-with-last-pattern) (slime-repl-previous-or-next-matching-input): Deleted. (sldb-list-locals, sldb-list-catch-tags): Deleted. Aren't of much use anymore. 2007-01-12 Helmut Eller * swank-clisp.lisp: Better classification on frames on the stack. Make variables in eval frames accessible to the debugger. (frame-type, *frame-prefixes*, frame-to-string, is-prefix-p) (frame-string-type, boring-frame-p): New. (%frame-count-vars, %frame-var-name, %frame-var-value) (frame-venv, next-venv, venv-ref, %parse-stack-values): Replaces old frame-do-venv. (extract-frame-line, extract-function-name, split-frame-string) (string-match): New code to print frames. (frame-locals, frame-var-value): Use the new stuff. (inspect-for-emacs): Fix various bugs. * swank-loader.lisp (compile-files-if-needed-serially): Don't wrap everything in a compilation unit. If we abort on load errors and it is confusing to see compiler warnings after the abort message. (handle-loadtime-error): CLISP's format implements ~< differently as everybody else, so use a explicit pprint-logical-block instead. * swank.lisp (list-all-systems-in-central-registry): Don't reference asdf directly, that leads to read errors in some systems. 2007-01-12 Juho Snellman * slime.el (slime-read-expression-map): Switch the slime-mode-map and minibuffer-local-map back the way they were. The previous change was made due to a misunderstanding, caused by a keybinding for [(return)] apparently being more specific than one for (kbd "RET"), even when the former is in a parent keymap and the latter in the child. 2007-01-12 Helmut Eller * swank.lisp (handle-request): Use 'abort as restart name, but bind *sldb-quit-restart* to the restart returned by find-restart. Also use a slighly friendlier message, because newbies seem to invoke the ABORT restart instead of pressing q in the debugger. 2007-01-12 Edi Weitz * slime.el (slime-find-asd): Remove file extension. (slime-read-system-name): Use SWANK:LIST-ASDF-SYSTEMS. * swank.lisp (list-all-systems-in-central-registry): Use only pathname name. (list-all-systems-known-to-asdf): New function. (list-asdf-systems): New function. 2007-01-12 Marco Baringer * slime.el (slime-keys): Remove binding of M-*, restore binding of M-,. 2007-01-11 Edi Weitz * slime.el (slime-repl-test-system, slime-repl-test/force-system): New REPL shortcuts. Patch by Kevin Rosenberg . 2007-01-11 Juho Snellman * slime.el (slime-read-expression-map): restore tab completion in the minibuffer. Switch the slime-mode-map and minibuffer-local-map around, so that the minibuffer binding for return takes precedence over the slime-mode one. 2007-01-11 Marco Baringer * swank.lisp (inspect-for-emacs integer): Don't die if the integer can't be expressed as a float. Patch by Ariel Badichi . * slime.el (slime-keys): Removed binding of M-, 2007-01-11 Helmut Eller * slime.el: Some cleanups for the debugger code: add some outline sections and docstrings. (sldb-setup): Always display the beginning of the condition text. Previously, we always showed the beginning of the backtrace. (sldb-prune-initial-frames): Do what the docstring says. Reverted to Luke's version. (sldb-dispatch-extras): Fix typo. (sldb-insert-restarts, sldb-insert-frames) (sldb-insert-frame, sldb-fetch-more-frames) (sldb-toggle-details, sldb-show-frame-details) (sldb-insert-locals): Simplified. (sldb-frame-details): New. (slime-save-coordinates, slime-coordinates) (slime-restore-coordinate, slime-count-lines): New macro and its helpers. (sldb-recenter-region): Renamed from slime-maybe-recenter-region. (sldb-enable-styled-backtrace, sldb-show-catch-tags) (sldb-highlight): Deleted. Seem to be obsolete. (sldb-add-face): Removed, because it is now the same as slime-add-face. (sldb-help-summary): Deleted. The docstring for sldb-mode is already pretty terse. (define-sldb-face): Renamed from def-sldb-face. * swank-sbcl.lisp, swank-cmucl.lisp (condition-extras): Fix typo 2007-01-10 Helmut Eller * swank.lisp (*sldb-printer-bindings*): Add *print-right-margin*. (debug-in-emacs): Bind *sldb-printer-bindings* here ... (backtrace, debugger-info-for-emacs, frame-locals-for-emacs): ... and remove redundant bindings here. 2007-01-10 Attila Lendvai * slime.el: FIX: set-keymap-parents for GNU Emacs was bogus, fixed by Ariel Badichi. 2007-01-09 Helmut Eller * slime.el (slime-repl-merge-histories): Use (setf (gethash ...) instead of puthash, for Emacs 20. 2007-01-09 Juho Snellman SBCL 1.0.1.15 supports restart-frame natively, and uses a different debug catch tag interface than earlier versions. * swank-sbcl (sbcl-with-restart-frame): New function, detects SBCL 1.0.1.15 or later. (return-from-frame): Another version for 1.0.1.15, using sb-debug:unwind-to-frame-and-call (restart-frame): Another version for 1.0.1.15, using sb-debug:unwind-to-frame-and-call 2007-01-07 Helmut Eller * swank.lisp (open-streams): Don't pass nil to make-fn-streams; use a dummy function as workaround. Both arguments must be functions and CMUCL checks the types. 2007-01-06 Attila Lendvai * slime.el: Added set-keymap-parents when not available (GNU Emacs). Result: slime bindings while reading expressions from the minibuffer. * slime.el, swank.lisp: FIX: slime-insert-possibly-as-rectange and sldb stuff on newer emacsen 2007-01-04 Attila Lendvai * slime.el: Added slime-insert-possibly-as-rectangle and use it when inserting things here and there. The effect of this is that multi-line strings coming from swank (e.g. stuff in sldb) are inserted with insert-rectangle, so they are properly indented. * swank.lisp: FIX: sort is destructive, call copy-seq at a few places. FIX: bind *sldb-printer-bindings* also in frame-locals-for-emacs. 2007-01-03 Attila Lendvai * swank.lisp: FIX: drop extra "Slots: " from standard-object's inspector presentation * swank.lisp: FIX: keyword symbols keep their : when travelling from swank to slime * slime.el: FIX: older Emacsen have no line-number-at-pos. * slime.el: Convert some minibuffer reading defun's to defun* and use keywords. Support extra arguments. * slime.el: Use set-parent-keymaps when available (xemacs only for now) when setting up slime-read-expression-map. The effect of this is that the minibuffer will have all the slime-mode-map keys where minibuffer-local-map is not overriding. * slime.el, swank.lisp: Handle better the case when swank can not read anything from the string sent to be inspected. Only bring up the debugger when the inspect command is prefixed. 2006-12-31 Matthias Koeppe Restore the nested-presentations feature. * present.lisp (slime-stream-p): Allow sending presentations to the repl-results stream. (make-presentations-result): Removed. (send-repl-results-to-emacs): New. * swank.lisp (connection): New slot repl-results (a stream). (make-output-function-for-target): New. (open-streams): Use it here to also create a stream for REPL results. (initialize-streams-for-connection): Store the stream. 2006-12-29 Edi Weitz * slime.el (slime-find-asd, slime-read-system-name): Only offer initial input if system is really in central registry. 2006-12-29 Matthias Koeppe Simplify the REPL-results protocol. The results are now printed using special :WRITE-STRING events from the Lisp side. * slime.el (slime-repl-insert-prompt): Don't insert a result, only the prompt. (slime-repl-insert-result): Removed. (slime-repl-eval-string, slime-repl-show-abort) (slime-repl-set-package, slime-output-buffer) (slime-repl-update-banner): Change all callers. (slime-dispatch-event): Event :WRITE-STRING gets an optional argument TARGET, which controls where the string is inserted. (slime-write-string): Handle targets NIL (regular process output) and :REPL-RESULT. * swank.lisp (make-presentations-result): Removed. (send-repl-results-to-emacs): New function, sends :WRITE-STRING events. (listener-eval): Use it here instead of make-presentations-result. 2006-12-28 Matthias Koeppe Performance improvement for slime-autodoc-mode, in particular when there are REPL results that are long lists. * slime.el (slime-repl-mode-beginning-of-defun) (slime-repl-mode-end-of-defun): New. (slime-repl-mode): Use them as beginning-of-defun-function and end-of-defun-function. (slime-enclosing-operator-names): Bind parse-sexp-lookup-properties to nil, don't parse more than 20000 characters before point, don't determine exact argument positions larger than 64. Byte-compile this function. 2006-12-24 Attila Lendvai * slime.el, swank.lisp: Added customizable dwim lookup hook support for inspect * doc/slime.texi: Small doc fixes by Alfredo Beaumont * swank.lisp: Change the order to [set value] [make unbound]. Sort slot names in the inspector 2006-12-23 Matthias Koeppe * swank-clisp.lisp (make-weak-key-hash-table) (make-weak-value-hash-table): Implement for CLISP, so that the REPL results history does not cause "memory leaks". * slime.el (slime-inspect): Add a dwim-mode keyword argument, move all input handling into the interactive spec. Restore the behavior of slime-inspect when point is within a presentation (no prompting, no DWIM). (slime-inspect-presentation-at-mouse): Don't do DWIM here, so the presentation-retrieval expression does not end up on the inspector stack. (slime-inspector-position): New. (slime-inspector-operate-on-point, slime-inspector-reinspect): Use it here to make it work on GNU Emacs too. (slime-open-inspector): Fix row-col addressing at end of buffer. 2006-12-20 Attila Lendvai * slime.el: FIX: inspecting presentations from the right click menu broke in the inspect refactor * slime.el: FIX: slime-fuzzy-target-buffer-completions-mode's keymap must always precede other keymaps * slime.el, swank.lisp: Extend :write-string with and &optional presentation id and use this in present-in-emacs * swank.lisp: Added present-in-emacs that prints a presentation of the given object in the repl * swank.lisp: Return the inspected object when inspecting from the lisp side. * swank.lisp: Turn off right margin for restart printing, too 2006-12-19 Attila Lendvai * HACKING: Added useful init.el piece into HACKING about update-change-log * swank.lisp: In all-slots-for-inspector pad slot names to be equal length, so the result is more readable * slime.el: Fix slime-insert-presentation to handle multi-line presentations better (use insert-rectangle) * swank.lisp: Properly bind *sldb-printer-bindings* and turn off right margin while printing stuff in sldb * slime.el: Smarten up the sldb heuristic that drops swank frames * swank-allegro.lisp, swank-backend.lisp, swank-openmcl.lisp, swank-sbcl.lisp, swank.lisp: Added hash-table-weakness and use it in hash-table-inspecting * swank.lisp: Hashtable inspecting: added [clear hashtable] and [remove entry] actions * slime.el, swank.lisp: FIX dwim inspecting to handle (setf some-fun) functions, too * slime.el: FIX: slime-sexp-at-point for foo::|bar::baz| * slime.el: FIX: Properly keep track of slime-buffer-package in the inspector * swank.lisp: Small: get rid of notes and warnings * slime.el, swank.lisp: Added dwim-mode to slime-inspect that tries to be smart unless prefixed * slime.el: Make slime-fuzzy-complete-symbol the default in the belife that it's better for new users * swank.lisp: Add (expt 1.2 length) higher scores for longer matches in fuzzy completion. A good example: puts "make-instance" before "make-string-input-stream" while completing "make-ins" * slime.el: Set slime-fuzzy-completion-in-place enabled by default * slime.el: Added (cons row col) addressing to slime-open-inspector, use in slime-inspector-operate-on-point * slime.el: FIX: operate the inspector in the debug thread when started from sldb * slime.el: Convert some inspector defuns to defun* and use keywords. Other minor cleanups. 2006-12-18 Marco Baringer * slime.el (slime-region-for-defun-at-point): end-of-defun and beginning-of-defun modify match-data, added a save-match-data to prevent this from affecting callers of slime-region-for-defun-at-point. 2006-12-15 Edi Weitz * swank-lispworks.lisp (make-weak-key-hash-table): Weak hash tables for Lispworks. (make-weak-value-hash-table): Ditto. 2006-12-14 Helmut Eller * swank.lisp (*sldb-printer-bindings*): *PRINT-LINES* is in effect only if *PRINT-PRETTY* is non-NIL, so it better to enable the pretty printer. Suggested by Madhu . * slime.el (slime-expand-abbreviations-and-complete): Emacs `choose-completion' (choosing a completion from the *Completions* buffer) always replaces text upto (point). So the code which figures out an `unambiguous-completion-length' and places the point there in `slime-expand-abbreviations-and-complete' causes problems: the replacement text gets garbled. Get rid of the bogus `unambiguous-completion-length'. Patch by Madhu * swank-cmucl.lisp (remove-gc-hooks): The variables EXT:*GC-NOTIFY-AFTER* and EXT:*NOTIFY-BEFORE* should hold functions and should be NIL. This affects the function REMOVE-GC-HOOKS in swank-cmucl.lisp which sets them to NIL, (should one happen to use it). Set them back to the original parameters. Patch by Madhu * slime.el (slime-repl-output-mouseover-face): Fix a pair of extra parens. Patch by Madhu 2006-12-14 Helmut Eller * slime.el (slime-search-buffer-package): Remove Xemacs special casing. There's already a compatibility defun for match-string-no-properties. 2006-12-13 Attila Lendvai * swank.lisp: FIX: fuzzy completion for M-V-B. Fix by Madhu. 2006-12-12 Nikodemus Siivola * swank.lisp (inspect-for-emacs integer): Pad the hex formatted value to eight digits, "Code-char:" instead of "Corresponding character:", "Integer-length:" instead of "Length:", "Universal-time:" instead of "As time". (inspect-object): Use TYPE-FOR-EMACS instead of TYPE-OF. (inspect-in-emacs): New function, analogous to ED-IN-EMACS. * swank-backend.lisp (type-for-emacs): New generic function, defaults to TYPE-OF for non-integers, and returns FIXNUM or BIGNUM for integers. * slime.el (destructure-case): Indicate in the error message that it was the Elisp destructure-case that failed to avoid confusion. (slime-check-eval-in-emacs-enabled): More verbose error message. 2006-12-11 Attila Lendvai * swank.lisp: Added [set value] command for slot inspecting * slime.el: Work on repl history navigation, restore old M-p/M-n behaviour due to #lisp demand Also print the current regexp in the minibuffer messages. M-p/M-n takes the repl input up to the point not the entire input as it did before. slime-repl-previous/next-input-starting-with-current-input: new names for the old M-p/M-n commands History navigation commands jump to the end of buffer when point is before the prompt. * slime.el: Fix/smarten up temp-buffer-quit Now it tries its best to remember the original window config and restore it at slime-temp-buffer-quit unless it was changed meanwhile. IOW, fix "q" after macroexpand in a macroexpand buffer not closing the temp window. Also fix the compiler notes usage of the temp buffer. * swank-backend.lisp, swank.lisp: Added inspect-slot-for-emacs to let users customize it. Use all-slots-for-inspector everywhere, render link to both the effective and direct slots when both are available. Dropped slot-value-using-class-for-inspector and friends. Added slot-makunbound-using-class to the swank-mop package and added a [make-unbound] action to the standard slot presentation. * slime.el: FIX: slime-symbol-name-at-point for symbols like foo::|bar::baz| * .cvsignore, swank.lisp: FIX: Drop #\. and add #\, to escaped symbol chars * slime.el: Added slime-repl-delete-from-input-history that deletes the current history entry when no input is supplied * slime.el: slime-repl-kill-input kills the entire input when point is at the prompt and resets the history navigation state * slime.el: Use a hashtable to remove duplicates in slime-repl-merge-histories 2006-12-07 Marco Baringer * swank.lisp (init-inspector): Added eval parameter. If NIL we don't eval FORM but limit our selves to cl:read'ing it and inspecting that value. * slime.el (slime-inspect): If a prefix argument is provided pass :eval nil to swank:init-inspector. 2006-12-07 Paul Collins * hyperspec.el (common-lisp-hyperspec): Strip all text properties from the symbol-at-point to avoid problems with read-only text. 2006-12-06 Marco Baringer * slime.el (slime-search-buffer-package): Don't call match-string-no-properties if it's not defined (as is on some xemacs') (slime-repl-clear-buffer): Added optional prefix argument specifying how many lines to leave. 2006-12-06 Johan Bockgård * swank.lisp (fuzzy-completion-set): Don't mix for clauses and body clauses in loop. 2006-12-05 Helmut Eller * swank.lisp (create-swank-server): Removed. Use create-server instead. * slime.el (slime-first-change-hook): Don't do anything if buffers file doesn't exist. (slime-start, slime-set-connection-info): Add support for a :init-function which is called after the usual initialization of the connection is completed. * swank-source-file-cache.lisp (buffer-first-change): Always return nil and remove the now redundant test with probe-file. * swank-backend.lisp (guess-external-format): Return nil if the file can't be opened. Previusly we wrongly read from stdin. 2006-12-05 Juho Snellman Real xref support for SBCL (requires SBCL 1.0.0.18). * swank-sbcl.lisp (who-calls): New function, fetch xref data from sb-introspect. (who-binds): Ditto. (who-sets): Ditto. (who-references): Ditto. (who-macroexpands): Ditto. (defxref): New macro, create the above functions. (source-location-for-xref-data): New, map from sb-introspect xref format to the Swank xref format. (sanitize-xrefs): Map PCL method names to something more readable. (string-path-snippet): New function, finds a more accurate source snippet for definition source locations which have both an :emacs-string and a full source path available. Otherwise the xref location would point to the toplevel form rather than the exact form for functions compiled with C-c C-c. (source-file-position): New function, somewhat like source-path-file-position but uses the source-file cache, handles missing form-paths more gracefully. (make-definition-source-location): Use the above two functions. (sbcl-with-xref-p): New function, detect whether SBCL has xref support for backwards compability. 2006-11-26 Juho Snellman * swank-source-file-cache.lisp (buffer-first-change): Check whether a file exists before trying load it into the source cache. 2006-11-26 Juho Snellman Restore the way M-n and M-p used to work in the REPL. (cherry-picked from a patch with other changes, sent by Attila Lendvai). * slime.el (slime-repl-previous-input-starting-with-current-input) (slime-repl-next-input-starting-with-current-input): New functions, work like the old slime-repl-previous-input / next-input. (slime-repl-matching-input-regexp): Restore old version. (slime-repl-mode-map): Bind s-r-p-i-s-w-c-i and s-r-n-i-s-w-c-i to M-p and M-n respectively. slime-repl-previous-input and slime-repl-next-input are still accessible with C-up / C-down. 2006-11-25 Helmut Eller * slime.el (slime-repl-read-break): Use a :emacs-interrupt message instead of a RPC to swank:simple-break. Suggested by Taylor R. Campbell. 2006-11-24 Helmut Eller * slime.el (slime-search-buffer-package): Prettify the package name if it is written as string or keyword. 2006-11-23 Helmut Eller * slime.el (slime-in-expression-p): Use `read' and `eq' to test the first element of the list. Previuosly, the pattern (foo) wrongly matched (foobar) because we used (looking-at ). * swank-cmucl.lisp (setf-definitions): Also include defs which were created with (defun (setf NAME) ...). Previously we only found definitions created with defsetf or define-setf-expander. 2006-11-22 Helmut Eller * slime.el (slime-edit-definition): Don't hide error messages. 2006-11-21 Helmut Eller * swank.lisp (*coding-system*): "Coding systems" are now strings instead of keywords. 2006-11-19 Helmut Eller * slime.el (slime-compile-file): Let the Lisp side choose the coding system. (slime-coding): Deleted. * swank.lisp (compile-file-for-emacs): Use guess-external-format. (swank:create-server): no more accepts an :external-format 'enc , use :coding-system "enc" instead. * swank-backend.lisp (find-external-format) (guess-external-format): New. (swank-compile-file): The external-format argument is now a backend specific value returned by find-external-format. * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp, swank-lispworks.lisp, swank-allegro.lisp, swank-corman.lisp, swank-ecl.lisp, swank-scl.lisp, swank-abcl.lisp, swank-openmcl: Update implementations accordingly. * swank-source-file-cache.lisp (read-file): Use guess-external-format. * swank.lisp (*swank-wire-protocol-version*): Is now initialized by the loader. (wire-protocol-version): Removed, because it contained a reference to swank-loader::*source-directory*. * slime.el (slime-set-connection-info): On protocol version mismatch, ask the user how to proceed. (slime-protocol-version): New variable. Initialize it at compile time to detect stale elc files. * swank-loader.lisp (load-swank): Set the protocol version. 2006-11-12 Marco Baringer * slime.el (slime-make-tramp-file-name): Added (require 'tramp) since tramp-make-tramp-file-name is not an autoloaded function. 2006-11-07 Edi Weitz * slime.el (slime-fuzzy-completion-time-limit-in-msec): Escaped left parenthesis in doc string. 2006-11-05 Matthias Koeppe * slime.el (slime-complete-keywords-contextually): Unused variable, removed. 2006-11-05 Helmut Eller * slime.el (sldb-sexp-highlight-mode): Remove bloat. 2006-11-04 Matthias Koeppe Support nested presentations in REPL results, when present.lisp is loaded. * swank.lisp (make-presentations-result): New, factored out from listener-eval. (listener-eval): Use it here. * present.lisp (make-presentations-result): Override it here. 2006-11-03 Marco Baringer * swank.lisp (all-slots-for-inspector): Added declare ignore for unused argument inspector (openmcl warns about this). Reindented. 2006-11-01 Attila Lendvai * slime.el (sldb-sexp-highlight-mode): New custom. (slime-handle-repl-shortcut): Trigger slime-lookup-shortcut when the point is anywhere before slime-repl-input-start-mark. IOW, you can press "," anywhere before the prompt. (slime-edit-definition): Handle the case when there are only such entries returned from swank that have errors. (slime-read-from-minibuffer): Allow overriding of the keymap. (slime-repl-previous-matching-input): Similar behaviour like isearch-forward. (slime-repl-next-matching-input): Ditto. In more details: You can freely navigate with slime-repl-previous/next-input with M-p and M-n at any time among the history entries. When M-r is pressed, which invokes slime-repl-previous-matching-input, the the minibuffer is activated to read the regexp to search for and the contents will default to the current repl input. Pressing M-r again will start searching with the last pattern used no matter what the content of the minibuffer is. Subsequent invocations of M-r get the next match, and of course the same applies for M-s, which is slime-repl-previous-matching-input. * swank.lisp (fuzzy-completion-set): Fix on clisp. (convert-fuzzy-completion-result): Fix symbol fbound and other annotations. (slot-value-using-class-for-inspector): New. (slot-boundp-using-class-for-inspector): New. (inspect-for-emacs): Use the special slot access methods so that it's possible to customize the inspecting of complex slots (e.g. computed-class at http://common-lisp.net/project/computed-class/). (all-slots-for-inspector): Converted to generic method. 2006-11-01 Marco Baringer * swank.lisp (*swank-wire-protocol-version*): Use a defvar to declare the existence of tihs variable to the lisp (Reported by: Jonathon McKitrick ). 2006-10-30 Marco Baringer * swank.lisp (*dont-close*): New variable. (defpackage :swank): Export *dont-close*. (start-server, create-server): Use *dont-close* as the default value of the :dont-close parameter. (connection-info): Send the wire-protocol-version (supplied by the swank-version.el file) to slime when connecting. (wire-protocol-version): New function. * slime.el (slime-global-variable-name-regexp): New variable. (slime-global-variable-name-p): Use slime-global-variable-name-regexp. ("swank-version"): Load swank-version.el to get the wire protocol version. (slime-set-connection-info): Check the wire protocol version. 2006-10-30 Helmut Eller * slime.el (slime-global-variable-name-p): Oops... need to handle very long strings. 2006-10-29 Attila Lendvai * slime.el (slime-global-variable-name-p): Use defun* instead of defun. 2006-10-29 Helmut Eller * slime.el (slime-global-variable-name-p): Simplified. 2006-10-28 Matthias Koeppe Add completion for character names. * slime.el (slime-completions-for-character): New. (slime-contextual-completions): Use it here. * swank-backend.lisp (character-completion-set): New interface. * swank-allegro.lisp (character-completion-set): Implement it. * swank.lisp (completions-for-character): New slimefun. (compound-prefix-match/ci/underscores) (longest-completion/underscores, tokenize-completion/underscores) (untokenize-completion/underscores): New functions. 2006-10-28 Ivan Toshkov * hyperspec.el: Missing Hyperspec links for ~| and ~~ 2006-10-27 Ivan Toshkov * hyperspec.el: Missing Hyperspec links for ~% and ~& 2006-10-27 Nikodemus Siivola * swank-sbcl.lisp (make-weak-key-hash-table): Restore support for older SBCLs without weak hash-tables. (make-weak-value-hash-table): Ditto. 2006-10-26 Utz-Uwe Haus * swank-allegro.lisp (sldb-break-at-start): Implement. 2006-10-26 Attila Lendvai * slime.el (slime-setup-command-hooks): Use make-local-hook. (slime-repl-mode): Ditto. (slime-fuzzy-choices-buffer): Ditto. (sldb-mode): Ditto. (slime-fuzzy-completion-limit): New variable. (slime-fuzzy-completion-time-limit-in-msec): New variable. (slime-fuzzy-next): Fix when at the end of the buffer. (completion-output-symbol-converter): New to handle escaped symbols for those who need to mess around with symbols like layered-function-definers::|CONTEXTL::SLOT-VALUE-USING-LAYER|. When a symbol is escaped then completion is case sensitive. (completion-output-package-converter): New. (mimic-key-bindings): New to easily define bindings by first trying to look up bindings for an operation and only use the provided default bindings if nothing was found in the source keymap. Use it to set up fuzzy bindings. (Hint: if you have keys like previous-line customized, then only load slime after they have been set, and the fuzzy mode will mimic them.) (slime-temp-buffer-quit): Always close the opened window, updated docstring. Also made the fuzzy maps smarter, they now try to look up keys with 'where-is-internal and map the functions on them. * swank-sbcl.lisp (make-weak-value-hash-table): New for sbcl. (make-weak-key-hash-table): New for sbcl. * swank.lisp (fuzzy-completions and friends): Added :limit and :time-limit-in-msec keyword params. Used vectors instead of lists that nearly doubled its speed (at least on sbcl). Also added some declare optimize and type annotations. (do-symbols*): New, uses a hash-table to visit only non-seen symbols. Replaced various uses of do-symbols where it was appropiate. 2006-10-26 Marco Baringer * slime.el (slime-global-variable-name-p): Use a custom 'parser' instead of string-match to avoid regexp overflow errors on very long strings. 2006-10-21 Helmut Eller * swank-lispworks.lisp (initialize-multiprocessing): Don't init MP if it is already running. * test.sh: Run Emacs in Screen. 2006-10-20 Helmut Eller * swank-backend.lisp, swank-cmucl.lisp: (startup-idle-and-top-level-loops): Deleted. Merged into initialize-multiprocessing. 2006-10-20 Attila Lendvai * slime.el (slime-fuzzy-choices-buffer): Added kill-buffer-hook to the completion buffer to slime-fuzzy-abort, so we get out from the completion mode and key maps when the completion buffer is closed. 2006-10-20 Marco Baringer * slime.el (slime-target-buffer-fuzzy-completions-map): Fix a bug I introduced when applying levente's patch. 2006-10-20 Martin Simmons * swank-backend.lisp (initialize-multiprocessing): New API to support lisps where initialize-multiprocessing may not return (lispworks). * swank.lisp (start-server): initialize-multiprocessing's API has changed. * swank-lispworks.lisp (initialize-multiprocessing): Update for new API. * swank-cmucl.lisp (initialize-multiprocessing): Update for new API. * swank-allegro.lisp (initialize-multiprocessing): Update for new api. 2006-10-20 Levente Mészáros Added "in-place" fuzzy completion GUI. See slime-fuzzy-completions-map and slime-target-buffer-fuzzy-completions-map for details. * slime.el (slime-fuzzy-completion-in-place): New variable. (slime-target-buffer-fuzzy-completions-mode): New keymap for in-place fuzzy completions. (slime-fuzzy-target-buffer-completions-mode): New minor mode for in-place fuzzy completions. (slime-fuzzy-current-completion-overlay): New overlay for highlighting currently selected completion. (slime-fuzzy-completions-map): Added new fuzzy completon keys (slime-fuzzy-indent-and-complete-symbol): New function. (slime-fuzzy-complete-symbol): Use new in-place fuzzy completion. (slime-fuzzy-choices-buffer): Support in-place completion editing. (slime-fuzzy-fill-completions-buffer): Highlight completions, don't automatically jump to completion buffer. (slime-fuzzy-enable-target-buffer-completions-mode, slime-fuzzy-disable-target-buffer-completions-mode): New modes for moving in/out of in-place fuzzy completion mode (slime-fuzzy-next, slime-fuzzy-prev): Don't assume point is in the completion buffer. (slime-fuzzy-dehighlight-current-completion, slime-fuzzy-highlight-current-completion): Manage completion selection highlighting. (slime-fuzzy-select-or-update-completions): New function. (slime-fuzzy-process-event-in-completions-buffer): New function. (slime-fuzzy-select-and-process-event-in-target-buffer): New function. (slime-fuzzy-done): Changed to deal with in-place completion. 2006-10-19 Helmut Eller * swank-backend.lisp (ignored-xref-function-names): Deleted. * swank.lisp (guess-package-from-string): Remove special case for "#.". parse-package will handle that just fine. (find-definitions-for-emacs): Don't filter errors out. (sanitize-xrefs): Moved to swank-sbcl. The backend is supposed to return sane values. * swank-sbcl.lisp: See above. * slime.el (slime-find-buffer-package): Simplify. 2006-10-17 Helmut Eller * slime.el (slime-accept-process-output): The timeout arg can be nil. Handle that case. 2006-10-17 Attila Lendvai * slime.el (slime-find-buffer-package): Handle #. forms. * swank.lisp (guess-package-from-string): Handle #. forms. (inspect-for-emacs standard-class): Handle non-string :documentation slot contents. * swank-sbcl.lisp (inspect-for-emacs weak-pointer ...): Added method. 2006-10-16 Helmut Eller * slime.el (sldb-activate): Get debug-info from the correct thread. Fixes bug reported by Dan Weinreb . (unwind-to-previous-sldb-level): New test. (slime-init-command): Send a single form. (slime-insert-presentation): Honor slime-repl-enable-presentations. Presentations kill SLDB and the inspector in Emacs 20 (besides being troublesome GC-wise). * swank.lisp: Clean up global IO redirection. (setup-stream-indirection): Turn macro into a function and delay initialization after user init files are loaded, so that we do nothing if *globally-redirect-io* is nil. (*after-init-hook*, run-after-init-hook) (init-global-stream-redirection): New. (parse-symbol-or-lose): Lose loudly and early (instead of failing silently). * swank-loader.lisp: Abort on compile-time or load-time errors. Don't try to load the source-file if COMPILE-FILE's 3rd return value is true (it's true even for warnings). (handle-loadtime-error): New function. Run the after-init-hook. * swank-cmucl.lisp (inspect-for-emacs): Don't break for simple-strings. 2006-10-11 Matthias Koeppe * slime.el (slime-presentation-syntax-table): New. (slime-add-presentation-properties): Install it in a syntax-table text property, so that #<...> is balanced in a presentation. (slime-remove-presentation-properties): Remove the text property. (slime-repl-mode): Respect the syntax text properties of presentations in REPL buffers. 2006-10-09 Matthias Koeppe * swank.lisp (completions-for-keyword): Look up the operator names in the right package. Return nil (rather than signalling an error) when no valid operator name is present. 2006-10-08 Matthias Koeppe * swank-loader.lisp (lisp-version-string) [allegro]: Distinguish between 32-bit and 64-bit version on the SPARC architecture. 2006-10-03 Marco Baringer Change license statement to say that all files without an explicit copyright notice are public domain. This change will allow SLIME to moved out of debian's nonfree tree. * README: Update license statement. 2006-10-02 Marco Baringer * slime.el (slime-highlight-compiler-notes): New variable. (slime-compilation-finished): Only highlight notes when slime-highlight-compiler-notes is non-NIL. 2006-09-28 Marco Baringer * swank-loader.lisp (compile-files-if-needed-serially): Don't ignore compile-time errors but drop into a debugger (it's not a slime debugger but it's certainly better than ignoring the error). 2006-09-27 Marco Baringer * swank.lisp (*globally-redirect-io*): Change default value to T. 2006-09-25 Juho Snellman Fix Slime on SBCL 0.9.17. * swank-backend.lisp (ignored-xref-function-names): New interface * swank.lisp (sanitize-xrefs): Use ignored-xref-function-names instead of having a #+sbcl special case. * swank-sbcl.lisp (ignored-xref-function-names): Implement. Filter out SB-C::STEP-VALUES, not just SB-C::STEP-FORM, as done by the old sanitize-xrefs. Don't implement the interface at all if SBCL is sufficiently new (those symbols don't exist any more, and there's nothing in their place to be ignored). 2006-09-21 Marco Baringer * swank.lisp (find-definitions-for-emacs): Don't return locations whose CAR is :error. (xref): Process whatever is returned by the various xref functions with the new sanitize-xrefs functions. (sanitize-xrefs): Clean up the list of xrefs to remove duplicates. Patch by Dan Weinreb * slime.el (slime-goto-first-note-after-compilation): New variable. This controls the behaviour of (next|prev)-note immediatly after a slime-compile-and-load-file. (slime-compilation-just-finished): New variable. (slime-compilation-finished): Update slime-compilation-finished. (slime-next-note, slime-previous-note): Respect slime-compilation-just-finished. (slime-autodoc-use-multiline-p): Specify the type. (slime-repl-grab-old-input): Typo in docstring. (slime-cheat-sheet): Deal with multiple-bindings (slime-cheat-sheet-table): Update as per #lisp's suggestions. 2006-09-20 Marco Baringer * slime.el (slime-cheat-sheet): New function. (slime-cheat-sheet-table): New variable which specifies what the cheat sheet should list. (slime-read-package-name): Set require to T in the call to completing read, it doesn't make any sense to switch to an inexistent package. * doc/slime.texi: Added "Tips and Tricks" chapter (need a better name for this). * swank-sbcl.lisp (fallback-source-location): Use abort-request instead of error. (locate-compiler-note): Say, in the error message, what data caused the error. 2006-09-20 Juho Snellman * swank-sbcl.lisp (call-with-debugger-hook): use INVOKE-STEPPER instead of calling the stepper hook manually 2006-09-19 Juho Snellman * swank-sbcl.lisp (call-with-debugger-hook): make the stepper also work with a threaded SBCL, by binding a handler for sb-ext:stepper-condition instead of relying on the one that SBCL establishes on the toplevel 2006-09-19 Juho Snellman Extend the stepper protocol to work nicely with the SBCL stepper. If sldb is invoked on a condition that's sldb-stepper-condition-p, the sldb functions sldb-step, sldb-next and sldb-out will invoke the matching backend functions for stepping into the stepped form, to the next form, or out of the current function. Otherwise the functions will behave like sldb-step used to (call active-stepping and select the continue restart). * swank-backend.lisp (sldb-stepper-condition-p, sldb-step-into, sldb-step-next, sldb-step-out): New interface functions * swank-sbcl.lisp (activate-stepper, condition-extras, sldb-stepper-condition-p, sldb-step-into, sldb-step-next, sldb-step-out): Implemented (conditional on CVS SBCL) (call-with-debugger-hook): bind sb-ext:*stepper-hook* to a function that binds *stack-top-hint* and invokes the debugger (conditional on CVS SBCL) * swank.lisp (define-stepper-function): new macro for defining stepper-related functions, since they all follow the same form (sldb-step): redefine with define-stepper-function (sldb-next, sldb-out): new functions (*sldb-stepping-p*): typo in docstring * slime.el (sldb-next, sldb-out): New commands (sldb-mode-map): bind sldb-next to "x" and sldb-out to "o" 2006-09-18 Dan Weinreb For those cases where SLIME can't complete a user request (like loading an asdf system without asdf or describing an inexistent symbol) instead of signaling an error SWANK should politely inform the user and return normally. * swank.lisp (eval-for-emacs): Handle request-abort conditions. (decode-keyword-arg, get-repl-result, parse-symbol-or-lose): Use abort-request instead of error. * swank-backend.lisp (request-abort): New condition. (abort-request): Convenience function for signaling request-abort conditions. (operate-on-system): Use abort-request instead of error (:swank-backend): Export the symbols abort-request and request-abort. * slime.el (slime-rex): Update docstring. (slime-eval, slime-eval-async): Added new REASON parameter sent along with :abort message. 2006-09-14 Douglas Crosher * swank-scl (arglist, function-arglist, spawn): update for the SCL. 2006-09-13 Brandon Bergren * slime.el (slime-filename-translations): Fix docstring 2006-09-13 Bob Halley * swank.lisp (format-iso8601-time): Properly handle non integer time zones. 2006-09-13 Taylor R. Campbell * slime.el (slime-init-output-buffer): Initial directory and package stacks should be empty. (slime-repl-push-package): Push the current package, as opposed to the new package, and set the new package to whatever the user specified. (slime-repl-pop-package): Set the current package to the top of the package stack, unless it's empty. 2006-09-13 Daniel Koning * slime.el (slime-repl-disconnect): New repl shortcut. 2006-09-13 Marco Baringer * slime.el (slime-open-inspector): Added a slime-part-number property to the topline so that you can slime-inspector-copy-down the object being inspected. There are some cases where we have an object in the inspector and we'd like to dump it to the repl but we can't get at it through other means (like in back-traces). (slime-insert-xrefs): Specify which file the item is in (when that information is available). * swank.lisp (format-arglist-for-echo-area): Instead of using let+first+rest to destructure a form use destructuring-bind. (lookup-presented-object): Added (declare (special *inspectee-parts*)) to silence openmcl's compiler. (inspect-object): Generate, and send to emacs, an ID for the object being inspected. 2006-09-01 Nikodemus Siivola * slime.el (slime-repl-matching-input-regexp): Use the portion between slime-repl-input-mark and point for history search, not the entire input. Patch by Ivan Shvedunov. * swank-sbcl.lisp: Declaim SB-C:INSERT-STEP-CONDITIONS 0 for to hide Swank while stepping and avoid endless mutex-acquisition loops. 2006-08-27 Helmut Eller * swank.lisp (input-available-p, process-available-input): Use READ-CHAR-NO-HANG instead of LISTEN because LISTEN suddenly returns false in SBCL 0.9.?? even if we are called from a fd-handler and the OPEN-STREAM-P returns true. 2006-08-26 Matthias Koeppe * slime.el (slime-repl-return-behaviour): Fix the defcustom type, so Emacs 21.3 does not signal an error when creating a customization buffer containing this variable. 2006-08-25 Kai Kaminski * swank.lisp (lookup-presented-object): Fix for OpenMCL 1.0 [ppc32], which requires that the :NO-ERROR clause is last in HANDLER-CASE. 2006-08-24 Matthias Koeppe * slime.el (slime-ensure-presentation-overlay): Provide a help-echo for presentations, showing the mouse bindings. (slime-presentation-around-click): New function. (slime-copy-or-inspect-presentation-at-mouse) (slime-inspect-presentation-at-mouse) (slime-copy-presentation-at-mouse) (slime-describe-presentation-at-mouse) (slime-pretty-print-presentation-at-mouse): New commands. (slime-copy-presentation-at-point): Removed (misnomer). (slime-presentation-map): Bind mouse-2 to slime-copy-or-inspect-presentation-at-mouse, so the right thing is done in REPL buffers and in Inspector and Debugger buffers. (slime-menu-choices-for-presentation): Use the new commands here instead of inline lambdas. (sldb-inspect-in-frame): Use slime-read-object here, so if point is in a presentation in the debugger buffer, inspect it immediately just like slime-inspect does. (slime-inspect-presented-object): Removed. (slime-inspect): Don't expect that "swank:init-inspector" is already part of the form. Accept an optional arg "no-reset". (slime-read-object): Don't add "swank:init-inspector" to the read form; slime-inspect now adds it. 2006-08-21 Matthias Koeppe Make the values of local variables in debugger frames and values of parts in the inspector accessible as presentations. In particular, this allows to copy # values to the REPL for further investigation. It also provides a context menu for the values, offering to inspect, pretty-print, and describe them. Note that the presentations are only valid as long as the corresponding Inspector or Debugger buffer is open. * swank.lisp (lookup-presented-object): Handle presentation ids (:frame-var frame index), (:inspected-part part-index). (init-inspector): New optional argument, reset. * slime.el (slime-inspector-insert-ispec): Mark up all values of inspected parts as presentations. (sldb-insert-locals): Mark up the values of local variables as presentations. (slime-remove-presentation-properties): Fix for read-only buffers. (slime-copy-presentation-at-point): Make it work when the current buffer is not the REPL buffer. (slime-menu-choices-for-presentation): Describe into a separate buffer, not the REPL. New menu item, pretty-print. (slime-presentation-expression): Handle presentation ids that are not numbers. (slime-inspect-presented-object): Don't reset the inspector if already in the inspector buffer. 2006-08-20 Matthias Koeppe * swank.lisp (*nil-surrogate*): New. (save-presented-object, lookup-presented-object): Distinguish between a saved NIL and a garbage-collected object that was replaced by NIL in the weak hash table. (compute-enriched-decoded-arglist with-open-file): Add an IGNORE declaration. 2006-08-19 Matthias Koeppe * slime.el (slime-parse-extended-operator-name/apply): New. (slime-extended-operator-name-parser-alist): Add it to the alist. * swank.lisp (compute-enriched-decoded-arglist): Add method for handling APPLY. 2006-08-14 Helmut Eller * slime.el (slime-accept-process-output): Use brute-force to detect whether accept-process-output can be called with a float as timeout arg. * swank-openmcl.lisp: Fix some breakage caused by the new defimplementation. 2006-08-11 Helmut Eller * swank.lisp (close-connection, swank-error): Include backtraces in our own errors. (simple-serve-requests): Don't try to enter the debugger if the connection is closed. * slime.el (disconnect): Test disconnecting. * swank-cmucl.lisp (startup-idle-and-top-level-loops): Initialize MP only once. 2006-08-10 Helmut Eller * swank-allegro.lisp (fspec-definition-locations): Improve handling of (:internal ... n) like fspecs. * slime.el (slime-restart-inferior-lisp-aux): Remove the interactive spec. * swank-backend.lisp (definterface): Drop that incredibly unportable CLOS stuff. Use plists and plain functions instead. Update backends accordingly. 2006-08-09 Helmut Eller * slime.el (slime-find-filename-translators): CL:MACHINE-INSTANCE can return nil. Silently accept that case for now. * swank.lisp (test-print-arglist): Print a message instead of signalling an error. This should avoid startup problems, in particular with CormanLisp. (setup-stream-indirection): Disable it for now. We should fix it, if there is a need for this functionality or just remove it. * swank-backend.lisp (definterface): Bring the old implementation based on NO-APPLICABLE-METHOD back. It avoids lots of redefintion warnings (but it creates more "noise" in backtraces). * swank-*.lisp (inspect-for-emacs): Don't use defimplementation for real generics. 2006-07-28 Helmut Eller * slime.el (slime-thread-quit): Call swank:quit-thread-browser. Reported by Taylor R. Campbell. 2006-07-28 Willem Broekema * swank-allegro.lisp: Profiling functions on Allegro (except for profile-package). 2006-07-24 Matthias Koeppe Add support for destructuring macro arglists in arglist display, form completion, and keyword completion; in particular for with-open-file. * swank.lisp (find-valid-operator-name): New, factored out from arglist-for-echo-area. (arglist-for-echo-area): Use it here. (print-arglist): New, factored out from decoded-arglist-to-string. Handle recursive arglist structures that arise in destructuring macro arglists. (decode-required-arg, encode-required-arg): New, handle destructuring patterns. (decode-keyword-arg, encode-keyword-arg, decode-optional-arg) (encode-optional-arg, decode-arglist, encode-arglist): Use them here to handle destructuring patterns. (print-decoded-arglist-as-template): Change interface, handle destructuring patterns. (decoded-arglist-to-template-string): Use it here. (enrich-decoded-arglist-with-keywords): New, factored out from enrich-decoded-arglist-with-extra-keywords. (enrich-decoded-arglist-with-extra-keywords): Use it here. (compute-enriched-decoded-arglist): New generic function, factored out from arglist-for-insertion, form-completion. Add specialized method for with-open-file. (arglist-for-insertion, form-completion): Use it here. (arglist-ref): New. (completions-for-keyword): Change interface, handle destructuring macro arglists. * slime.el (slime-enclosing-operator-names): For nesting levels without operator, record nil. (slime-completions-for-keyword): New argument arg-indices. (slime-contextual-completions): Pass all enclosing operators and arg-indices to slime-completions-for-keyword. 2006-07-16 Matthias Koeppe * slime.el (slime-edit-definition): Invoke the slime-edit-definition-fall-back-function also in the case where find-definitions-for-emacs returns an error message. (slime-edit-definition-fallback-function): Fix typo (find-tag rather than find-tags). 2006-07-15 Juho Snellman * swank-sbcl.lisp (preferred-communication-style): Remove use of linux_no_threads_p alien variable (the value has been hardcoded to false for about a year), so that we can also remove it from from SBCL in the future. (*definition-types*): defcondition -> define-condition, to make slime-show-definitions display condition FOO as (DEFINE-CONDITION FOO) instead of (SWANK-BACKEND::DEFCONDITION FOO). 2006-07-15 Matthias Koeppe * slime.el (slime-shared-lisp-mode-hook): New function, factored out from slime-lisp-mode-hook. (slime-lisp-mode-hook): Use it here. (slime-scheme-mode-hook): New function, use slime-shared-lisp-mode-hook. (slime-setup): If scheme-mode is one of the slime-lisp-modes, install our hook. 2006-07-13 Matthias Koeppe * swank.lisp (keywords-of-operator): New support function for writing user-defined `extra-keywords' methods. 2006-07-11 Helmut Eller * swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak hashtables. * swank.asd: Set *source-directory* to the asdf component dir. 2006-07-01 Luís Oliveira * swank-sbcl.lisp (locate-compiler-note): Change first branch to handle the changes introduced by the previous patch to swank-compile-string. 2006-06-26 Helmut Eller * swank-sbcl.lisp (find-definitions): Remove backward compatibility code. 2006-06-26 Luís Oliveira * swank-sbcl.lisp (tmpnam, temp-file-name): New functions. (swank-compile-string): Create temporary file with the string and compile-file it instead of compiling an anonymous lambda, as before, in order to better handle eval-when forms. 2006-06-25 Helmut Eller * swank-source-path-parser.lisp (suppress-sharp-dot): Return a unique symbol to avoid multiple entries for nil at toplevel in the source-map. * slime.el (test compile-defun): Add a test for #. reader macro at toplevel. (slime-run-one-test): New command. (sldb-activate): Recreate the sldb buffer if it doesn't exist. (Can happen if someone kills the buffer manually.) (slime-wait-condition): Add a dummy to slime-stack-eval-tags while waiting so that the SLDB enters a recursive edit. 2006-06-18 Matthias Koeppe * slime.el (slime-echo-arglist): Simplify, just use slime-autodoc. * swank.lisp (arglist): Distinguish between provided actual args and required formal args using the new slot provided-args. (form-completion): Likewise. (decoded-arglist-to-string): Use it here to display the argument list (make-instance 'CLASS-NAME ...) rather than (make-instance (quote CLASS-NAME) ...). * swank.lisp (extra-keywords change-class): Don't drop the first argument. * slime.el (slime-parse-extended-operator-name): Don't move point; fixes infinite loop. 2006-06-17 Matthias Koeppe * slime.el (slime-parse-extended-operator-name/cerror): Handle cerror and change-class with :make-instance. (slime-extended-operator-name-parser-alist): Handle change-class. (slime-parse-extended-operator-name) (slime-enclosing-operator-names): Fix the case when point is within the operator. * swank.lisp (operator-designator-to-form): Handle cerror and change-class with :make-instance. 2006-06-16 Matthias Koeppe * swank.lisp (operator-designator-to-form): Handle :cerror. (extra-keywords cerror): Make it work. * slime.el (slime-parse-extended-operator-name) (slime-parse-extended-operator-name/make-instance) (slime-parse-extended-operator-name/defmethod): New functions, factored out from slime-enclosing-operator-names. (slime-parse-extended-operator-name/cerror): New function. (slime-extended-operator-name-parser-alist): New variable. (slime-enclosing-operator-names): Use them here. 2006-06-14 Matthias Koeppe * slime.el (slime-goto-definition): If all definitions of a name have the same location, go there directly rather than presenting an xref buffer. 2006-06-11 Douglas Crosher * swank-scl (ext:stream-write-chars): update for SCL 1.3. 2006-06-09 Alan Ruttenberg * swank-abcl: Update to cvs version of abcl and warnings errors when compiling in a buffer will now be properly caught by slime vs current behavior of always saying 0 errors 0 warnings and printing them in the repl instead 2006-05-31 Nathan Bird * swank.lisp (*sldb-quit-restart*): New variable. (throw-to-toplevel): Use the restart named by *sldb-quit-restart* as opposed to hard coding abort-request. 2006-05-30 Tobias Rittweiler * slime.el (slime-get-temp-buffer-create): New keyword REUSEP which indicates whether an already-existing buffer named like the buffer to be created should be reused, i.e. not killed, then freshly created. Update docstring accordingly. (slime-with-output-to-temp-buffer): Make &optional arg MODE an &key keyword arg. Add REUSEP keyword. (slime-macroexpansion-minor-mode-map): Make remapped `undo' update highlighted edits in the macroexpansion buffer. (slime-eval-macroexpand-in-place): Update highlighted edits when macroexpanding in-place. (slime-eval-macroexpand): Reuse macroexpansion buffer if it exists already to preserve `undo' functionality. 2006-05-30 Tobias Rittweiler * slime.el (slime-use-autodoc-mode): Fix typo in docstring. (slime-use-highlight-edits-mode): New variable, analogous to SLIME-USE-AUTODOC-MODE. (slime-setup, slime-lisp-mode-hook): Make above variable work. Also, activates the HIGHLIGHT-EDITS-MODE in proper way (thus avoiding the nasty "Toggling ... off; better pass an explicit argument." message.) * slime.el: Fix typo in comment about communication protocol. 2006-05-27 Alan Ruttenberg * swank-abcl: slot-boundp-using-class slot-value-using-class so you can inspect instances. 2006-05-26 Tobias C. Rittweiler * slime.el (slime-eval-macroexpand-inplace): Fix out-of-range error on in-place macroexpand when point is placed at a closing parenthesis. In this case the sexp closed by that paren is expanded. Also make expanding of expressions work that are quoted like, for instance, "'(FOO BAR)" if point is placed at the opening paren. 2006-05-24 Brian Downing * swank.lisp (recursively-compute-most-completions & friends): Micro-optimize the fuzzy completion engine, improving performace by a factor of about 4 on SBCL. However, it will only work on simple-strings now, and CHAR= is burned in instead of being an option. I don't think this is too much of a limitation. At this point rendering the results on the emacs side takes much longer than finding them for long result lists. 2006-05-24 Alan Ruttenberg * swank-abcl: Add some more mop functions to you can inspect classes, generic functions, methods, slots. 2006-05-16 Marco Baringer * slime.el (slime-repl-return-behaviour): New variable which controls slime-repl-return's heaviour. (slime-repl-return): Respect slime-repl-return-behaviour. 2006-05-14 Marco Baringer * slime.el (slime-macroexpansion-minor-mode-map): Rebind 'undo' to set buffer-read-only temporarily to t. (slime-repl-return): Only send repl input if point is past a complete form. 2006-05-12 Matthias Koeppe * swank.lisp (update-indentation-information): Fix for problem with Allegro CL 8.0: If I type M-x slime-update-indentation, Allegro CL starts growing until it hits a STORAGE-CONDITION or even segfaults. 2006-05-04 Matthias Koeppe * swank-allegro.lisp (fspec-definition-locations): Handle :top-level-form entries that appear in backtraces. 2006-04-20 Marco Baringer * swank-openmcl.lisp (toggle-trace): Implemented. Currently only provides 'best effort' support, :labels and :flet are ignored, :defmethod and :call are treated like a normal trace of the operator. 2006-04-20 Helmut Eller * swank.lisp (*use-dedicated-output-stream*): Make it nil by default to avoid race conditions. 2006-04-19 Christophe Rhodes * doc/Makefile (contributors.texi): use texinfo macros for accented characters. * ChangeLog: canonize Gábor Melis' spelling, otherwise he appears twice in the "Hackers of the good Hack table" * doc/slime.texi (nyorsko): delete (EDITION): make it say 2.0 2006-04-19 Christophe Rhodes * swank.lisp (decoded-arglist-to-string): if the keyword and the variable are different, print the keyword name with escapes. (encode-keyword-arg): get the keyword and the arg-name the same way round as in lambda lists. (appliable-methods-keywords): use swank-mop:compute-applicable-methods-using-classes and compute-applicable-methods in the AMOP-friendly way, to get EQL specializers right. (class-from-class-name-form, extra-keywords/slots): new. (extra-keywords/make-instance): use new functions. Also get keywords from SHARED-INITIALIZE (after Dan Barlow) and ALLOCATE-INSTANCE. (extra-keywords/change-class): new. (extra-keywords (eql 'change-class)): new. Won't work at present, just as the CERROR case doesn't work. 2006-04-19 Christophe Rhodes * swank-sbcl.lisp (preferred-communication-style): Make it nil under win32, for now. * doc/slime.texi: document nil *communication-style* 2006-04-18 Espen Wiborg * swank-corman.lisp: Define a class file-stream to let swank.lisp load. 2005-04-17 Andras Simon * swank-abcl.lisp: (accept-connection): New argument: timeout. 2006-04-14 Gerd Flaig * slime.el (slime-autodoc): Fix reference to unbound variable. 2006-04-13 Martin Simmons * swank-loader.lisp (load-site-init-file, swank-source-files): Fix pathname construction to take all unspecified components from the directory pathname, in particular the drive letter on Windows. 2006-04-13 Helmut Eller * slime.el (slime-find-filename-translators): Use assoc-if instead of assoc-default for XEmacs compatibility. (slime-show-note-counts): Don't show the highlighting bit as it spills of the screen. (slime-highlight-notes): Use with-temp-message. (with-temp-message): Define it for XEmacs. (slime-beginning-of-symbol): Use eq instead of char-equal as char-equal signals an error at the beginning of a buffer. 2006-04-13 Douglas Crosher * swank-scl (make-socket-io-stream): set the stream to ignore character conversion errors, and to substitute the character #\?. Without this the communication channel is prone to lockup when a conversion error occurs. * swank-scl (inspect-for-emacs function): correct the index into the closure environment; it was reading off the end of the closure environment and picking up a corrupting value. * swank-scl (mailbox): rework the mailbox implementation to better handle interruption. Use a polling loop rather than condition variables because interrupting a condition variable wait leaves the thread with the condition variable lock held and leads to a deadlock error. 2006-04-12 Robert Macomber * swank-backend.lisp (make-recursive-lock): New interface function. (call-with-recursive-lock-held): New interface function. * swank-grey.lisp (class slime-output-stream): Added recursive locking to class and generic functions specialized on it. (clss slime-input-stream): Added recursive locking to class and generic functions specialized on it. * swank-sbcl.lisp (make-recursive-lock): Implement the new interface. (call-with-recursive-lock): Implement the new interface. 2006-04-01 Matthew D. Swank * slime.el (slime-fontify-string): Use set-text-properties, not propertize, for Emacs 20 compatibility. 2006-03-30 Helmut Eller * slime.el (slime-init-command): Don't translate filenames since the new scheme doesn't work without a connection. (slime-to-lisp-filename,slime-from-lisp-filename): Remove some redundancy. (slime-macroexpansion-minor-mode): Make it Emacs 20 compatible. 2006-03-29 Matthias Koeppe * slime.el (slime-repl-mode): Enable autodoc-mode if slime-use-autodoc-mode is true. 2006-03-28 Matthias Koeppe * swank.lisp (multiple-value-or): New macro. * slime.el (slime-recently-visited-buffer): Ignore internal buffers (starting with a space), to avoid selecting the *slime-fontify* buffer. Reported by Andreas Fuchs. * slime.el (slime-enclosing-operator-names): Handle forms similar to make-instance (make-condition, error, etc.), to get extra keywords based on the condition class. * swank.lisp (operator-designator-to-form): Handle forms similar to make-instance (make-condition, error, etc.) (extra-keywords/make-instance): New function. (extra-keywords): Specialize on operators make-condition, error, signal, warn, cerror. Use multiple-value-or. 2006-03-27 Marco Baringer * slime.el (slime-make-tramp-file-name): If emcas' tramp has tramp-multi-methods then pass the method parameter to tramp-make-tramp-file-name, otherwise don't. (slime-create-filename-translator): Use slime-make-tramp-file-name. 2006-03-27 Matthias Koeppe * hyperspec.el (common-lisp-hyperspec-strip-cl-package): New function. (common-lisp-hyperspec): Don't get confused by a cl: or common-lisp: package prefix. * slime.el (slime-hyperspec-lookup): Don't get confused by a cl: or common-lisp: package prefix. 2006-03-26 Matthias Koeppe * slime.el (slime-enclosing-operator-names): Fix for situation when point is at end of buffer, as it happens often in the REPL. 2006-03-25 Matthias Koeppe * swank.lisp (arglist-for-echo-area): New keyword arg, print-lines. (decoded-arglist-to-string): New function, implement argument highlighting also for &optional and &rest/&body arguments. (arglist-to-string): Use decoded-arglist-to-string. (arglist): New slots aux-args, known-junk, unknown-junk. (nreversef): New macro. (decode-arglist, encode-arglist): Refine to handle more structure in argument lists, including implementation-defined stuff like &parse-body. (format-arglist-for-echo-area): New keyword arg, print-lines. Simplify the code as there is no need to fall back to the unparsed arglist any more. * slime.el (slime-fontify-string): Fix for arguments spanning multiple lines. (slime-autodoc-message-dimensions): New. (slime-autodoc-thing-at-point): Use it here to either ask for a one-line or a nicely formatted multi-line arglist. (slime-enclosing-operator-names): Handle linebreaks. 2006-03-24 Mikel Bancroft * swank-allegro.lisp (set-default-directory): Fix for pathnames without a trailing slash. 2006-03-24 Matthias Koeppe * slime.el (slime-background-activities-enabled-p): Allow "background activities" in sldb-mode. (slime-autodoc-message-ok-p): Allow autodoc in sldb-mode. (sldb-mode-syntax-table): New variable. (sldb-mode): Enable autodoc-mode when slime-use-autodoc-mode is true. Use sldb-mode-syntax-table to make #<...> balance like parentheses. This enables autodoc-mode to match # actual arguments in the backtraces with formal arguments of the function. (slime-beginning-of-symbol, slime-end-of-symbol): Handle es::|caped| symbols. (slime-enclosing-operator-names): Use syntax table to check whether we are at the beginning of a balanced expression. 2006-03-23 Christophe Rhodes * swank.lisp (ed-in-emacs): Allow conses as function names. Ensure that there is a connection to emacs before sending the :ed message. * slime.el (slime-edit-definition): read names, not symbols. (slime-ed): handle conses whose car is not a string as function names. 2006-03-23 Matthias Koeppe * slime.el (slime-qualify-cl-symbol-name): Strip leading colon from package names for qualifying symbols. (slime-call-defun): New command. (slime-keys): Bind it to C-c C-y. (slime-easy-menu): Show it in the menu. * slime.el (slime-autodoc-use-multiline-p): New defcustom. (slime-autodoc-message): Use it here. Fix bug that autodoc messages exceeding one line could not be overwritten by later autodoc messages. (slime-autodoc-pre-command-refresh-echo-area): Use message rather than slime-background-message. * swank.lisp (casify): Removed. (casify-char, tokenize-symbol-thoroughly): New functions. (parse-symbol): Use tokenize-symbol-thoroughly, so as to handle |escaped symbols|. This fixes arglist display for operators with strange symbol names. 2006-03-23 Douglas Crosher * swank-backend (accept-connection): add a 'timeout argument to this function. * swank-backend (set-stream-timeout): new implementation specific function. Used to set the timeout for stream operations, which can help make the network connection establishment more robust. * swank (setup-server): ignore errors from the function 'serve to allow another connection to be made. * swank (serve-connection): ensure the listener socket is closed when 'dont-close is false, even if the connection attempt fails. * swank (accept-authenticated-connection): ensure the new connection is closed if the connection establishment fails. Set a short stream timeout to prevent denial of survice. * swank (open-dedicated-output-stream): ensure the listener socket is closed, even if unable to open the dedicated stream. Implement a timeout while waiting for a connection for the dedicate stream to prevent denial of service. * swank (create-connection): ensure the new connection is closed if not successful. 2006-03-22 Matthias Koeppe * swank.lisp (arglist-for-echo-area): Fix when arg-indices are not given. * slime.el (slime-ed): Handle (FILENAME :charpos CHARPOS). * swank.lisp (inspect-for-emacs): Specialize on FILE-STREAM and STREAM-ERROR, offering to visit the file at the current stream position as an inspector action. Useful for dealing with reader errors. 2006-03-20 Matthias Koeppe * slime.el (slime-autodoc-pre-command-refresh-echo-area): Show the last autodoc message again (movement commands clear it); technique to avoid flickering, taken from eldoc. (slime-autodoc-mode): Install it as a pre-command-hook. (slime-autodoc-last-message): New variable. (slime-autodoc-message): New function. (slime-autodoc): Use them here. (slime-autodoc-message-ok-p): OK to overwrite an autodoc message. * slime.el (slime-handle-indentation-update): Also update scheme-indent-function if slime-lisp-modes contains scheme-mode. 2006-03-19 Matthias Koeppe Highlight the formal argument corresponding to the actual argument around point in the echo-area arg-list display. Works most impressively when slime-autodoc-mode is enabled and when one has to deal with extremely long argument lists. * slime.el (slime-space): First insert the space, then obtain information. (slime-fontify-string): Also handle argument highlights. (slime-enclosing-operator-names): As a secondary value, return a list of the indices of the arguments to the nested operator. (slime-contextual-completions): Use changed interface of slime-enclosing-operator-names. (slime-function-called-at-point): Removed. (slime-function-called-at-point/line): Removed. (slime-autodoc-thing-at-point): New. (slime-autodoc): Re-implement with slime-enclosing-operator-names instead of slime-function-called-at-point. (slime-echo-arglist): Pass the argument indices to arglist-for-echo-area. (slime-autodoc-message-ok-p): Autodoc is also OK in REPL buffers. * swank.lisp (arglist-for-echo-area): New keyword argument arg-indices. (arglist-to-string): New keyword argument highlight. (format-arglist-for-echo-area): Likewise. 2006-03-18 Matthias Koeppe * slime.el (slime-goto-location-buffer): Avoid calling the expensive function find-file-noselect when we are already in the right buffer. * swank.lisp (arglist-for-echo-area): Add keyword argument print-right-margin. (arglist-to-string, format-arglist-for-echo-area): Likewise. * slime.el (slime-autodoc): Use it here to make use of the whole width of the echo area for arglist display. 2006-03-16 Gábor Melis * swank-allegro.lisp (inspect-for-emacs): Fix typo. 2006-03-16 Gary King * swank-loader.lisp (lisp-version-string): Modified swank-loader so that Allegro's alisp and mlisp programs get different locations. Otherwise mlisp complains about alisp's files. 2006-03-16 Marco Baringer * slime.el (slime-to-lisp-filename): Call expand-file-name before passing the filename to the to-lisp function. 2006-03-14 Matthias Koeppe * slime.el (slime-system-history): New variable. (slime-read-system-name): Use a separate history list for ASDF system names. (slime-note-counts-message): New variable. (slime-show-note-counts): Store the note counts message for later use. (slime-highlight-notes, slime-list-compiler-notes): Show a progress message, keeping note counts visible. (slime-find-buffer-package): Handle IN-PACKAGE forms that appear in SWIG/Allegro CL wrappers. * swank-allegro.lisp (compile-from-temp-file): Suppress Allegro's redefinition warnings; they are pointless when we are compiling via a temporary file. (profile-report): Implement. 2006-03-06 Nathan Bird * slime.el (slime-create-filename-translator): use the tramp methods for dissecting and building filenames. 2006-03-04 Wojciech Kaczmarek * slime.el (slime-filename-translations): Typo in example. (slime-create-filename-translator): Typo in generated lambdas. 2006-03-03 Marco Baringer Allow per-host (per machine-instance actually) filename translation functions. * slime.el (slime-translate-to-lisp-filename-function): removed. (slime-translate-from-lisp-filename-function): removed. (slime-filename-translations): New variable. (slime-to-lisp-filename): Rewrote to search through available transalations. (slime-from-lisp-filename): idem. (slime-create-filename-translator): New function. (slime-add-filename-translation): New function. 2006-02-27 Matthias Koeppe * slime.el (slime-eval-macroexpand-inplace): Indent the inserted macroexpansion. 2006-02-27 Marco Baringer Provide functions for performing macroexpansion inplace, use these functions in the *SLIME macroexpansion* buffer. * slime.el (slime-macroexpansion-minor-mode): Attempt to map -inplace functions to the same keys as their regular contureparts in slime-mode-map. (slime-eval-macroexpand-inplace): New function. (slime-macroexpand-1-inplace): New function. (slime-macroexpand-all-inplace): New function. * doc/slime.texi: Document new macroexpansion mode. 2006-02-26 Douglas Crosher * swank-scl.lisp: (ext:stream-read-chars): Correct the updating of the buffer index. Fixes slime input stream problems. 2006-02-25 Helmut Eller * swank-loader.lisp (default-fasl-directory): Previously we return only the directory-namestring which breaks SCL, because it loses the host and device components. Return the complete pathname instead. Patch by Douglas Crosher. * slime.el (slime-lisp-host): New variable. Replace all references to "127.0.0.1" with the variable. 2006-02-25 Douglas Crosher * swank-backend.lisp (operate-on-system): symbol case fix for SCL's lowercase mode. * swak.lisp (setup-stream-indirection) (globally-redirect-io-to-connection) (revert-global-io-redirection): symbol case fixes. * swank-scl.lisp: (inspect-for-emacs): Fixes for the inspect standard-objects, and inspect array. Plus misc symbol case fixes. 2006-02-22 Matthias Koeppe * slime.el (slime-repl-send-input): Don't include the final newline in the slime-repl-input-face overlay, thus avoid showing the "Evaluation aborted" message in boldface. Don't set non-existent "rear-nonsticky" overlay property; overlay stickiness is controlled by make-overlay arguments. 2006-02-20 Matthias Koeppe Use argument list information to complete keywords contextually. Example: (find 1 '(1 2 3) :s --completes--> :start rather than suggesting all ever-interned keywords starting with ":s". * slime.el (slime-complete-keywords-contextually): New customizable variable. (slime-enclosing-operator-names): New optional argument max-levels. (slime-completions-for-keyword): New. (slime-contextual-completions): New. (slime-expand-abbreviations-and-complete): Use it instead of slime-completions. * swank.lisp (operator-designator-to-form): New, factored out from arglist-for-echo-area. (arglist-for-echo-area): Use it here. (completions-for-keyword): New. (find-matching-symbols-in-list): New. 2006-02-19 Matthias Koeppe * slime.el (slime-expand-abbreviations-and-complete): Scroll the completions buffer if the TAB key is pressed another time, like Emacs minibuffer completion does. 2006-02-18 Marco Baringer * slime.el (slime-macroexpansion-minor-mode): New minor mode for macroexpansion buffer. Exactly like slime-temp-buffer-mode but with slime-macroexpand-again bound to "g". (*slime-eval-macroexpand-expression*): New variable. introduced for slime-macroexpand-again, used by slime-eval-macroexpand as well. (slime-eval-macroexpand): Added optional string argument which defaults to (slime-sexp-at-point-or-error). (slime-macroexpand-again): New function, redoes the last macroexpansion. (slime-sexp-at-point-or-error): New function. Like slime-sexp-at-point but signals an error when slime-sexp-at-point would return nil. * swank-openmcl.lisp (swank-mop:compute-applicable-methods-using-classes): Implement. 2006-02-16 Matthias Koeppe * sbcl-pprint-patch.lisp: New file, adds the annotations feature to the SBCL pretty printer. This is needed for sending presentations through pretty-printing streams. * present.lisp [sbcl]: Load it here. (slime-stream-p, write-annotation) [sbcl]: Handle pretty-streams. 2006-02-10 Helmut Eller * swank-allegro.lisp, swank-lispworks.lisp (inspect-for-emacs): Use the backend specific method to inspect standard-objects because {slot-boundp,slot-value}-using-class don't conform to the MOP spec in LW and ACL. * swank.lisp (macro-indentation): Don't count '&optional as argument. * swank-loader.lisp (default-fasl-directory): Include the SLIME version. (slime-version-string): New. 2006-02-06 Matthias Koeppe Show enriched arglists for DEFMETHOD in the echo area when the user types SPC after the generic function name. * swank.lisp (arglist-to-template-string): Unused, removed. (extra-keywords): Indicate which part of the actual arglist was used to determine the extra keywords. For MAKE-INSTANCE, don't signal an error if the class does not exist. (enrich-decoded-arglist-with-extra-keywords): Indicate which part of the actual arglist was used to determine the extra keywords, and whether any extra keywords were added. (form-completion): Generalize to handle display of enriched formal arglists. (read-incomplete-form-from-string): New, factored out from complete-form. Handle end-of-file. (complete-form): Use it here. (format-arglist-for-echo-area): Use form-completion, so as to show enriched formal arglists for MAKE-INSTANCE and DEFMETHOD calls. (arglist-for-echo-area): Handle MAKE-INSTANCE and DEFMETHOD calls. * slime.el (slime-enclosing-operator-names): Represent MAKE-INSTANCE calls by (:make-instance "CLASS-NAME"), handle DEFMETHOD too. 2006-02-05 Matthias Koeppe * slime.el (slime-complete-form): Indent the inserted template. 2006-02-04 Matthias Koeppe * slime.el (slime-fontify-string): New. (slime-echo-arglist, slime-arglist, slime-autodoc): Use it here to fontify echo-area arglists. 2006-02-02 Marco Baringer * swank-openmcl.lisp: Added imports for slot-boundp-using-class, slot-value-using-class and finalize-inheritance. 2006-02-01 Alan Ruttenberg * swank-abcl.lisp: define with-compilation-hooks (= funcall for now), so that you can do slime-oos 2006-01-30 Ian Eslick Show slot values for metaclasses that override the default storage locations for objects slots (i.e. where the default slot-boundp returns nil) in the inspector. * swank.lisp (inspect-for-emacs standard-object): Use slot-value-using-class and slot-boundp-using-class. * swank-backend.lisp: Add slot-value-using-class and slot-boundp-using-class to the swank-mop package. 2006-01-26 Luís Oliveira * slime.el (slime-enclosing-operator-names): detect make-instance forms and collect the class-name argument if it exists and is a quoted symbol. * swank.lisp (arglist-for-echo-area): handle pairs of of the form ("make-instance" . "") by passing them to format-initargs-and-initforms-for-echo-area. (class-initargs-and-iniforms): New function. (format-initargs-and-initforms-for-echo-area): New function. 2006-01-20 Mészáros Levente * swank-sbcl.lisp (restart-frame): Provide an implementation even if it doesn't quite do what it's supposed to do. 2006-01-19 Helmut Eller Return to the previous loading strategy: load everything when swank-loader is loaded. It's just to convenient to give that up. To customize the fasl directories, the new variable swank-loader:*fasl-directory* can be set before loading swank-loader. * swank-loader.lisp (*fasl-directory*, *source-directory*): New variables. (load-swank): Call it during loading. 2006-01-14 Helmut Eller * slime.el (slime-compile-defun): If point was at the opening paren we wrongly used the preceding toplevel form. Fix it. Reported by Chisheng Huang and Liam M. Healy. * swank.lisp (spawn-threads-for-connection): Fix a race condition: Don't accept input before all threads are ready. Make the fasl directory customizable: load-swank must now be called explicitly so that we can supply the fasl dir as argument. * swank-loader.lisp (load-swank): New entry point. 2006-01-14 Andreas Fuchs * slime.el (slime-selector ?r): Call slime instead of slime-start to pick up the usual defaults. 2005-12-31 Harald Hanche-Olsen * slime.el (slime-open-stream-to-lisp): Inherit the process-coding-system from the current connection. 2005-12-27 Alan Ruttenberg * swank-abcl. (backtrace-as-list-ignoring-swank-calls): remove the swank calls from the backtrace to make it easier to use. (frame-locals): Fix a typo that caused entry into the debugger if you tried to look at frame locals. Now you don't error out, but you still don't see frame locals because I don't know how to get them :( 2005-12-27 Helmut Eller Keep a history of protocol events for better bug reports. * swank.lisp (log-event): Record the event in the history buffer. (*event-history*): Buffer for events. (dump-event-history): New function. (close-connection): Escape non-ascii strings and include the event history in the error message. 2005-12-22 Helmut Eller Make highlighting of modified text a minor mode. Also use after-change-functions instead of rebinding all self-inserting keys. * slime.el (slime-highlight-edits-mode): New minor mode. (slime-self-insert-command): Deleted. (slime-before-compile-functions): New hook to decouple edit highlighting from compilation. (slime-highlight-edits-face): Renamed from slime-display-edit-face. 2005-12-20 Marco Baringer When inspecting classes, methods and generic functions show all the slots in the case that what we're inspecting is a subclass of the standard class and has extra user defined slots. * swank.lisp (all-slots-for-inspector): New function. (inspect-for-emacs): Use all-slots-for-inspector. 2005-12-19 Peter Seibel * slime.el (slime-self-insert-command): Got rid of message about setting up face and skipping edit-hilights when in a comment. 2005-12-18 Nikodemus Siivola * slime.el (slime-mode-hook): Bind simple characters to slime-self-insert-command only if there was no previous local binding, and the major mode is _not_ slime-repl-mode. This restores keybindings of slime-xref-mode and prevents us from stomping on user bindings. The hilighting also makes no sense in the REPL. 2005-12-16 Nikodemus Siivola * slime.el (slime-selector-method: ?r): If no connection offer to start Slime. * swank.lisp (to-string): Handle errors from printing objects. Among other things makes the inspector more robust in the face of objects with unbound slots and print-methods that fail to cope. 2005-12-16 William Bland Added hilighting of tetx which has been edited but not yet compilied. * slime.el (slime-display-edit-hilights): New variable. (slime-display-edit-face): New face. (slime-compile-file, slime-compile-defun, slime-compile-region): Remove edits overlay. (slime-remove-edits): New function. (slime-self-insert-command): New function. (slime-mode-hook): Rebind simple characters to slime-self-insert-command. 2005-12-07 Matthias Koeppe * swank-allegro.lisp (find-definition-in-file) (find-fspec-location, fspec-definition-locations): Allegro CL properly records all definitions made by arbitrary macros whose names start with "def". Use excl::find-source-file and scm:find-definition-in-definition-group (rather than scm:find-definition-in-file) to find them. * slime.el (slime-load-file): Change the default to be the buffer file name with extension. This is more convenient for files like .asd files that do not have the default source file extension. (slime-save-some-lisp-buffers, slime-update-modeline-package): Handle all files with major mode in slime-lisp-modes, not just lisp-mode. 2005-12-06 Juho Snellman * swank-sbcl.lisp (function-source-location, safe-function-source-location): Oops, define these functions also for the >0.9.6 case. Fixes broken sldb-show-source on SBCL 0.9.7. 2005-12-05 Helmut Eller * slime.el (slime-find-coding-system): Use check-coding-system only if it's actually fbound. 2005-11-22 Marco Monteiro * slime.el (slime-connect): Use slime-net-coding system if the optional arg coding-system was not supplied. 2005-11-22 Helmut Eller * slime.el (slime-compile-file): Call 'check-parens before compiling. (slime-compile-file): Call 'check-parens before compiling. (slime-find-coding-system): Return nil if the coding system isn'tvalid instead of singalling an error. (slime-repl-history-file-coding-system): Use slime-find-coding-system to find the default. * swank-cmucl.lisp (accept-connection): Remove fd-handlers if the encoding isn't iso-latin-1. 2005-11-21 Helmut Eller * slime.el (slime-start): Don't set slime-net-coding-system .. (slime-read-port-and-connect): .. read it from the inferior lisp args. (slime-connect): Take the coding-system as third argument. (slime-repl-history-file-coding-system): New user option. (slime-repl-safe-save-merged-history): New function. Use it in hooks so that bad coding systems don't stop us from exiting. (slime-repl-save-history): Include the coding-system which was used to save the buffer. (repl-shoctut change-package): Add alias ,in and ,in-package. (slime-eval-macroexpand): Error out early if there's no sexp at point. (slime-compiler-macroexpand): New command. (slime-inspector-pprint): New command. * swank-cmucl.lisp (inspect-for-emacs): Add support for funcallable instances. * swank.lisp (pprint-inspector-part, swank-compiler-macroexpand): New. * swank-backend.lisp (compiler-macroexpand) (compiler-macroexpand-1): New functions. 2005-11-14 Douglas Crosher * swank-scl.lisp (accept-connection): handle the :buffering argument. 2005-11-13 Andras Simon * swank-abcl.lisp: (accept-connection): New argument: buffering. 2005-11-13 Andras Simon * swank-abcl.lisp: Steal auto-flush stuff from swank-sbcl.lisp 2005-11-11 Helmut Eller * swank.lisp (*dedicated-output-stream-buffering*): New variable to customize the buffering scheme. For single-threaded Lisps we disable buffering because lazy programmers forget to call finish-output. (open-dedicated-output-stream): Use it. * swank-backend.lisp, swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp.lisp, swank-abcl.lisp, swank-corman.lisp, swank-ecl.lisp (accept-connection): New argument: buffering. * slime.el (slime-repl-save-history): When the history exceeds slime-repl-history-size remove the old not the new entries. Some renaming: slime-repl-read-history -> slime-repl-load-history, slime-repl-read-history-internal -> slime-repl-read-history. (slime-eval-macroexpand): Call font-lock-fontify-buffer explicitly, because with certain Emacs versions the buffer doesn't get fontified immediately. 2005-11-07 Helmut Eller * slime.el (slime-eval-macroexpand): Use lisp-mode (and font-lock-mode) when dispaying the expansion. Suggested by Jan Rychter. * swank-source-path-parser.lisp (make-source-recording-readtable): Suppress the #. reader-macro. 2005-11-06 Juho Snellman * swank-sbcl.lisp (find-definitions, make-source-location-specification make-definition-source-location, source-hint-snippet): As of SBCL 0.9.6.25 SB-INTROSPECT has better support for finding source locations. Use as much of it in swank-sbcl as possible. (Original version left reader-conditionalized for older SBCLs). 2005-11-04 Helmut Eller * swank.lisp (connection-info): Docfix. * slime.el (slime-set-connection-info): Generate a new connection name only if the implementation-name and the inferior-lisp-name are different. 2005-10-31 Helmut Eller * slime.el (slime-start, slime-lookup-lisp-implementation) (slime-set-connection-info): Add a :name property for the implementation and use it to derive the connection-name. (slime-lisp-implementation-name): Renamed from slime-lisp-implementation-type-name. * swank.lisp (simple-serve-requests): Add an extra abort restart. (connection-info): Rename :type-name to :name. 2005-10-30 Andras Simon * swank-abcl.lisp (inspect-for-emacs): Track mop changes in ABCL. 2005-10-30 Helmut Eller * slime.el (slime-eval): Ensure that the connection is open before waiting for input. * swank.lisp (simple-serve-requests): Close the connection at the end. 2005-10-23 Harald Hanche-Olsen * slime.el (slime-init-keymaps): Use vectors when defining keys, because e.g. (define-key (string ?\C-c) ...) doesn't work in the emacs-unicode-2 branch. 2005-10-23 Stefan Kamphausen * slime.el (slime-repl-history-size, slime-repl-history-file): Use defcustom to declare the variables. 2005-10-23 Gábor Melis * swank-backend.lisp (install-debugger-globally): new interface function * swank.lisp (install-debugger): call install-debugger-globally * swank-sbcl.lisp (install-debugger-globally): set sb-ext:*invoke-debugger-hook* too 2005-10-23 Helmut Eller * swank-sbcl.lisp (make-stream-interactive): Spawn a thread to flush interactive streams in reasonably short intervals. Remove the old backward-compatible threading implementation. * swank.lisp (package-string-for-prompt): Respect *print-case*. 2005-10-21 Helmut Eller * slime.el (slime-start-swank-server): Avoid comint-send-input here as it seems to trigger a bug in ansi-color-for-commit-mode. 2005-10-18 Douglas Crosher * swank.lisp (canonical-package-nickname): always return the package name as a STRING if found. This restores the printing of package names as strings. 2005-10-17 Marco Baringer * swank.lisp (eval-in-emacs): Instead of taking a string and attempting to parse it emacs side the function now takes a form and converts it to a string internally. This should allow users of the function to not have to worry about quoting issues and emacs' different printed represenation for, among other things, characters. (process-form-for-emacs): New function. Converts a list into a string for passing to emacs. * slime.el (slime-eval-for-lisp): New API. This function now takes a single string, representing the form to evaluate, and uses emacs' read function to convert it into a form before eval'ing it. (slime-dispatch-event): The :eval event now passes a single string (instead of a string and something looking kind of like a form). 2005-10-15 Douglas Crosher * swank-scl.lisp: Support for Scieneer Common Lisp. * swank-backend.lisp (*gray-stream-symbols*) Scieneer Common Lisp implements stream-line-length. * swank-loader.lisp: Support for Scieneer Common Lisp: (*sysdep-pathnames*) use swank-scl. (*impl ementation-features*) add :scl. (*os-features*) add :hpux. (*architecture-features*) add :amd64, :i686, :i486, :sparc64, :sparc, :hppa64, and :hppa. * swank.lisp: (*canonical-package-nicknames*) use lowercase symbols to name the packages. This supports CL implementations with lowercase default symbol names, such as Scieneer Common Lisp, while still being compatible with ANSI-CL. 2005-10-11 Stefan Kamphausen * slime.el: Persistent REPL history. The history from REPL buffers is now saved to the file ~/.slime-history.eld. The file is read on startup and saved when a REPL buffer gets killed or when Emacs exits. There are also commands to save or read the history file. (slime-repl-save-merged-history, slime-repl-merge-histories) (slime-repl-read-history, slime-repl-save-history): New functions. (slime-repl-history-file, slime-repl-history-size): New vars. (slime-repl-mode): Add hooks to load and save the history. 2005-10-11 Helmut Eller * slime.el (slime-read-interactive-args): Split the string inferior-lisp-program to get the values for :program and :program-args. Also let slime-lisp-implementations take precedence if non-nil. (slime-lisp-implementations): Renamed from slime-registered-lisp-implementations. * swank.lisp (force-user-output): There seems to be a bug in Allegro's two-way-streams. As a workaround we use force-output for the user-io stream. (finish-output *debug-io*) still triggers the bug. 2005-10-10 Svein Ove Aas * swank-allegro.lisp (find-external-format): Translate :utf-8-unix to :utf8, which Allegro 7.0 understands. 2005-10-09 Helmut Eller * slime.el (slime, slime-start): Introduce a separate function for the non-interactive case. `slime-start' takes lots of keyword arguments and `slime' is reserved for interactive use. (slime-read-interactive-args): New function. (slime-maybe-start-lisp, slime-inferior-lisp) (slime-start-swank-server): Pass all arguments needed to start the subprocess as a property list. Also store this list in a buffer-local var in the inferior-lisp buffer, so that we can cleanly restart the process. (slime-registered-lisp-implementations): Change the format and document it. M-- M-x slime can now be used select a registered implementation. (slime-symbolic-lisp-name): Deleted. And updated all the functions which passed it along. (slime-set-connection-info): Use the new format. (slime-output-buffer): Don't re-initialize buffer-local variables if the buffer already exists. This saves the history. From Juho Snellman. * swank-cmucl.lisp (sis/in): Use finish-output instead of force-output. * swank.lisp (connection-info): Include the initial package and a more self-descriptive format. 2005-10-01 Juho Snellman * swank-backend (*gray-stream-symbols*): Add :STREAM-LINE-LENGTH to *GRAY-STREAM-SYMBOLS* on implementations that support this extension to gray streams. Reported by Matthew D Swank. 2005-09-29 Luke Gorrie * swank-scheme48: Removed due to excessive whining. 2005-09-28 Helmut Eller * slime.el (slime-multiprocessing): Deleted. No longer needed. (slime-init-command): Updated accordingly. (slime-current-package): Add a special case for Scheme. (slime-simple-completions, slime-apropos): Quote the package, because in can be a plain symbol in Scheme. (slime-inspector-reinspect): Use a proper defslimefun. * swank.lisp (inspector-reinspect): New function. (start-server): Call initialize-multiprocessing before starting the server and startup-idle-and-top-level-loops afterwards. Calling startup-idle-and-top-level-loops here shouldn't be a problem because start-server is only invoked at startup via stdin. * swank-scheme48/source-location.scm: New file. For M-. * swank-scheme48/module.scm (list-all-package): New function. * swank-scheme48/interfaces.scm (module-control-interface): Export it. * swank-scheme48/inspector.scm: Add methods for records and hashtables. (swank:arglist-for-echo-area): Implement it. Only works for functions with enough debug-data (ie. only user-defined functions). * swank-scheme48/completion.scm: New file. (swank:simple-completions, swank:apropos-list-for-emacs): Implemented. * swank-scheme48/load.scm, swank-scheme48/defrectypeX.scm: Renamed the file from defrectype*.scm * swank-scheme48/packages.scm (swank-general-rpc): Don't use posix-process because it doesn't work on Windows, and we don't need it for a mulithreaded server. 2005-09-22 Helmut Eller * swank-backend.lisp (*gray-stream-symbols*): Collect the needed symbols here, so that we don't need to mention them in every backend. (import-from). New function. * swank-sbcl.lisp, swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-ecl.lisp: Use *gray-stream-symbols* when importing the needed symbols. * swank-gray.lisp (stream-fresh-line): Define a method, so that Allegro passes our tests. 2005-09-21 Aleksandar Bakic * swank.lisp (accept-authenticated-connection): Minor fix. Ensure that the decoded message is a string before calling string= on it. 2005-09-21 Helmut Eller * slime.el (slime-setup-command-hooks): Make after-change-functions a buffer-local variable; it's by default global in XEmacs. * swank.lisp (throw-to-toplevel): Invoke the `abort-restart' request instead of throwing to the `slime-toplevel' catch tag. (handle-request): Rename the restart from abort to abort-request. (call-with-connection): Remove the slime-toplevel catch tag because with-connection is used in far to many places which aren't at "toplevel". * present.lisp (presentation-start, presentation-end): Use finish-output instead of force-output. * swank-gray.lisp, swank-cmucl.lisp: Improve stream efficiency by buffering more output. stream-force-output simply does nothing, if the output buffer was flushed less than 200 millisecons before. stream-finish-output can still be used to really flush the buffer. (slime-output-stream): New slot last-flush-time. (stream-finish-output): New function. Do what stream-force-output did previously. (stream-force-output): Buffer more output. * slime.el (slime-process-available-input): Oops, don't start a timer for every event. (slime-write-string): Renamed from slime-output-string. (slime-dispatch-event): Rename :read-output to :write-string. (slime-io-speed-test): New command. (slime-open-stream-to-lisp): Fix parens. The coding system should also be set if presentations are disabled. * swank.lisp (make-output-function): Rename :read-output to :write-string. (eval-for-emacs, interactive-eval, eval-region): Use finish-output not force-output. * swank-sbcl.lisp, swank-openmcl.lisp, swank-allegro.lisp, swank-lispworks: Import `stream-finish-output'. * swank-scheme48/io.scm (empty-swank-output-buffer): Rename :read-output to :write-string. * swank-scheme48/load.scm (slime48-start): Fix '() vs. #f bug. 2005-09-19 Luke Gorrie * nregex.lisp: Released into the public domain by Lawrence E. Freil. 2005-09-19 Helmut Eller * slime.el (slime48): New command. 2005-09-19 Taylor R. Campbell * swank-scheme48/: New backend. 2005-09-18 Wolfgang Jenkner * bridge.el: cl is required at macro expansion time (because of `block'). Reported by Matthew D Swank. 2005-09-18 Matthias Koeppe * swank.lisp: Move presentation menu protocol here from present.lisp. 2005-09-15 Alan Ruttenberg * slime.el (slime-repl-return) don't copy presentation to input if already in input area. 2005-09-15 Helmut Eller * swank-clisp.lisp (compute-backtrace): Include only "function frames" in the backtrace. I hope that makes some sense. (sldb-backtrace, function-frame-p): New functions. (*sldb-backtrace*, call-with-debugging-environment, nth-frame): Compute and remember the backtrace when entering the debugger. (arglist): If the function has a function-lambda-expression, fetch the arglist from there. (find-encoding): Use strings instead of 'charset:foo symbols to avoid compile time problems if the charset is not available. Suggested by Vaucher Laurent. * swank.lisp (eval-in-emacs): Fix a race condition which occurred with sigio. (*echo-area-prefix*): New variable. * slime.el (slime-process-available-input): Simplify it a bit and make it easier to debug read errors. (slime-net-close): Don't kill the buffer if the new optional arg `debug' is true. (slime-run-when-idle): Accept arguments for the function. (slime-init-connection-state): Close over the proc variable. It was lost when the async evaluation returned. (slime-output-buffer, slime-connection-output-buffer): Make slime-output-buffer faster by keeping the buffer in a connection variable. (slime-restart-inferior-lisp-aux, slime-quit-lisp): Disable the process filter to avoid errors in XEmacs. 2005-09-14 Alan Ruttenberg * slime.el (slime-menu-choices-for-presentation), (slime-presentation-menu) Fix loss after refactoring. xemacs can't handle lambda forms in the menu spec given to x-popup-menu, only symbols, so save the actions in a hash table keyed by a gensym, give x-popup-menu the gensym and then call the gensym. Haven't checked that it actually works in xemacs because my xemacs is hosed in os x Tiger. Could someone let me know... * swank.lisp (inspect-factor-more-action) rename (inspect-show-more-action) Prompt before reading how many more. Would be nicer to prompt in the minibuffer... 2005-09-14 Matthias Koeppe * slime.el (slime-presentation-expression): Remove handling of cons presentation-ids. 2005-09-13 Alan Ruttenberg * slime.el (defcustom slime-ed-use-dedicated-frame ... vs defvar (defcustom slime-when-complete-filename-expand: Use comint-replace-by-expanded-filename instead of comint-dynamic-complete-as-filename to complete file names * swank.lisp (run-repl-eval-hooks .. finally (return vs no return inspector-call-nth-action Allow second value :replace for inspector actions (defvar *slime-inspect-contents-limit* default nil. How many elements of a hash table or array to show by default. If table has more than this then offer actions to view more. Set to nil for no limit. Probably should set default to reasonable value - I like 200. (inspect-for-emacs ((ht hash-table) inspector)) - banner line is hash table object. Respect *slime-inspect-contents-limit* (defmethod inspect-for-emacs ((array array) inspector) Respect *slime-inspect-contents-limit* * swank-openmcl.lisp inspector for closures shows closed-over values. To be fixed: inspector-princ needs to be loaded earlier since swank package not available when compiling 2005-09-13 Helmut Eller * present.lisp (menu-choices-for-presentation-id): Use lookup-presented-object secondary return value instead of *not-present*. (execute-menu-choice-for-presentation-id, presenting-object-1): Remove references to *can-print-presentation*. * slime.el (slime-current-output-id): Remove this ugly klugde. (slime-repl-insert-result): New function. Handle the presentations and other special cases cleaner. (slime-repl-insert-prompt): Use it. The `result' arg is now a structured list; update callers accordingly. (slime-repl-return): Make the prefix arg work again. (package-updating): The result of swank::listener-eval changed a bit. Update the test. Remove some unnecessary uses of `defun*' and reindent it to 80 columns. * swank.lisp: Simplify the object <-> presentation-id mapping. (save-presented-object): Remove the optional `id' arg. (lookup-presented-object): Id should be a fixnum not some cons with fuzzy/non-documented meaning. Use the secondary return value to test for absence of the id. Update callers accordingly. (*not-present*): Deleted. Remove the repl result special cases, let the general presentation machinery handle it. (*last-repl-result-id*, add-repl-result, *current-id*) (clear-last-repl-result): Deleted. (listener-eval): Don't *current-id* to tag result values. (*can-print-presentation*): Deleted. Nobody quite knows whether it's still needed so let just try without it. Updated referrers accordingly. (eval-region, run-repl-eval-hooks): Move the eval hook stuff to a separate function. * swank-loader.lisp (lisp-version-string)[cmu]: Replace spaces with underscores. 2005-09-12 NIIMI Satoshi * swank.lisp, slime.el, swank-clisp.lisp, swank-sbcl.lisp: add EUC-JP as coding system. This patch eliminates the requirement of Mule-UCS to use Japanese characters. (Nice for pre-22 Emacs users.) 2005-09-10 Matthias Koeppe * slime.el (slime-enable-evaluate-in-emacs): Resurrected. (slime-dispatch-event): Respect slime-enable-evaluate-in-emacs for messages :eval-no-wait and :eval. 2005-09-09 Alan Ruttenberg * slime.el (slime-choose-overlay-region). Don't try to overlay a note if location is nil. 2005-09-08 Alan Ruttenberg * bridge.el Fix bug in bridge filter where a bridge message which straddled a packet would be mishandled. Sometimes this would result in spurious bridge message text being inserted with the presentation and the presentation not being sensitive. In other cases there would be an actual error. Introduce bridge-leftovers to save the last, unfinished bit for the next call, and prepend it before processing a chuunk. Also, fix the parentheses so that the unwind protect cleanup forms are actually in the cleanup section. In openmcl, where apparently communication with slime is done in 2k chunks, you can trigger the bug with something like this: (swank::presenting-object 'foo t (dotimes (i 2040) (write-char #\:))) * swank-openmcl.lisp (handle-compiler-warning). Don't create a location if the condition doesn't have a filename. If it does, make sure you pass a string rather than a pathname object otherwise you get a net-read error 2005-09-07 Matthias Koeppe * present.lisp (menu-choices-for-presentation): The Inspect/Describe/Copy items are now provided from the Emacs side. Implement all pathname menu items without having Emacs evaluate a form. Fix for Lisps where ".lisp" is parsed as :name ".lisp". * slime.el (slime-menu-choices-for-presentation): New function, return a menu with Inspect/Describe/Copy plus the items that come from the menu protocol. (slime-presentation-menu): Security improvement for the presentation menu protocol: Don't eval arbitrary forms coming from the Lisp. Minor cleanup: Use x-popup-menu in the normal Emacs way, associating a command with each menu item. 2005-09-05 Helmut Eller * swank-cmucl.lisp (background-message): New function. Forward the call to the front end. (pre-gc-hook, post-gc-hook): Use it. (swank-sym, sending-safe-p): Deleted. * swank.lisp (y-or-n-p-in-emacs): Simplify arglist. (evaluate-in-emacs, dispatch-event, send-to-socket-io): Remove evaluate-in-emacs stuff. (to-string): Undo last change. to-string is not to supposed to ignore errors. Bind *print-readably* instead. (background-message): New function. (symbol-external-p): Simplify it a little. * slime.el (slime-setup-command-hooks): Add after-change-functions only if presentations are enabled. (slime-dispatch-event, slime-enable-evaluate-in-emacs) (evaluate-in-emacs): Remove evaluate-in-emacs stuff. It was not used and redundant. (slime-save-some-lisp-buffers): Renamed from save-some-lisp-buffers. (slime-choose-overlay-region): Ignore :source-form locations. (slime-choose-overlay-for-sexp): Ignore errors when stepping over forms. (slime-search-method-location, slime-goto-location-position): Move all this regexpery to its own function. (slime-recenter-if-needed, slime-repl-return): Factor some duplicated code into its own function. (slime-presentation-bounds, slime-presentation-around-point) (slime-presentation-around-or-before-point): Minor cleanups. 2005-09-04 Matthias Koeppe * slime.el (slime-ensure-presentation-overlay): New. (slime-add-presentation-properties): Don't add face, mouse-face, keymap text properties. Call slime-ensure-presentation-overlay to implement them via overlays. (slime-remove-presentation-properties): Don't remove these text properties. Delete the right overlay. (slime-after-change-function): Add overlays for presentations if necessary. (slime-copy-presentation-at-point): Don't add face text property. (slime-repl-grab-old-output): Likewise. 2005-08-31 Marco Baringer * swank.lisp (to-string): Handle errors during printing of objects. 2005-08-30 Alan Ruttenberg * slime.el (slime-mark-presentation-start/end-handler) modify regexp to recognize negative presentation ids to make presenting-object work with bridge mode. 2005-08-30 Luke Gorrie * present.lisp: Added public domain dedication (OK'd by Alanr and Matthias on the list). 2005-08-29 Matthias Koeppe * swank-lispworks.lisp (env-internals:confirm-p): Use new function y-or-n-p-in-emacs rather than eval-in-emacs. * swank-cmucl.lisp (eval-in-emacs): Removed. (send-to-emacs): New. (pre-gc-hook, post-gc-hook): Use new protocol message :background-message rather than eval-in-emacs. * swank.lisp (dispatch-event, send-to-socket-io): Handle new messages :y-or-n-p, :background-message. (y-or-n-p-in-emacs): New function. * slime.el (slime-dispatch-event): Handle new messages :y-or-n-p, :background-message. (slime-y-or-n-p): New. 2005-08-29 Alan Ruttenberg * slime.el (sldb-insert-condition) - Add tooltip for long condition string which otherwise falls off the right of the screen * swank.lisp (list-threads) - thread name might be a symbol - pass the symbol name when that happens 2005-08-29 Juho Snellman * swank-sbcl.lisp (make-weak-key-hash-table): Remove the implementation; SBCL doesn't actually support weak hash-tables. 2005-08-28 Matthias Koeppe * slime.el (slime-repl-kill-input): New command. (slime-repl-mode-map): Bind it to C-c C-u, like in comint. (slime-repl-easy-menu): Include it in the REPL menu. (slime-repl-mode-hook): Show the SLIME menu in the REPL too. * swank-backend.lisp (make-weak-key-hash-table) (make-weak-value-hash-table): New interfaces. * swank-cmucl.lisp (make-weak-key-hash-table): Implement it. * swank-sbcl.lisp (make-weak-key-hash-table): Implement it. * swank-openmcl.lisp (make-weak-key-hash-table) (make-weak-value-hash-table): Implement it. * swank.lisp (*object-to-presentation-id*) (*presentation-id-to-object*): Use new functions make-weak-key-hash-table, make-weak-value-hash-table. * slime.el (slime-enable-evaluate-in-emacs): New variable. (evaluate-in-emacs): Security improvement: If slime-enable-evaluate-in-emacs is nil (the default), don't evaluate forms sent by the Lisp. * swank.lisp (send-to-socket-io): Handle :evaluate-in-emacs. 2005-08-27 Matthias Koeppe * slime.el (slime-presentation-menu): When an object is no longer recorded, remove text properties from the presentation. 2005-08-15 Alan Ruttenberg * swank-openmcl.lisp (condition-source-position) ccl::compiler-warning-stream-position is sometimes nil, so placate this function by making it (or .. 0). Wrong but I don't have enough time now to figure out what the right thing is. 2005-08-24 Marco Baringer * swank.lisp (fuzzy-find-matching-symbols): When completing the string "package:" present a list of all the external symbols in package (completing "package::" lists internal symbols as well). (inspect-for-emacs standard-class): List all the slots in the class (as per standard-object). The previous method of hard coding the slots in the inspector's code made inspecting custom meta-classes useless. 2005-08-24 Christophe Rhodes * swank-sbcl.lisp (method-definitions): present qualifiers (if any). 2005-08-23 Taylor R. Campbell * slime.el (slime-goto-location-position): Added a second regexp for the :function-name case which matches "(def... ((function-name ..." (with N opening parens preceding the function name). This is to allow scheme48 style function names and definitions. 2005-08-22 Wolfgang Jenkner * swank-clisp.lisp (fspec-pathname): Cope with CVS CLISP's (documentation symbol 'sys::file) returning a list. Return either a list of start and end line positions or nil as second value. (fspec-location): Use it. Also, if we have to guess the name of a source file make sure that it actually exists. (with-blocked-signals, call-without-interrupts): Don't add :linux to *features* since this changes the return value of unique-directory-name in swank-loader.lisp. Comment out with-blocked-signals. Update some comments at the top of the file. State the licence in the same terms as slime.el does. 2005-08-21 Matthias Koeppe * present.lisp (menu-choices-for-presentation-id): Check against the gensym in *not-present* instead of :non-present. 2005-08-20 Christophe Rhodes * swank-sbcl.lisp (preferred-communication-style): guard against non-Linux non-linkage-table platforms (and assume that they won't have dodgy threads) with #+linux. 2005-08-20 Matthias Koeppe Enable nested presentations. * slime.el (slime-presentation): Remove slots start-p, stop-p. (slime-add-presentation-properties): Use a new text property layout. Also add an overlay to enable nested highlighting. (slime-remove-presentation-properties): New. (slime-presentation-whole-p): Changed interface. (slime-presentations-around-point): New. (slime-same-presentation-p): Removed. (slime-presentation-start-p, slime-presentation-stop-p): New. (slime-presentation-start, slime-presentation-end): Changed to use new text property layout. (slime-presentation-bounds): New. (slime-presentation-around-point): Reimplemented to handle nested presentations. (slime-for-each-presentation-in-region): New. (slime-after-change-function): Use slime-remove-presentation-properties and slime-for-each-presentation-in-region. (slime-copy-presentation-at-point): Complain if no presentation. (slime-repl-insert-prompt): Don't put rear-nonsticky text property. (slime-reify-old-output): Handle nested presentations. (slime-repl-return): Use slime-presentation-around-or-before-point. Enable reification of presentations in non-REPL buffers. * slime.el (slime-buffer-substring-with-reified-output): New, factored out from slime-repl-current-input. (slime-repl-current-input): Use it here. (slime-last-expression): Use it here. (slime-add-presentation-properties): Add text properties modification-hooks et al. to enable self-destruction of incomplete or edited presentations in non-REPL buffers. 2005-08-15 Alan Ruttenberg * slime.el (slime-goto-location-position) fix so the :method locator regexp so that it can find eql specializers, (setf foo) methods, and to allow (a single) newline between arguments in the arglist. * swank-openmcl.lisp (specializer-name) patch from Gary Byers and Bryan O'Conner to fix complaint about certain classes slipping through the etypecase 2005-08-14 Matthias Koeppe * slime.el (slime-mark-presentation-end): Really remove the presentation-start entry from the hash table. Merge some code from present.lisp, removing code duplication. Minor code clean-up. * swank.lisp (*object-to-presentation-id*) (*presentation-id-to-object*, clear-presentation-tables) (*presentation-counter*, lookup-presented-object): Move here from present.lisp. (save-presented-object): Likewise. Assign negative numbers only, so as not to clash with continuation ids. * swank.lisp (*repl-results*): Removed. * swank.lisp (get-repl-result, clear-repl-results): Use new implementations from present.lisp. (add-repl-result): Likewise, don't take the negative of the id. (*last-repl-result-id*): New variable. (clear-last-repl-result): Use it here. * slime.el (slime-repl-insert-prompt): Don't take the negative of the id. (slime-presentation-expression): New, take care to handle arbitrary *read-base* settings. (reify-old-output): Use it here. (slime-read-object): Use it here. 2005-08-12 Matthias Koeppe * slime.el (substring-no-properties): Fix to handle non-zero start argument correctly. Patch to remove use of the slime-repl-old-output text property in favor of the slime-repl-presentation text property, in order to simplify the code. * slime.el (slime-presentation-whole-p): Generalize to work with strings too. (slime-presentation-start, slime-presentation-end): Likewise. (slime-presentation-around-point): Likewise. (slime-presentation-around-or-before-point): New. * slime.el (reify-old-output): Use slime-repl-presentation property and slime-presentation-around-point function rather than slime-repl-old-output property. (slime-repl-return): Use slime-repl-presentation rather than slime-repl-old-output. (slime-repl-grab-old-output): Use slime-presentation-around-or-before-point. (slime-read-object): Use slime-presentation-around-point. * slime.el (toplevel): Don't handle slime-repl-old-output text property. (slime-add-presentation-properties): Likewise. (slime-after-change-function): Likewise. 2005-08-12 Yaroslav Kavenchuk * swank-clisp.lisp (fspec-pathname): Use the documentation function instead of accessing clisp internals. 2005-08-11 Edi Weitz * swank.lisp (transpose-lists): Fixed it. 2005-08-10 Alan Ruttenberg * slime.el move slime-repl-add-to-input-history to slime-repl-send-input so we can see the presentations we copied to input when we reuse history rather than #.(blah...) [Thanks Matthias! - was very busy and just returned to see your changes merged. Most excellent.] 2005-08-10 Matthias Koeppe * slime.el (slime-presentation-around-point): Change interface, return presentation as primary return value. (slime-copy-presentation-at-point): Use slime-presentation-around-point. Copying now also works when the first character is clicked and when the REPL buffer is not current. (slime-presentation-menu): Use slime-presentation-around-point. 2005-08-10 Martin Simmons * swank-lispworks.lisp (defadvice compile-file): Return all values from the real compile-file. 2005-08-10 Edi Weitz * swank.lisp (transpose-lists): Replaced with much nicer function by Helmut Eller. 2005-08-09 Matthias Koeppe * slime.el (slime-read-object): Handle ids that are conses. Patch by "Thas" on #lisp. 2005-08-09 Edi Weitz * swank.lisp (transpose-lists): Reimplemented without APPLY so we don't have problems with CALL-ARGUMENTS-LIMIT. 2005-08-08 Matthias Koeppe * slime.el (undo-in-progress): Define for XEmacs compatibility. Reported by Friedrich Dominicus. 2005-08-07 Matthias Koeppe Fix for the presentations menu. Reported by Aleksandar Bakic. * present.lisp (lookup-presented-object): Handle ids that are conses. (execute-menu-choice-for-presentation-id): Use equal for comparing ids, to handle the cons case. (menu-choices-for-presentation): Quote the presentation id, as it can be a cons. * slime.el (slime-presentation-menu, slime-presentation-menu) (slime-inspect-presented-object): Quote the presentation id. 2005-08-06 Matthias Koeppe * swank.lisp (form-completion): New generic function, factored out from complete-form. (complete-form): Factor out form-completion. (form-completion): Specialize on defmethod forms to insert arglist of generic function. * doc/slime.texi (Programming Helpers): Document C-c C-s, slime-complete-form. 2005-08-04 Matthias Koeppe Improvements to the presentations feature. Parts of presentations can be copied reliably using all available Emacs facilities (not just kill-ring-save), and they are no longer "semi-readonly" (in the sense that keypresses are silently ignored). Whenever a user attempts to edit a presentation, it now simply turns into plain text (which is indicated by changing the face); this can be undone. Presentations are now also supported if *use-dedicated-output-stream* is nil. It is now possible to access the individual values of multiple-value results. For some systems (Allegro CL and upcoming CMUCL snapshots), presentations can be reliably printed through pretty-printing streams. * present.lisp (slime-stream-p) [allegro]: Allow printing presentations through pretty printing streams. [cmu]: Allow printing presentations through pretty printing streams, if CMUCL has annotations support and we are using the bridge-less protocol. [sbcl]: Allow printing presentations through indenting streams. * present.lisp (write-annotation): New function. (presentation-record): New structure. (presentation-start, presentation-end): New functions, supporting both bridge protocol and bridge-less protocol. (presenting-object-1): Use them here. * present.lisp [sbcl, allegro]: Add printer hooks for unreadable objects and pathnames. * swank.lisp (*can-print-presentation*): New variable, moved here from present.lisp. * swank.lisp (interactive-eval, listener-eval, backtrace) (swank-compiler, compile-file-for-emacs, load-file) (init-inspector): Bind *can-print-presentation* to an appropriate value. * present.lisp: Remove code duplication with swank.lisp for the functions above. * swank.lisp (encode-message): Don't use the pretty printer for printing the message length. * slime.el (slime-dispatch-event): New events :presentation-start, :presentation-end for bridge-less presentation markup. * swank.lisp (dispatch-event, send-to-socket-io): Likewise. * swank.lisp (listener-eval): Store the whole values-list with add-repl-result. * slime.el (slime-repl-insert-prompt): Accept a list of strings, representing individual values of a multiple-value result. Mark them up as separate presentations. (reify-old-output): Support reifying individual values of a multiple-value result. * slime.el (slime-pre-command-hook): Don't call slime-presentation-command-hook. (slime-post-command-hook): Don't call slime-presentation-post-command-hook. (slime-presentation-command-hook): Removed. (slime-presentation-post-command-hook): Removed. * slime.el (slime-presentation-whole-p): New. (slime-same-presentation-p): New. (slime-presentation-start, slime-presentation-end): New. (slime-presentation-around-point): New. (slime-after-change-function): New. (slime-setup-command-hooks): Install slime-after-change-function as an after-change-function. * slime.el (slime-repl-enable-presentations): Make slime-repl-presentation nonsticky. (slime-mark-presentation-start, slime-mark-presentation-end): New functions. (slime-mark-presentation-start-handler): Renamed from slime-mark-presentation-start. (slime-mark-presentation-end-handler): Renamed from slime-mark-presentation-end. (slime-presentation): New structure. (slime-add-presentation-properties): New function. (slime-insert-presentation): New function. 2005-08-03 Zach Beane * swank-sbcl.lisp (swank-compile-string): Restore honoring of *trap-load-time-warnings*. 2005-08-03 Juho Snellman * swank-sbcl.lisp: Remove SBCL 0.9.1 support. (swank-compile-string): Funcall the compiled function outside with-compilation-hooks to prevent runtime warnings from popping up a *compiler-notes* buffer. 2005-07-29 Marco Baringer * doc/slime.texi (Other configurables): Document *dedicated-output-stream-port*. * swank.lisp (*dedicated-output-stream-port*): New variable. (open-dedicated-output-stream): Open the stream on the port *dedicated-output-stream-port*. * slime.el (slime-set-default-directory): Fix typo in doc string. 2005-07-26 Matthias Koeppe * swank.lisp (inspect-for-emacs): Don't make whitespace surrounding :action buttons part of the highlighted region. * slime.el (slime-goto-location-buffer): Put "SLIME Source Form" buffer into Lisp mode. 2005-07-26 Helmut Eller * swank.lisp (compile-file-for-emacs): Accept optional external-format arg. I frogot to commit this file on 2005-07-05. * slime.el (slime-input-complete-p): Skip over strings too. 2005-07-26 Zach Beane * swank-sbcl.lisp (swank-compile-string): Revert to old string compilation behavior to fix compiler note annotations. Code from Juho Snellman. 2005-07-24 Tom Pierce * swank.lisp (format-iso8601-time): New functions. Properly formats a universal-time as an iso8601 string. (inspect-for-emacs integer): Use the new format-iso8601 function when printing an integer as a date. 2005-07-22 Marco Baringer * swank-openmcl.lisp (frame-catch-tags): Remove some debugging forms which were "polluting" the repl buffer when viewing an sldb buffer. (function-source-location): Make :error messages have the proper form (exactly one string argument). This fix also removes the issues with sending unreadble lists (containing #<...> to emacs). 2005-07-14 Helmut Eller * swank-allegro.lisp (find-external-format): Fix typo. 2005-07-06 Helmut Eller * slime.el (slime-send-sigint): Use the symbol SIGINT stead of the signal number. Suggested by Joerg Hoehle. (slime-compile-file): XEmacs needs the buffer as argument to local-variable-p. Reported by Andy Sloane. 2005-07-05 Helmut Eller The file variable slime-coding can now be used to specify the coding system to use for C-c C-k. E.g., if the file contains -*- slime-coding: utf-8-unix -*- Emacs will tell the Lisp side to call COMPILE-FILE with an external-format argument. * slime.el (slime-compile-file): Send the coding system if the buffer local variable `slime-coding' is bound. * swank-backend.lisp, swank-sbcl.lisp, swank-clisp.lisp, swank-lispworks.lisp, swank-cmucl, swank-allegro.lisp, swank-abcl.lisp, swank-corman.lisp (swank-compile-file): New optional argument `external-format'. * swank-clisp.lisp (getpid): Undo the last change. * swank-corman.lisp (spawn, thread-alive-p): More thread tweaking. 2005-07-03 Joerg Hoehle * swank-clisp (describe-symbol-for-emacs): Report :setf and :type where appropriate. 2005-07-03 Helmut Eller * slime.el (next-single-char-property-change) (previous-single-char-property-change) [xemacs]: Only define them if not present. (next-char-property-change, previous-char-property-change): Define if needed. * README: Show examples for the filenames instead of the general "/the/path/to/this/directory". Suggested by Brandon J. Van Every. * swank-corman.lisp (default-directory): Return a namestring instead of the pathname. (inspect-for-emacs, inspect-structure): Teach the inspector how to deal with structures. (spawn, send, receive): Implement rudimentary threading support. It's now possible to connect with the :spawn communication style and to bring up a listener. Unfortunately, debugging the non-primary threads doesn't work at all. Still no support for interrupt-thread. * slime.el (slime-start-swank-server): Send an extra newline before the "(swank:start-server ...". I don't know why, but this seems to fix the problem when starting CLISP/Win32. Interrupting CLISP/W32 is still horribly broken. * swank-loader.lisp (compile-files-if-needed-serially) [corman]: force-output after each file. 2005-07-02 Marco Baringer * slime.el (save-some-lisp-buffers): New Function. (slime-repl-only-save-lisp-buffers): New customizable variable. (slime-repl-compile-and-load): Use save-some-lisp-buffers. (slime-oos): Use save-some-lisp-buffers. 2005-07-01 Gábor Melis * swank-sbcl.lisp (threaded stuff): make SBCL 0.9.2.9+ work while retaining support for 0.9.2 2005-06-28 Gábor Melis * swank-sbcl.lisp (threaded stuff): horrible hack to make threaded SBCL 0.9.2 work. (also, Happy Birthday Christophe!) 2005-06-21 Edi Weitz * swank.lisp (find-matching-packages): Also use nicknames. 2005-06-13 Edi Weitz * swank.lisp (list-all-systems-in-central-registry): Delete duplicates. * swank-lispworks.lisp (unmangle-unfun): If you rename a package you should rename it everywhere... 2005-06-12 Alexey Dejneka * slime.el (slime-with-xref-buffer): fix "pgk" typo. 2005-06-12 Christophe Rhodes * swank.lisp (ed-in-emacs): allow strings as well as pathnames; don't call emacs for things that the emacs editor doesn't know how to deal with. Return T if we called emacs and NIL if not. * slime.el (slime-ed): Change a listp to consp, so that NIL arguments are correctly handled. 2005-06-11 Nikodemus Siivola * swank-sbcl.lisp: Patched for SBCL HEAD: utilize the new :source-plist functionality; maintain compatibility with 0.9.1 till 0.9.2 is out. Removed cruft left over from previous excercises in supporting both HEAD and latest release. * doc/slime.texi: Document Slime as supporting the latest official release of SBCL, as opposed to a specific version number which would need to be updated monthly. 2005-06-10 Helmut Eller * nregex.lisp (slime-nregex): Rename package to avoid name clashes with other version of this file. * swank.lisp (compiled-regex): Use the new package name. * slime.el (slime-with-xref-buffer): Gensym package too, to avoid problems when switching to buffers with -*- package: ... -*- file variables. From Antonio Menezes Leitao. (slime-property-bounds): Use the prop argument instead of the hardcoded 'slime-repl-old-output. From Andras Simon. 2005-06-07 Espen Wiborg * swank-corman.lisp: Convert to Unix line-endings. (create-socket): Pass through the port argument unmodified, gettting a random port if 0. Requires supporting change in /modules/sockets.lisp. (inspect-for-emacs): defimplementation instead of defmethod. 2005-06-06 Espen Wiborg * doc/slime.texi, PROBLEMS: Added notes about CCL. 2005-06-03 Helmut Eller * slime.el (slime-background-activities-enabled-p): Allow background stuff in repl-mode buffers too. * swank-cmucl.lisp (sis/misc): Return t for :interactive-p. 2005-06-01 Helmut Eller * slime.el (slime-load-system, slime-oos): Fix bug related to file locking. Don't bind the variable system-name. system-name is a predefined Emacs variable and is used among other things for lock filenames. 2005-06-01 Joerg Hoehle * swank-clisp (getpid): Updates for current CLISP versions. Use defimplementation. Define always (slime needs it). 2005-06-01 Helmut Eller * slime.el (slime-background-activities-enabled-p): Return nil instead of signalling an error if there is a open but no default connection. (slime-current-connection): New helper function. (slime-connection): Use it. (slime-first-change-hook): Only run when slime-background-activities-enabled-p. 2005-06-01 Joerg Hoehle * swank-cmucl.lisp, swank-sbcl.lisp, swank-clisp.lisp (describe-symbol-for-emacs): Distinguish macro and special operators from functions. * slime.el (slime-print-apropos): Must keep in sync with above, therefore added :macro and :special-operator properties. * swank.lisp (present-symbol-before-p): Make it conform to its specification -- sort first by package and then by symbol name. * swank-clisp.lisp (describe-symbol-for-emacs): Report :alien-type when the name is known as foreign type. 2005-06-01 Espen Wiborg * swank-loader.lisp: Redefine compile-files-if-needed-serially for Corman Lisp to load everything from source. 2005-05-27 Espen Wiborg * swank-corman.lisp: New file, swank for Corman Lisp. * swank.lisp (simple-announce-function): force-output after announcing. (symbol-external-p): Be extra paranoid about the symbol's package; find-symbol barfs on a nil package in Corman Lisp. * swank-loader.lisp: Add Corman Lisp support. 2005-05-24 Alan Ruttenberg * slime.el text-property-default-nonsticky not defined in xemacs. oops. 2005-05-24 Alan Ruttenberg * slime.el meta-w now removes properties before insertion if you cut just a portion of the presentation. Added xemacs support. Enabled in xemacs. 2005-05-23 Alan Ruttenberg * slime.el slime-presentation-menu - use with-current-buffer, so that menus work even if you are not in the buffer with the presentation. * present.lisp More menu items for pathnames. Remember last slime-stream-p value. *can-print-presentation* t during swank-compiler and during presentation menu action. 2005-05-22 Alan Ruttenberg * present.lisp. (slime-stream-p) check if a stream is destined for output in a slime listener. (checks *connections* looks int o pretty-print streams in openmcl and cmucl) Don't present unless (slime-stream-p stream). Variable *enable-presenting-readable-objects* The only readable object which is presented are pathnames (e.g. pathnames printed when loading and *load-verbose* is t). Try the useful menu :) More to come if this doesn't cause problems. (nil this if it does) *can-print-presentation* t around compile-string-for-emacs, load-file, interactive-eval. In cmucl, use fwrappers to modify behaviour rather than redefinition. 2005-05-22 Alan Ruttenberg * present.lisp. mouse-3 now gives a menu for actions on the presentation. See documentation in file for information about how to define menus. Also, disable presentations in inspector. Initial bits of dealing with the possibility of presenting readable objects. * slime.el support menu. Xemacs users beware this uses x-popup-menu, which may be fsf specific. 2005-05-20 Alan Ruttenberg * swank.lisp make repl output presentation work even if present.lisp not loaded 2005-05-20 Luke Gorrie * slime.el (slime-repl-enable-presentations): Default is enabled in GNU Emacs but disabled in XEmacs. Feature is not portable yet. Brutally 80-column'ified alanr's latest changes :-) 2005-05-20 Alan Ruttenberg * bridge.el new file. from ilisp cvs distribution to collect in-band messages using process filter mechanisms. One edit which calls bridge-insert with process argument as well as output * present.lisp new file. Enough code to do the following: (swank::presenting-object object stream (print "This is really object")). This makes the string "This is really object" behave like old repl input for the object. Sample code for openmcl and cmucl that hooks this into the printing of unreadable objects This should be part of swank.lisp (and lisp specific files) but I am too chicken to merge yet. For now you have to load this file manually. * slime.el changes to support above: slime-repl-enable-presentations: customize to enable this stuff. Default value t. Set to nil to turn it off. slime-presentation-start-to-point: map object ids to the (point) where they start to print out. slime-mark-presentation-start, slime-mark-presentation-end. handlers for the bridge messages. slime-open-stream-to-lisp: When enabled start the bridge and define the handlers. 2005-05-19 Alan Ruttenberg * slime.el slime-presentation-map 2005-05-20 Luke Gorrie * swank.lisp (clear-repl-results): Fixed unbalanced parens. Thanks Lawrence Mitchell. 2005-05-19 Alan Ruttenberg * slime.el (slime-presentation-command-hook) new function for nicer behaviour for presentations. (slime-pre-command-hook) do slime-presentation-command-hook (slime-post-command-hook) put pre-command-hook back if goes away (slime-copy-presentation-at-point) mouse-2 copies previous output to point slime-repl-output-mouseover-face what the old output looks like when the mouse moves over it default: box around it like on lispm (slime-repl-insert-prompt) add mouseover face, mouse action. newline after output not propertized. (slime-property-bounds) adjust for lack of propertized newline to fix: presentation region behaviour should be attach to generic property like (:acts-as-token t ) rather than tying to repl-output property 2005-05-19 Luke Gorrie * swank.lisp (*record-repl-results*): Variable to enable/disable recording of REPL results. True by default. (*repl-results*): Renamed from ****. * slime.el (slime-property-bounds): Factored out this common part of slime-repl-grab-old-{input,output}. (slime-read-object): Avoid inline CL code. 2005-05-18 António Menezes Leitão * slime.el (slime-repl-inputed-output-face): new face. (slime-current-output-id): New variable. (slime-dispatch-event): Bind slime-current-output-id when neccessary. (slime-repl-insert-prompt): Add the neccessary text properties to the result. (reify-old-output): New function which makes sure swank sees \(swank::get-**** ...) while the user sees the printed representation of the object. (slime-repl-return): When called on a old output (as per the slime-repl-old-output text property, call slime-repl-grab-old-output. (slime-repl-send-input): Added the slime-repl-old-input text property. (slime-repl-grab-old-input): Keep the old input's text properties (unwanted text properties are removed later). (slime-repl-grab-old-output): New function. (slime-repl-clear-buffer): Added call to swank::clear-**** (slime-repl-clear-output): Added call to swank::clear-**** and bind inhibit-read-only to nil. (slime-inspect): Call slime-read-object to get the value to inspect. (slime-read-object): New function which either reads an object from the minibuffer or returns the object at point if it has the slime-repl-old-output text property. * swank.lisp (*current-id*, ****): New variables. (add-****, get-****, clear-last-****, clear-****): New functions for manipulating the repl history. (listener-eval): Add * to ****. 2005-05-12 Alan Ruttenberg * swank.lisp Add ability to customize behavior of the repl. To do so, add a function to the list swank::*slime-repl-eval-hooks*. This function is passed the form typed into the repl. The function should decide whether it wants to handle evaluation of the form. If not, call (repl-eval-hook-pass) and the next hook is tried. Otherwise the values the function returns are used instead of calling eval. Inside the body of the function you can also suppress having the repl print the result by calling (repl-suppress-output) and/or suppress the advancement of the history variables (*** ** * /// // /) by calling (repl-suppress-advance-history). 2005-05-11 Tim Daly Jr. * swank-source-path-parser.lisp (read-and-record-source-map): Ensure that at least the toplevel form is in the source-map. 2005-05-11 Helmut Eller * slime.el (slime-remove-old-overlays): Remove overlays in all slime buffers not only in the current buffer. (slime-filter-buffers): New helper. (slime-display-completion-list): Take the completed prefix as additional argument to initialize completion-base-size. This is apparently needed to make mouse-selection working. (slime-maybe-complete-as-filename): Factor for common code in slime-complete-symbol* and slime-simple-complete-symbol. 2005-05-06 Alan Ruttenberg * swank-openmcl.lisp specializer-name didn't handle structure-class which caused meta-. of methods specialized on defstruct arguments to fail. 2005-05-06 Helmut Eller * swank-cmucl.lisp (post-gc-hook): Include the elapsed time and the size distribution. 2005-05-05 Edi Weitz * swank-lispworks.lisp (unmangle-unfun): New function to convert strange symbols in SETF package to SETF function names. (signal-undefined-functions): Use it. 2005-05-04 Edi Weitz * swank-lispworks.lisp (call-with-compilation-hooks): Provide better implementation. (compile-file-and-collect-notes): Advice for COMPILE-FILE so pathname information for undefined functions can be recorded. (*within-call-with-compilation-hooks*): New special variable used by CALL-WITH-COMPILATION-HOOKS. (*undefined-functions-hash*): New special variable to record pathname information for undefined functions. (signal-error-database): Make LOCATION parameter optional, use FILENAME info from error database if not provided. (signal-undefined-functions): Make LOCATION parameter optional, use info from *UNDEFINED-FUNCTIONS-HASH* if not provided. 2005-05-03 Luke Gorrie * swank.lisp (slime-secret): Removed #+unix conditional, suggested by Edi Weitz. 2005-05-02 Mark Wooding * swank.lisp: If ~/.slime-secret exists then insist that Emacs sends the contents (as a password) during initial handshaking. (announce-server-port): Use :IF-EXISTS :ERROR to prevent bad guys from slipping a symlink into /tmp and reading what port Lisp is listening on. * slime.el: If ~/.slime-secret exists then send it, as per above. 2005-05-01 Marco Baringer * slime.el (slime-inspector-reinspect): New function which reinspects the current object. (slime-inspector-mode-map): Bind slime-inspector-reinspect to g. 2005-04-29 Dan Pierson * slime.el (slime-parse-context): Fix method parsing so that pressing, say, C-c C-t when point is on a '-' in a symbol name won't break. (slime-browser-map): New variable. Add support for the common 'q' keystroke to quit out of the xref. (slime-fetch-browsable-xrefs): New function. Remove the (FLET ...) entries which appear on at least CMUCL. I don't believe you can actually expand them on any current implementation and they just mess up the browse tree. Use only the method name when looking up (METHOD ...) entries on CMUCL. This really shouldn't be here, but I can't see how to avoid the error thrown by swank:xref. (slime-expand-xrefs): Use it. (slime-call-with-browser-setup): Initialize slime-buffer-package properly. Previously, lisp-mode was called after setting it, but lisp-mode clears all local variables, use lisp-mode-variables instead. * swank-cmucl.lisp (toggle-trace): Be more carefully when tracing methods: try both (METHOD ...) and (PCL:FAST-METHOD ...). 2005-04-27 Helmut Eller * swank-cmucl.lisp (+header-type-symbols+): Drop the third arg to apropos-list; it's no longer supported in recent CMUCLs. 2005-04-21 Luke Gorrie * swank.lisp (arglist-to-string): Rolled back the previous change because it interferred with values appearing in parameter lists. 2005-04-20 Luke Gorrie * swank.lisp (arglist-to-string): Bind *PRINT-ESCAPE* to NIL. This way symbols in arglists are printed as with PRINC, i.e. without package qualifier. * swank-sbcl.lisp (preferred-communication-style): Use `linux_no_threads_p' alien variable to decide whether to use :SPAWN. From dan_b for compatibility with new SBCLs. 2005-04-19 Helmut Eller * PROBLEMS: Warn about old kernels. * swank-backend.lisp: Fix some typos. * swank-sbcl.lisp (preferred-communication-style): Don't test for sb-futex, it has lost its meaning in 0.8.21. 2005-04-18 Helmut Eller * slime.el (inferior-lisp-program): Defvar it here, in case it is not defined in loaddefs and inf-lisp is not loaded. (That's the case in XEmacs.) * mkdist.sh: update version number. * doc/slime.texi: Update version numbers for SBCL and ACL. 2005-04-17 Peter Seibel * swank-loader.lisp (*implementation-features*): Added features for GCL and ECL ... (lisp-version-string): ... and code to compute version string. (Supplied by someone who's email I've misplaced.) 2005-04-14 Helmut Eller * slime.el (slime-selector): Discard input after sleeping. 2005-04-09 Helmut Eller * slime.el (sldb-get-buffer): Create a fresh buffer if there's no buffer for the connection (and don't reuse an existing buffer even if it has a matching name). (slime-buffer-visible-p, slime-ir1-expand): Delete unused functions. Mark some others as unused, but leave them there because they are potentially useful. * swank.lisp (with-io-redirection, with-connection) (with-buffer-syntax): Implement macros with `call-with' functions to avoid some code bloat. (call-with-connection, maybe-call-with-io-redirection) (call-with-buffer-syntax): New functions. (interactive-eval): Use from-string instead of read-from-string to avoid problems whit *read-suppress*. * swank-sbcl.lisp: Add a few comments. * swank-abcl.lisp (print-frame): Trim whitespace to make the backtrace look a bit terser. 2005-04-07 Helmut Eller * slime.el (slime-net-coding-system): More fixes for non-mule-XEmacsen. (slime-net-coding-system): Even more fixes to make it for mule-XEmacs. 2005-04-05 Juergen Gmeiner * swank-lisworks.lisp (find-top-frame): If we can't find an invoke-debugger frame we take any old frame at the top. 2005-04-04 James McIlree * slime.el (find-coding-system, check-coding-system) (process-coding-system, set-process-coding-system): Dummy functions for no-mule-XEmacsen. 2005-04-04 Helmut Eller * slime.el (slime-repl-show-maximum-output): New function. Immitate the scrolling behavior of a terminal. (slime-with-output-end-mark, slime-repl-return) (slime-repl-send-input, slime-display-output-buffer): Use it (slime-lisp-implementation-version, slime-machine-instance): New connection variables. Suggested by Eduardo Muñoz. (slime-set-connection-info): Initialize them. * swank.lisp (connection-info): Include version and hostname in the result. * swank-cmucl.lisp (breakpoint-values): Fixes for CMUCL-2005-03 snapshot. * doc/slime.texi: Fix spelling errors. * cl-indent.el: Remove the file. Let the Emacs developers maintain it. 2005-04-01 Helmut Eller * slime.el (sldb-get-buffer): Initialize the buffer local variables slime-buffer-connection and slime-current-thread when creating a fresh buffer. * swank.lisp (spawn-repl-thread): Use *default-worker-thread-bindings* just like spawn-worker-thread. (wrap-sldb-vars): New function. Rebind *sldb-level* to avoid confusion with recursive errors during eval-in-frame. (eval-string-in-frame, pprint-eval-string-in-frame): Use it. * swank-allegro.lisp (eval-in-frame): Allegro's eval-form-in-context does nothing special with lexical variables in the frame. Wrap an explicit LET around the form to get similar behavior as in the other Lisps. (inspect-for-emacs (structure-object)): Remove structure related methods. It's already covered by the general case with allegro-inspect. (common-seperated-spec): Deleted 2005-04-01 Luke Gorrie * slime.el (slime-xref-mode): Summarise the most important bindings in the mode description. * metering.lisp: Now supports only CLISP and OpenMCL. Removed a lot of really ugly reader-conditionalized code, much of it for archaic lisps (#+cltl2, #+lcl3.0, #+mcl1.3.2, etc). * swank-source-path-parser.lisp (check-source-path): Signal an error if a source path is malformed. SBCL sometimes gives (NIL). (source-path-stream-position): Use it. * slime.el (slime-goto-definition): Handle :error locations here before any window/buffer changes are made. 2005-04-01 Matthias Koeppe * slime.el (slime-keys): Bind slime-edit-definition-other-window to `C-x 4 .' and slime-edit-definition-other-frame to `C-x 5 .', shadowing the equivalent find-tag... bindings. (slime-goto-definition): In the other-window and other-frame cases, make sure point does not move in the originating window, even when the definition is found in the same buffer. 2005-03-31 Luke Gorrie * doc/slime.texi (slime-selector): New section. (Inspector): Updated for the post-1.0 inspector. * slime.el (slime-selector): Removed unneeded "the" prefixes in descriptions of what the selector methods do. 2005-03-27 Helmut Eller * PROBLEMS, NEWS, doc/slime.texi: Some updates for the upcoming release. 2005-03-27 Russell McManus * swank-clisp.lisp (getpid): Try sys::process-id if sys::program-id doesn't exist. 2005-03-23 Marco Baringer * swank.lisp (commit-edited-value): Read a backquated string, instead of quating the result of read. This allows one to put ,(form) into edit-value buffers. 2005-03-22 Helmut Eller * swank-lispworks.lisp (swank-compile-string): Bind *print-radix* to t, to avoid problems if somebody uses different values for *print-base* and *read-base*. Reported by Alain Picard. (emacs-connected): Add default methods for environment-display-notifier and environment-display-debugger. 2005-03-21 Helmut Eller * swank-sbcl.lisp (locate-compiler-note): Handle errors in macros better. (source-file-source-location): Read the snippet at the right position. * swank-source-file-cache.lisp (read-snippet): Take the start position as optional argument. 2005-03-21 Helmut Eller * swank-sbcl.lisp (quit-lisp): If we are running multithreaded, terminate all other threads too. (still broken in 0.8.20.27; used to work in ~0.8.20.2.) (with-debootstrapping, call-with-debootstrapping): Remove ugly backward compatibility code. (sbcl-source-file-p, guess-readtable-for-filename): New utilities. (function-source-location): Handle work off to helper functions. (find-function-source-location): New function. Use the shebang-readtable for SBCL source files. (function-source-position, function-source-filename) (function-source-write-date, function-toplevel-form-number) (function-hint-snippet, function-has-start-location-p) (function-start-location): New helpers. (safe-source-location-for-emacs): Don't catch errors if *debug-definition-finding* is true. (inspect-for-emacs): Minor beautifications. * swank.lisp (commit-edited-value): Use buffer syntax. (compile-file-for-emacs, compile-string-for-emacs): Bind *compile-print* to nil. * swank-cmucl.lisp (call-with-debugging-environment): Rebind kernel:*current-level* 0. Useful for debugging pretty printer code. (inspect-for-emacs): Show details of interpreted functions. 2005-03-21 Luke Gorrie * swank-sbcl.lisp (function-source-location): For definitions compiled in Emacs buffers, include the :emacs-string as a :snippet hint for search-based M-. lookup. 2005-03-21 Edi Weitz * swank-loader-lisp (*implementation-features*, *os-features*, *architecture-features*): LispWorks was completely missing. 2005-03-18 Luke Gorrie * slime.el (slime-complete-symbol*-fancy): Now nil by default. 2005-03-18 Helmut Eller * swank-source-path-parser.lisp (make-source-recording-readtable): Ignore non-ascii chars. * swank-sbcl.lisp (swank-compile-string): Re-implemented. This time with temp-files and proper source-location tracking. (install-debug-source-patch, debug-source-for-info-advice): Patch SBCL's debug-source-for-info so that we can dump our own bits of debug info. (function-source-location, code-location-source-path): Rewritten to handle C-c C-c functions. Also use the source-path to locate the position. (locate-compiler-note): Renamed from resolve-note-location. (temp-file-name, call/temp-file): New utilities. (file-source-location, lisp-source-location) (temp-file-source-location, source-file-source-location) (string-source-position, code-location-debug-source-info) (code-location-debug-source-name, code-location-debug-source-created,) (code-location-debug-fun-fun, code-location-from-emacs-buffer-p) (function-from-emacs-buffer-p, function-debug-source-info) (info-from-emacs-buffer-p, code-location-has-debug-block-info-p) (stream-source-position): Lots of new helper functions. (with-debootstrapping): Moved upwards so that it can be used for source location searching. (source-location-for-emacs): Deleted 2005-03-16 Helmut Eller * slime/swank.lisp (*macroexpand-printer-bindings*): New user variable. (apply-macro-expander): Use it. (call-with-bindings): Bind variables in reverse order. Thit makes it easer to cons or push a new binding at the front the list. (with-bindings): New macro. * slime.el (slime-run-when-idle): New function to hide Emacs/XEmacs differences. (slime-process-available-input): Use it. * swank-loader.lisp (unique-directory-name): Rewritten to avoid the rather irritating warning that (warn "Don't know ...") is unreachable. 2005-03-13 Luke Gorrie * slime.el (slime-dispatch-event): Use `slime-busy-p' to control the "; pipelined request" message. This way it takes requests blocked in the debugger into account and avoids spurious messages. * swank.lisp (inspect-for-emacs symbol): Add an "unintern it" action for symbols. * swank-source-file-cache.lisp (read-snippet): Skip comments and whitespace in SBCL. The source-positions reported by SBCL are not adjusted to skip over whitespace before the definition. * swank-sbcl.lisp (function-source-location): Updated for revised sb-introspect patch: s/DEFINITION-SOURCE-CREATED/DEFINITION-SOURCE-WRITE-DATE/ * swank-loader.lisp (*os-features*): Added :mswindows. Thanks Will Glozer. 2005-03-12 Luke Gorrie * slime.el (slime-edit-value): New function on `C-c E'. Prompts for a Lisp expression, evaluates and displays the result in a new buffer for editing, and then setf's the edited value in Lisp after you press C-c C-c. Usage example: `C-c E asdf:*central-registry*' Minor docstring and pull-down-menu changes. * swank.lisp (value-for-editing, commit-edited-value): New functions for slime-edit-value. * swank-allegro.lisp (toggle-trace): Fix from Antonio Menezes Leitao. * swank-sbcl.lisp: Use swank-source-file-cache to find snippets of definitions. M-. is now much more robust to modifications in the source file. NOTE: To be effective requires a patch to sb-introspect that I have posted to sbcl-devel. * swank-source-file-cache.lisp: Factored this into its own file, from swank-cmucl.lisp. * swank-loader.lisp, swank-cmucl.lisp: Updated for the above. 2005-03-10 António Menezes Leitão * slime.el (slime-toggle-trace-fdefinition): If there is no symbol at point then prompt for one. 2005-03-09 Peter Seibel * swank-loader.lisp (*architecture-features*): Added :pc386 for CLISP. (unique-directory-name): Change ERROR to WARN. * slime.el (slime-register-lisp-implementation): Add facility for registering lisp implementations with symbolic names that can be passed to C-u M-x slime. 2005-03-08 Peter Seibel * doc/Makefile (clean): added clean and really_clean targets. (all): and added slime.pdf to all prerequisites. * swank-loader.lisp (*implementation-features*): Whoops. Forgot CLISP. (*architecture-features*): Added :x86-64 for SBCL on AMD64 (thanks Vincent Arkesteijn) 2005-03-07 Peter Seibel * swank-loader.lisp (unique-directory-name): Replaced *lisp-name* variable with more sophisticated version that accounts for impl, impl version, os, and hardware architecture. 2005-03-07 Edi Weitz * swank.lisp: Fixed parenthesis-balancing problem. 2005-03-06 Matthias Koeppe * slime.el (slime-easy-menu): Add menu item for slime-complete-form. * swank.lisp (format-arglist-for-echo-area): Use extra-keywords to enrich the list of keywords. (arglist-to-string): Remove extraneous whitespace. (keyword-arg, optional-arg): New structures. (decode-keyword-arg, decode-optional-arg): Return structure objects rather than multiple values. (encode-keyword-arg, encode-optional-arg, encode-arglist): New functions. (arglist): New slot key-p. (decode-arglist): Handle &whole, &environment. Store more information on optional and keyword args, set arglist.key-p. (values-equal?): Removed. (print-decoded-arglist-as-template): If keyword is not a keyword symbol, quote it in the template. (extra-keywords): Return a secondary value (allow-other-keys). For make-instance, try to finalize the class if it is not finalized yet (fix for Allegro CL 6.2). If class is not finalizable, use direct slots instead of slots and indicate that the keywords are not complete. (enrich-decoded-arglist-with-extra-keywords): New function, use the secondary value of extra-keywords. (arglist-for-insertion, complete-form): Use it here. (remove-keywords-alist): New variable. (remove-actual-args): When the keyword :test is provided, don't suggest :test-not and vice versa. * swank-backend.lisp (:swank-mop package): Export finalize-inheritance. 2005-03-06 Luke Gorrie * swank.lisp: Export *LOG-OUTPUT*. 2005-03-05 Helmut Eller * slime.el (slime-net-sentinel): Always print a message when the lisp disconnects. (slime-inferior-lisp): Don't display the buffer. Let callers do that. (slime): Display the inferior buffer here. (slime-quit-lisp, slime-quit-sentinel): Use set a special sentinel and do most of the cleanups there. (slime-repl-sayoonara): Use slime-quit-lisp. (slime-restart-inferior-lisp, slime-restart-inferior-lisp-aux) (slime-restart-sentinel): Use a special sentinel to restart processes. (slime-hide-inferior-lisp-buffer): Do the windows arrangement a bit differently. Related to restart-lisp. (slime-repl-buffer): Take the connection as second optional argument. Useful for rearranging windows for dead processes. * swank-allegro.lisp (call-with-debugging-environment) (find-topframe): Hide the first 2 frames. Those are created by swank-internal functions. 2005-03-04 António Menezes Leitão * swank-allegro.lisp (process-fspec-for-allegro, toggle-trace): Handle setf functions. (tracedp): Fix free variable. * slime.el (slime-trace-query): The :defgeneric query was bogus. (slime-extract-context): Don't skip over the method name if we are already at the end of the name. 2005-03-03 Nikodemus Siivola * swank-sbcl.lisp: Fixed for latest SBCL HEAD revision and temporarily backwards-compatible with the current release. 2005-03-02 Marco Baringer * swank-loader.lisp Look for a file in the same directory as swank-loader.lisp called site-init.lisp. If it exists we load that instead of attempting to load ~/.swank.lisp. (user-init-file): Superseded by load-user-init-file. (load-user-init-file): New function. (load-site-init-file): New function. 2005-03-01 Helmut Eller * slime.el (slime-who-bindings): Bind who-specializes to C-c W a. (slime-extract-context): Renamed from name-context-at-point. (slime-beginning-of-list): Renamed from out-first. (slime-slime-parse-toplevel-form): Renamed from definition-name. (slime-arglist-specializers): Renamed from parameter-specializers. (slime-toggle-trace-function, slime-toggle-trace-defgeneric) (slime-toggle-trace-defmethod, slime-toggle-trace-maybe-wherein) (slime-toggle-trace-within): Deleted. Everything is now handled by slime-trace-query. (slime-calls-who): For symmetry with silme-who-calls. (slime-edit-definition-with-etags): Better intergration with TAGS. (slime-edit-definition-fallback-function): Mention it in the docstring. * swank-backend (calls-who, toggle-trace): New functions. (toggle-trace-function, toggle-trace-generic-function-methods, (toggle-trace-method, toggle-trace-fdefinition-wherein): Replaced by toggle-trace. * swank.lisp (*sldb-printer-bindings*, *swank-pprint-bindings*): New variables. The alists replace the variables which where previously hidden with the define-printer-variables macro. (define-printer-variables, with-printer-settings): Deleted, because the variable names where not visible in the source code. (swank-toggle-trace): Renamed from toggle-trace-fdefinition. * swank-cmucl.lisp, swank-lispworks, swank-sbcl.lisp, swank-allegro.lisp (toggle-trace): Update tracing code for new interface. 2005-02-24 Helmut Eller * slime.el (slime-dispatch-event): Add :eval-no-wait and :eval events. (slime-eval-for-lisp): New function. (sldb-buffers): Delete the variable. Use buffer-list instead. * swank.lisp: (eval-for-emacs): Use the new backend function call-with-debugger-hook. (eval-in-emacs): Cleaned up. Add support for synchronous RPCs. (receive-eval-result): New function. (dispatch-event, read-from-socket-io, send-to-socket-io): New :eval event. Rename :%apply to :eval-no-wait. (read-user-input-from-emacs, evaluate-in-emacs): Increment *read-input-catch-tag* instead of re-binding it. Reduces the danger of throwing to the wrong tag a bit. * swank-backend.lisp (call-with-debugger-hook): New function. Useful if the backend needs special incantations for BREAK. (toggle-trace-function): Add a default implementation for simple symbols. * swank-lispworks.lisp (slime-env): New class. (call-with-debugger-hook): Use env:with-environment to pop up our debugger on a BREAK. (toggle-trace-method, parse-fspec, tracedp, toggle-trace): Implement method tracing. * swank-sbcl.lisp (call-with-debugger-hook): Bind sb-ext:*invoke-debugger-hook* instead of setting it in emacs-connected. (emacs-connected): Deleted. * swank-loader.lisp (compile-files-if-needed-serially): Reduce verbosity by setting the :print argument for compile-file to nil. 2005-02-23 Helmut Eller * slime.el (slime-startup-animation, slime-repl-update-banner): Put the animation back in to keep the kids quiet. (slime-kill-without-query-p): Change default to nil. (slime-eval-describe, slime-eval-region) (slime-pprint-eval-last-expression): Fix typos in docstrings. (slime-eval/compile-defun-dwim): Deleted. We never had a key binding anyway. 2005-02-22 Helmut Eller * slime.el (slime-complete-form): Emacs 20 compatibility fix. (slime-repl-update-banner): Remove animation stuff. (slime-startup-animation): Deleted. * swank-lispworks.lisp (compute-applicable-methods-using-classes): Implement it. 2005-02-20 Matthias Koeppe Supersede the command slime-insert-arglist with the new command slime-complete-form and bind it to C-c C-s. The command completes an incomplete form with a template for the missing arguments. There is special code for discovering extra keywords of generic functions and for handling make-instance. Examples: (subseq "abc" --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 initialize-instance :after ((object foo) &key blub)) (make-instance 'foo --inserts--> :bar bar :blub blub initargs...) * swank.lisp (arglist): New struct for storing decoded arglists. (decode-arglist): New function. (arglist-keywords, methods-keywords, generic-function-keywords, applicable-methods-keywords): New functions. (decoded-arglist-to-template-string, print-decoded-arglist-as-template): New functions. (arglist-to-template-string): Rewrite using above functions. (remove-actual-args): New function. (complete-form): New slimefun. * swank.lisp (extra-keywords): New generic function. * swank-backend.lisp (:swank-mop package): Export compute-applicable-methods-using-classes. * swank.lisp (arglist-for-insertion): Use extra-keywords to enrich the list of keywords. * swank.lisp (valid-operator-symbol-p): New function. (valid-operator-name-p): Use valid-operator-symbol-p. * slime.el (slime-complete-form): New command. (slime-keys): Bind C-c C-s to slime-complete-form rather than slime-insert-arglist. 2005-02-18 António Menezes Leitão Improve the trace mechanism (on lisps that support it). SLIME is now able to trace/untrace flet/labels functions, methods and, of course, regular and generic functions. In the process support for sending code to emacs form the lisp was added. The code, elisp forms, is sent over the wire like normal lisp code, evaluated in emacs and the return value is returned back to the lisp. * slime.el (slime-dispatch-event): Added the :evaluale-in-emacs dispatch state which simply parses the message and class evaluate-in-emacs. (evaluate-in-emacs): New function. (complete-name-context-at-point, name-context-at-point, out-first, definition-name, parameter-specializers, slime-toggle-trace-fdefinition, slime-toggle-trace-function, slime-toggle-trace-defgeneric, slime-toggle-trace-defmethod, slime-toggle-trace-maybe-wherein, slime-toggle-trace-within): New functions implementing the new intelligent slime trace. * swank-backend.lisp (toggle-trace-function, toggle-trace-generic-function-methods, toggle-trace-method, toggle-trace-fdefinition-wherein, toggle-trace-fdefinition-within): New backend functions for the new trace facility. * swank.lisp (dispatch-event): Handle the :evaluate-in-emacs message type. (evaluate-in-emacs): New function. * swank-allegro.lisp (toggle-trace-generic-function-methods, toggle-trace, toggle-trace-function, toggle-trace-method, toggle-trace-fdefinition-wherein, toggle-trace-fdefinition-within): Implement. (process-fspec-for-allegro): New function. * swank-cmucl.lisp (toggle-trace-generic-function-methods, toggle-trace-function, toggle-trace-method, toggle-trace-fdefinition-wherein): Implement. (toggle-trace, process-fspec): New functions. * swank-sbcl.lisp (toggle-trace-generic-function-methods, toggle-trace-function, toggle-trace-method, toggle-trace-fdefinition-wherein): Implement. (toggle-trace, process-fspec): New functions. 2005-02-02 Helmut Eller * slime.el: Require the timer package explicitly. 2005-02-02 Luke Gorrie * slime.el (slime-repl-send-input): Move some properties of old REPL input (e.g. read-only) from text properties into an overlay, so that kill/yank will leave them behind. Left `slime-repl-old-input' as a text properties because it's more convenient to lookup that way. (slime-repl-return): Ignore `slime-repl-old-input' property if the point is in front of the current REPL prompt, i.e. if the user has copy&pasted some old REPL input into the current input area. 2005-01-30 Bryan O'Connor * slime.el (slime-goto-location-position): Changed the regexp to require the function-name to be followed by a non-symbol-constituent character \S_. Previously, a function-name of "find" first matched find-if-not if it occured earlier in the file. 2005-01-27 Helmut Eller * slime.el (slime-busy-p): Ignore debugged continuations to enable arglist lookup while debugging. Suggested by Lynn Quam. (sldb-continuations): New buffer local variable in sldb buffers to keep track of debugged continuations. (sldb-debugged-continuations): New function. (sldb-buffers): Renamed from sldb-remove-killed-buffers. (slime-eval-print): New function to insert the stream output and the result of an evaluation in the current buffer. (slime-eval-print-last-expression): Use it. (slime-interactive-eval): Use slime-eval-print when a prefix argument was given. * swank.lisp (*pending-continuations*, eval-in-emacs) (debugger-info-for-emacs): Keep track of debugged continuation the new variable *pending-continuations* and include the list of active continuations in the debugger info for Emacs. (eval-and-grab-output): New function. Used by slime-eval-print. (*log-output*): Renamed from *log-io*. Use *standard-error* as initial value instead of *terminal-io*. CMUCL opens its own tty and that makes it hard to redirect to output with a shell. *standard-error* writes its output to file descriptor 2. (*canonical-package-nicknames*): Fix typo. 2005-01-20 Helmut Eller * swank.lisp (parse-symbol): Don't break if the package doesn't exist. Reported by Lynn Quam. 2005-01-20 Ian Eslick * swank-allegro.lisp (restart-frame): Handle frames with arguments better. 2005-01-20 Edi Weitz * swank-allegro.lisp (handle-undefined-functions-warning): Prevent breakage if the undefined function is called at multiple locations. 2005-01-19 Helmut Eller * swank-gray.lisp (stream-unread-char): If the char argument doesn't match the contents in the buffer, ignore it and emit a warning instead. 2005-01-19 Utz-Uwe Haus * swank-cmucl.lisp (breakpoint): Add a slot for return values to make return values inspectable in the debugger. (signal-breakpoint): Initialize the new slot. 2005-01-19 Matthias Koeppe * slime.el (slime-insert-arglist): Inserts a template for a function call instead of the plain arglist; this makes a difference for functions with optional and keyword arguments. * swank.lisp (arglist-to-template-string): New function. (arglist-for-insertion): Use it (decode-keyword-arg, decode-optional-arg): New functions. 2005-01-19 Lars Magne Ingebrigtsen * slime.el (slime-header-line-p): Customize variable to enable/disable the header-line in the REPL. 2005-01-18 Luke Gorrie * slime.el (slime-complete-symbol*-fancy): New variable to enable extra bells and whistles with slime-complete-symbol*. Currently controls whether to use arglists semantically. Default is t. (slime-complete-symbol*-fancy-bit): Factored out this function. Only do "semantic" completion when the symbol is in function-position, avoid interning argument names in Emacs, and don't display arglists if the minibuffer is active. 2005-01-14 Luke Gorrie * slime.el (slime-repl-send-input): Make old input read-only using an overlay instead of a text property. This way if you copy&paste the input elsewhere it will become editable (overlay is associated with the buffer region and not the text). 2005-01-14 Edi Weitz * slime.el (slime-complete-symbol*): Maybe insert closing parenthesis or space (depending on arglist) after symbol completion has finished. Optionally also show arglist. 2005-01-13 Helmut Eller * swank-cmucl.lisp (create-socket): The byte-order of the :host argument for CREATE-INET-LISTENER was changed in the Jan 2005 snapshot. Test whether the symbol 'ext:socket-error exists to decide if we are in a older version. (resolve-hostname): Return the address in host byte-order. 2005-01-12 Robert Lehr * slime.el (slime-changelog-date): Return nil if the ChangLog file doesn't exits. (slime-repl-update-banner): Write "ChangeLog file not found" if the ChangeLog doesn't exist. 2005-01-12 Matthias Koeppe * slime.el (slime-inspector-operate-on-click): New command for inspecting the value value at the clicked-at position or invoking an inspector action. (slime-inspector-mode-map): Bind it to mouse-2. (slime-inspector-insert-ispec): Add mouse-face properties for clickable values and action buttons. 2005-01-12 Helmut Eller * swank.lisp (*default-worker-thread-bindings*): New variable to initialize dynamic variables in worker threads. (spawn-worker-thread, call-with-bindings): New helper functions. (thread-for-evaluation): Use them. 2005-01-10 Utz-Uwe Haus * swank-sbcl.lisp (profile-package): Add implementation for SBCL. 2005-01-10 Eduardo Muñoz * swank.lisp (inspect-for-emacs-list): LispWorks has a low args limit for apply: use reduce instead of apply. 2005-01-10 Helmut Eller * slime.el (slime-conservative-indentation): The default is now nil. Suggested by Travis Cross. 2005-01-10 Matthias Koeppe * slime.el (slime-inspector-next-inspectable-object): Accept a prefix argument and make wrapping around more reliable. The code is adapted from `widget-move'. (slime-inspector-previous-inspectable-object): New command. (slime-inspector-mode-map): Bind to S-TAB. 2004-12-16 Martin Simmons * swank-lispworks.lisp (create-socket): Work around bug in comm::create-tcp-socket-for-service on Mac OS LW 4.3. 2004-12-16 Edi Weitz * slime.el (slime-complete-symbol*): Bind comint-completion-addsuffix so unambiguous or exact completion closes the string automatically. 2004-12-16 Matthias Koeppe * slime.el (slime-keys): Bind M-* to slime-pop-find-definition-stack for compatibility with standard Emacs conventions. 2004-12-16 Helmut Eller * swank-source-path-parser.lisp (read-source-form): New function which uses *read-suppress* properly. Common code from source-path-stream-position and form-number-stream-position. (source-path-stream-position): Use it. * swank-cmucl.lisp (form-number-stream-position): Use read-source-form. * swank.lisp (frame-for-emacs): Print the frame number a little nicer with ~2D. 2004-12-15 Matthias Koeppe * slime.el (slime-lisp-modes): New variable to make C-c C-k customizable and usable in scheme-mode. (slime-compile-file): Use it. 2004-12-15 Helmut Eller * swank-cmucl.lisp, swank-backend.lisp (frame-package): Delete it. Include the package name for local variables because it is utterly confusing if `eval-in-frame' doesn't work due to missing package prefixes. * swank-source-path-parser.lisp (source-path-stream-position): Bind *read-suppress* to nil before calling read-and-record-source-map. * swank-clisp.lisp (*buffer-name*, *buffer-offset*): Move definitions upward before the first use. 2004-12-15 Bryan O'Connor * slime.el (slime-edit-definition): Switch to the other frame if the `where' is 'frame. (slime-edit-definition-other-frame): New function. 2004-12-15 Helmut Eller * slime.el (slime-repl-send-input): Make the input read-only to avoid confusion. (slime-make-region-read-only): New function. 2004-12-13 Helmut Eller * slime.el (slime-repl-mode-map): Bind to slime-repl-bol. Suggested by Chris Capel. (slime-repl-grab-old-input): Remove the 'old-input text-property from the copied text. Reported by Tim Oates. (slime-repl-grab-old-input): Append the old input to the current input by default. If the new `replace' argument is true, replace the current input. Suggested by Antonio Menezes Leitao. (slime-repl-return): Pass the prefix argument to slime-repl-grab-old-input. 2004-12-09 Helmut Eller * swank.lisp (*sldb-print-pretty*, *sldb-print-circle*) (*sldb-print-length*, *sldb-print-level*, *sldb-print-lines*) (*sldb-print-pprint-dispatch*): Export those symbols. 2004-12-05 Helmut Eller * slime.el (slime-global-variable-name-p): Also return true for names of constants like +foo+. Suggested by Christian Lynbech. * swank-allegro.lisp (handle-compiler-warning): Handle undefined-functions warnings by looking the fromat-arguments of the condition. (compiler-undefined-functions-called-warning-p) (location-for-warning, handle-undefined-functions-warning): New functions. * swank-cmucl.lisp (*install-gc-hooks*): New user variable. (sending-safe-p): New predicate. (pre-gc-hook, post-gc-hook): Use it. * swank.lisp (eval-region): Use a simple loop. 2004-12-02 Helmut Eller * swank.lisp: (inspect-for-emacs (symbol)): Handle non-interned symbols. * slime.el (slime-repl-clear-buffer, slime-repl-clear-output): Fix docstrings. 2004-11-29 Lynn Quam * slime.el (slime-global-variable-name-p): Allow optional ":" or "::". 2004-11-29 Chris Capel * swank.lisp (macro-indentation): Ignore &whole, &aux, and &environment args. 2004-11-29 Helmut Eller * slime.el (slime-repl-wrap-history): New user variable. (slime-repl-history-replace): Implement wrap around. (slime-repl-easy-menu): Fix binding for "Next Input". Reported by Surendra Singhi. * swank-lispworks.lisp (list-callers-internal): Return the function if dspec:object-dspec returns nil. (xref-results): Previously, functions for which dspec:dspec-definition-locations returned nil were ignored. Include them with a unknown source-location. * swank-abcl.lisp, swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp, swank-lispworks (accept-connection): The :external-format argument defaults now to :iso-latin-1-unix. 2004-11-26 Helmut Eller * swank-cmucl.lisp (read-into-simple-string): Use #-cmu19 instead of #+cmu18e. 2004-11-25 Chris Capel * slime.el (slime-indent-and-complete-symbol): Echo the arglist if there's no symbol before point. Don't complete after parens. (slime-echo-arglist): Factorized from slime-space. (slime-space): Use it. (slime-repl-history-replace): Clear the input at the end of the history. * swank.lisp (arglist-to-string): Don't show &whole, &aux and &environment args. (clean-arglist): New function. 2004-11-25 Helmut Eller * slime.el (slime-net-coding-system): Emacs does funky encoding for `raw-text-unix' use `binary' instead. (slime-safe-encoding-p): New function. (slime-net-send): Use it and don't try to send stuff which can't be decoded by Lisp. (slime-inferior-lisp-program-history): XEmacs compatibility: declare it as a variable. (slime-xref-mode): In Emacs 21, set delayed-mode-hooks to nil because we don't want to run the lisp-mode-hook. Reported by Chris Capel. * swank.lisp (dispatch-loop): Catch errors and close the connection. It's almost impossible to run the debugger inside the control-thread, so let it crash instead. A backtrace would be nice, though. (cleanup-connection-threads): Can now be called in the control-thread. Add a check to avoid thread suicide. (start-swank-server-in-thread): Fix the call to start-server. * swank-sbcl.lisp (%thread-state-slot, %thread-state): Refactored from thread-status. (thread-status): Use it. (all-threads): Exclude zombies. 2004-11-24 Helmut Eller * slime.el (slime-start-and-load): Use vanilla comint instead of inf-lisp. Let's try that for a while. (slime): Ask for the coding system when invoked with C-u C-u. (slime-net-coding-system, slime-net-valid-coding-systems): Add some alternatives for older Emacsen. (slime-find-buffer-package): Skip quotes. Old code looks sometimes like (in-package 'foo). (slime-repl-mode-map): Inhibit C-c C-z. Avoids accidental loading inf-lisp. (slime-net-coding-system): Use find-coding-system in XEmacs. coding-system-p means something different here. (slime-repl-mode-map): XEmacs compatibility: use (kbd "C-") instead of [C-up]. * swank.lisp (inspect-for-emacs-list): subseq on improper lists breaks in Lispworks. Handle that case better. * swank-sbcl.lisp (inspect-for-emacs)[code-component]: Disassemble code-components too. * swank-backend.lisp (import-swank-mop-symbols): Better error message for the assertion. * swank-cmucl.lisp (debug-var-value): Return #:invalid or #:unknown instead of :. (swank-compile-file): Load the fasl file only if load-p is true. (inspect-for-emacs, inspect-alien-record, inspect-alien-pointer): Add inspector support for some alien types. * swank-lispworks.lisp (emacs-connected): Set the sigint handler only for single threaded operation. I.e. when *communication-style* is nil. * swank-allegro.lisp (set-external-format): New function. Use LF as eol mark. (call-with-compilation-hooks): Trap compiler-notes too. 2004-11-24 Luke Gorrie * slime.el (slime-repl-mode-map): Add C-up and C-down to move through history. Consistent with comint-mode. (slime-repl-mode-map): Add slime-load-file on `C-c C-l' and slime-compile-file on `C-c C-k'. This is mostly to override unwanted inf-lisp bindings in lisp-mode-map. (slime-load-file): Handle (buffer-file-name) being nil. 2004-11-20 Helmut Eller * swank-sbcl.lisp (make-socket-io-stream): Add some #+sb-unicode. 2004-11-20 Travis Cross * swank-sbcl.lisp (thread-status): Fix unbalanced parenthesis. 2004-11-20 Marco Baringer * swank-openmcl.lisp (make-stream-interactive): Only add ouptut streams (subclasses of ccl:fundamental-output-stream) to ccl::*auto-flush-streams*. 2004-11-19 Helmut Eller * slime.el (slime-net-coding-system): New variable. Specifies the coding system to use for network communication. The default is iso-latin-1 and should work for all Lisps. Only a small set of coding systems is currently supported. (slime-net-valid-coding-systems): New variable. A list of coding systems which may be used. (slime-check-coding-system, slime-coding-system-mulibyte-p) (slime-coding-system-cl-name): New utility function for coding systems. (slime-net-connect, slime-make-net-buffer, slime-open-stream-to-lisp): Use it. (slime-net-decode-length, slime-net-encode-length): Renamed from slime-net-read3 and slime-net-enc3. The length is now encoded as a 6 char hex string. * swank.lisp (*coding-system*): New variable. (start-server): Accept external-format as argument. (create-server, create-swank-server, setup-server) (serve-connection, open-dedicated-output-stream) (create-connection): Ditto. (defstruct connection): Add external-format slot. (decode-message-length): New function for new length encoding. (decode-message): Use it. (encode-message): Use new encoding. * swank-cmucl.lisp (accept-connection): Accept external-format argument. (inspect-for-emacs): Add CMUCL specific versions for array and vectors. * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp, swank-clisp.lisp, swank-backend.lisp, swank-allegro.lisp, swank-abcl.lisp (accept-connection): Accept :external-format as argument. 2004-11-19 Matthew Danish * swank-allegro.lisp: (count-cr): New function. Convert file-offsets to match Emacs' eol-conventions. (find-definition-in-file): Use it. * slime.el (slime-insert-xrefs): Display the multi-line label much more cleanly. 2004-11-19 Helmut Eller * swank-sbcl.lisp (thread-status): Decode the thread-state-slot instead of returning ???. * swank-allegro.lisp (swank-mop:slot-definition-documentation): ACL 7 says documentation should have 2 args. So, pass t as second argument. (fspec-primary-name): Recurse until we have a symbol. (allegro-inspect): New function. Mostly reverse engineered from ACL's native inspector. (inspect-for-emacs (t), inspect-for-emacs (function)): Use it. * swank.lisp (inspect-for-emacs array): Use row-major-aref instead of a displaced array. I hope that does the same. (inspect-for-emacs integer): Ignore errors in decode-universal-time. Negative values and, in SBCL, also small values cannot be decoded. (list-threads): Include the thread-id. Useful for SLIME debugging. * slime.el (slime-list-threads, slime-thread-insert): Show the thread-id. (slime-thread-control-mode-map): Remove the binding for the no-longer-existent slime-thread-goahead command. 2004-11-18 Alexey Dejneka * swank.lisp (inspect-for-emacs): Fix bug in handling of arrays with fill-pointers. 2004-11-15 Helmut Eller * slime.el: The REPL commands ,quit and ,sayoonara are now distinct. Previously Quit killed all Lisps an all buffers. The new Quit command kills only the current Lisp. (slime-quit-lisp): New function. (repl-command quit): Use it. Don't delete all buffers. (repl-command sayoonara): No longer an alias for ,quit. (slime-connection-list-mode-map): Bind C-k to slime-quit-lisp. (slime-communication-style): New connection variable. (slime-use-sigint-for-interrupt): Is no longer a connection local variable. It's derived from the new slime-communication-style. (slime-inhibit-pipelining): New user option. (slime-background-activities-enabled-p): New predicate to control various background activities like autodoc and arglist fetching. (slime-space, slime-autodoc-message-ok-p): Use it. (slime-search-call-site): Use hints provided to search a call-site in a defun. Useful for the show-frame-source command. (slime-goto-source-location): Use it. (slime-quit): Deleted, as it was broken. May come back later. (slime-inspector-label-face, slime-inspector-value-face) (slime-inspector-action-face, slime-reader-conditional-face): Provide better defaults for Emacsen which don't support :inherited faces. * swank-backend.lisp (emacs-connected): Don't pass the stream as argument. make-stream-interactive is a better place for setting buffering options. * swank-cmucl.lisp (emacs-connected): Install GC hooks to display GC messages in the echo area. (sos/misc :flush-output): There seem to be funny signal safety issues if the dedicated output stream is not used. So, lets first reset the buffer index before sending the buffer to the underlying stream. * swank-lispworks.lisp (frame-source-location-for-emacs): Pass the function name of the next (newer) frame as a hint to Emacs. This way we can highlight the call site in some cases, instead of the entire defun. (frame-location): Renamed from function-name-location. The argument is now a dspec, not only a name. Also include hints for Emacs. (lispworks-inspect): Simplified from old code. (inspect-for-emacs): Use it for also for simple functions. (emacs-connected, make-stream-interactive): Move the soft-force-output stuff to make-stream-interactive. * swank-abcl.lisp (emacs-connected): Deleted. The default implementation should be good enough. * swank-sbcl.lisp (emacs-connected): Updated for new interface. * swank-openmcl.lisp (emacs-connected, make-stream-interactive): Move buffering stuff to make-stream-interactive. * swank.lisp (defstruct connection): Add new slot: communication-style for convenience. (create-connection): Initialize the new slot. (connection-info): Send the communication-style to Emacs. (install-fd-handler, simple-serve-requests): Sending :use-sigint-for-interrupt is no longer necessary. 2004-11-11 Raymond Toy * slime.el (slime-activate-font-lock-magic): Add XEmacs support. (slime-reader-conditional-face): New face. 2004-11-10 Marco Baringer * swank-backend.lisp (definterface): Eliminate unused variable received-args. (emacs-connected, make-stream-interactive, condition-references, condition-extras, buffer-first-change): Add (declare (ignore X)) for unused arguments in default implementations. (inspect-for-emacs): Remove (declare (ignore)) for inexistent variable inspection-mode. Added T qualifiers in method arguments. * swank-openmcl.lisp (inspect-for-emacs): Use definterface so SLIME knows we implement this. (arglist function): Use ccl:arglist, not ccl::arglist-from-map. (inspect-for-emacs): Added support for inspecting the uvector objects under lisp datums. 2004-11-09 Helmut Eller * swank.lisp (features-for-emacs): New function to avoid keyword/string confusion. Case doesn't matter since Emacs will downcase them anyway. (connection-info, sync-features-to-emacs): Use it. Should fix highlighting bug reported by Edi Weitz. * slime.el (slime-eval-feature-conditional): Convert AND, OR, and NOT to lowercase keywords. (slime-net-read3): Silly optimization: give char-after the offset as argument to avoid save-excursion and forward-char. 2004-11-07 Brian Downing * slime.el (slime-fuzzy-explanation): Added line to describe flags (:boundp, :fboundp, :macro, etc), which are now reported in the fuzzy-completion output. (slime-fuzzy-insert-completion-choice): Added flags. (slime-fuzzy-choices-buffer): Added flags header. * swank.lisp (fuzzy-completions): Changed docstring to describe new flags in the completion results. (convert-fuzzy-completion-result): New function to marshall the results from the completion core into something Emacs is expecting. Added flags. (fuzzy-completion-set): Use the above. (compute-completion): Removed. (score-completion): Cleaned up a little bit. (highlight-completion): Use destructive nstring-upcase. 2004-11-01 Helmut Eller * slime.el (slime-easy-menu): Add item for slime-update-indentation. Suggested by Lynn Quam. (slime-severity-faceslime-show-note-counts) (slime-most-severe, slime-choose-overlay-region): Handle read-errors. (slime-show-buffer-position): New function. (slime-show-source-location): Use it. * swank-backend.lisp (deftype severity): Add read-errors. * swank-cmucl.lisp (severity-for-emacs): Special case read-errors. (read-error-location): Add the offset to the buffer start. * swank.lisp (assign-index): Avoid linear search. 2004-10-30 Helmut Eller * swank-source-path-parser.lisp (source-path-stream-position): Bind *read-suppress* only as long as we skip over forms. The last toplevel form in the path is read with *read-suppress* = nil because in newer versions of CMUCL and SBCL read will return nil if *read-suppress* is t. 2004-10-28 Helmut Eller * swank-clisp.lisp: Ups. Undo previous change. * swank-clisp.lisp: Add workaround for CLISP's broken control string parser. * swank-cmucl.lisp (set-step-breakpoints): Handle breakpoints at single-return points in escaped frames better. Previously we tried to set a breakpoint at the current position and consequently was only hit during the next call. (inspect-for-emacs)[function]: Call the next method only for funcallable instances. (profile-report, profile-reset, unprofile-all): We have to use eval because the macro expansion depends on the value of *timed-functions*. Reported by Chisheng Huang. * slime.el (slime-space): Call slime-message in the right buffer, so that after-command hooks are added in the right buffer. Reported by Juho Snellman. (slime-dispatch-event): Accept stepping flag. (sldb-setup): Don't query when entering a recursive edit. (sldb-exit): Don't kill the buffer if we are in stepping mode. (slime-inspector-insert-ispec): New function. (slime-open-inspector): Use it. (slime-inspector-operate-on-point): Simplified. (test interactive-eval): Fix test case. (slime-kill-all-buffers): More regexp kludges. From Bill Clementson. * swank-backend.lisp (activate-stepping): New function. * swank.lisp (*sldb-stepping-p*): New variable. Used to tell emacs that the debugger buffer should not be closed even if we unwind. (debug-in-emacs): Use it. (sldb-step): Moved to the front end. (inspector-princ, method-specializers-for-inspect): Simplified. (methods-by-applicability): Use a simpler algorithm. I doubt there is much difference in practice. (inspect-for-emacs)[symbol, function, standard-generic-function] [standard-method]: Use less than 80 columns. (inspector-call-nth-action): Don't accept &rest args. Was never used. (inspect-for-emacs) [integer]: Fix control string. Thanks to CSR for pointing it out. 2004-10-27 Helmut Eller * swank-sbcl.lisp (signal-compiler-condition): Actually delete one of the reader-conditionalized forms. 2004-10-26 Helmut Eller * cl-indent.el: Add indentation specs for some missing CL symbols. (lisp-prefix-match-indentation): Change default to nil to avoid confusion for people who don't care about the issue. * swank-sbcl.lisp (signal-compiler-condition): Remove reader conditionals as the current code doesn't work in any SBCL before 0.8.13 anyway. * swank-source-path-parser.lisp: Remove workarounds for SBCL bugs. The bugs are fixed in the versions we support. * swank-cmucl.lisp (read-error-location) (signal-compiler-condition): Handle read-errors. (swank-compile-file): Don't load the fasl file if there was an error. * swank.lisp (define-printer-variables): Handle doc strings properly. (*sldb-pprint-dispatch*): Initialize it with the default dispatch table. * slime.el (slime-init-command): New function to send the command to load swank. Having a separate function for the task should make it easier to start a Lips with a preloaded swank. (slime-maybe-start-lisp): Use it. (slime-maybe-start-multiprocessing): Deleted. (slime-repl-buffer): Include the name of the implementation. (slime-set-default-directory) (slime-sync-package-and-default-directory): Translate filenames. 2004-10-25 Marco Baringer * swank.lisp (inspect-for-emacs array): Properly deal with arrays without fill pointers. (inspect-for-emacs function): Show function-lambda-expression when available. * swank-openmcl.lisp (specializer-name): New function. (who-specializes): Use it. (maybe-method-location): Use it. (function-source-location): Use it. * swank-cmucl.lisp (inspect-for-emacs function): Use next method's values and simply add cmucl specific details. * slime.el (slime-repl-defparameter): Change default value to "*". 2004-10-25 Thomas Schilling * swank-allegro.lisp (inspect-for-emacs): Use excl::external-fn_symdef to get the function documentation. * swank.lisp (inspect-for-emacs): Order generic function's methods and show abbreviated docs for methods. (abbrev-doc): New function. (methods-by-applicability): New function. (*gf-method-getter*): New variable. 2004-10-19 Luke Gorrie * slime.el (slime-show-source-location): Call `push-mark' to push the source position onto the global mark ring. 2004-10-19 Helmut Eller * swank.lisp (define-printer-variables): NIL is not a valid docstring. Reported by Alain Picard. (printer-variables sldb-print): Include print-gensym, pprint-dispatch, base, radix, array, and lines. 2004-10-17 Luke Gorrie * slime.el (slime-message): Use slime-typeout-frame if available. 2004-10-17 Helmut Eller * cl-indent.el: Our local copy. Should eventually be merged the file with in the main distribution. * slime.el: (slime-find-buffer-package-function): New variable to allow customization for unusal syntax. (slime-maybe-rearrange-inferior-lisp): Removed unused function. (slime-set-inferior-process): Non-macro version to make byte-compiler happy. Reported by Raymond Wiker. (slime-maybe-start-lisp): Use it. (slime-sync-package-and-default-directory): Synch the default-directory in the REPL buffer too. (slime-goto-connection): Close the connection list window. Suggested by Andras Simon. (slime-repl-clear-buffer): Place point after the prompt. (selector-method ?i): Use slime-process to switch to the right buffer. (slime-background-message): Do nothing if the minibuffer is active. (slime-indent-and-complete-symbol): Don't indent if we at the same line as the prompt. * swank.lisp (*sldb-pprint-frames*): Renamed to *sldb-print-pretty*. (*sldb-print-level*, *sldb-print-length*, *sldb-print-circle*) (*sldb-print-readbly): Group of new variables to customize printing in the debugger. The default values should be safe. (define-printer-variables, with-printer-settings): New macros to make defining and binding groups of printer variables easier. (inspect-for-emacs-list): Fix bug with circular lists and only shows the first 40 elements. (inspect-for-emacs): Various cleanups. (all-qualified-readnames): Removed. It was not needed because common-lisp-indent-function strips of any package prefix and downcases the symbol anyway. (printer-variables sldb-print): Ooops. Better use sldb-print as prefix than sldb alone. *sldb-level* was already defined. * swank-cmucl.lisp (inspect-for-emacs (code-component)): Disassemble the memory region if there's not enough debug info. 2004-10-17 Jan Rychter * swank-cmucl.lisp (return-from-frame): Add it. 2004-10-11 Thomas F. Burdick * swank-sbcl.lisp (function-definitions): Find compiler macros, too. (find-defintions, compiler-definitions) (optimizer-definitions, transform-definitions): Add compiler transformers and optimizers to the list of definitions. 2004-10-07 Peter Seibel * swank.lisp (spawn-threads-for-connection): Bind *debugger-hook* instead of SETF'ing it. 2004-10-06 Luke Gorrie * swank.lisp (update-indentation/delta-for-emacs): Configure Emacs indentation settings not just for the symbol name but for all package-qualified forms of it as well. * doc/slime.texi (Credits): Updated the credits list to include more Lisp implementors who're also SLIME hackers. 2004-10-05 Luke Gorrie * swank.lisp (arglist-for-echo-area): Handle errors and return a message. (parse-symbol): Recognise an empty package name as the KEYWORD package. 2004-10-03 Reini Urban * swank-clisp.lisp (getpid)[win32]: Use win32:|GetCurrentProcessId|. 2004-10-03 Helmut Eller * slime.el: Reduce dependency on inf-lisp internals. Make it possible to start the inferior lisp in a buffer different from "*inferior-lisp*". (slime): Parse the command argument explicitly and don't rely on `inferior-lisp'. Don't close all connections, but only the one for the inferior lisp buffer we are using. (slime-maybe-start-lisp): Take the command and buffer as argument. Decide here whether we should start start a new processwe or just disconnect and reconnect . (slime-start-lisp): Load verbosely. (slime-inferior-lisp): New function. Replaces call to `inferior-lisp'. (slime-inferior-connect, slime-start-swank-server): Take the inferior process as argument (slime-read-port-and-connect): Set the slime-inferior-process variable in the new connection. (slime-inferior-process): New connection local variable. (slime-process): Use it. (slime-restart-inferior-lisp): Don't use inferior lisp stuff. (slime-switch-to-output-buffer): Process interactive arguments properly. * swank-loader.lisp (compile-files-if-needed-serially): Load verbosely. 2004-10-01 Helmut Eller * swank-allegro.lisp (find-fspec-location): excl:source-file can return stuff like (:operator ...); try to handle it. * swank-cmucl.lisp (code-component-entry-points): Only include entry points with "valid" functions names. This excludes internal lambdas which have usually a string as name, like "defun foo". * swank.lisp (parse-symbol): Don't use the reader to avoid interning unknown symbols. The downside is that we no longer handle escaped |symbols| correctly. * slime.el (slime-set-connection-info): Hide the *inferior-lisp* buffer after we know Lisp's pid. Print the words of encouragement here, when all the other asynchronous initialization is completed. (slime-find-buffer-package): We need to preserve the case for things like (:in-package "foo"), so return "\"foo\"". 2004-09-27 Helmut Eller * slime.el (slime-process): New function intended to replace all those references to the *inferior-lisp* buffer. (slime-maybe-start-lisp): Split it up. (slime-start-lisp): New function. (slime-restart-inferior-lisp): Use the command from the existing process to start the new process. 2004-09-27 Christian Lynbech * slime.el (define-slime-dialect): New macro to make starting Lisps with different command line options easier. 2004-09-27 Rui Patrocínio * swank.lisp (mop, mop-helper): Support functions for the class browser. * slime.el (slime-browse-classes, slime-browse-xrefs): New commands to browse class hierarchies and xref graphs in a tree widget. * tree-widget.el: New file. Only needed for older Emacsen. 2004-09-23 Helmut Eller * slime.el (slime-start-and-load): Take arguments so that the function can be called non-interactively. Only start SLIME is if it is not running. (slime-recompile-bytecode): Don't warn about uses of cl-functions. (slime-reset): Kill all sldb buffers. (slime-goto-location-position): Fix syntax for Emacs 20. (sldb-mode-map): Add C-c C-d bindings. (slime-open-inspector): Insert the type in the second line so that we can make longer titles, e.g we should include the princed version of the inspected object. * swank-backend.lisp (frame-package, label-value-line) (label-value-line*): New functions. * swank.lisp (frame-locals-for-emacs): Bind *print-pretty* to *sldb-pprint-frames* to get more compact lines and bind *package* to frame-package to get shorter labels for variables. (format-values-for-echo-area): Include the hex and octal representation for integers. (apply-macro-expander, disassemble-symbol): Use the buffer-package for reading. (inspector-content-for-emacs): Use print-part-to-string so that we see cycles in the data structure. (inspect-for-emacs): Minor beautifications. (load-file-set-package): New function. * swank-cmucl.lisp (frame-package): Implemented. (inspect-for-emacs): Only include stuff that is actually stored in the object itself (see objdef.lisp for exact object layout). Include the disassembly for functions and code components. 2004-09-19 Helmut Eller * swank-gray.lisp (stream-read-char): Treat empty strings as end-of-file. * swank-cmucl.lisp (sis/in): Treat empty strings as end-of-file. (map-allocated-code-components): Inhibit efficiency notes. (arglist)[symbol] Delete unreachable code. (sldb-break-on-return, sldb-break-at-start): Implement it (sldb-step): Some cleanups. * swank.lisp (thread-for-evaluation): Restart the listener thread if it was dead for some reason. (debugger-condition-for-emacs): Include "extra" stuff. Currenlty only used to pop up the source buffer at breakpoints. (sldb-break): New function. (interrupt-worker-thread): Interrupt the repl thread if there is no other active thread. * swank-backend.lisp (import-swank-mop-symbols): New function. Useful if the implementation has most of the mop symbols in the same package. (sldb-break-on-return, sldb-break-at-start, condition-extras): New functions. * slime.el (sldb-break-on-return, sldb-break): New commands. (slime-repl-return-string): Allow empty strings. That's our way to send end-of-file. (sldb-insert-condition): Add "extra" slot for random thing that don't fit nicely somewhere else. (sldb-dispatch-extras): New function. (sldb-show-frame-source): New non-interactive version of sldb-show-source. (sldb-show-source): Use it. (slime-beginning-of-symbol, slime-end-of-symbol): New functions which don't include the character after a hash '#'. (slime-symbol-name-at-point): Use them. (slime-symbol-start-pos, slime-symbol-end-pos): Ditto. 2004-09-17 Marco Baringer * swank.lisp: Don't print "Documentation:" if none is available; add support for classes specializer-direct-methods; deal with eql-specializers in methods. (inspector-princ): New function. (method-specializers-for-inspect): New function. (method-for-inspect-value): New function. (inspect-for-emacs): Use inspector-princ instead of princ-to-string. * swank-backend.lisp (swank-mop): Require eql-specializer, eql-specializer-object and specializer-direct-methods in swank-mop package. * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp (swank-mop): Export eql-specializer, eql-specializer-object and specializer-direct-methods from swank-mop. * swank-cmucl.lisp (inspect-for-emacs): Thinko fix. * swank-lispworks.lisp (swank-mop): Export specializer-direct-methods. (eql-specializer): Implement. (eql-specializer-object): Implement. * swank-sbcl.lisp (inspect-for-emacs): Fix broken ignore declaration. * doc/slime.texi: Update inspector documentation. 2004-09-16 Marco Baringer * swank-clisp.lisp (swank-mop, inspect-for-emacs): Only define the CLOS parts of the inspector if the underlying lisp provides the required functionality. If not enough MOP is present to implement the inspector then we define some very simple replacement methods. 2004-09-16 Marco Baringer * swank-clisp.lisp (swank-mop): Implement the MOP compatability package. (inspect-for-emacs): Update for new inspection API. 2004-09-15 Alan Ruttenberg * swank-openmcl: typo in who-references. Fix frame-var-value 2004-09-15 Marco Baringer * slime.el (slime-inspector-label-face, slime-inspector-value-face, slime-inspector-action-face, slime-inspector-type-face): These faces now inherit from similar font-lock- faces. (slime-open-inspector): Use slime-inspector-value-face for values. * swank.lisp (inspect-for-emacs): Add function and compiler-macro documentation when inspecting symbols. View the truename of logical pathnames where they exist. Fix typos in package inspector (fix by Torsten Poulin ). * swank-sbcl.lisp, swank-cmucl.lisp (inspect-for-emacs): Insert function object's documentation when it's available. 2004-09-15 Eduardo Muñoz * .cvsignore: Added *.elc * hyperspec.el: Fixed syntax error. 2004-09-15 Alan Caulkins * swank.lisp (cleanp-connection-threads): Kill all Swank threads for a connection when it terminates. 2004-09-14 Thomas Schilling * swank-allegro.lisp (inspect-for-emacs): Fixes to previous patch. 2004-09-14 Marco Baringer * swank-backend.lisp (inspector, make-default-inspector): Add an INSPECTOR object argument to the inspector protocol. This allows implementations to provide more information regarding cretain objects which can't be, or simply aren't, inspected using the generic inspector implementation. also export inspect-for-emacs and related symbols from the backend package. (make-default-inspector): New function. * swank.lisp (inspected-parts): Rename to inspect-for-emacs and add an inspector argument. Move inspect-for-emacs to swank-backend.lisp, leave only the default implementations. * swank-openml.lisp, swank-sbcl.lisp, swank-allegro.lisp, swank-cmucl.lisp, swank-lispworks.lisp (inspected-parts): Rename and change argument list. Many of the inspected-parts methods were being clobbered by the inspected-parts in swank.lisp, now that they're being used the return values have been updated for the new inspect-for-emacs API. 2004-09-14 Thomas Schilling * swank-allegro.lisp (inspected-parts): Implement inspector for structs. 2004-09-13 Helmut Eller * swank.lisp (intern-catch-tag): New function. (read-user-input-from-emacs, take-input): Use it. 2004-09-13 John Paul Wallington * swank.lisp (define-special): Make the doc-type `variable' rather than `symbol'. Don't quote `doc'. Doc fix. 2004-09-09 Martin Simmons * swank-lispworks.lisp: Set up the swank-mop package. Implement swank-mop:slot-definition-documentation and function-name. 2004-09-13 Marco Baringer * swank.lisp (inspected-parts): Added inspectors for pathnames, logical pathnames, standard-objects and numbers (float, ratio, integer and complex). * swank-backend.lisp: Define import-to-swank-mop. * swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: Don't define the import-to-swank-mop function (now defined in swank-backend.lisp). * swank-cmucl.lisp (swank-mop, function-name): Implement backend for inspector. (arglist): Add support for extracting arglists from function objects. (create-socket): Don't specify the host on PPC. 2004-09-13 Alan Ruttenberg * slime.el slime-goto-location-position: New location specifiers: (:method name specializers . qualifiers) all are strings. Looks for defxxx name then the qualifiers as words, in order then the specializers as words, in order (except for "T", which is optional). Pass the symbols names for specializers and qualifiers (no packages). Used by openmcl but might be useful for others (:text-anchored ) Got to position, then search for string, then move delta. To support upcoming source recording for openmcl debugging. * swank-openmcl multiple changes: - fix support for *sldb-top* (formerly *swank-debugger-stack-frame*) Was not thread safe. Now (application-error), and (interrupt-thread) records the error pointer in a table associated with thread and map-backtrace picks up the appropriate pointer. *process-to-stack-top*, (grab-stack-top), (record-stack-top). - Other adjustments for changes to multiprocessing: remove (force-break-in-listener) no longer necessary since we use process-interrupt instead of ccl::*interactive-abort-process* Adjust break-in-sldb to do so for swank repl connections (abstraction breaking reference to swank::*connections*, but nicely via intern) - changes to (find-definitions) (function-source-location), addition of (maybe-method-location) (remove-filename-quoting). To support editing definitions of methods. To fix bug with pathnames with quoted characters (like "\\.swank.lisp"). To remove bogus source recording of l1-boot-3 in functions that didn't have a source file noted. - Implementation of xref functions: (xref-locations) uses xref implementation added to openmcl recently. Note that you have to (ccl::start-xref) for it to work for other than who-calls, and that xref information is not currently persisted in fasl files (I will release a patch for this soon) Backend functions (who-binds) (who-macroexpands) (who-references) (who-sets) (who-calls) (list-callees) (who-specializes) - Lifted profile backend functions from swank-clisp which use "metering.lisp" - (openmcl-set-debug-switches) turns on the various variables I. know about that have the lisp record extra debugging information(including starting xref). I suggest you call it. Should it be called by default? - (frame-arguments) use builtin ccl::frame-supplied-args since the current version was sometimes missing the first argument to the function. (I think this was when it was passed by register. If you don't want to lose it in the frame locals in backtrace, call (openmcl-set-debug-switches) specifically, set ccl::*ppc2-compiler-register-save-label* to t - implement frame-var-value backend * metering.lisp: Minor changes to #+ #- to recognize openmcl * swank-loader.lisp: Load "metering.lisp" 2004-09-13 Marco Baringer * swank.lisp (inspected-parts): Deal with unfinalized classes in standard-class inspector. (Patch from Thomas Schilling) 2004-09-13 Marco Baringer * swank.lisp: New inspector protocol. The lisp side now returns a specially formated list of "things" to format which are then passed to emacs and rendered in the inspector buffer. Things can be either text, recursivly inspectable values, or functions to call. (inspected-parts): Redefine for new inspector protocol. (*inspectee-parts*): Redefine as array. (*inspectee-actions*): New array, similar to *inspectee-parts*. (reset-inspector): Update for new implementation of *inspectee-parts* and new variable *inspectee-actions*. (inspector-contents-for-emacs): New function. (inspect-object): Update for new inspector protocol. (inspector-nth-part): Update for new *inspectee-parts* implementation. (inspector-call-nth-action): New function. * slime.el (slime-inspector-action-face): New face. (slime-open-inspector): Adapt to new inspector protocol. (slime-inspector-operate-on-point): New function, subsumes slime-inspector-inspect-object-at-point. (slime-inspector-next-inspectable-object): Skip to next object, not just end of current object; wrap around buffer. (slime-inspector-mode-map): change bindings of [return] and "\C-m" * swank-bacend.lisp (swank-mop): New package. Simply defines all the MOP related symbols we need from an implementation. (arglist): Update doc string. Provide default implementation. (function-name): New backend function. * swank-allegro.lisp (swank-mop, slot-definition-documentation): Implement. (Patch from Thomas Schilling) * swank-sbcl.lisp (swank-mop, slot-definition-documentation, function-name): Implement. * swank-openmcl.lisp (swank-mop, function-name): Implement. (arglist): Implement for function objects. 2004-09-12 Helmut Eller * swank.lisp (compile-file-for-emacs): Use with-buffer-syntax so that SBCL source files can be compiled. From Christophe Rhodes. 2004-09-09 Martin Simmons * swank-loader.lisp (make-swank-pathname): Preserve the host component (important for LispWorks on Windows). 2004-09-08 Martin Simmons * swank-lispworks.lisp: Implement call-with-compilation-hooks. 2004-09-03 Helmut Eller * NEWS: Summarize changes since August. * slime.el: Add some docstrings. * mkdist.sh: Add PROBLEMS file. We're no longer alpha. * swank.lisp: Remove debugging code in comment. * swank-sbcl.lisp: Delete dead code. * swank-lispworks.lisp (defimplementation): define-dspec-alias seems to more apropriate than define-form-parser. * swank-cmucl.lisp (print-frame): Catch errors during printing. * README: Fix typo. 2004-09-02 Wolfgang Mederle * swank-loader.lisp (*lisp-name*): Replace / with - in CMUCL version strings. 2004-09-01 John Paul Wallington * slime.el (slime-oneliner): Don't use free variable. (slime-recenter-window, slime-set-connection-info) (slime-pprint-event, slime-compiler-notes-quit) (slime-apropos-summary): Likewise. (slime-connect): Tidy up handshake `message' call. 2004-09-01 Helmut Eller * slime.el (slime-repl-push-directory): Fix interactive spec. (sldb-reference-properties): Take a the reference object as argument instead of its parts. Fix callers accordingly. (slime-fuzzy-choices-buffer): Remove assignment to unused variable slime-fuzzy-target-mtime. (slime-ed): Replace call to new-frame with make-frame. (sldb-find-buffer): Cleanup. (sldb-highlight-sexp): Fix regexp. It's now almost a full line. * swank.lisp (completion-set, tokenize-symbol-designator) (tokenize-completion, fuzzy-completion-set) (briefly-describe-symbol-for-emacs): Remove simple-base-string declarations. 2004-08-30 Helmut Eller * PROBLEMS: We require SBCL 0.8.13. 0.8.12 is no longer supported. * swank-allegro.lisp (find-fspec-location): Catch errors in excl:source-file. * swank.lisp (send-to-socket-io): Add some ignore declarations. * slime.el (sldb-fetch-all-frames, sldb-end-of-backtrace) (sldb-beginning-of-backtrace): New commands. (slime-search-suppressed-forms): Change the start regexp so that reader conditionals in single line comments, like "; #+foo", are ignored. 2004-08-27 Peter Seibel * swank-backend.lisp (swank-compile-string): Add directory argument which is used by Allegro backend to improve source recording for definitions compiled with C-c C-c. 2004-08-23 John Paul Wallington * slime.el (slime-pretty-package-name): Fix last cond clause. 2004-08-21 Luke Gorrie * swank.lisp (*global-debugger*): New configurable to globally install swank-debugger-hook as *debugger-hook*. True by default. 2004-08-19 Luke Gorrie * doc/slime.texi: C-c C-c C-a, C-c C-u C-e. Thanks Barry Fishman for reporting incorrect indexing. 2004-08-18 Matthew Danish * swank-allegro.lisp (swank-compile-string): Use #\; instead of #\: to separate the position from the buffer-name. This avoids troubles on Windows. 2004-08-16 Luke Gorrie * doc/slime.texi: Random updates. * slime.el (slime-space): Use slime-message instead of slime-background-message. This displays multi-line arglists. (sldb-mode-map): Bind 'C' to sldb-inspect-condition. 2004-08-14 Helmut Eller * slime.el (slime-find-buffer-package): Use "%s", not "%S", to avoid ugly escape characters, if the package name contains dots. 2004-08-13 Luke Gorrie * slime.el (sldb-eval-in-frame): Print result to the REPL when a prefix argument is given. Added pull-down menus for SLDB and the REPL. * swank-source-path-parser.lisp: Removed caching of readtables and the source-map hashtable. Fresh creation is ultra-cheap (<1ms). The caching didn't handle modifications to readtables and generally made me feel uneasy while tracking down an obscure bug in a reader macro. The cached source-map hashtable also wasn't thread-safe (ho hum). 2004-08-13 Helmut Eller * slime.el (slime-merge-notes, slime-tree-for-note): Use the short note message for annotation in the source buffer and the long message in the tree widget. Used to be the other way around. (sldb-insert-frames): Set the `start-open' property for XEmacs. Without `start-open', the `point-entered' property is inherited when we insert something before the "--more--" marker. Reported by Sundar Narasimhan. * swank.lisp (variable-desc-for-echo-area): Bind some printer variables to limit the length of the output. 2004-08-05 Luke Gorrie * slime.el (slime-setup): Added typeout-frame keyword argument. (slime-thread-attach): Fixed misnamed function call. 2004-08-04 Luke Gorrie * swank-allegro.lisp (find-fspec-location): Fixed to work for more types of definition than just functions. So M-. now works for e.g. classes in Allegro. From Matthew Danish. (find-fspec-location): Include the type of the definition in the designator sent to Emacs. From Matthew Danish. 2004-08-04 Martin Simmons * swank-lispworks.lisp (frame-actual-args): Correct syntax for handler-case. 2004-08-04 Helmut Eller * slime.el: (slime-mode-map, slime-repl-mode-map) (slime-repl-read-mode-map): Remove the binding for C-c C-g. C-c C-b is now the default interrupt key. (slime-list-repl-short-cuts): Don't trash the shortcut-table: copy it before sorting. (Thanks to Mark Simpson.) 2004-08-02 Luke Gorrie * slime.el (slime-connect): Shorten the welcome message by leaving out the port number (which is displayed in the REPL anyway). This avoids line-wrapping some messages of encouragement. * swank.lisp (with-buffer-syntax): Don't bind *readtable* to *buffer-readtable* if they are already EQ. When we shadow this binding the user can't assign *readtable* from the REPL so it's best avoided when possible. * swank-allegro.lisp: Removed fwrapper-based code for inheriting "swankiness" to newly spawned threads. This was fighting the system and not the right thing. * slime.el (slime-choose-overlay-region): Tweaked the multiline-annotation-avoidance code to work with forms not starting with an open-paren, e.g. `(..) or #'(..). (slime-update-modeline-package): New configurable. Non-nil (the default) means update the Lisp package in the modeline using an idle timer. (slime-repl-send-input): Make the `slime-repl-old-input' property cover the whole input (including newline) so that pressing RET on the end of an input line works. Use a unique integer as the value of this property to distinguish adjacent inputs. (slime-current-package): Deal with narrowing. 2004-08-01 Helmut Eller * swank-allegro.lisp (swank-compile-string): Use a temporary file and set excl::*source-pathname* manually. This way we can find the source buffer of functions compiled with C-c C-c. (call-with-temp-file, compile-from-temp-file): New functions. (list-callers, function-callers, in-constants-p) (map-function-constants): Implements list callers by groveling through the constants pools of named functions. * swank-lispworks.lisp: Minor refactoring. 2004-07-30 Helmut Eller * slime.el (slime-connection): Say "No default connection selected" if there are open connections but no default connection. (slime-tree-indent-item): Point wasn't updated correctly if the last line was empty. Use insert-before-markers instead of insert to do it properly. (slime-draw-connection-list): Don't break if there is no default connection. * swank-cmucl.lisp (call-with-debugging-environment): Only handle DI::UNHANDLED-CONDITION not all DI:DEBUG-CONDITIONs. * swank-backend.lisp (sldb-condition): Show the original condition in the message. 2004-07-28 Helmut Eller * slime.el (slime-eval-feature-conditional): Treat uppercase operators NOT, AND, OR correctly. (sldb-find-buffer): Remove killed buffers. (sldb-quit): Raise an error if the RPC returns. (slime-expected-failures): Delete unused function. (complete-symbol): Test completion of swank::compile-file. LispWorks has extra completions for cl::compile-file. (arglist): Test arglist of method cl:class-name. Add enough regexpery to pass the test in most implementations. * swank-sbcl.lisp (list-callers, list-callees): Implemented. 2004-07-26 Luke Gorrie * slime.el (slime-first-change-hook): Add `save-match-data' to avoid breaking e.g. query-replace. Also added `save-excursion' just to be safe. * README: s/setup-slime/slime-setup/ in the .emacs snippet. 2004-07-23 Luke Gorrie * slime.el (slime-set-state): Show the message in the modeline in the case where we aren't connected. Otherwise the "not connected" status is ignored. (slime-net-sentinel): Close the connection before changing the status message. The old behaviour of this combined with the old behaviour of `slime-set-state' could generally cause spurious errors after a connection was closed. 2004-07-22 Luke Gorrie * swank.lisp (carefully-find-package): Return *BUFFER-PACKAGE* if no other package can be found. This is reverting a previous change that broke completion in buffers with no known package. * slime.el (slime-maybe-start-lisp): Check that *inferior-lisp* exists /and/ has a running process. Fixes a startup problem if your inferior-lisp has died and you want to restart SLIME. 2004-07-21 Luke Gorrie * slime.el (slime-sync-package-and-default-directory): Sync `default-directory' in the REPL buffer too. (slime-set-state): Convenience function for setting a connection's state-name and updating the modeline if appropriate. This function is called in the right places. (slime-to-lisp-filename): Use `expand-file-name'. 2004-07-20 Luke Gorrie * slime.el (slime-repl-update-banner): Restore old behaviour of using an asynchronous evaluation to setup the REPL. This works around a problem I'd reintroduced where the first REPL command uses the wrong keymap. 2004-07-20 Andreas Fuchs * swank-sbcl.lisp (call-with-compilation-hooks): Trap and report errors that cause compilation to fail, e.g. read errors. 2004-07-19 Luke Gorrie * HACKING: Updated. Some notes about Emacs features. * slime.el: More major refactoring. Restructured and documented the networking and protocol code. (slime-rex-continuations): Now connection-local. 2004-07-18 Luke Gorrie * slime.el: Major refactoring. Mostly resectioning and reordering definitions to try and improve readability. (slime-get-temp-buffer-create): New utility function to popup a temporary buffer that automatically has a binding on `q' to intelligently restore window configuration. Handy, but currently not applicable to all of our temporary buffers. (slime-with-chosen-connection): Removed this macro. Consequently the compilation commands no longer prompt for which connection to use when given a prefix argument. `slime-switch-to-output-buffer' still works like that, but for other cases I think the connection-list buffer is sufficient. (slime-eval-async): New arglist: (form &optional cont pkg). If the continuation is unspecified then the evaluation result is ignored, and if the package is unspecified then (slime-buffer-package) is used. (slime-eval): Package arg now defaults to (slime-buffer-package). (slime-current-package): New name for (slime-buffer-package). No more caching: returns the buffer-local `slime-buffer-package' if set, otherwise searches for an `in-package' form. A consequence of non-caching is that the package name doesn't appear in the modeline anymore. The simplification is worthwhile in my opinion. 2004-07-17 Luke Gorrie * slime.el (slime-autodoc): If there is a global variable name at point then show its value. (slime-autodoc-cache-type): Cache type 'full is no longer supported. (slime-background-message): Truncate messages to fit on a single echo area line. (slime-repl-update-banner-p, slime-dont-prompt) (slime-swank-connection-retries): Removed these unused or unuseful configuration variables. Rearranged organised "customize" groups. * swank.lisp (variable-desc-for-echo-area): New function. (arglist-for-echo-area): Return nil if symbol can't be found. (close-connection): Close connection before printing error message. This avoids it getting lost in closed I/O redirection. * README, doc/slime.texi: Updated setup instructions. 2004-07-16 Luke Gorrie * slime.el (slime-conservative-indentation): New variable. When true (the default) don't auto-learn indentation of def* and with-* macros. Set to nil if you want to learn them. (slime-handle-indentation-update): Use it. * swank.lisp (known-to-emacs-p): Removed filtering of def* and with-*. Now handled by Emacs. * slime.el (slime-interactive-eval): Changed display of results. By default the result goes to `slime-message', which leads either to echo area, temporary buffer, or typeout frame. With a prefix argument the result is printed to the REPL. This goes for all commands based on slime-interactive-eval, e.g. `C-x C-e' and `C-c M-:'. 2004-07-16 Peter Seibel * slime.el (package-updating): Fixing this and other tests I broke with my change to how emacs keeps track of the package prompt string. (arglist): Fix an test failure under Allegro due to a slight difference in the way EXCL:ARGLIST returns arglist (no default values of &optional parameters) 2004-07-16 Luke Gorrie * swank.lisp (print-connection): print-function for connection objects. Dumping the indentation-cache was damned ugly with non-truncated lines (e.g. bug reports on slime-devel). * slime.el (slime-setup): New function for installing a lisp-mode-hook. You can call this from ~/.emacs to setup SLIME. Takes a `autodoc' keyword argument to enable slime-autodoc-mode. We can add more keywords in future. (slime-keys): Moved `slime-reindent-defun' from C-M-q to C-cM-q. This avoids overriding the standard binding of C-M-q to index-sexp. (slime-typeout-frame-properties): Removed some properties: `name', because it interacts badly with X properties, `left' and `top' because they don't put the frame anywhere terribly convenient, and (width . 40) because it makes the frame narrower than the usual word-wrapping width. 2004-07-14 Peter Seibel * slime.el (slime-lisp-package-prompt-string): Separate SLIME's notion of package into two parts, an actual package name and the name used in the prompt since the latter isn't necessarily an actual package nickname any more. 2004-07-13 Luke Gorrie * slime.el (slime-restart-inferior-lisp): Renamed shortcut to "restart-inferior-lisp" from "restart-lisp". The name better suggests what it does: kill *inferior-lisp* and rerun SLIME. 2004-07-13 Eric Blood (slime-inspector-next-inspectable-object): New inspector command to goto the next inspectable object (slot). Bound to TAB. 2004-07-13 Christophe Rhodes * slime.el: add support for actionable references in the *slime-compiler-notes* buffer. (slime-merge-notes): merge references if applicable. (slime-compiler-notes-mode-map): use new functions defaulting to show-details, but overrideable by text properties. (slime-tree-default-printer): destroy generality by assuming a tree of conditions, and insert references if applicable. (sldb-format-reference-source): add :amop * swank-sbcl.lisp (signal-compiler-condition, brief-compiler-message-for-emacs, long-compiler-message-for-emacs): handle references in compiler conditions. * swank.lisp (make-compiler-note): propagate references. * swank-backend.lisp (compiler-condition): add references slot. 2004-07-12 Luke Gorrie * slime.el (slime-easy-menu): Added "Apropos all" menu item. (slime-restart-lisp): Added `restart-lisp' shortcut. Doesn't do the right thing if you have multiple Lisps up. * swank.lisp: Added some docstrings. Rearranged completion code and somewhat SLDB trying to layout functions above their subfunctions in a tree-like way. (slime-protocol-error): Renamed from slime-read-error. (carefully-find-package): Now returns NIL if package can't be determined, rather than *BUFFER-PACKAGE*. Correct? I didn't see why it should return *BUFFER-PACKAGE*. (xref): Find symbol in *BUFFER-PACKAGE*. 2004-07-09 Peter Seibel * swank.lisp (package-string-for-prompt): Change the way package name in prompt is computed. N.B. after this change the name displayed will not necsarily be either an actual name or nickname of the package: if the name contains dots by default the prompt will only display the last element, i.e. COM.GIGAMONKEYS.SPAM will be shown as SPAM. This change also makes CL-USER the canonical name for COMMON-LISP-USER even in implementations that provide a shorter nickname such as USER. 2004-07-09 Christophe Rhodes * slime.el (sldb-lookup-reference): substitute hyphens for spaces in the url. 2004-07-07 Thomas Schilling * swank.lisp (arglist-for-insertion): Changed formatting to use arglist-to-string. That results in proper cases for slime-insert-arglist. 2004-07-07 Luke Gorrie * swank-loader.lisp (*lisp-name*): Include the version number in ACL. * slime.el (slime-alistify): Preserve order. This keeps the *compiler-notes* right. Pointed out by Christophe Rhodes. (slime-repl-update-banner-p): Renamed from slime-reply-.. (slime-changelog-date): Reintroduced for informational purposes. (slime-repl-update-banner): Show ChangeLog date in the animation. (slime-space): Do arglist lookup before inserting the space. Otherwise we get a funky race condition: entering the space may trigger `first-change-hook', which would send an async notification to Lisp, which would put us in the 'busy' state and thus we wouldn't lookup the arglist! Detective work by Edi Weitz. (sldb-prune-initial-frames): More regexp fudgery :-(. (read-directory-name): Use `file-name-as-directory' to ensure we have the trailing / on the directory name. (byte-compile-warnings): Bye-compile slime-alistify. Its inputs can be pretty big. 2004-07-04 Luke Gorrie * slime.el, swank-backend.lisp, swank.lisp: Added a new backend function `buffer-first-change' which is called via Emacs's `first-change-hook' in slime-mode buffers. This gives Lisp a chance to do something with source files before you change them on disk. * swank-cmucl.lisp (buffer-first-change): Suck the source file into the cache unless already present. This is for M-. to increase the chances of our having a copy of the sources corresponding with the loaded code. Should help with the case where a user edits and saves a file (without recompiling it) and then M-.'s for one of its definitions. * swank-allegro.lisp (make-process/inherit): Changed reader conditionals to use fwrappers for #+(version>= 6). * swank-backend.lisp (make-stream-interactive): This backend function is called with each stream that will be used for user-interaction, i.e. the redirected stdio streams. Can be used to setup special output-flushing or similar. * swank.lisp (open-streams): Call make-stream-interactive on the redirected io streams. * swank-allegro.lisp (make-stream-interactive): Set interactive-stream-p slot on the stream to make it auto-flush. (*swank-thread*, *inherited-bindings*): New variables. (spawn): Bind *swank-thread* to T. (make-process/inherit): Fwrapper (advice) for mp:make-process. When *swank-thread* is T then make the new thread inherit "sliminess": debugger hook, I/O streams, and also *swank-thread* so that its children will inherit too. 2004-07-03 Luke Gorrie * hyperspec.el (common-lisp-hyperspec-section-4.0): Bugfix from Lennart Staflin. * slime.el (slime-repl-clear-output): Avoid clearing the previous REPL expression too. Patch from Andras Simon. * swank-backend.lisp (definterface): Don't use NO-APPLICABLE-METHOD for default methods. Instead just define them as regular methods with all argument types being T. Defimplementation will then replace them by using the same signature. N-A-M was a stupid idea! 2004-07-02 Brian Downing * slime.el (slime-reindent-defun): Added a check for (boundp 'slime-repl-input-start-mark) before checking the variable, as XEmacs leaves variables unbound when `make-variable-buffer-local' is run, while GNU Emacs binds them to NIL. 2004-07-02 Martin Simmons * swank-lispworks.lisp (dspec-stream-position, make-dspec-location): Fix typo in features for LW 4.1 and 4.2. 2004-07-01 Helmut Eller * swank-lispworks.lisp (frame-actual-args): Bind *break-on-signals* to nil and special case &rest, &optional, and &key. 2004-07-01 Luke Gorrie * slime.el (sldb-lookup-reference): Preserve case in SBCL node names. Previously they were downcased, but the HTML manual's filenames seem to have changed. * NEWS: Added security note about the TCP server. Added notes for ACL and ABCL. * doc/slime.texi: General updatings for an alpha release. 2004-06-30 Helmut Eller * slime.el (slime-display-compilation-output): New customizable variable. * swank.lisp: Minor cleanups. (find-symbol-designator, find-symbol-or-lose) (case-convert-input): Deleted. Replaced with calls to parse-symbol{-or-lose}. * swank-lispworks.lisp (describe-symbol-for-emacs): Include information about setf-functions. (emacs-connected): Add a default method to env-internals:environment-display-debugger. 2004-06-30 Luke Gorrie * slime.el (slime-read-port-and-connect-to-running-swank) (slime-connect, slime-open-stream-to-lisp): Replace "localhost" with "127.0.0.1". This is believed to avoid unwanted DNS lookups on certain operating systems. The lookups can become crippling if the DNS server isn't available. (line-beginning-position, line-end-position): Simple bugfix suggested by Richard Klinda. * swank-sbcl.lisp (preferred-communication-style): Choose :fd-handler instead of :sigio when threads aren't available. A lot of people seem to have had problems with :sigio on SBCL. 2004-06-30 Luke Gorrie * NEWS: Wrote preliminary release notes for alpha-1. 2004-06-29 Luke Gorrie * mkdist.sh: New shell script for creating a tarball for distribution. 2004-06-29 Bill Clementson * slime.el (slime-who-map): Add extra bindings for the XREF commands as with the documentation commands. Now `C-c C-w C-c' is `slime-who-calls' in addition to `C-c C-w c', etc. 2004-06-29 Luke Gorrie * slime.el (sldb-prune-initial-frames): Tweaked regexp for matching SWANK's own stack frames for effectiveness in SBCL. (slime-keys): Shadow remaining inf-lisp keys (C-c C-a, C-c C-v) with a null `slime-nop' command until we put them to a real use. * swank.lisp (open-streams): Renamed the restart around reads from the user-input stream from ABORT to ABORT-READ. Invoking this restart seems kinda dangerous, so better for 'a' in SLDB not to do so. 2004-06-28 Thomas F. Burdick * swank.lisp (inspector-nth-part): * slime.el (slime-inspector-copy-down, slime-inspector-mode-map): Added copy-down command (M-RET) to easily move an object from the inspector to the repl. 2004-06-28 Luke Gorrie * slime.el (slime-doc-map): New keymap for documentation commands. These all use the `C-c C-d' prefix, followed by: a - apropos p - apropos-package z - apropos-all d - describe-symbol f - describe-function h - hyperspec lookup ~ - hyperspec lookup of a format character The final keystroke is bound both unmodified and with control, so both `C-c C-d a' and `C-c C-d C-a' will make an apropos search. The exception is hyperspec-lookup, because it's nice to leave C-h unbound so that `C-c C-d C-h' will summarise the documentation bindings. 2004-06-28 Helmut Eller * swank-allegro.lisp (nth-frame): Skip frames where frame-visible-p is false. * slime.el (slime-buffer-package): Return the cached package if we can't find something more sensible; this reverts a previous change. The Lisp side will now fall back to an existing package if the one supplied by Emacs doesn't exist. Using the cached version is also necessary for some commands in the apropos buffer. (sldb-insert-frame): Set the default-action property; pressing RET on frame lines now shows/hides details. (sldb-toggle-details): Preserve the current column. (slime-inspector-buffer, slime-saved-window-config) (slime-inspector-quit): Save and restore the window configuration. (slime-highlight-suppressed-forms, slime-search-suppressed-forms): Display expressions with reader conditionals (#+/#-) in font-lock-comment-face if the test is false. Not implemented for XEmacs. (repl-return): New test. 2004-06-28 Luke Gorrie * slime.el: Events in the *slime-events* buffer are now exact on-the-wire messages, without including e.g. Elisp continuation functions. This is easier for debugging I think. * swank-allegro.lisp (compute-backtrace): Only include frames satisfying `debugger:frame-visible-p'. I did this as a lame workaround for a problem where `output-frame' was segfaulting on certain frames, and those frames happened not to be visible-p. I don't know if it really fixes anything. * hyperspec.el (common-lisp-hyperspec-format): This command now works at the end of the buffer, fixed `char-after' usage as suggested by Johan Bockgård. 2004-06-28 Christophe Rhodes * hyperspec.el: add support for issue cross-reference lookups, strongly inspired by hyperspec symbol lookup. (common-lisp-hyperspec-issuex-table, common-lisp-hyperspec-issuex-symbols): new variables (common-lisp-issuex): new function * slime.el (sldb-format-reference-node, sldb-lookup-reference): (sldb-reference-properties): use new support for issue lookups to support :ansi-cl :issue reference types. * hyperspec.el: add support for glossary lookups. (common-lisp-glossary-fun): new variable (common-lisp-glossary-4.0, common-lisp-glossary-6.0): new functions * slime.el (sldb-format-reference-node, sldb-lookup-reference): (sldb-reference-properties): use new support for glossary lookupts to support :ansi-cl :glossary reference types. 2004-06-27 Helmut Eller * doc/slime.texi: Remove macros from chapter and section headings to avoid texi2pdf breakage. * swank-source-path-parser.lisp (cmucl-style-get-macro-character): Add tests for #\space and #\\. Suggested by Christophe Rhodes. * swank-sbcl.lisp, swank-openmcl.lisp, swank-lispworks.lisp, swank-cmucl.lisp, swank-backend.lisp, swank-allegro.lisp, swank-abcl.lisp (thread-id, find-thread): New backend functions. * swank.lisp (dispatch-event): Quitting from the debugger was seriously broken. Fix it. Move generation of thread ids to the backends. (encode-message, send-to-socket-io): Use WITHOUT-INTERRUPTS in send-to-socket-io. The multithreaded version of encode-message doesn't need it. (nth-thread): Renamed from lookup-thread-by-id. (debug-nth-thread): Renamed from debug-thread-by-id: (kill-nth-thread): Renamed from kill-thread-by-id. * slime.el (sldb-get-buffer): Add support for sldb buffers for multiple threads. 2004-06-25 Thomas F. Burdick * swank-sbcl.lisp (call-with-syntax-hooks, with-debootstrapping): Preserve compatability with fairly recent SBCLs by checking for the presense of the debootstrapping facilities at macroexpansion time. * slime.el (sldb-insert-condition): Initialize sldb-default-action so that pressing RET inspects the condition. 2004-06-25 Helmut Eller * slime.el (slime-repl-insert-prompt): Set defun-prompt-regexp. beginning-of-defun can be very slow in the repl buffer if the defun-prompt-regexp is not set. (sldb-insert-locals): Initialize sldb-default-action. (sldb-var-number-at-point, sldb-inspect-var): New function. * swank.lisp (inspect-frame-var): New function. * swank-backend, swank-cmucl.lisp, swank-sbcl.lisp, swank-allegro.lisp, swank-lispworks.lisp, swank-clisp.lisp (frame-var-value): New backend function. 2004-06-24 Christophe Rhodes * slime.el (sldb-format-reference-node): fix for when `what' is a list. (sldb-lookup-reference,sldb-reference-properties): support :ansi-cl :section reference types. * hyperspec.el (common-lisp-hyperspec-6.0): generalize to work with section numbers lower than 10. 2004-06-24 Brian Downing * slime.el (slime-repl-send-input): Fixed a subtle difference in sending input to the Lisp introduced in 1.316. The newline was not getting sent, resulting in the Lisp constantly asking for more read data. I believe the code has been adjusted to behave the same as 1.315 with regard to sending newlines. Also adjusted the `slime-repl-old-input' text property to end just before the newline, not just after. This causes a gap between inputs even if no Lisp output appeared in between, so that putting point on an old line and hitting RET will only call up that line, and hitting RET in the middle of the current line will send it and not bring up a confusing combination of all previous input. Many thanks to Loyd Fueston for pinpointing the date and exact patch for when this problem was introduced. 2004-06-23 Brian Downing * slime.el: Re-added most of Luke's patches from yesterday. It has the shortened names, uses markers instead of stored `(point)' values, and `slime-fuzzy-complete-symbol' is an option for `slime-complete-symbol-function'. It still string compares the target buffer instead of using `(buffer-modified-tick)'. I left the `C-c M-i' keybinding in, as it allows use of the regular completion as well. If there's an objection to this it can be removed. `window-configuration-change-hook' is used if the variable is present, and ignored it not. This neatly sidesteps its absence in XEmacs while not killing the functionality for GNU Emacs. * doc/slime.texi: Added a command entry and short description for `C-c M-I, slime-fuzzy-complete-symbol', and added its existence to the `slime-complete-symbol-function' documentation. 2004-06-22 Luke Gorrie * doc/slime.texi: Noted ABCL support. * slime.el: Backed out all of my changes to fuzzy completion. I was too hasty and didn't do good things. Now it's back in pristine state from Brian's patch -- use `C-c M-i' to fuzzy-complete. * doc/Makefile (contributors.texi): The contributors list in the manual is now sorted by most number of ChangeLog entries. Patch from Michael Weber. * slime.el: Some minor hacking to fuzzy completion: Use the shorter `slime-fuzzy-' symbol prefix. Use markers instead of numbers to remember where the completion is being done. This way they are self-updating. Use `buffer-modified-tick' to detect modifications instead of text comparison. Always restore window configuration when a completion is chosen. For this completion style I think this will work okay [famous last words], and the existing code wasn't XEmacs-compatible for want of window-configuration-change-hook. Now there is no separate keybinding for fuzzy completion, but it's included as a customize option for `slime-complete-symbol-function' 2004-06-22 Brian Downing * slime.el, swank.lisp: Added "fuzzy completion." 2004-06-22 Matthew Danish * swank-backend.lisp (unbound-slot-filler): New structure for representing an unbound slot in the inspector functions. * swank.lisp, swank-allegro.lisp: Use it. 2004-06-22 Luke Gorrie * slime.el (slime-output-filter): Choose connection based on process-buffer, not current buffer. This fixes a bug where output from multiple Lisp sessions could get mixed up. (slime-kill-all-buffers): Include all *inferior-lisp*[] buffers. Split the customize settings into more subgroups. * swank.lisp (prefixed-var): Intern *REAL-STANDARD-INPUT* etc in the SWANK package instead of the COMMON-LISP package. 2004-06-21 Luke Gorrie * swank-loader.lisp (*lisp-name*): Add version number to Lispwork's fasl directory. We should do this for ACL and OpenMCL too, but for some reason my ACL 5.0 gets an error when trying to create a directory with a version number in its name, and I don't have OpenMCL to test with. * swank-backend.lisp, swank.lisp (add-hook, run-hook): Moved the hook mechanism and all hooks to swank.lisp (from swank-backend.lisp). There is no compelling use for the hooks in backends yet and I want to pass swank.lisp-internal data structures in the existing hooks. (notify-backend-of-connection): Call `emacs-connected' with the user-io stream for its argument. Should fix previous breakage where the connection structure was passed instead. (*globally-redirect-io*): New configurable: when true the standard streams are globally redirected to Emacs. That way even e.g. SERVE-EVENT handlers will print to Emacs. Currently does not handle standard input -- that is trickier since the Lisp's native REPL can be trying to read from that. * slime.el (slime-complete-maybe-restore-window-configuration): Only restore the window configuration if the completions buffer is currently visible in the window that we popped it up in. (slime-complete-maybe-save-window-configuration): Don't save the window configuration if the completions buffer is already visible. (slime-repl-return): Make sure the newline goes at the end of the input, not at point. (slime-complete-restore-window-configuration): Wrap the `set-window-configuration' call in (run-at-time 0 ..). XEmacs does not allow us to set the window configuration from inside pre-command-hook. 2004-06-20 Helmut Eller * swank-sbcl.lisp (emacs-connected): Set *invoke-debugger-hook* to our debugger hook. Not optimal, but at least BREAK will then invoke our debugger. (*trap-load-time-warnings*): New variable. If it is true, conditions, most notably redefinition warnings, signalled at load time are not trapped. (swank-compile-file, swank-compile-string): Use it. * swank.lisp (guess-buffer-package): Don't signal a continuable error if the package doesn't exists; that's too annoying. * slime.el: Fix outline structure. (slime-maybe-list-compiler-notes): Fix thinko. (break): New test. Reorganize the test-suite a bit to support "expected failures". (slime-eval-feature-conditional, slime-to-feature-keyword): Add a ?: to the symbol-name if needed. 2004-06-20 Luke Gorrie * swank.lisp (changelog-date): Removed unneeded function. (connection-info): No more version field in result. * slime.el: Audited to remove namespace slipups. Tracking a really horrible clashing-with-some-user-configuration bug and want to eliminate potential symbol conflicts. (sldb-get-buffer): Renamed from `get-sldb-buffer'. (slime-emacs-20-p): Renamed from `emacs-20-p'. (slime-defun-if-undefined): Renamed from `defun-if-undefined'. (slime-isearch): Small bugfix that could cause M-. to go to the wrong place in CMUCL. (slime-changelog-date, slime-check-protocol-version): Removed unneeded functions. * swank-backend.lisp (add-hook, run-hook): Added an Emacs-like hook mechanism. The hope is that this will make some sections of the code more self-describing by showing where they hook in. (*new-connection-hook*): Hook run when a new connection is established. Initialized to '(swank-backend:emacs-connected). (*pre-reply-hook*): Hook run before sending a reply to Emacs. * swank.lisp: Added some comments and docstrings. (package-external-symbols): Removed unused function. (serve-connection): Call *new-connection-hook*. (eval-for-emacs): Call *pre-reply-hook*. (sync-features-to-emacs, sync-indentation-to-emacs): Added to *pre-reply-hook*. (cl-package, keyword-package): Now defconstant instead of defvar. Removed the *'s accordingly. * slime.el (slime-abort-connection): Renamed from `slime-connection-abort'. The new name is easier to find with completion. * swank-sbcl.lisp: Change sb-posix:: to sb-posix: 2004-06-19 Luke Gorrie * swank.lisp (known-to-emacs-p): Bugfix. Indentation-updates was broken. 2004-06-18 Luke Gorrie * slime.el (slime-buffer-package): If DONT-CACHE is true and no package name can be found, then default to "COMMON-LISP-USER." Previously we just kept using the cached version, but that could lead to error-after-error if it was incorrect. * swank.lisp (throw-to-toplevel): If our top-level catcher isn't on the stack (i.e. we're using the debugger from outside an RPC) then ABORT instead. That makes 'q' DWIM in SLDB. 2004-06-18 Matthew Danish * swank-allegro.lisp (frame-source-location-for-emacs): Implemented. 2004-06-18 Luke Gorrie * slime.el (slime-repl-return): If the user presses return on old REPL input then take it and insert it as the current input. Signal an error if the point is not on any input. (slime-preserve-zmacs-region): Function to ensure that the current command doesn't deactivate zmacs-region (XEmacs only). (slime-repl-bol, slime-repl-eol): Use it. (slime-kill-all-buffers): Changed buffer-name regexps for XEmacs compatibility. The ",quit" shortcut now works in XEmacs. (slime-display-message): Fixed call to `slime-typeout-message' to handle formatting characters. Avoids errors on certain messages. (slime-list-compiler-notes): Save the window configuration earlier. This fixes an error under XEmacs when dismissing the notes buffer. (slime-recenter-window): Avoid moving the point. This keeps the point in the right place when showing debugger-frame locations in Emacs 21. 2004-06-17 Luke Gorrie * swank-loader.lisp (binary-pathname): Place fasl files under ~/.slime/fasl/ instead of the SLIME installation directory. The installation directory can now be read-only. (binary-pathname, user-init-file): Removed Win32 conditionalization. The init file is now called ~/.swank.lisp instead of ~/_swank.lsp. * swank-lispworks.lisp (with-fairly-standard-io-syntax): New macro. Like with-standard-io-syntax, but keeps the existing values of *package* and *readtable*. (dspec-stream-position): Use it. (quit-lisp): Implemented. 2004-06-16 Helmut Eller * slime.el (slime-set-default-directory): Don't call slime-repl-update-banner in Emacs 20. (slime-show-source-location, slime-recenter-window): Use set-window-start instead of recenter; this avoids flickering. (sldb-list-locals): Don't forget about slime-current-thread in the temporary buffer. (Fixes bug reported by Mike Beedle.) (sldb-step): Re-enabled. The CMUCL backend has rudimentary support for stepping. * swank.lisp (*readtable-alist*): Call backend function for initialization. (eval-for-emacs, guess-buffer-package): Signal a continuable error if a package name was supplied but no such package exists. Not sure if this is better than what we did before (i.e. silently use the current package). * swank-cmucl.lisp (default-directory): Add implementation. (sldb-step): Uncomment it and remove references to *swank-debugger-condition*. * swank-backend.lisp (sldb-step, default-readtable-alist): New backend functions. (emacs-connected): Pass the redirected stream as argument, so that the OpenMCL backend can add it to CCL::*AUTO-FLUSH-STREAMS*. * swank-sbcl.lisp (default-readtable-alist): Implement it. * swank-loader.lisp: Move readtable-alist initialization to swank-sbcl.lisp. * swank-allegro.lisp (default-directory, call-with-syntax-hooks): Add implementations as workarounds for ACL5 bugs. 2004-06-16 Lawrence Mitchell * slime.el (slime-maybe-rearrange-inferior-lisp): Call `generate-new-buffer-name' manually, rather than relying on the UNIQUE argument to `rename-buffer' to do so. 2004-06-16 Frederic Brunel * slime.el (slime-startup-animation): Use defcustom to declare the variable. (slime-enable-startup-animation-p): Deleted. 2004-06-16 Robert Lehr * slime.el (slime-backend): This variable can now be set to an absolute filename. 2004-06-15 Luke Gorrie * slime.el (slime-compile-file): Just prompt for saving the current file instead of calling `save-some-buffers'. Based on a patch from Brian Downing. 2004-06-12 Helmut Eller * wank-allegro.lisp (format-sldb-condition, condition-references): Add workarounds for buggy no-applicable-method. * swank.lisp (parse-symbol, parse-package): Handle reader errors. * swank-openmcl.lisp (send, receive): Ensure that messages are never nil. 2004-06-10 Christophe Rhodes * swank-sbcl.lisp (call-with-syntax-hooks): Add hooks to fix "SB!"-style package names. (shebang-readtable): Return a readtable with readermacros needed to parse SBCL sources. * swank.lisp (with-buffer-syntax): New macro. This should be used for code which needs to READ code from Emacs buffers. *package* and *readtable* are bound suitable values. (to-string, format-values-for-echo-area, interactive-eval) (eval-region, interactive-eval-region, re-evaluate-defvar) (swank-pprint, pprint-eval, listener-eval) (compile-string-for-emacs, disassemble-symbol, describe-to-string) (describe-symbol, describe-function) (describe-definition-for-emacs) (documentation-symbol, init-inspector, inspect-nth-part) (inspector-pop, inspector-next, describe-inspectee) (inspect-current-condition): Use it. 2004-06-10 Helmut Eller * swank-loader.lisp: Initialize swank::*readtable-alist* for SBCL. * swank-backend.lisp (default-directory, call-with-syntax-hooks): New functions. * swank.lisp (*readtable-alist*): New configurable. The keys are package name and the values readtables. The readtable will be used to READ code originating from Emacs buffers in the associated slime-buffer-package. (drop-thread): Simplified. (*buffer-readtable*): New variable. (parse-package): New function. (parse-string): Renamed from symbol-from-string. Make it case insensitive. (eval-for-emacs): Initialize the *buffer-readtable*. (symbol-indentation): Don't consider symbols in the CL package. Emacs already knows how to indent them. (compile-file-if-needed): Used for REPL shortcut 'compile-and-load'. * slime.el (pwd): Re-add REPL shortcut. (slime-repl-push-directory, slime-repl-compile-and-load): Simplified. 2004-06-10 Luke Gorrie * slime.el (sldb-step): Command is disabled because the function `swank:sldb-step' that it calls doesn't exist. I don't see any stepping code in our backends. 2004-06-09 Helmut Eller * slime.el (slime-goto-location-position) [:function-name]: The function name can also occur after a ?(, not only after whitespace. * (slime-init-output-buffer): Initialize the package stack. Reported by Rui Patrocínio. * (slime-completions): Make it consistent with slime-simple-completions. The second argument was never supplied. Reported by Rui Patrocínio. 2004-06-09 Eric Blood * slime.el (slime-indent-and-complete-symbol): Renamed from slime-repl-indent-and-complete-symbol. (slime-typeout-frame-properties): Add more default options for the typeout frame--specifically it now has a default width, and moves the typeout frame to the upper right. 2004-06-09 Andras Simon * swank-abcl.lisp: New backend for Armed Bear Common Lisp. * swank-loader.lisp: Add ABCL support. 2004-06-09 Martin Simmons * swank-lispworks.lisp (dspec-stream-position): New function to make source location work for anything complicated e.g. methods. (with-swank-compilation-unit): Refactoring. (who-macroexpands): Implemented. (list-callers): Implemented. * swank-backend.lisp (network-error): Inherit from simple-error to get correct initargs. 2004-06-09 Luke Gorrie * slime.el (sldb-insert-references): Added support for hyperlinked references as part of conditions being debugged. This is a new feature in SBCL to reference appropriate sections of their manual or CLHS from condition objects. The references are clickable. * swank-backend.lisp (format-sldb-condition): New backend function to format conditions for SLDB. (condition-references): New function to return a list of documentation references associated with a condition. * swank.lisp (debugger-condition-for-emacs): Call the above backend functions to add a `references' list for Emacs. * swank-sbcl.lisp (format-sldb-condition, condition-references): Implemented. Requires a recent (latest?) SBCL release. 2004-06-08 Luke Gorrie * swank-cmucl.lisp (close-socket): Remove any SERVE-EVENT handlers for the socket's file descriptor. * swank-sbcl.lisp (close-socket): Same fix. 2004-06-07 Luke Gorrie * swank-cmucl.lisp: Minor refactorings. 2004-06-07 Edi Weitz * swank-allegro.lisp (call-with-compilation-hooks): Implemented. Wrap IMPORT call in EVAL-WHEN. * swank.lisp, swank-backend.lisp: Wrap EXPORT calls in EVAL-WHEN. Fixes many warnings in ACL. 2004-05-25 Luke Gorrie * slime.el (slime-kill-without-query-p): Default to T. (sldb-highlight): Variable to control face-based highlighting of SLDB locations. (In Emacs21 the point is visible even in unselected windows, which is sufficient for me.) (sldb-show-location-recenter-arg): Argument to `recenter' when showing SLDB locations. Default to nil, i.e. location appears in the middle of the window. 2004-05-24 Helmut Eller * slime.el (slime-input-complete-p): Return nil for unbalanced sexps starting with quote ?', backquote ?`, or hash ?#. C-j can be used for more complicated cases. 2004-05-22 Marco Baringer * slime.el (slime-repl-sayoonara): Added "quit" as an alias for sayoonara. 2004-05-22 Helmut Eller * swank-cmucl.lisp (arglist): Catch (reader) errors in READ-ARGLIST. * swank-allegro.lisp (fspec-primary-name): New function. (find-fspec-location): Use it, if the start position cannot be found. * slime.el (slime-pprint-event): New function. (slime-log-event): Use it. (slime-reindent-defun): Indent the form after point, if point is in the first column an immediately before a #\(. 2004-05-21 Bill Clementson * slime.el (slime-switch-to-output-buffer): Use "P" as interactive spec. 2004-05-21 Helmut Eller * slime.el (slime-switch-to-output-buffer): Override the prefix-arg if we are called non-interactively. (slime-repl-current-input): Don't add newlines. (slime-repl-return): Send input if we are in read-mode also if it isn't a complete expression. (repl-read-lines): New test case. (slime-enable-startup-animation-p): New configurable. (slime-repl-update-banner): Use it. (slime-hide-inferior-lisp-buffer): New function. Reuse the *inferior-lisp* buffer window for the SLIME REPL. * swank-allegro.lisp (find-fspec-location): Better handling of methods. From Bill Clementson. 2004-05-17 Luke Gorrie * xref.lisp, swank-clisp.lisp: Renamed XREF package to PXREF (P for portable). This makes it possible to load the package in e.g. CMUCL, which is nice because it's a good package. * swank-cmucl.lisp: Some refactoring and high-level commenting. Mostly just trying to organise things into fairly self-contained sections (my new hobby, sad I know!) * slime.el: Added `C-c C-e' as an alternative binding for `slime-interactive-eval' (usually `C-c :'). This seems slightly more convenient, and has the added bonus of clobbering an unwanted `inf-lisp' binding. 2004-05-14 Marco Baringer * slime.el (slime-with-output-to-temp-buffer): Now takes a package arg specifying what slime-buffer-package should be in the generated buffer. (slime-show-description): actually pass the package arg. (slime-show-apropos): pass the package arg to slime-with-output-to-temp-buffer. (slime-list-repl-shortcuts): pass a package arg. 2004-05-12 Alan Ruttenberg * swank-openmcl.lisp: Fixes to support openmcl 0.14.2 changes in backtrace protocol, from Gary Byers. - Replace string "tcr" to "context". - Change the call to %current-tcr in map-backtrace to get-backtrace-context, defined so as to be back compatible with 0.14.1. - Change the call to %catch-top to explicitly use %current-tcr instead of the passed in tcr-which-is-now-called-context. Users of map-backtrace (outside of slime code) note: The tcr position in the function call is now occupied by the backtrace "context" which is always nil. If you really need the tcr then you need to call %current-tcr yourself now. Gary comments: The part that's a little hard to document about the new "context" stuff - used to walk the stacks of thread A from thread B - is that thread B has to be aware of when a context becomes invalid (a context describing part of thread A's stack is valid while thread A's sitting in a break loop and becomes invalid as soon as it exits that break loop.) A thread sort of announces when a context becomes valid and when it becomes invalid; whether and how SWANK could hook into that isn't yet clear. * swank-openmcl.lisp: Minor changes to backtrace display: Anonymous functions names in function position surrounded by #<>. Use prin1 instead of princ to print function arguments (so strings have "s around them). prefix symbol and list arguments by "'" to make them more look like a valid function call. Let me know if you don't like this... 2004-05-12 Luke Gorrie * slime.el: Fixes for outline-mode in *slime-events* from Edi Weitz. 2004-05-11 Helmut Eller * slime.el (slime-events-buffer): Disable outline-mode by default. (slime-inhibit-ouline-mode-in-events-buffer): New variable. (slime-expected-failures): Reduce the number for SBCL. * swank-sbcl.lisp (resolve-note-location): Resolve the location if we are called by swank-compile-string. The pathname argument is never :stream in SBCL, so the method written for CMUCL was never called. 2004-05-10 Luke Gorrie * swank.lisp (from-string): Bind *READ-SUPPRESS* to NIL. (swank-compiler): Bind a restart to abort compilation but still report the compiler messages already trapped. (string-to-package-designator): Function that uses READ to case-convert package names. (apropos-list-for-emacs): Use it. * slime.el (slime-eval-with-transcript): Don't print the "=>" prefix in messages showing evaluation results. It mucks up alignment in multi-line messages. (sldb-eval-in-frame): Don't print "==>" prefix on evaluation results, for the same reason. (slime-show-source-location): Move the point to the source location in addition to highlighting the matching parens. 2004-05-08 Helmut Eller * swank-cmucl.lisp (find-definitions): Add support for variables and constants. 2004-05-07 Helmut Eller * swank-clisp.lisp (compiler-note-location): Use make-location to instead of `(:location ...). This initializes the new hint slot automatically. 2004-05-07 Barry Fishman * swank.lisp (prin1-to-string-for-emacs, arglist-to-string): CVS CLISP prints NIL as |COMMON-LISP|::|NIL| if *print-readably* is true. Set *print-readably* to nil for a more Emacs friendly printer syntax. 2004-05-06 Helmut Eller * slime.el (slime-maybe-list-compiler-notes): Display the notes listing after C-c C-c only if there are no annotations in the buffer. CMUCL creates usually one warning with an error location and an almost redundant warning without at the end of the compilation unit. Don't display the listing in this common case. (slime-reindent-defun): Pass nil as the third arument to indent-region. 2004-05-06 Marco Baringer * slime.el (slime-repl-sayoonara): Don't attempt to quit the lisp if we're not connected. * swank-openmcl.lisp (*buffer-offset*, *buffer-name*): Supply default values. This avoids unbound value errors when compiling an asdf system signals errors. 2004-05-04 Alan Shutko * slime.el (slime-compiler-notes-show-details/mouse): New command. (slime-compiler-notes-mode-map): Use it. 2004-05-04 Helmut Eller * swank-cmucl.lisp (arglist): Handle byte-code functions better. We don't know much about the actual argument list, only the number of arguments. Return at least something mildly interesting like (arg0 arg1 &optional arg2 ...) (function-location): Special-case byte-code functions. * swank-backend.lisp (with-struct): New macro. 2004-05-04 Thomas F. Burdick * slime.el (slime-reindent-defun): New command on C-M-q. Reindent the current Lisp defun after trying to close any unmatched parenthesis. If used within a comment it just calls fill-paragraph. 2004-05-04 Luke Gorrie * slime.el (slime-goto-location-position): Regexp fix. (slime-reindent-defun): New command on M-q. Reindent the current Lisp defun after trying to close any unmatched parenthesis. * swank.lisp: Remove (declaim (optimize ...)). The side-effect this has on people's environment seems harmful (I saw someone having trouble on the OpenMCL list). * swank-cmucl.lisp (source-location-from-code-location): Fixed a bug where the source-file-cache was not really used. Now always report the location based on source file (cached or not) even if modified -- not falling back on regexps, which was probably a misfeature. * slime.el: Remove `slime-cleanup-definition-refs'. 2004-05-02 Helmut Eller * slime.el (slime-start-and-load): New command. Suggested by Lars Magne Ingebrigtsen. 2004-05-02 Lars Magne Ingebrigtsen * slime.el (slime-kill-without-query-p): New variable. (slime-net-connect): Use it. (slime-open-stream-to-lisp): Ditto. (slime-maybe-start-lisp): Ditto. 2004-05-02 Luke Gorrie * slime.el (slime-goto-source-location): Added support for the :snippet "hint" in a location specifier. If Lisp sends the (initial) source text for the definition then Emacs isearches for it in both directions from the given character position. This makes M-. robust when the Emacs buffer has been edited. Requires backends to provide this snippet information. (slime-goto-location-position): Tightened up the regular expressions for :function-name style location search. (slime-cleanup-definition-refs): New function to do a little post-processing on definition references from Lisp. Mostly this is a hack: if POSITION is NIL then we fill it in with the function name, ready for regexp search. I was in a hurry and it was easier to do here, and it doesn't seem entirely unreasonable. * swank-backend.lisp (:location): Added a 'hints' property list to the location structure. This is for extra information that compliments the buffer/position. * swank-cmucl.lisp (code-location-stream-position): Position the argument stream at the definition before returning. (source-location-from-code-location): Include the :snippet hint for Emacs (see above). The snippet will only be accurate provided that the source file on disk has not been modified. (*source-file-cache*) The contents of all source files consulted for M-. are now cached if they match the version of the running code. This is so that we can accurately lookup source locations even when the file is modified, provided we manage to get the right version (by file timestamp) at least once. (source-location-from-code-location): If the right source version is not available on disk or in our cache then let Emacs fall back on a regular expression search. 2004-05-01 Helmut Eller * swank-lispworks.lisp (find-top-frame): New function used to hide debugger-internal frames. (call-with-debugging-environment): Use it. 2004-05-01 Luke Gorrie * slime.el (sldb-abort): Print a message if the Emacs RPC returns. It shouldn't, if ABORT manages to unwind the stack, but it currently does in OpenMCL due to some bug. (slime-edit-definition-fallback-function): Name of a function to try if the builtin edit-definition finding fails. You can set this to `find-tag' to fall back on TAGS. * swank.lisp (list-all-systems-in-central-registry): Use explicit :wild in pathname for matching (needed in at least SBCL). * swank-openmcl.lisp: Removed obsolete `swank-compile-system'. * swank-sbcl.lisp: Removed obsolete `swank-compile-system'. Removed some stale comments about supported features. 2004-04-30 Helmut Eller * slime.el (slime-repl-update-banner): Don't print the working directory. It rarely fits in a line and was only Emacs' default-directory. M-x pwd is convenient enough. * swank.lisp (symbol-indentation): Don't infer indentation for symbols starting with 'def' or 'with-'. It was wrong most of the time and Emacs' defaults are better. * swank-lispworks.lisp (emacs-connected): Add methods to stream-soft-force-output for socket-streams and slime-output-streams. This flushes those streams automatically (i assume it gets called when Lisp is idle). 2004-04-29 Helmut Eller * slime.el (slime-repl-mode): Set slime-current-thread to :repl-thread. * swank.lisp (thread-for-evaluation, dispatch-event): Accept :repl-thread as thread specifier and dispatch evaluation and interrupt request properly. (repl-thread-eval, repl-eval): Deleted. We do the special casing in thread-for-evaluation. 2004-04-29 Lars Magne Ingebrigtsen * slime.el (slime-event-buffer-name): New variable. (slime-events-buffer): Use it. (slime-space-information-p): Ditto. (slime-space): Use it. (slime-reply-update-banner-p): Ditto. (slime-repl-update-banner): Use it. 2004-04-28 Helmut Eller * swank-loader.lisp (*lisp-name*): Add versioning support for CLISP. * swank-clisp.lisp (arglist): Trap exceptions and return :not-available in that case. * swank.lisp (arglist-for-insertion): Don't use ~< ..~:@>. CLISP's pretty printer can't handle it. 2004-04-28 Luke Gorrie * NEWS: Created a NEWS file for recording changes that we want users to read about. * slime.el (slime-log-event): Use outline-minor-mode in *slime-events* instead of hideshow-mode. It's more reliable. (Patch from Lawrence Mitchell.) 2004-04-28 Helmut Eller * slime.el (slime-net-connect): Bind inhibit-quit to nil, so that we have a chance to interrupt Emacs if open-network-stream blocks. (slime-complete-maybe-restore-window-configuration): Keep trying after slime-repl-indent-and-complete-symbol. (slime-space): Don't close the completion buffer. We don't know the window-config before the completion, so leave the buffer open. * swank.lisp (create-server): New keyword based variant to start the server in background. (setup-server): Add support to keep the socket open for single-threaded Lisps. 2004-04-27 Luke Gorrie * doc/slime.texi (Other configurables): Updated instructions on globally installing SLDB on *debugger-hook*. * slime.el (slime-log-event): Better bug-avoidance with hs-minor-mode. Hopefully XEmacs users can rest safely now. (slime-prin1-to-string): Bind `print-escape-newlines' to nil. (slime-set-connection-info): Commented out call to `slime-check-protocol-version'. Let's see how we do without it. (slime-oneway-eval): Removed unused function. * swank.lisp (oneway-eval-string): Removed unused function. 2004-04-26 Luke Gorrie * swank.lisp: Move definition of `with-io-redirection' above `with-connection' to avoid a CLISP error. This is really weird. (interactive-eval): Bind *package* to *buffer-package*, so that `C-x C-e' and related commands evaluate in the expected package. * slime.el (sldb-insert-frames): Handle empty backtrace (I got one in CLISP). * swank-allegro.lisp (arglist): Return :not-available if arglist lookup fails with an error. * slime.el: Moved snippets of Common Lisp code into swank.lisp from the thread control panel. (Remember, no CL code in slime.el!) * swank-loader.lisp (*lisp-name*): Include a short version number in the Lisp name to separate FASL files for different versions. Only implemented for CMUCL and SBCL sofar. * swank.lisp (ed-in-emacs): Avoid mutating the argument. (spawn-repl-thread): Add a new thread for evaluating REPL expressions. This same thread is used for all REPL evaluation. This fixes some issues with variables like * and ** in at least SBCL. * nregex.lisp: Typo fix (thanks Barry Fishman). * slime.el (slime-events-buffer): Don't use hideshow-mode in XEmacs for the *slime-events* buffer. It causes obscure problems for some users. Still used in GNU Emacs. 2004-04-25 Helmut Eller * swank-backend.lisp (arglist): Return a list or :not-available. Don't return strings or raise exceptions. * swank.lisp (arglist-for-echo-area): Simplified and adapted for the new semantic of ARGLIST. (arglist-for-insertion): Now a separate function. (read-arglist): Deleted. No longer needed. * swank-cmucl.lisp, swank-lispworks.lisp (arglist): Return :not-available if the arglist cannot be determined. * slime.el (slime-set-connection-info): Hide the *inferior-lisp* buffer here, so that we have all the buffer rearrangement in one place. (slime-insert-arglist): Use swank:arglist-for-insertion. 2004-04-24 Helmut Eller * slime.el (slime-init-connection-state): Use an asynchronous RPC instead of slime-eval to reduce the amount of work we do in the timer function. We can remove the workaround for the timer problem. 2004-04-23 Luke Gorrie * slime.el: Updated top comments. Make SLIME faces inherit from their font-lock cousins properly. (slime-connect): Bind `slime-dispatching-connection' to avoid being confused by old buffer-local variables when initializing the connection. This fixes a bug where doing `M-x slime' from the REPL could give a "Not connected" error. 2004-04-22 Edi Weitz * slime.el (slime-read-system-name): Perform completion on all systems in the central registry. * swank.lisp (list-all-systems-in-central-registry): New function. 2004-04-22 Helmut Eller * slime.el (slime-repl-update-banner): Add workaround to force the proper behavior of the the first command in the REPL buffer. (slime-repl-shortcut-history): Define the variable to make XEmacs happy. 2004-04-22 Tiago Maduro-Dias * slime.el (slime-space): Cleanup. (slime-complete-restore-window-configuration): Use slime-close-buffer instead of bury-buffer. 2004-04-21 Helmut Eller * slime.el: Suppress byte-compiler warnings by binding byte-compiler-warnings to nil. (slime-repl-shortcut): Use a structure instead of a list for the short cut info. Update the users accordingly. * swank-cmucl.lisp (arglist): Return a list instead of the string. 2004-04-21 Edi Weitz * slime.el (slime-apropos): Add support for regexp-based apropos. We use nregex, so the regexp syntax is different from Emacs' regexps and bit restricted (alternation '|' and optional groups '(xy)?' are not implemented). (slime-insert-arglist): New command - stolen from ILISP. I always thought this was quite useful. (slime-oos): Fix typo. * swank.lisp (apropos-symbols): Use regexp and support case-sensitive matching. (arglist-for-echo-area): New argument to control if the operator name should be included. * nregex.lisp: New file. * swank-loader.lisp (*sysdep-pathnames*): Load it. 2004-04-21 Helmut Eller * doc/slime.texi (Compilation): slime-remove-notes is bound to C-c M-c not M-c. Noted by Edi Weitz. 2004-04-21 Edi Weitz * swank.lisp (list-all-package-names): Optionally include nicknames in the result. * slime.el (slime-read-package-name): Include nicknames in the completions set. (slime-repl-mode-map): Bind C-c : to slime-interactive-eval just like in most other SLIME buffers. (read-directory-name): Compatibilty defun. 2004-04-20 Tiago Maduro-Dias * slime.el (slime-close-buffer): New utility function. (slime-space): Use it to kill superfluous *Completions* buffers. 2004-04-17 Raymond Toy * swank-cmucl.lisp (source-location-tlf-number) (source-location-form-number): New functions to extract the encoded form-numbers from source locations. (resolve-stream-source-location, resolve-file-source-location): Use them. 2004-04-17 Helmut Eller * slime.el (slime-merge-notes): Use mapconcat instead of (concat (slime-intersperse (mapcar ....))) (slime-intersperse): Handle empty lists. 2004-04-16 Luke Gorrie * doc/Makefile: Added 'install' and 'uninstall' targets for the Info manual. It may be necessary to tweak `infodir' in the Makefile to suit the local system before installing. (Patch from from Richard M Kreuter.) * doc/slime.texi (Top): The Top node is now smaller, with details moved into Introduction. This makes the Info front page easier to navigate. (Patch from Richard M Kreuter.) 2004-04-15 Ivan Boldyrev * slime.el (slime-handle-repl-shortcut): Call `completing-read' with an alist as expected, using `slime-bogus-completion-alist'. 2004-04-14 Luke Gorrie * doc/slime.texi (Shortcuts): Described REPL shortcuts. * slime.el (slime-oos): Generic ASDF interface. (force-compile-system, compile-system, load-system, force-load-system): New REPL commands. * swank-backend.lisp (operate-on-system): More generic interface to ASDF. * swank.lisp (operate-on-system-for-emacs): More generic interface to ASDF. * slime.el (slime-repl-mode-map): Portability fix for definition of the REPL command character. (slime-maybe-rearrange-inferior-lisp): Bugfix for running multiple inferior lisps. 2004-04-13 Marco Baringer * slime.el (slime-handle-repl-shortcut, slime-list-all-repl-shortcuts, slime-lookup-shortcut, defslime-repl-shortcut): Refactor repl shortcut code to provide a more leggible help. 2004-04-09 Lawrence Mitchell * slime.el (slime-same-line-p): Use `line-end-position', rather than searching for a newline manually. (slime-repl-defparameter): Use VALUE, not VALUE-FORM. 2004-04-08 Marco Baringer * slime.el (slime-repl-package-stack): New buffer local variable. (slime-repl-directory-stack): New buffer local variable. (slime-repl-command-input-complete-p): Remove. (slime-repl-update-banner): New function. (slime-init-output-buffer): Use slime-repl-update-banner. (slime-repl-shortcut-dispatch-char): New variable. (slime-repl-return): Don't check for repl commands anymore. (slime-repl-send-repl-command): Remove. (slime-repl-mode-map): Bind slime-repl-shortcut-dispatch-char to slime-handle-repl-shortcut. (slime-set-default-directory): Use read-directory-name, call slime-repl-update-banner. (slime-repl-shortcut-table): New global variable. (slime-handle-repl-shortcut): New function. (defslime-repl-shortcut): New macro for defining repl shortcuts. (slime-repl-shortcut-help, "change-directory", slime-repl-push-directory, slime-repl-pop-directory, "change-package", slime-repl-push-package, slime-repl-pop-package, slime-repl-resend, slime-repl-sayoonara, slime-repl-defparameter, slime-repl-compile-and-load): New repl shortcuts. (slime-kill-all-buffers): Kill sldb buffers as well. * swank.lisp: Remove the repl related functions. (requires-compile-p): New function. 2004-04-07 Lawrence Mitchell * slime.el (slime-repl-prompt-face): New face. (slime-repl-insert-prompt): Use it. (slime-with-chosen-connection, with-struct): Docstring fix for function's arglist display. (when-let, slime-with-chosen-connection, with-struct): Docstring fix for function's arglist display. (slime-read-package-name): Use `slime-bogus-completion-alist' to construct completion table. (slime-maybe-rearrange-inferior-lisp): Use `rename-buffer's optional argument to rename uniquely. (slime-check-connected): Display keybinding for `slime' via `substitute-command-keys'. (slime-repl-send-repl-command): Use whitespace character class in regexp. (slime-autodoc-stop-timer): New function. (slime-autodoc-mode): Add `interactive' spec to specify optional arg. This allows prefix toggling of mode (behaves more like most Emacs modes now). Stop timer if switching mode off with `slime-autodoc-stop-timer'. (slime-autodoc-start-timer, slime-complete-symbol) (slime-complete-saved-window-configuration) (slime-insert-balanced-comments): Docstring fix. (slime-ed): Call `slime-from-lisp-filename' on filename for list case of argument. (slime-insert-transcript-delimiter, slime-thread-insert): Use ?\040 to indicate SPC. (line-beginning-position): `forward-line' always puts us in column 0. (line-end-position): Define if not fboundp (for older XEmacs). 2004-04-07 Peter Seibel * swank-allegro.lisp (set-default-directory): Allegro specific version that also uses excl:chdir. * swank.lisp (swank-pprint): Add swank versions of two missing pretty-printer control variables. 2004-04-07 Luke Gorrie * swank.lisp (completion-set): Also complete package names. (Patch from Sean O'Rourke.) (find-matching-packages): Add a ":" to the end of package names in completion. 2004-04-06 Luke Gorrie * slime.el (slime-bytecode-stale-p): Automatically check if slime.elc is older than slime.el and try to help the user out if so. 2004-04-06 Marco Baringer * slime.el (slime-repl-command-input-complete-p): New function. (slime-repl-send-string): New optional arg specifying what string to put on slime-repl-input-history, usefull when this string differs from what we actually want to eval. (slime-repl-return): Check for repl commands and pass then to slime-repl-send-repl-command. (slime-repl-send-repl-command): New function. (slime-kill-all-buffers): New function. * swank.lisp: Define the various repl command handlers: sayoonara, cd, pwd, pack and cload. * swank-backend.lisp (quit-lisp): Define as part of the backend interface and export. * swank-sbcl.lisp, swank-openmcl.lisp, swank-cmucl.lisp, swank-clisp.lisp, swank-allegro.lisp (quit-lisp): implement. 2004-04-06 Luke Gorrie * swank.lisp (macro-indentation): Check that the arglist is well-formed. This works around a problem with ACL returning arglists that aren't real lambda-lists. 2004-04-05 Lawrence Mitchell * swank.lisp (*swank-pprint-circle*, *swank-pprint-escape*) (*swank-pprint-level*, *swank-pprint-length*): Fix typo in docstring. * slime.el (slime-arglist): Don't `message' arglist directly, in case it contains %-signs. (slime-repl-output-face): Fix quoting. (slime-symbol-at-point): Call `slime-symbol-name-at-point', rather than ourselves. (slime-check-protocol-version): Docstring fix. 2004-04-05 Luke Gorrie * doc/slime.texi (Semantic indentation): Documented new automatically-learn-how-to-indent-macros feature. Added auto version control header in subtitle. * slime.el (slime-close-parens-at-point): New command bound to C-a C-a. Inserts close-parenthesis characters at point until the top-level form becomes well formed. Could perhaps be made fancier. (slime-update-indentation): New command to update indentation information (`common-lisp-indent-function' properties) based on macro information extracted from Lisp. This happens automatically, the command is just to force a full rescan. * swank.lisp (connection): Added slots to track indentation caching. (*connections*): List of all open connections. (default-connection): Function to get a "default" connection. This is intended to support globally using the debugger hook outside the context of a SLIME request, which is broken at present. (with-connection): Don't setup a restart: that must be done separately. (sync-state-to-emacs): Call `update-connection-indentation'. (update-connection-indentation): Automatically discover how to indent macros and tell Emacs. * swank-backend.lisp (arglist): Specify that strings returned from ARGLIST should be READable. 2004-04-02 Helmut Eller * slime.el (slime-maybe-list-compiler-notes): Display the notes for C-c C-c, when there are notes without a good source-location. 2004-04-01 Helmut Eller * swank-sbcl.lisp: Remove the non-working workarounds for non-existent fcntl. Reported by Brian Mastenbrook. (preferred-communication-style): Use multithreading if futexes are available, sigio if fcntl is present, and fd-handlers otherwise. (resolve-note-location): Don't try to construct a source-location if there's no context. Notes without location will be displayed in the note-listing buffer. 2004-04-01 Bill Clementson * swank-allegro.lisp (send): Fix misplaced parens. 2004-03-31 Helmut Eller * swank-cmucl.lisp (debug-function-arglist): Return symbols if possible. (class-location): Support for experimental source-location recording. 2004-03-30 Helmut Eller * slime.el (slime-repl-result-face): New face. (slime-inspector-mode-map): Add a binding for M-. (compile-defun): Add test case for escaped double quotes inside a string. * swank.lisp (ed-in-emacs): New allowed form for argument. (pprint-eval-string-in-frame): Apply arguments in proper order. * swank-cmucl.lisp (method-dspec): Include method-qualifiers. (class-definitions): Renamed from struct-definitions. Try to locate condition-classes and PCL classes (in the future). (debug-function-arglist): Insert &optional, &key, &rest in the right places. (form-number-stream-position): Make it a separate function. 2004-03-29 Lawrence Mitchell * swank.lisp (ed-in-emacs): New allowed form for argument. * slime.el (slime-ed): Deal with list form of argument. For a list (FILENAME LINE [COLUMN]), visit the correct line and column number. 2004-03-29 Helmut Eller * swank-source-path-parser.lisp (cmucl-style-get-macro-character): New function. Workaround for bug(?) in SBCL. (make-source-recording-readtable): Use it. 2004-03-29 Luke Gorrie * HACKING: Some small updates (more needed). * slime.el (slime-inspector-buffer): Enter `slime-inspector-mode' after `slime-mode'. This seems to give priority of keymap to the inspector, so that it can override SPC. (slime-easy-menu): Add slime-switch-to-output-buffer. Enable SLIME menu in the REPL buffer. (slime-symbol-name-at-point): Avoid mistaking the REPL prompt for a symbol. (slime-words-of-encouragement): A few new ones. (slime-insert-xrefs): Removed the final newline from XREF buffers. This helps to avoid unwanted scrolling. * doc/slime.texi: Added a section about user-interface conventions and our relationship with inf-lisp. 2004-03-27 Helmut Eller * slime.el (slime-changelog-date): Reinitialize it at load-time. This avoids the need to restart Emacs (horror!) after an update. * swank-cmucl.lisp (debug-function-arglist): Properly reconstruct the arglist from the debug-info. (Not complete yet.) (arglist): Use it. * swank-lispworks.lisp (spawn): Remove CL symbols from mp:*process-initial-bindings*, to avoid the irritating behavior for requests executed in different threads. E.g., when someone tries to set *package*. * swank.lisp (*log-io*): New variable. Bind it to *terminal-io* at load-time, so we can log to a non-redirected stream. (disassemble-symbol): Allow generalized function names. (apropos-symbols): Handle the PACKAGE argument properly to get useful output for C-c P. * slime.el (slime-repl-indent-and-complete-symbol): New command. Bound to TAB in the REPL mode. First try to indent the current line then try to complete the symbol at point. (slime-dispatch-event): Ignore a unused thread variable to keep XEmacs' byte compiler quiet. * swank-sbcl.lisp (enable-sigio-on-fd): Use sb-posix::fcntl instead of sb-posix:fcntl to avoid the ugly reader hack. SBCL doesn't have package locks and even if they add locks in the future sb-posix::fcntl will still be valid. (getpid): Use defimplementation instead of defmethod. (function-definitions): Take generalized function names ala '(setf car)' as argument. 2004-03-26 Luke Gorrie * slime.el (slime-group-similar): Bugfix: return NIL if the input list is NIL. (slime-inspector-buffer): Enter `slime-inspector-mode' after `slime-mode'. This seems to give priority of keymap to the inspector, so that it can override SPC. 2004-03-26 Bjørn Nordbø * swank.lisp (print-arglist): Updated to handle arglists with string elements, causing arglists for macros to display properly in LW 4.1. 2004-03-26 Marco Baringer * swank-cmucl.lisp (set-default-directory): Define only once; define with defimplementation, not defun. 2004-03-26 Luke Gorrie * slime.el (slime-merge-notes-for-display): New function to merge together compiler notes that refer to the same location. This is an optimization for when there are a lot of compiler notes: `slime-merge-note-into-overlay' concat'd messages together one by one in O(n^2) time/space, and became noticeably slow in practice with ~100 notes or more. (slime-tree-insert): This function is now automatically byte-compiled (good speed gain). Wrap byte-compilation in `save-window-excursion' to avoid showing an unwanted warnings buffer (in XEmacs). 2004-03-25 Bjørn Nordbø * swank-lispworks.lisp: (create-socket, set-sigint-handler) (who-references, who-binds, who-sets): Add backward compatibility for LW 4.1. (dspec-buffer-position): Fix inappropriate use of etypecase. 2004-03-24 Luke Gorrie * swank-sbcl.lisp (getpid): Use sb-posix:getpid. * slime.el (slime-inspector-mode-map): Added SPC as extra binding for slime-inspector-next (like info-mode). * doc/slime.texi: Added completion style and configuration. 2004-03-23 Alan Shutko * swank-clisp.lisp (set-default-directory): New function. 2004-03-23 Helmut Eller * swank-allegro.lisp (send): Wait a bit if there are already many message in the mailbox. * swank-clisp.lisp (xref-results): Use fspec-location instead of the of fspec-source-locations. Reported by Alan Shutko. (break): Be friendly to case-inverting readtables. * swank-lispworks.lisp (emacs-connected): Add default method to environment-display-notifier. Reported by Bjørn Nordbø. (set-default-directory, who-specializes): Implemented for Lispworks. (gfp): New function. (describe-symbol-for-emacs, describe-definition): Distinguish between ordinary and generic functions. (call-with-debugging-environment): Unwind a few frames. Looks better and avoids the problems with the real topframe. (interesting-frame-p): Use Lispworks dbg:*print-xxx* variables to decide which frames are interesting. (frame-actual-args): New function. (print-frame): Use it. * swank.lisp (open-streams, make-output-function): Capture the connection not only the socket. This way the streams can be used from unrelated threads. Reported by Alain Picard. (create-connection): Factorized. Initialize the streams after the connection is created. (initialize-streams-for-connection, spawn-threads-for-connection): New functions. (with-connection): Fix quoting bug and move upwards before first use. (guess-package-from-string): Add kludge for SBCL !-package names. (apropos-list-for-emacs): Lispworks apparently returns duplicates; remove them. (inspect-object): Princ the label to allow strings and symbols. (send-output-to-emacs): Deleted. (defslimefun-unimplemented): Deleted. Was unused. * slime.el (slime-easy-menu): Add some more commands. (slime-changelog-date): New variable. Initialized with the value returned by the function of the same name. This detects incompatible versions if Emacs has not been restarted after an upgrade. (slime-check-protocol-version, slime-init-output-buffer): Use it. (slime-events-buffer, slime-log-event): Use fundamental mode instead of lisp-mode to avoid excessive font-locking for messages with lots of strings. 2004-03-22 Luke Gorrie * doc/slime.texi: New user manual. * swank.lisp (*communication-style*): New name for *swank-in-background*. Exported configuration variables: *communication-style*, *log-events*, *use-dedicated-output-stream*. 2004-03-20 Julian Stecklina * swank-sbcl.lisp (+o_async+, +f_setown+, +f_setfl+): Add correct constants for FreeBSD. 2004-03-19 Alan Shutko * swank.lisp, swank-loader.lisp: Take into account `pathname-device' when deriving paths. A fix for Windows. 2004-03-19 Luke Gorrie * slime.el (slime-connected-hook): New hook called each time SLIME successfully connects to Lisp. This is handy for calling `slime-ensure-typeout-frame', if you want to use that feature. (sldb-print-condition): New command to print the SLDB condition description into the REPL, for reference after SLDB exits. Can be called from `sldb-hook' if you want the condition to always be printed. Bound to 'P' in SLDB. 2004-03-18 Helmut Eller * swank.lisp (format-values-for-echo-area): Bind *package* to *buffer-package*. (load-system-for-emacs): Renamed from swank-load-system. (carefully-find-package): Be friendly to case inverting readtables. (inspect-current-condition): New function. * swank-backend.lisp, swank-cmucl.lisp (set-default-directory): New backend function. * swank-allegro.lisp, swank-clisp.lisp, swank-lispworks.lisp, swank-sbcl.lisp (swank-compile-string): Be friendly to case-inverting readtables. * slime.el (sldb-inspect-condition): Use swank:inspect-current-condition. (slime-inspector-label-face): Make it bold by default. (slime-check-protocol-version, slime-process-available-input): Wait 2 secs after displaying the error message. (sldb-list-catch-tags, sldb-show-frame-details): Display catch tags as symbols not as strings. 2004-03-16 Helmut Eller * slime.el (slime-dispatch-event, slime-rex): Pass a form instead of a string with :emacs-rex. (slime-connection-name): New connection variable. Use it in various places instead of slime-lisp-implementation-type-name. * swank.lisp: Better symbol completion for case-inverting readtables. (Thanks Thomas F. Burdick for suggestions.) (output-case-converter): New function. (find-matching-symbols): Case convert the symbol-name before comparing. (compound-prefix-match, prefix-match-p): Use char= instead of char-equal. (case-convert-input): Renamed from case-convert. (eval-for-emacs): Renamed from eval-string. Take a form instead of a string. (dispatch-event, read-from-socket-io): Update callers. (eval-region, interactive-eval): Use fresh-line to reset the column. 2004-03-13 Helmut Eller * slime.el (slime-space): Send a list of the operator names surrounding point to Lisp. Lisp can use the list to select the most suitable arglist for the echo area. Suggested by Christophe Rhodes and Ivan Boldyrev. (slime-enclosing-operator-names): New function. * swank.lisp (arglist-for-echo-area): Renamed from arglist-string. (format-arglist-for-echo-area, arglist-to-string): New functions. 2004-03-12 Helmut Eller * swank-backend.lisp (find-definitions): Fix docstring. * slime.el (slime-dispatch-event): Re-enable :ed command. (sldb-return-from-frame): Send swank:sldb-return-from-frame. * swank-cmucl.lisp (find-definitions): Allow names like (setf car). * swank.lisp (sldb-return-from-frame): Convert the string to a sexp. (dispatch-event, send-to-socket-io): Allow %apply events. (safe-condition-message): Bind *pretty-print* to t. (set-default-directory): Use the truename. (find-definitions-for-emacs): Allow names like (setf car). 2004-03-12 Wolfgang Jenkner * swank.lisp (:swank): Export startup-multiprocessing, restart-frame, return-from-frame. What about kill-thread and interrupt-thread, which are accessed as internal symbols? 2004-03-10 Helmut Eller * swank-cmucl.lisp (struct-definitions, find-dd) (type-definitions, function-info-definitions) (source-transform-definitions, setf-definitions): New funtions. (find-definitions): Include struct definitions, deftypes, setf defintions, compiler-macros and compiler transforms. 2004-03-10 Andras Simon * swank.lisp (print-arglist): Use with-standard-io-syntax. 2004-03-10 Pawel Ostrowski * swank-cmucl.lisp (unprofile-all): (eval '(profile:unprofile)) instead of just calling it since it is a macro in cmucl. * swank.lisp (:swank): export profile symbols (profiled-functions, profile-report, profile-reset, unprofile-all, profile-package) 2004-03-10 Helmut Eller * swank-allegro.lisp, swank-lispworks.lisp, swank-sbcl.lisp, swank-clisp.lisp, swank-cmucl.lisp (find-definitions): Some tweaking. * swank.lisp (print-arglist): Bind *pretty-circle* to nil to avoid output like "(function . (cons))". Suggested by Michael Livshin. (test-print-arglist): Re-enable the tests. (find-definitions-for-emacs): Renamed from find-function-locations. * slime.el (slime-edit-definition): Renamed from slime-edit-fdefinition. Display the dspec if there are multiple definitions. (slime-symbol-name-at-point): Handle the case when there is no symbol at point. (slime-expected-failures): New function (slime-execute-tests): Use it. 2004-03-09 Helmut Eller * swank.lisp (frame-source-location-for-emacs): Export it. Reported by Jouni K Seppanen (test-print-arglist): Disable the tests until we know what's wrong with print-arglist. Reported by Michael Livshin. * swank-source-path-parser.lisp, swank-gray.lisp (in-package): We are in-package :swank-backend. Thanks to Raymond Wiker. Merge package-split branch into main trunk. * swank-clisp.lisp (find-fspec-location): Handle "No such file" errors. * swank-openmcl.lisp (preferred-communication-style): Implemented. (call-without-interrupts, getpid): Use defimplementation. (arglist, swank-compile-file, swank-compile-string) (swank-compile-system, backtrace): Renamed. (print-frame): New function. (frame-catch-tags): Don't exclude nil source location. (format-restarts-for-emacs, debugger-info-for-emacs, inspect-in-frame). deleted (frame-arguments): Don't use to-string. (find-source-locations, find-function-locations (method-source-location): Deleted. (canonicalize-location, find-definitions, function-source-location, list-callers): Use ccl::edit-definition-p and ccl::get-source-files-with-types&classes. Makes things easier. (return-from-frame): Take a sexp not a string. (describe-definition): Describe more types. * swank-loader.lisp: Change load order. swank.lisp is now the last file. * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-gray.lisp, swank-lispworks.lisp, swank-sbcl.lisp, swank-source-path-parser.lisp: Implement changed backend interface and remove references to frontend symbols. * swank-backend.lisp (:swank-backend): New package. (definterface): Export the symbol. (:location, :error, :position, :buffer): Define structure of source locations here. (preferred-communication-style, compute-backtrace, print-frame): New functions. (debugger-info-for-emacs): Deleted. Renaming: compile-file-for-emacs -> swank-compile-file compile-string-for-emacs -> swank-compile-string compile-system-for-emacs -> swank-compile-stystem arglist-string -> arglist backrace -> compute-backtrace find-function-locations -> find-definitions * swank.lisp (:swank): Create the package here. (*swank-in-background*): Call the backend function preferred-communication-style to for the initial value. (find-symbol-designator): Handle NIL properly. (arglist-string): Renamed from format-arglist. Call backend function directly. (*sldb-restarts*, swank-debugger-hook, format-restarts-for-emacs) (nth-restart, invoke-nth-restart, sldb-abort): Handle restarts in the front end. (frame-for-emacs): Renamed from print-with-frame-label. (backtrace, debugger-info-for-emacs, pprint-eval-string-in-frame) (set-default-directory): Now in the front end. (frame-locals-for-emacs): Use print not princ for variable names. (compile-file-for-emacs, compile-string-for-emacs): Small wrappers around backend functions. (describe-definition-for-emacs): Handle unknown symbols before calling the backend. (find-function-locations): Wrapper for new backend function find-definitions. (group-xrefs, partition, location-valid-p, xref-buffer, xref): Updated for the new backend functions. * slime.el: (slime-symbol-at-point, slime-symbol-name-at-point): slime-symbol-at-point calls slime-symbol-name-at-point not the other way around. This avoids the mess if the symbol at point is NIL. (slime-compile-file, slime-load-system, slime-compile-region) (slime-call-describer, slime-who-calls, sldb-catch-tags): Updates for renamed lisp functions. (slime-list-callers, slime-list-callees): Unified with other xref commands. (sldb-show-frame-details): Catch tags no longer include the source location. (sldb-insert-locals): Simplified. 2004-03-09 Helmut Eller * swank-cmucl.lisp (read-into-simple-string): Use the correct fix. Reported by Håkon Alstadheim. 2004-03-08 Helmut Eller * slime.el (slime-start-swank-server, slime-maybe-start-lisp): Translate filenames. Reported by Dan Muller. 2004-03-08 Bill Clementson * slime.el (slime-insert-balanced-comments) (slime-remove-balanced-comments, slime-pretty-lambdas): New functions. 2004-03-07 Jouni K Seppanen * slime.el (sldb-help-summary): New function. (sldb-mode): Add docstring so that describe-mode is useful. (sldb-mode-map): Add bindings for sldb-help-summary and describe-mode. (define-sldb-invoke-restart-key): Generate docstrings. (sldb-default-action/mouse, sldb-default-action) (sldb-eval-in-frame, sldb-pprint-eval-in-frame) (sldb-inspect-in-frame, sldb-down, sldb-up, sldb-details-up) (sldb-details-down, sldb-list-locals, sldb-quit, sldb-continue) (sldb-abort, sldb-invoke-restart, sldb-break-with-default-debugger) (sldb-step): Add rudimentary docstrings. 2004-03-07 Helmut Eller * slime.el (slime-complete-symbol*, slime-simple-complete-symbol): Use the correct block name when returning. (slime-display-completion-list): Fix typo. * swank-cmucl.lisp (frame-locals): Use #:not-available instead of "". 2004-03-05 Bill Clementson * swank-lispworks.lisp (getpid, emacs-connected): Conditionalize for Windows. 2004-03-05 Helmut Eller * swank.lisp (frame-locals-for-emacs): Bind *print-readably* to nil. 2004-03-05 Marco Baringer * swank.lisp (frame-locals-for-emacs): New function. * slime.el (sldb-frame-locals): Use swank::frame-locals-for-emacs not swank::frame-locals. (sldb-insert-locals): use the :value property, not the :value-string property. * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-lispworks.lisp, swank-sbcl.lisp (frame-locals): Return lisp objects, not strings. Use the :value property and not the :value-string property. 2004-03-04 Helmut Eller * slime.el (slime-display-comletion-list): New function. Set syntax table properly. (slime-complete-symbol*, slime-simple-complete-symbol): Use it. (slime-update-connection-list): New function. (slime-draw-connection-list): Simplified. (slime-connection-list-mode-map): Bind g to update-connection-list. (slime-open-inspector): Print the primitive type in brackets. (slime-test-arglist): Add test for empty arglist. * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-lispworks.lisp, swank-sbcl.lisp, swank-backend.lisp (thread-alive-p): Add default implementation. (describe-primitive-type): Add default implementation. (inspected-parts): Implemented for Allegro and CLISP. * swank.lisp (remove-dead-threads): New function. (lookup-thread): Use it. (print-arglist): New function. This time without a custom pretty print dispatch table. (format-arglist): Use it. (inspected-parts): Add method for hash-tables. 2004-03-03 Helmut Eller * swank.lisp: Use *emacs-connection*, *active-threads*, and *thread-counter* as thread local dynamic variables. (init-emacs-connection): Don't set *emacs-connection*. (create-connection, dispatch-event): Pass the connection object to newly created threads. (with-connection): New macro (handle-request, install-fd-handler, debug-thread): Use it. * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp (call-with-compilation-hooks): Bind fewer variables. Most of them are already bound in swank.lisp. * swank.lisp (setup-server, serve-connection): New dont-close argument to keep the socket open after the first connection. (start-server, create-swank-server): Update callers. Reported by Bill Clementson. * swank-cmucl.lisp (resolve-note-location): Don't be too clever, if there is no context available. The compiler notes buffer is probably more adequate in this situation. (compile-file-for-emacs): Use the :load argument to compile-file. (inspect-in-frame): Deleted. * slime.el (slime-compilation-finished-hook): Use slime-maybe-list-compiler-notes as default. (slime-maybe-list-compiler-notes): New function. (slime-list-compiler-notes): Insert "[no notes]" if there aren't any. Pop to the buffer. (slime-complete-symbol*, slime-simple-complete-symbol): Set the lisp-mode-syntax-table in the completion buffer. (check-parens): Compatibility function for XEmacs and Emacs 20. * swank.lisp (find-completions): Deleted. (simple-completions): Use longest-common-prefix instead of longest-completion. (inspect-in-frame): Moved here from swank-cmucl.lisp. * swank-lispworks.lisp (call-with-debugging-environment): Bind *sldb-top-frame*. (nth-frame): Use *sldb-top-frame*. (name-source-location, name-source-locations): Renamed from dspec-source-location, dspec-source-locations. The result now includes methods for generic functions. (eval-in-frame, return-from-frame, restart-frame): Implemented. (compile-string-for-emacs): Set dspec::*location* to the buffer location. (signal-undefined-functions, signal-error-data-base) (make-dspec-location): Remove temp-file kludges. (patch-source-locations, replace-source-file): Deleted. 2004-03-01 Marco Baringer * swank.lisp (format-arglist): deal with nil arglists. 2004-03-01 Helmut Eller * swank-lispworks.lisp (compile-string-for-emacs): Patch the recorded source locations. (replace-source-file, patch-source-locations): New function. (dspec-buffer-position): Handle defgeneric. (make-dspec-location): Handle (patched) emacs-buffer locations. (emacs-buffer-location-p): New function. (describe-primitive-type, inspected-parts): Implemented. (kill-thread): Implemented. * swank-sbcl.lisp, swank-cmucl.lisp, swank-allegro.lisp (kill-thread): Implemented. 2004-02-29 Helmut Eller * slime.el (slime-complete-symbol): Make slime-complete-symbol customizable. I don't understand how the ILISP style completion is supposed to work and find it unintuitive. (slime-complete-symbol-function): New variable. (slime-complete-symbol*): Renamed from slime-complete-symbol. (slime-simple-complete-symbol, slime-simple-completions): New function. (slime-compiler-notes-to-tree): Return a list of trees, not a single tree. * swank.lisp (format-arglist): Don't use a custom pprint table. Didn't work with CLISP and the behavior was different in SBCL and Lispworks. (completions): Factorize. (parse-completion-arguments, format-completion-set, (completion-set, find-matching-symbols, find-completions): New functions. (simple-completions): New function. (prefix-match-p) New function. 2004-02-28 Helmut Eller * slime.el (slime-compilation-finished-hook): New hook variable. (slime-compilation-finished): Call it. (slime-maybe-show-xrefs-for-notes): New function. (slime-make-default-connection): Use the current connection. (slime-connection-at-point): New function. (slime-goto-connection, slime-connection-list-make-default): Use it. (slime-draw-connection-list): Minor cleanups. Define selectors for t and c for thread and connection list. * swank.lisp: (*initial-pprint-dispatch-table*) (*arglist-pprint-dispatch-table*): Workaround for bug in CLISP. Don't supply nil as argument to copy-pprint-dispatch. (print-cons-argument): Insert a space after the car. 2004-02-27 Marco Baringer * slime.el (slime-read-port-and-connect, slime-read-port-and-connect-to-running-swank): Refactor slime-read-port-and-connect into two functions so that slime-thread-attach can use the logic in slime-read-port-and-connect. (slime-thread-control-mode-map): Added key bindings for slime-thread-kill, slime-thread-attach, slime-thread-debug and slime-list-threads. (slime-thread-kill, slime-thread-attach, slime-thread-debug): New functions. * swank-backend.lisp (kill-thread): Added to swank interface. * swank-openmcl.lisp (kill-thread): Implement. * swank.lisp (start-server): Add optional background argument, defaults to *swank-background*. (lookup-thread-by-id): New function. (debug-thread): New function. 2004-02-26 Peter Seibel * slime.el (slime-draw-connection-list): Use text-properties to associate the connections each line of the connections list buffer. 2004-02-26 Peter Seibel * slime.el (slime-list-connections): Make the buffer created by this function do a bit more: Can use it to switch to different connections and change the default. 2004-02-26 Marco Baringer * swank-openmcl.lisp (ccl::force-break-in-listener): Pass a condition object to invoke-debugger. Patch by Bryan O'Connor 2004-02-26 Helmut Eller * swank-backend.lisp (:swank): export connection-info. * swank-allegro.lisp (lisp-implementation-type-name): Implement it. * swank-sbcl.lisp (compile-file-for-emacs): Load the fasl file regardless of f-p. * swank.lisp (swank-pprint): Bind *package* to *buffer-package*. Reported by Alan Picard. * swank-lispworks.lisp (dspec-buffer-position): Renamed from dspec-buffer-buffer-position. Handle dspecs of the form (defmacro foo). Reported by Alan Picard. (arglist-string): Handle unknown arglists properly. 2004-02-25 Helmut Eller * swank-cmucl.lisp (arglist-string): Delay the call to di::function-debug-function until it is actually needed. (compile-file-for-emacs): Load the fasl file irrespective of COMILE-FILE's third return value. * swank.lisp (connection-info): New function. (open-streams): Don't send the :check-protocol-version message. Now handled with CONNECTION-INFO. * slime.el (slime-symbol-at-point): Don't skip backwards across whitespace when we are at the first character of a symbol. To handle this case: skip symbol constituents forward before skipping whitespace backwards. Reported by Jan Richter. (slime-connection-close-hook, slime-next-connection) (slime-make-default-connection): Remove extra call to format. (slime-init-connection-state): Use only a single RPC instead of 4. 2004-02-25 Helmut Eller * slime.el (slime-with-chosen-connection): Bind slime-dispatching-connection and not slime-buffer-connection. slime-buffer-connection is a buffer local variable not a dynamic variable. (slime-find-connection-by-type-name) (slime-read-lisp-implementation-type-name): Were lost during the merge. (sldb-fetch-more-frames): Use (goto-char (point-max)) instead of end-of-buffer. 2004-02-25 Peter Seibel * slime.el: Various bits of support for maintaining multiple SLIME connections to different Lisp implementations simultaneously. * swank-backend.lisp (lisp-implementation-type-name): Add function to return simple name of lisp implementation; used by new multi-connection functionality in slime.el. 2004-02-25 Helmut Eller * swank.lisp (format-arglist): Use a special pprint-dispatch table. 2004-02-22 Lawrence Mitchell * swank.lisp (format-arglist): Bind *PRINT-PRETTY* to NIL. (eval-in-emacs): Fix typo in docstring. * swank-cmucl.lisp (arglist-string): Bind *PRINT-PRETTY* to NIL. 2004-02-21 Helmut Eller Add support for SERVE-EVENT based communication. * swank-sbcl.lisp (add-sigio-handler, remove-sigio-handlers): Renamed. (add-fd-handler, remove-fd-handlers): Implement interface. * swank-cmucl.lisp (fcntl): New function. (add-sigio-handler, remove-sigio-handlers): Renamed. (add-fd-handler, remove-fd-handlers): Implement interface. * swank.lisp (create-connection): Add support for fd-handlers. (install-fd-handler, deinstall-fd-handler): New functions. * swank-backend.lisp (add-sigio-handler): Renamed from add-input-handler. (remove-sigio-handlers): Renamed from remove-input-handlers. (add-fd-handler, remove-fd-handlers): New interface functions. * slime.el (slime-batch-test): Use sit-for instead of accept-process-output, so that we see something when swank gets compiled. May be problematic in real batch mode. (loop-interrupt-continue-interrupt-quit): Wait a second before interrupting. The signal seems to arrive before the evaluation request if don't wait => the endless loop is executed inside the debugger and sldb-quit will not be processed with fd-handlers. * swank.lisp (process-available-input): Move auxiliary function to toplevel. Test if the stream is open. (install-sigio-handler): Handle the first request after installing the signal handler. * slime.el (slime-keys): Bind C-c C-x t to slime-list-threads and C-c C-x c to slime-list-connections. (slime): Disconnect before reconnecting if the inferior-lisp buffer wasn't renamed. (slime-connect): Use the host argument and not "localhost". (slime-compilation-finished): Undo last change. Switch to the buffer to remove old annotations. (slime-choose-overlay-region): Ignore errors in slime-forward-sexp. 2004-02-18 Helmut Eller * slime.el (slime): Just close the connection when called without prefix-argument. Keeping the connection open doesn't make sense. We could ask if the Lisp process should be killed, though. (slime-maybe-close-old-connections): Delete unused function. (slime-start-swank-server): Use comint-send-string instead of comint-proc-query, 'cause I don't like Olin "100%" Shivers' code. (slime-init-output-buffer): Show some animations. (slime-repl-clear-output): Fixed. (slime-compilation-finished): It's not necessary to switch to the original buffer, because the buffer is encoded in the source-locations. (sldb-show-source): Don't raise an error if the source cannot be located. Print a message instead, because errors in process-filters cause a 1 second delay. * swank-cmucl.lisp (read-into-simple-string): Workaround for read-sequence bug in 18e. 2004-02-18 Peter Seibel * swank-loader.lisp: Place the fasl files of different implementations in different directories. 2004-02-18 Helmut Eller * swank-clisp.lisp: Update comments about metering package. * metering.lisp: Imported from CLOCC. Suggested by Peter Seibel. 2004-02-17 Helmut Eller * swank.lisp, slime.el (make-compiler-note): Don't send the short-message across the wire if the slot is nil. * swank-cmucl.lisp (clear-xref-info): Compare the truenames with equalp instead of the unix-truenames. The old version was very inefficient (clearing the tables with about 1000 entries required serveral seconds). (xref-context-derived-from-p, pathname=): Delete unused functions. * swank-clisp.lisp (remove-input-handlers): socket:socket-stream-handle is not available on Windows. Reported by Alan Shutko. * slime.el (slime-length>): New function. (slime-compiler-notes-to-tree): Don't collapse if there is only one kind of notes. 2004-02-16 Helmut Eller * swank.lisp (make-compiler-note): Include short-message. * swank-sbcl.lisp (signal-compiler-condition): Initialize short-message slot. (long-compiler-message-for-emacs): New function. * swank-cmucl.lisp (handle-notification-condition): Don't use the context of the previous message. (signal-compiler-condition): Set short message slot. (long-compiler-message-for-emacs): New function. (sigio-handler): Ignore arguments. * swank-clisp.lisp (set-sigio-handler, add-input-handler): Conditionalize for linux. * swank-backend.lisp (compile-system-for-emacs): Add default implementation. (compiler-condition): New slot short-message. * slime.el (slime-compilation-finished): Display compiler notes grouped by severity in a separate buffer. (slime-compilation-finished-continuation, slime-compile-file) (slime-load-system, slime-compile-string): Update callers. (slime-list-compiler-notes, slime-alistify, slime-tree-for-note) (slime-tree-for-severity, slime-compiler-notes-to-tree) (slime-compiler-notes-mode, slime-compiler-notes-quit): New functions. (with-struct, slime-tree): New code for pseudo tree widget. (slime-init-connection-state): Set slime-state-name to "". 2004-02-08 Helmut Eller * swank-cmucl.lisp (create-socket): Fix last fix. Use the proper port argument. * swank-allegro.lisp, swank-backend.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp (create-socket): Take interface as argument. * slime.el (sldb-show-frame-details): Fix typos. (slime-print-apropos): Don't bind action. (slime-reset): Kill sldb-buffers. (slime-test-find-definition, slime-test-complete-symbol) (slime-test-arglist): Add more slime-check-top-level calls. * swank.lisp (setup-server): Pass loopback-interface to create-socket. Reported by Dirk Gerrits. (*loopback-interface*): New parameter. (sldb-loop): Send :debug event inside unwind-protect, so we never lose the corresponding :debug-return event. 2004-02-08 Marco Baringer * swank-openmcl.lisp (find-source-locations): Eliminate unused variable warning. * swank.lisp (swank-pprint): Bind pretty print vars to *swank-pprint-X* counter parts. (*swank-pprint-circle*, *swank-pprint-escape*, *swank-pprint-level*, *swank-pprint-length*): Swank counterparts to *print-X* variables used when swank needs to pretty print a form. (apply-macro-expander): Use swank-pprint. 2004-02-07 Helmut Eller * swank-cmucl.lisp (send, receive, interrupt-thread): Implement more threading functions. * swank-sbcl.lisp (inspected-parts): Implemented. * slime.el (slime-rex): Mention thread argument in docstring. (sldb-break-with-default-debugger): Use slime-rex and don't switch to the output buffer (happens automatically). (slime-list-threads): Renamed from slime-thread-control-panel. (slime-thread-insert): Use slightly different layout. (slime-give-goahead, slime-waiting-threads) (slime-popup-thread-control-panel, slime-register-waiting-thread) (slime-thread-goahead): Deleted. (slime-maybe-start-multiprocessing): Call swank:startup-multiprocessing. Reported by Paolo Amoroso. * swank.lisp (dispatch-event): :debug, :debug-condition, :debug-activate events were all encoded as :debug events, which means the debugger never worked! Fix it. I guess no one uses SLIME with a multithreaded Lisp. (read-user-input-from-emacs): Flush the output before reading. (sldb-loop): Add a sldb-enter-default-debugger tag, so we can enter the default debugger by throwing to it. (sldb-break-with-default-debugger): Throw to sldb-enter-default-debugger. (*thread-list*): New variable. (list-threads): New function. * swank-backend.lisp (thread-name): Take a thread object as argument. (thread-status, all-threads, thread-alive-p): New function. (thread-id): Deleted. * swank-allegro.lisp, swank-cmucl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp: Update for modified thread interface. * swank-sbcl.lisp (enable-sigio-on-fd): New function. Use fallback if sb-posix:fcntl isn't fbound. * swank-cmucl.lisp (gf-definition-location): Return an error when pathname for the GF is nil (this happens if the GF is not compiled from a file). * swank.lisp (undefine-function): New function. (print-with-frame-label, print-part-to-string): Bind *print-circle* to t, to avoid unbound recursion when printing cyclic data structures. * slime.el (slime-undefine-function): New command. Bound to C-c C-u. 2004-02-06 Helmut Eller * slime.el (sldb-setup): Offer to enter a recursive edit if there are pending continuations. (slime-eval): Unwind the stack, thereby exititing recursive edits, before signaling the error. 2004-02-05 Helmut Eller * swank-openmcl.lisp (compile-system-for-emacs): Remove compile time dependency on ASDF. 2004-02-05 Wolfgang Jenkner * swank-clisp.lisp, swank-loader.lisp: Add profiling support via Kantrowitz's metering package. Reporting needs to be refined (profile-package currently ignores callers-p and methods). 2004-02-04 Bryan O'Connor * swank-openmcl.lisp (mailbox): Use a semaphore instead of process-wait. Works better with native threads. 2004-02-04 Helmut Eller * swank-backend.lisp (debugger-info-for-emacs): Export it. * swank-sbcl.lisp (add-input-handler): Use fcntl from the sb-posix package. * swank.lisp (sldb-loop, dispatch-event, send-to-socket-io): Send a :debug-activate event instead of a :debug event (to avoid sending a potentially long backtrace each time). (handle-sldb-condition): Include the thread-id in the message. * slime.el (slime-path): Use load-file-name as fallback. Suggested by Lawrence Mitchell. (slime-dispatch-event): Add support for :debug-activate event. (sldb-activate): New function. (sldb-mode): make-local-hook doesn't seem to work in Emacs 20. Use a buffer local variable instead. (slime-list-connections): Don't print Lisp's state. (slime-short-state-name): Deleted. 2004-02-02 Helmut Eller * slime.el (slime-debugger): The customization group is called 'slime-debugger', fix referrers. Reported by Jouni K Seppanen. * swank.lisp (simple-break): Bind *debugger-hook* before invoking the debugger. Reported by Michael Livshin. 2004-01-31 Robert E. Brown * swank-sbcl.lisp, swank.lisp: Add more type declarations and detect missing initargs for the connection struct. 2004-01-31 Jouni K Seppanen * slime.el (slime-path): Placed inside an eval-and-compile. Works around some problems when byte-compiling slime-changelog-date. 2004-01-31 Marco Baringer * swank-openmcl.lisp: remove defslimefun-unimplemented forms. (call-with-compilation-hooks, compile-system-for-emacs): Implement them. (compile-file-for-emacs, compile-string-for-emacs): Use with-compilation-hooks. (list-callers): Define with defimplementation and not defslimefun. * swank-backend.lisp (compile-system-for-emacs): Declare method as part of the interface. * slime.el (slime-find-asd): Handle files whose directory does not contain an asdf system definition. 2004-01-31 Helmut Eller Merge stateless-emacs branch into main trunk. We use now signal driven IO for CMUCL and one thread per request for multithreaded Lisps. 2004-01-31 Robert E. Brown * swank-backend.lisp, swank-sbcl.lisp, swank-source-path-parser.lisp, swank.lisp: Add type declarations to keep SBCL quiet. 2004-01-29 Michael Weber * slime.el, swank-backend.lisp, swank-cmucl.lisp, swank-sbcl.lisp, swank.lisp: Profiler support. 2004-01-23 Alan Ruttenberg * swank-openmcl.lisp: Bind ccl::*signal-printing-errors* to nil inside debugger so that error while printing error take us down. 2004-01-23 Helmut Eller * swank-sbcl.lisp (eval-in-frame, return-from-frame): Implemented. (sb-debug-catch-tag-p): New auxiliary predicate. (source-path<): Delete unused function. 2004-01-23 Michael Weber * slime.el (slime-keys): Bind C-c M-p to slime-repl-set-package. (slime-easy-menu): Add entry for slime-repl-set-package. 2004-01-23 Michael Weber * slime.el (slime-repl-set-package): New command to set the package in the REPL buffer. * swank.lisp (set-package): Return the shortest nickname. 2004-01-23 Helmut Eller * slime.el (sldb-disassemble): Was lost somewhere. 2004-01-22 Wolfgang Jenkner * swank-clisp.lisp: Replace defmethod by defimplementation where appropriate. (return-from-frame, restart-frame): Implement them. 2004-01-22 Helmut Eller * test.sh: Copy the ChangeLog file too. * swank-cmucl.lisp: Replace some defmethods with defimplementation. * swank-allegro.lisp (return-from-frame, restart-name): Implement interface (partly). * swank-openmcl.lisp (restart-frame, return-from-frame): Remove sldb-prefix. * swank-backend.lisp (return-from-frame, restart-frame): Are now interface functions. * swank.asd: Remove dependency on :sb-bsd-sockets. Is already done in swank-sbcl. * swank-loader.lisp: Don't reference the swank package at read-time. * swank.lisp (completions): Never bind *package* to nil. That's a type error in SBCL. (swank-debugger-hook): Flush the output streams and be careful when accessing *buffer-package*. (create-swank-server): Return the port of the serve socket. * swank-lispworks.lisp (interesting-frame-p): Don't print catch frames. (make-sigint-handler): New function. (emacs-connected): Use it. * slime.el (slime-lisp-implementation-type): New per connection variable. (slime-handle-oob): Handle debug-condition event. Can be signaled CMUCL when cannot produce a backtrace. (slime-debugging-state): Don't pop up the debugger buffer an activate events. Annoying. (sldb-break-with-default-debugger): Switch to the output buffer before returning to the tty-debugger. (sldb-return-from-frame, sldb-restart-frame): Use slime-rex. (slime-list-connections, slime-short-state-name): New functions. 2004-01-20 Helmut Eller * slime.el (slime-complete-symbol): Insert the completed-prefix before deleting the original text to avoid troubles with left inserting markers. (slime-symbol-start-pos): Skip backward across symbol constituents. (slime-evaluating-state): [:read-sring] Save the window configuration. (slime-read-string-state): Don't handle activate events (troublesome if, e.g, complete-symbol is used from another buffer). Restore the window configuration. (slime-repl-read-string): Goto the end of buffer. (slime-debugging-state): [:activate] Display the debugger buffer if not visible. (slime-to-lisp-filename, slime-from-lisp-filename) (slime-translate-to-lisp-filename-function) (slime-translate-from-lisp-filename-function, slime-compile-file) (slime-goto-location-buffer, slime-ed, slime-load-file): Support for remote filename translation (untested). * swank.lisp (create-swank-server): Take announce-fn as optional argument. * swank-allegro.lisp: Replace defmethod with defimplementation. (eval-in-frame): Implemented. 2004-01-20 Lasse Rasinen * slime.el (slime-prin1-to-string): Replacement for prin1-to-string that avoids escaping non-ascii characters in a way that the CL reader doesn't understand. Allows use of 8-bit characters in Lisp expressions with Emacs in unibyte-mode. 2004-01-20 Luke Gorrie * slime.el (slime-eval-print-last-expression): Insert a newline before and after the result. (slime-easy-menu): Added menu items: "Eval Region", "Scratch Buffer", "Apropos Package..." Added some bold to default SLDB faces. 2004-01-19 Alan Ruttenberg *swank-openmcl.lisp in frame-catch-tags) (ppc32::catch-frame.catch-tag-cell -> 0) (ppc32::catch-frame.csp-cell -> 3. FIXME when this code is more stable in openMCL. 2004-01-19 Michael Weber * slime.el (slime-close-all-sexp): New command to close all unmatched parens in the current defun. Bound to `C-c C-]'. With prefix argument, only operate in the region (for closing subforms). 2004-01-19 Luke Gorrie * swank-openmcl.lisp (thread-id, thread-name): Fixed silly bugs (thanks Marco Baringer). * swank-loader.lisp: Call (swank:warn-unimplemented-interfaces). * swank.lisp (ed-in-emacs): New command with the same interface as CL:ED. * swank-cmucl.lisp, swank-sbcl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-allegro.lisp, swank-clisp.lisp: Updated to use `defimplementation'. * swank-backend.lisp (definterface, defimplementation): New macros as sugar around defgeneric/defmethod. This supports conveniently supplying a default (on NO-APPLICABLE-METHOD). Because the underly mechanism is still generic functions this doesn't break code that isn't updated. (warn-unimplemented-interfaces): Print a list of backend functions that are not implemented. (xref and list-callers): Defined interfaces for these functions. (describe-definition): New function that takes over from the many other describe-* functions called from apropos listing. Takes the type of definition (as returned by describe-symbol-for-emacs) as an argument. * slime.el (sldb-enable-styled-backtrace): This is now true by default. (slime-keys): Bound `slime-inspect' to `C-c I'. (slime): `M-x slime' now offers to keep existing connections alive (else disconnect them). If you disconnect them, the new connection gets to reuse the existing REPL. (slime-connection): Error if the connection is closed. (slime-handle-oob): New message (:ED WHAT) for `slime-ed'. (slime-display-output-buffer): Don't pop up the REPL if it is already visible in any frame. (slime-find-asd): Handle case where (buffer-file-name) is nil. (slime-ed): Elisp backend for (CL:ED WHAT). (slime-apropos): Add a summary line to apropos listings. (slime-print-apropos): Replaced `action' property (name of lisp describe function) with `type' (argument to pass to unified swank:describe-definition function). (slime-apropos-package): New command on `C-c P'. Presents apropos listing for all external (with prefix also internal) symbols in a package. 2004-01-18 Helmut Eller * swank-lispworks.lisp (sigint-handler): Bind a continue restart. (make-dspec-location): Handle strings like pathnames. Some multithreading support. * slime.el (compile-defun): Don't use keywords. The keyword package is locked in Lispworks and causes the test-suite to hang. (slime-eval-with-transcript): Fix bug triggered when 'package' is a buffer local variable. Reported by Janis Dzerins. (slime-batch-test): Wait until the connection is ready. 2004-01-18 Alan Ruttenberg * swank-openmcl: Implement frame-catch-tags. Added debugger functions sldb-restart-frame, sldb-return-from-frame. Should probably be added to backend.lisp but let's discuss first. Do other lisps support this? * slime.el sldb-restart-frame, sldb-return-from-frame 2004-01-18 Wolfgang Jenkner * swank-clisp.lisp (call-without-interrupts): Evaluate linux:SIGFOO at read time since the macro with-blocked-signals expects a fixnum. (compile-file-for-emacs): Comment fix. 2004-01-18 Helmut Eller * swank-sbcl.lisp (make-fn-streams): Deleted. Already defined in swank-gray.lisp. * swank.lisp (find-symbol-or-lose, format-arglist): New functions. (without-interrupts): New macro. (send-to-emacs): Use it. * swank-backend.lisp, swank-clisp.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp, swank-allegro.lisp: (arglist-string): Refactor common code to swank.lisp. (call-without-interrupts, getpid): Are now generic functions. * slime.el (arglist): Test slot readers and closures. * swank-cmucl.lisp (arglist-string): Use pcl:generic-function-lambda-list for generic functions. Handle closures. Print arglist in lower case. (inspected-parts-of-value-cell): Was lost during the inspector refactoring. 2004-01-18 Wolfgang Jenkner * swank-clisp.lisp (compile-file-for-emacs, split-compiler-note-line): Revert last change. (handle-notification-condition): Don't signal the condition. (*compiler-note-line-regexp*): Fix and rewrite it as extended regexp. * slime.el (slime-changelog-date): Use file-truename of byte-compile-current-file. 2004-01-17 Helmut Eller * slime.el (slime-format-arglist): Add some sanity checks and print zero argument functions nicer. Suggested by Ivan Boldyrev. (slime-test-expect): Take test predicate as argument. (arglist): Test generic functions. * swank-cmucl.lisp (arglist-string): Handle generic functions better. Reported by Ivan Boldyrev. 2004-01-16 Helmut Eller * swank-allegro.lisp: Multiprocessing support. * swank-openmcl.lisp, swank-cmucl.lisp, swank-backend.lisp, swank.lisp: Refactor inspector code. * swank.lisp (changelog-date): Use *compile-file-truename* instead of *compile-file-pathname*. (with-I/O-lock, with-a-connection): The usual CLISP fixes. (create-swank-server): Patch by Marco Baringer . Bring it back again. (create-connection): Use return the dedicated output stream if available. * slime.el: Numerous REPL related fixes. (slime-update-state-name): Take state as argument. (slime-repl-beginning-of-defun, slime-repl-end-of-defun): Fix typos. (sldb-insert-restarts): Remove duplicate definition. 2004-01-16 Luke Gorrie * swank-openmcl.lisp: Multiprocessing support. * swank.lisp (changelog-date): make-pathname portability fix (from alanr). (with-io-redirection): Use (current-connection) instead of *dispatching-connection* (from alanr). * slime.el (slime-init-output-buffer): XEmacs portability fix, and use header-line-format to show info about Lisp in Emacs21. 2004-01-15 Helmut Eller * swank-sbcl.lisp, swank-cmucl.lisp (remove-input-handlers): New method. * swank-allegro.lisp (excl:stream-read-char-no-hang): Import it. (emacs-connected): Add default method. The method for no-applicable-method doesn't seem to work. ACL bug? * swank-loader.lisp (compile-files-if-needed-serially): Don't handle compilation errors. We must compile everything because changelog-date requires *compile-file-truename*. * slime.el: (slime-changelog-date) (slime-check-protocol-version): New functions. (slime-handle-oob): Handle :check-protocol-version event. (slime-init-output-buffer): Print some info about the remote Lisp. (slime-connect): Use it. (slime-note-transcript-start): Renamed from slime-insert-transcript-delimiter. (slime-note-transcript-end): New function. (slime-with-output-end-mark, slime-repl-insert-prompt) (slime-repl-show-result, slime-compile-file) (slime-show-evaluation-result): Insert output from eval commands after the prompt and asynchronous output before the prompt. Needs documentation. (repl-test, repl-read, interactive-eval-output): New tests. (slime-flush-output): Accept output from all processes. * swank.lisp (serve-requests): New function. (setup-server): Use it. (start-server): Pass backgroud to setup-server. (create-connection): Check the protocol version. (changelog-date): New function. (make-output-function): Use write-string instead of princ. * swank-backend.lisp (remove-input-handlers): New function. 2004-01-15 Luke Gorrie * slime.el (slime-aux-connect, slime-handle-oob): Support for (:open-aux-connection port) message where Lisp requests that Emacs make a connection. These are "auxiliary" connections which don't (or at least shouldn't) have their own REPL etc. * swank.lisp: New support for multiprocessing and multiple connections + commentary. (with-a-connection): Macro to execute some forms "with a connection". This is used in the debugger hook to automatically create a temporary connection if needed (i.e. if the current thread doesn't already have one). (open-aux-connection): Helper function to create an extra connection to Emacs. * swank-sbcl.lisp: Implemented multiprocessing. Not perfect. * swank-cmucl.lisp: Implemented new multiprocessing interface. (create-socket): Make FDs non-blocking when multiprocessing is enabled. (startup-multiprocessing): Set *swank-in-background* to :spawn. * swank-backend.lisp: Changed multiprocessing interface. 2004-01-15 Wolfgang Jenkner * swank-clisp.lisp (with-blocked-signals): New macro. (without-interrupts): Use it. (*use-dedicated-output-stream*, *redirect-output*): Don't set them here, use the default settings. Make :linux one of *features* if we find the "LINUX" package. 2004-01-14 Luke Gorrie * swank-openmcl.lisp (emacs-connected): Typo fix (missing close-paren). 2004-01-13 Helmut Eller * slime.el (slime-input-complete-p): Tolerate extra close parens. (slime-idle-state): Don't active the repl. (slime-insert-transcript-delimiter): Insert output before prompt. (slime-open-stream-to-lisp): Initialize the process-buffer with the connection buffer. (slime-repl-activate): Deleted. (slime-repl-eval-string, slime-repl-show-result) (slime-repl-show-abort): Better handling of abortion. (slime-compile-file): Insert output before prompt. * swank-lispworks.lisp (create-socket): Fix condition message. * swank-openmcl.lisp (*swank-in-background*): Set to :spawn. (emacs-connected): Initialize ccl::*interactive-abort-process*. * swank.lisp (*swank-in-background*): New variable. (start-server): Start swank in background, depending on *swank-in-background*. * swank-cmucl.lisp, swank-sbcl.lisp (*swank-in-background*): Set to :fd-handler. * swank-clisp.lisp (accept-connection): Remove superfluous call to socket-wait. New more direct socket interface. The new interface is closer to the functions provided by the implementations. For Lispworks we use some non-exported functions to get a sane interface. The interface also includes add-input-handler and a spawn function (not used yet). The idea is that most of the logic can be shared between similar backends. * swank-gray.lisp (make-fn-streams): New function. (stream-read-char-no-hang, stream-read-char-will-hang-p): Moved to here from swank-clisp.lisp. * swank-allegro.lisp, swank-clisp.lisp, swank-cmucl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp: (create-socket, local-port, close-socket, accept-connection) (add-input-handler, spawn): Implement new socket interface. * swank.lisp (start-server, open-dedicated-output-stream &etc): Use new socket functions. * swank-backend.lisp (create-socket, local-port, close-socket) (accept-connection, add-input-handler, spawn): New functions. (accept-socket/stream, accept-socket/run): Deleted. 2004-01-13 Luke Gorrie * swank-clisp.lisp: Updated for new network interface but not tested! Probably slightly broken. * swank-lispworks.lisp: Updated for new network interface. (accept-socket/stream): This function is currently broken, so LispWorks can't use the dedicated output channel at the moment. * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Updated for new network interface. * swank-backend.lisp (accept-socket/stream, accept-socket/run): New functions replacing the ancient (over 24 hours!) `create-socket-server'. This interface is much simpler. 2004-01-12 Luke Gorrie * swank-lispworks.lisp: Partially updated for new backend interface, but not actually working. The sockets code is broken, I haven't grokked LispWorks the interface properly. * swank-gray.lisp (slime-input-stream, slime-output-buffer): Added slots to support the new `make-fn-streams' interface from swank-backend.lisp. These slots need to be initialized by the backend, see swank-sbcl.lisp for an example (very easy). * swank-sbcl.lisp (create-socket-server): Implemented new server interface. * slime.el (slime-handle-oob): Added :open-dedicated-output-stream message, previously implemented with :%apply. (slime-repl-read-string, slime-repl-return-string): Pass integer argument to `slime-repl-read-mode' to set rather than toggle. * swank.lisp: Taking over previously non-portable jobs: (start-server): Now only uses sockets code from the backend. (handle-request): Top-level request loop. (open-dedicated-output-stream): Dedicated output socket. (connection): New data structure that bundles together the things that constitute a connection to Emacs: socket-level stream and user-level redirected streams. * swank-cmucl.lisp (create-socket-server): Generic TCP server driven by SERVE-EVENT. (serve-one-request, open-stream-to-emacs): Deleted. Now handled portably in swank.lisp. (make-fn-streams): Implement new stream-redirection interface. (slime-input-stream): New slot referencing output sibling, so it can be forced before input requests. * swank-backend.lisp (create-socket-server): Generic callback-driven TCP server interface. Replaces `create-swank-server', with the higher-level logic moved into swank.lisp. (emacs-connected): Invoked when Emacs initially connects, as a hook for backend implementations. (make-fn-streams): Interface for creating pairs of input/output streams that are backended by callback functions. Used to implement redirected-via-Emacs standard I/O streams. 2004-01-12 Lawrence Mitchell * slime.el (slime-events-buffer): Set `hs-block-start-regexp' before running `hs-minor-mode'. 2004-01-10 Luke Gorrie * slime.el (package-updating): Expected package is now a list (can be any), since the shortest nickname is not standardized. e.g. USER or CL-USER for COMMON-LISP-USER. * swank-cmucl.lisp: Don't enable xref (let the user decide). (set-fd-non-blocking): Removed unused function. Miscellaneous refactoring of the networking code. * slime.el (slime-complete-symbol): Use markers to hold the beginning and end of the completion prefix, in case looking up completions causes insertions (e.g. GC announcements). 2004-01-09 Luke Gorrie * slime.el (slime-activate-state): Only update state name when `slime-default-connection' activates. This fixes an annoying "Selecting deleted buffer" bug that prevented SLIME from being restarted. (slime-next-connection): Fixed a bug where buffer-local connection bindings could get in the way and prevent the connection from actually changing. (slime-complete-restore-window-configuration): Wrap `set-window-configuration' in `save-excursion'. This fixes a problem where the cursor would end up in the wrong place after completion in XEmacs. 2004-01-09 Helmut Eller * slime.el: Place (require 'cl) inside a eval-and-compile. (slime-with-connection-buffer): Move definition upwards before the first use. (package-updateing): New test for package updates in the listeners. * swank.lisp (eval-region): Bind *package* outside the unwind-protect to detect updates. * swank-backend.lisp (debugger-info-for-emacs) (find-function-locations): Doc fix. 2004-01-09 Wolfgang Jenkner * swank-clisp.lisp: Add methods for GRAY:STREAM-READ-CHAR-NO-HANG and for the CLISP specific GRAY:STREAM-READ-CHAR-WILL-HANG-P. This should fix the behaviour of SYS::READ-FORM. 2004-01-08 Luke Gorrie * slime.el (slime-inspector-fontify): Function to insert a string in a particular inspector face. Replaces macro-code-generation function `slime-inspector-expand-fontify'. Fixes a byte-compile problem (macro was calling function not defined at compile-time). 2004-01-07 Luke Gorrie * slime.el: Multisession internal improvements. Now there are three separate connection variables, in order of priority: slime-dispatching-connection (dynamically-bound) slime-buffer-connection (buffer-local) slime-default-connection (global) The most specific one available is used. This is splitting `slime-connection' into multiple variables, so that you can be specific about what you want to assign (i.e. know if you're setting a dynamic binding or a buffer-local one). Fixed some related bugs. (slime-connection-close-hook): If default connection closes, select another connection. (slime-lisp-package): Initially CL-USER nickname instead of COMMON-LISP-USER (for REPL prompt). * slime.el (slime): Multisession support: with prefix argument, gives the option of keeping existing sessions and firing up an additional *inferior-lisp* to connect to. Each connection now has its own *slime-repl[]* buffer. (slime-connection): Should now be read via the function of the same name. The accessor will check if the value is NIL, and if so use `slime-default-connection'. (slime-default-connection): The connection that will be used by default, i.e. unless `slime-connection' is bound. Renamed from `slime-primary-connection'. (slime-init-connection-state): When reconnecting, update the `slime-connection' binding in the REPL to use the new connection. (slime-repl-input-history, ...): REPL variables are now buffer-local. 2004-01-06 Helmut Eller * swank.lisp (eval-string): New argument 'id'. Used to identify the remote continuation. (log-event): New debugging function. (read-from-emacs, send-to-emacs): Use it. * slime.el: The new macro 'slime-rex' can now be used to evaluate sexps remotely. It offers finer control what to do when the evaluation aborts. (slime-rex): New macro (slime-eval, slime-eval-async, sldb-continue) (sldb-invoke-restart): Use it. (slime-continuation-counter, slime-push-evaluating-state): New functions. (slime-output-buffer): Initialize markers. (sldb-mode): XEmacs doesn't like (add-hook (make-local-hook ...)). (slime-init-connection): New optional argument SELECT. (slime-def-connection-var): Workarounds for Emacs 20 reader bugs. Backquote is pretty broken Emacs 20. 2004-01-06 Ignas Mikalajunas * swank-loader.lisp (user-init-file): Use merge-pathames. Fix Windows support. 2004-01-05 Luke Gorrie * slime.el: Multiple session support, i.e. Emacs can open multiple connections to Lisps. The guts is there, but user-interface is currently minimal. (slime-net-process): Replaced with slime-net-processes. (slime-net-send): Take process as argument. (slime-process-available-input): Poll all connections. (slime-connection): Current connection (process) to use for talking to Lisp. Can be bound dynamically or buffer-local. (slime-with-connection-buffer): Macro to enter the process-buffer of `slime-connection' to manipulate the local variables. (slime-stack-stack): Now buffer-local in the process-buffer of each connection. (slime-push-state, slime-pop-state): Operate on the stack inside `slime-connection's process-buffer. (slime-dispatch-event): Take optional process argument, to bind `slime-connection' appropriately when events arrive from the network. (slime-def-connection-var): Macro to define variables that are "connection-local". Such variables are used via (setf'able) accessor functions, and their real bindings exist as local variables in the process-buffers of connections. The accessors automatically work on `slime-connection'. (slime-lisp-features, slime-lisp-package, slime-pid, sldb-level): These variables are now connection-local. (slime-read-from-minibuffer): Inherit `slime-connection' as buffer-local so that we complete towards the right Lisp. (sldb-mode): Inherit `slime-connection' as buffer-local so that we debug towards the right Lisp. (get-sldb-buffer): New function to return (optionally create) the SLDB buffer for the current connection. Since multiple Lisps can be debugged simultaneously, the buffername now includes the connection number. (slime-connection-abort): New command to abort a connection attempt (don't use `slime-disconnect' anymore - that closes all connections). (slime-execute-tests): Honor `slime-test-debug-on-error'. (slime-next-connection): Cycle through open Lisp connections. 2004-01-02 Helmut Eller * slime.el (slime-display-output-buffer): Move the output markers to the end of the buffer. * swank-clisp.lisp (frame-do-venv): Rename the :symbol property to :name. (format-condition-for-emacs): Replaced with debugger-condition-for-emacs. (backtrace): Use print-with-frame-label. * swank-openmcl.lisp (format-condition-for-emacs): Replaced with debugger-condition-for-emacs. (backtrace): Use print-with-frame-label. (frame-locals): Rename the :symbol property to :name. * swank-lispworks.lisp (format-condition-for-emacs): Replaced with debugger-condition-for-emacs. (backtrace): Use print-with-frame-label. (frame-locals): Rename the :symbol property to :name. * swank-allegro.lisp (frame-locals): Rename the :symbol property to :name. (format-condition-for-emacs): Replaced with debugger-condition-for-emacs. (backtrace): Use print-with-frame-label. * swank-sbcl.lisp (tracedp, toggle-trace-fdefinition) (format-condition-for-emacs): Remove unused functions. (format-frame-for-emacs): Use print-with-frame-label. (compute-backtrace): Simplified. (backtrace): Return our frame numbers. (frame-locals): Rename the :symbol property to :name. Remove the :validity property. * swank-cmucl.lisp (accept-loop, safe-definition-finding): Doc fix. (location-buffer=, file-xrefs-for-emacs) (sort-contexts-by-source-path, source-path<) (format-condition-for-emacs): Remove unused functions. (format-frame-for-emacs): Don't include the frame number in the description, but use the frame number for indentation. Update callers. (frame-locals): Rename the :symbol property to :name. * slime.el (slime-add-face): New function. (sldb-add-face): Use it. (sldb-setup): Some refactoring. (sldb-insert-condition): New function. Factorized from sldb-setup. Message and types are now separate. (sldb-insert-restarts): New function. Factorized from sldb-setup. (sldb-insert-frame): Factorized from slime-insert-frames. The frame number in no longer part of the string describing the frame. (sldb-insert-frames): Use it. (sldb-show-frame-details): Print frame numbers. Fix printing of catch tags. Move to the start of the frame before at the beginning to get unfontified text properties. (sldb-inspect-condition): New command. (sldb-insert-locals): The :symbol property is now called :name. Fix locals with :id attribute. (slime-open-inspector): Fix the bugs I introduced last time. * swank.lisp (safe-condition-message): New function. (debugger-condition-for-emacs): Used to be format-condition-for-emacs in each backend. Separate the condition message from the type description. Update all backends accordingly. (print-with-frame-label): New function. * slime.el (slime-hyperspec-lookup): New function. 2004-01-02 Wolfgang Jenkner * swank-clisp.lisp: New file. Merged with Vladimir's version. * xref.lisp: New file. Used by swank-clisp. * swank-loader.lisp (user-init-file): Add CLISP files. * swank.lisp (eval-region, tokenize-completion): Modify loops a bit to make CLISP happy. * swank-backend.lisp (with-compilation-hooks): Replace () with (&rest _) to make CLISP happy. * slime.el (slime-goto-source-location): Support for CLISP style line numbers. Split it up. (slime-goto-location-buffer, slime-goto-location-position): New functions. (slime-load-system): Use slime-display-output-buffer. (slime-repl-mode): Disable conservative scrolling. Not sure if it was a good idea. (sldb-insert-frames, sldb-show-frame-details, sldb-list-locals): Minor fixes. (sldb-insert-locals): Renamed from sldb-princ-locals. (sldb-invoke-restart): Use slime-eval instead of slime-oneway-eval, because interactive restarts may read input. (slime-open-inspector): Minor indentation fixes. (slime-net-output-funcall): Removed. Was unused. 2003-12-19 Alan Ruttenberg * slime.el 1.157 fix bug in sldb-princ-locals I introduced when adding fonts to sldb 2003-12-19 Alan Ruttenberg * swank-openmcl.lisp 1.42 in request-loop register output stream to be periodically slushed per Gary Byer's email. * slime.el 1.156 slime-goto-source-location. Sometimes source information is recorded but it isn't a standard "def" in that case, don't error out, just look for the most likely place for the definition. 2003-12-19 Luke Gorrie * null-swank-impl.lisp: Deleted this old file. See swank-backend.lisp instead. 2003-12-18 Alan Ruttenberg * swank-openmcl.lisp 1.41 in openmcl (break) now goes into slime debugger. (setq swank:*break-in-sldb* nil) to disable that. 2003-12-17 Alan Ruttenberg * slime.el 1.155 Allow font choices for backtrack. Add group for customizing them: sldb. Whole thing is enabled with sldb-enable-styled-backtrace which is off by default, for now. Try '(sldb-condition-face ((t (:foreground "DarkSlateGray" :weight bold)))) '(sldb-detailed-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) '(sldb-local-name-face ((t (:weight bold)))) '(sldb-restart-face ((t (:foreground "DarkBlue" :weight bold)))) '(sldb-restart-number-face ((t (:underline t :weight bold)))) '(sldb-restart-type-face ((t (:foreground "DarkSlateGrey" :weight bold)))) '(sldb-section-face ((t (:weight bold :height 1.2)))) '(sldb-selected-frame-line-face ((t (:foreground "brown" :weight bold :height 1.2)))) '(sldb-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) 2003-12-17 Alan Ruttenberg slime.el 1.154 Allow some face choices in the inspector. Try '(slime-inspector-label-face ((t (:weight bold)))) '(slime-inspector-topline-face ((t (:foreground "brown" :weight bold :height 1.2)))) '(slime-inspector-type-face ((t (:foreground "DarkRed" :weight bold)))) You can also set slime-inspector-value-face 2003-12-17 Alan Ruttenberg * swank-openmcl.lisp 1.40 Fix an error with frame-source-location-for-emacs when the function was a method-function. Defined method-source-location that handles this case. You can still end up looking at the wrong definition, as the protocol doesn't allow passing back the qualifiers and specializers to look up the correct one in the file. * swank-openmcl.lisp 1.39 Allow you to continue after interrupting. Properly set *swank-debugger-stack-frame* when interrupting. * slime.el 1.152 sldb-continue now uses slime-oneway-eval 2003-12-17 Helmut Eller * slime.el: Better handling of asynchronous output. (slime-output-end): New variable. Use this marker to insert output. Insert asynchronous output inserted before the "input region" and before the prompt. (slime-show-last-output): Use it. (slime-repl-insert-prompt): Initialize it. (slime-last-output-start): Removed. (slime-flush-output): Increase delay to 20 usecs. (slime-with-output-end-mark): Renamed from slime-with-output-at-eob. Insert a newline if needed. (slime-output-string, slime-repl-activate): Use it. (slime-repl-return): Ensure that slime-repl-input-end-mark points to a reasonable location. 2003-12-17 Luke Gorrie * HACKING: New file summarising our way of working. 2003-12-16 Luke Gorrie * slime.el (slime-lisp-preferred-package-nicknames): Removed. Not very interesting (and slightly broken) now that shortest-nicknames are automatically used. (slime-output-oneway-evaluate-request): New function to evaluate an expression for side-effects (without getting a result). (slime-idle-state): Handle new :emacs-evaluate-oneway. (slime-debugging-state): Handle :emacs-evaluate-oneway. (sldb-invoke-restart): Use slime-oneway-eval. This avoids pushing an evaluating state (which will be aborted, and print an unnecessary message saying so). (sldb-break-with-default-debugger): New command to break into the default TTY debugger. Bound to 'B' in *sldb*. (slime-read-string-state): Added :emacs-evaluate-oneway. * swank.lisp (invoke-nth-restart-for-emacs): Wrapper around INVOKE-NTH-RESTART that checks that Lisp and Emacs agree on the debug level. This detects and ignores old restart requests when several are sent at once (possible because of new oneway-eval feature). (oneway-eval-string): New function to evaluate a string without sending a result, and with *DEBUGGER-HOOK* bound to NIL. (The debugger hook is inhibited to avoid state conflicts.) 2003-12-15 Luke Gorrie * swank-openmcl.lisp (ccl::*warn-if-redefine-kernel*): Support for interrupting the listener (by Alan Ruttenberg). 2003-12-15 Helmut Eller * swank.lisp *start-swank-in-background*: Set to t by default. * slime.el (slime-eval-last-expression-display-output): New command. Bound to C-x M-e. Suggested by Nicolas Neuss. (slime-display-output-buffer): New function. (slime-slime-compile-file): Use it. 2003-12-15 Luke Gorrie * swank.lisp (*processing-rpc*, *multiprocessing-enabled*, *debugger-hook-passback*): New variables. (with-conversation-lock, with-I/O-lock): New macros. (read-next-form): Use with-I/O-lock. (send-to-emacs): Use with-I/O-lock. (swank-debugger-hook): When called asynchronously (i.e. not during RPC) and multiprocessing is enabled, suspend until acknowleged by Emacs. (install-global-debugger-hook): Install a SLIME-DEBUGGER-FUNCTION globally on *DEBUGGER-HOOK*. (startup-multiprocessing-for-emacs): Called to initialize multiprocessing. (eval-string): Dynamically set the *PROCESSING-RPC* flag. (eval-string): Nasty hack with *DEBUGGER-HOOK-PASSBACK* to install debugger hook. Temporary, I swear! (eval-region, shortest-package-nickname): Report the shortest package nickname to Emacs (for the REPL prompt). Patch from Marco Baringer. * swank-backend.lisp: Defined multiprocessing interface. * swank-cmucl.lisp: Implmemented the multiprocessing interface. * slime.el (slime-multiprocessing): When true, use multiprocessing in Lisp if available. (slime-global-debugger-hook): When true, globally set *debugger-hook* to use the SLIME debugger. For use with SERVE-EVENT and multiprocessing. (slime-handle-oob): Handle :AWAITING-GOAHEAD message from threads that have suspended to wait for Emacs's attention. (slime-give-goahead): New command to allow a suspended thread to continue (bound to RET in the thread-control-panel). (slime-thread-control-panel): New command to display a buffer showing all threads that are suspending waiting for Emacs's attention. Bound to `C-c C-x t'. (slime-popup-thread-control-panel): When true, automatically popup the thread-control buffer when a new thread suspends. 2003-12-14 Alan Ruttenberg * swank-openmcl.lisp (eval-in-frame, inspect-object and friends): Most of this is copied from swank-cmucl. The parts between &&&&& are what I added for openmcl. I piggyback off the inspector which is shipped with openmcl, so inspecting won't look the same as it would in cmucl, I imagine. Still, it's a start. eval in frame uses frame-locals to get bindings so if you have debug settings low or don't have *save-local-symbols* set you won't be able to evaluate. 2003-12-14 Helmut Eller * swank-lispworks.lisp (tracedp, toggle-trace-fdefinition): Moved to swank.lisp. * swank-allegro.lisp (create-swank-server): Add support for BACKGROUND and CLOSE argument. (call-with-debugging-environment): Use excl::int-newest-frame to avoid the kludge with *break-hook*. (sldb-abort): New function. (frame-source-location-for-emacs): Dummy definition. (compile-file-for-emacs): The argument is called :load-after-compile and not :load. (xref-results-for-emacs): Use dolist instead of loop. * swank-openmcl.lisp (create-swank-server): Add support for BACKGROUND and CLOSE argument. (open-stream-to-emacs): Support for dedicated output stream. * swank.lisp: *start-swank-in-background*, *close-swank-socket-after-setup*, *use-dedicated-output-stream*: Moved here from swank-cmucl. (sldb-continue): Don't pass the condition as argument, because that doesn't work with Allegro. (toggle-trace-fdefinition, tracedp): Replace backend specific code with portable, but ugly, calls to eval. * swank-cmucl.lisp (compile-system-for-emacs): Add method for CMUCL. * slime.el (slime-goto-source-location): Better regexp for package qualified symbols. Allow dashes in the name and two colons. Reported by Alan Ruttenberg. 2003-12-13 Helmut Eller * swank-openmcl.lisp (create-swank-server): Interrupt the right thread. Patch by Alan Ruttenberg. Not yet enabled, due to lack of test platform. (sldb-disassemble): Implement sldb-disassemble command. Patch by Alan Ruttenberg. Remove #' from lambdas. 2003-12-12 Helmut Eller * swank-cmucl.lisp (create-swank-server): New keyword arguments to control the server: BACKGROUND and CLOSE. fd-handlers are used if BACKGROUND is true. If close CLOSE is true, close the socket after the first connection; keep it open otherwise. *start-swank-in-background*, *close-swank-socket-after-setup*: The default values of the corresponding arguments for create-swank-server. (compile-file-for-emacs): Don't load the fasl-file when the compilation failed. * swank-openmcl.lisp (toggle-trace-fdefinition, tracedp): Implement trace command. Patch by Alan Ruttenberg. (find-function-locations, find-source-locations): Handle variables, and method-combinations. General cleanups. (source-info-first-file-name): Removed. (list-callers): Fixed. (list-callers): Fixed some more. method-name is not exported in 0.14. From Marco Baringer. (swank-accept-connection): Accept multiple connections. Patch by Marco Baringer. * swank-loader.lisp (user-init-file): Use homedir's truename. Reported by Friedrich Dominicus. * slime.el (slime-repl-current-input): Don't remove the final newline if we are in reading state. (slime-goto-source-location): Regex-quote the function-name and handle package prefixes. Reported by Alan Ruttenberg. (slime-output-string): Insert asynchronous output before the prompt. 2003-12-12 Daniel Barlow * swank-source-path-parser.lisp: new file, excerpting part of swank-cmucl.lisp to where SBCL can find it as well. 2003-12-11 Luke Gorrie * slime.el (slime-one-line-ify): New function to convert multi-line strings to one-liners by replacing any newline followed by indentation by a single space. (slime-xrefs-for-notes): Use it. 2003-12-11 Daniel Barlow * swank-sbcl.lisp (compiler-note-location): replace with thinly-ported version from the CMUCL backend which understands :lisp as a pathname * slime.el (slime-xrefs-for-notes): a little more temporary variables, a little less cdr. Should be slightly faster on big systems (slime-goto-next-xref): set window point as well as buffer point - now works in GNU Emacs 21.2.1 * swank.lisp (swank-compiler): new function abstracts commonality between swank-compile-{file, string}. (swank-load-system): call swank-compiler to load asdf system * swank-sbcl.lisp (compiler-note-location and elsewhere): remove all trace of *compile-filename* (compile-*-for-emacs): shorten * swank-backend.lisp (call-with-compilation-hooks): new GF should set up all appropriate error condition loggers etc to do a compilation preserving the notes. Implement for sbcl, cmucl * slime.el (slime-find-asd, slime-load-system): new command to compile and load an ASDF system with all the usual compiler notes and stuff (slime-compilation-finished): if more than one file has new errors/notes, create an xref buffer to show them all (slime-remove-old-overlays): bug fix: now removes overlays even at start of buffer (slime-overlay-note): do nothing quietly if slime-choose-overlay-region returns nil (slime-choose-overlay-region): return nil if note has no location 2003-12-11 Helmut Eller * slime.el (slime-repl-previous-prompt, slime-repl-next-prompt): New commands. Suggested by Håkon Alstadheim. (slime-repl-beginning-of-defun, slime-repl-end-of-defun): New commands. Suggested by Andreas Fuchs. (slime-repl-insert-prompt): Mark the prompt with a slime-repl-prompt text property. (slime-repl-eol): New function. Mostly for symmetry. (slime-repl-in-input-area-p, slime-repl-at-prompt-end-p): New predicates. (slime-repl-find-prompt, slime-search-property-change-fn): New functions. (slime-ir1-expand): New command. * swank-cmucl.lisp (accept-connection, request-loop): Don't use fd-handlers. The code for the request-loop itself is now almost the same as in the Allegro version. (print-ir1-converted-blocks, expand-ir1-top-level): New functions. 2003-12-10 Daniel Barlow * swank-sbcl.lisp (serve-request): more fiddling with serve-event descriptors * slime.el (slime-repl-return): slime-check-connected, otherwise pressing Return in an unconnected repl gets a bit weird 2003-12-10 Helmut Eller * swank-allegro.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp (create-swank-server): Accept an announce-function keyword argument. * swank.lisp (start-server): Pass an announce callback function to create-swank-server. Works better with single threaded implementations. (announce-server-port, simple-announce-function): New functions. (alistify): Doc fix. * swank-cmucl.lisp (create-swank-server): Use announce callback. (sldb-disassemble): New function. * slime.el (sldb-disassemble): New command. Bound to D. 2003-12-08 Luke Gorrie * swank-cmucl.lisp (*debug-definition-finding*): Now nil by default, so that errors while looking for definitions are printed as a message and not debugged. * slime.el (slime-read-from-minibuffer): Now the only completing-read function, stale ones deleted. 2003-12-07 Luke Gorrie * slime.el (sldb-prune-initial-frames): Use regexp-heuristics and the '--more--' token to avoid showing the user Swank-internal backtrace frames initially. (slime-repl-current-input): Don't include the final newline character, to make backtraces prettier. (slime-autodoc): Fixed annoying case where autodocs would be fetched in a loop for undocumented symbols. * swank.lisp (compound-prefix-match): New name and rewritten for speed. Completion is much faster now. (*sldb-initial-frames*): Send up to this many (default 20) backtrace frames to Emacs when entering the debugger. 2003-12-07 Helmut Eller * swank-allegro.lisp, swank-backend.lisp, swank-cmucl.lisp, swank-lispworks.lisp, swank-openmcl.lisp, swank-sbcl.lisp (function-source-locations): Make it at generic function. (function-source-location-for-emacs): Removed. Fixes bug reported by Marco Baringer. * slime.el (slime-interactive-eval): Insert the result at point, if called with prefix argument. 2003-12-06 Luke Gorrie * slime.el (slime-easy-menu): Added menubar support, contributed by Friedrich Dominicus. 2003-12-06 Helmut Eller * swank-allegro.lisp: New file. * swank-loader.lisp (user-init-file): Translate logical pathnames. Reported by Friedrich Dominicus. * swank-sbcl.lisp (handle-notification-condition): Don't ignore warnings without context. (compiler-note-location, brief-compiler-message-for-emacs, compiler-note-location): Handle null context. (compile-file-for-emacs): Bind *compile-filename* and load the fasl file only if it exists. (function-source-location): The name argument is now optional and should be a symbol. (find-function-locations): Return errors as a list of one error. (call-with-debugging-environment): Set *print-level* to 4 and *print-length* to 10. (Both where nil.) (source-location-for-emacs): Fall back to the location of the function, if there is no debug-block-info. (safe-source-location-for-emacs): Don't catch all conditions; only errors. *compile-filename*: New variable (open-listener): Don't make the socket non-blocking. * slime.el (slime-eval/compile-defun-dwim): New command. Suggested by "jan" . 2003-12-04 Helmut Eller * slime.el (slime-debugging-state): Don't set sldb-level after sldb-setup. Breaks the test-suite. (slime-eval-defun): Fix typos. (slime-xref-buffer, slime-goto-next-xref): Updated for the new xref code. (sldb-inspect-in-frame): Query with the sexp at point as initial value. (sldb-step): New command. Bound to s. * swank-cmucl.lisp (format-frame-for-emacs, compute-backtrace, backtrace): Don't send CMUCL's frame numbers to Emacs, use our own numbering. (set-step-breakpoints, sldb-step): Lisp side of sldb-step command. 2003-12-04 Luke Gorrie * hyperspec.el: Updated URL to point to a live copy of the hyperspec at lispworks.com, because the one on xanalys.com has disappeared. Patch from Vincent Arkesteijn on the ilisp-devel mailing list. 2003-12-04 Helmut Eller * swank-lispworks.lisp (toggle-trace-fdefinition, tracedp): New support functions for toggle-trace command. Written by Alain Picard. (compile-from-temp-file): Don't delete the binary file if there is none. (lispworks-severity): Map all ERRORs to :error. * slime.el (slime-eval-defun): Use slime-re-evaluate-defvar if the defun starts with "defvar". C-M-x in elisp does this too. (slime-re-evaluate-defvar): Take the form as argument. 2003-12-03 Helmut Eller * slime.el (slime-debugging-state): Initialize the sldb-buffer if (/= sldb-level level). (slime-who-specializes): New command. * swank-cmucl.lisp (create-swank-server): Set reuse-address to t by default. (resolve-note-location): Add method for warnings in interpreted code. (who-specializes): New function. (dd-source-location): Handle case without constructors more correctly. (source-path-source-position): Skip ambigous entries in source-map. (source-location-from-code-location): Simplified. 2003-12-03 Luke Gorrie * slime.el (slime-completing-read-internal): Fix from Sean O'Rourke. 2003-12-02 Helmut Eller * swank-sbcl.lisp (find-function-locations): Return a non-empty list of source locations. * slime.el (slime-with-xref-buffer): Remove spurious comma. (Bug reported by Raymond Wiker). Some reordering of the xref code. * swank.lisp (documentation-symbol): New optional argument for return value if the symbol is not documented. 2003-12-02 Sean O'Rourke * slime.el: (slime-repl-{clear-buffer,clear-output}): clear the last and entire output in the *slime-repl* buffer (slime-documentation): pop up a buffer with a symbol's documentation instead of its description, if found. (slime-complete-symbol): tweak the completion, taken from ilisp, to complete filenames inside strings. (slime-set-default-directory): also set *slime-repl*'s default-directory, so e.g. find-file makes sense. 2003-12-02 Daniel Barlow * slime.el (slime-with-xref-buffer): moved further up the file so it's defined before slime-show-xrefs needs it * swank-sbcl.lisp (function-source-location-for-emacs): return a list of source locations (one per method) when the request is for a GF. This seems to make the elisp side popup a window to let the user select one. Cool. 2003-12-01 Helmut Eller * swank-[cmucl,sbcl,openmcl,lispworks].lisp (invoke-nth-restart): Use invoke-restart-interactively. * slime.el (slime-create-note-overlay, slime-sexp-depth): The 'priority' property is unused. Remove it. * swank-openmcl.lisp (find-function-locations): Return all methods for generic functions. Doesn't work very well if multiple methods are in the same file. (swank-accept-connection): Don't create an extra thread, call request-loop directly. 2003-12-01 Luke Gorrie * slime.el (slime-repl-return): Goto end of input area before inserting newline. (slime-autodoc-message-ok-p): Test to see if a documentation message should be printed (returns nil if the minibuffer/echo-area is already being used). (slime-symbol-at-point): Skip back over whitespace before looking for the symbol. (slime-autodoc-delay): New configurable to specify the delay before printing an autodoc message (default 0.2 secs). (slime-ensure-typeout-frame): New function to call create a typeout frame unless it already exists. Suitable to run on slime-mode-hook if you always want to have a typeout window. (slime-log-events): When nil, don't log events to *slime-events*. This works-around a problem Raymond Toy has when starting SLIME under XEmacs. Still investigating.. 2003-11-29 Helmut Eller * slime.el: Rewrite the xref code to work with other source locations. (slime-edit-fdefinition): Use the xref window to display generic functions with methods. (slime-goto-source-location): New representation for source locations. Drop old code. (slime-list-callers, slime-list-callees): Use the xref window. Remove the slime-select-* stuff. (slime-describe-function): New command. Bound to C-c C-f. Primarily useful in Lispworks. (slime-complete-symbol): Display the completion window if the prefix is complete but not unique. (slime-forward-positioned-source-path): Enter the sexp only if the remaining sourcepath is not empty. (slime-read-symbol-name): New optional argument QUERY forces querying. * swank.lisp (group-xrefs): Handle unresolved source locations. (describe-symbol): Print something sensible about unknown symbols. * swank-cmucl.lisp: Use the new format for source locations. (find-function-locations): New function. Replaces function-source-location-for-emacs. Returns a list of source-locations. (resolve-note-location): Renamed from resolve-location. Simplified. (brief-compiler-message-for-emacs): Print the source context (that's the thing after ==>). (who-xxxx): Take strings, not symbols, as arguments. (function-callees, function-callers): Use the same format as the who-xxx functions. Support for byte-compiled stuff. (code-location-stream-position): Try to be clever is the source path doesn't match the form. (call-with-debugging-environment): Bind *print-readably* to nil. * swank-lispworks.lisp: Use the new format for source locations. Implement the find-function-locations. (list-callers, list-callers): New functions. * swank-sbcl.lisp, swank-openmcl.lisp: Use the new format for source locations and implement find-function-locations (just calls the old code). 2003-11-29 Daniel Barlow * swank-sbcl.lisp (source-location-for-emacs): sb-debug::print-description-to-string takes only two args, not three. Now 'v' command works in sldb :-) * slime.el (slime-idle-state): added :debug as a valid transition * swank.lisp (slime-debugger-function): New. Returns a function suitable for use as the value of *DEBUGGER-HOOK* to install the SLIME debugger globally. Must be run from the *slime-repl* buffer or somewhere else that the slime streams are visible so that it can capture them. e.g. for Araneida: PKG> (setf araneida:*restart-on-handler-errors* (swank:slime-debugger-fucntion)) 2003-11-29 Helmut Eller * slime.el: Some tweaking to the REPL. slime-repl-input-end-mark is now always left inserting and slime-mark-input-end "deactivates" the end mark by moving it to the beginning of the buffer. (slime-goto-source-location): Next try for more uniform source-locations. A source-location is now a structure with a "buffer-designator" and "position-designator". The buffer-designator open the file or buffer and the position-designator moves point to the right position. (slime-autodoc-mode): New command. (slime-find-fdefinitions): Experimental support for generic functions with methods. (slime-show-xrefs, slime-insert-xrefs, slime-goto-xref): Rewritten to work with more general source locations. * swank.lisp: Structure definitions for source-locations. (alistify, location-position<, group-xrefs): Utilities for xref support. * swank-cmucl.lisp (code-location-source-location): Renamed from safe-source-location-for-emacs. (code-location-from-source-location): Renamed from source-location-for-emacs. (find-fdefinitions, function-source-locations): New functions. (safe-definition-finding): New macro. * swank-lispworks.lisp: Xref support. (make-dspec-location): Updated for the new source-location format. 2003-11-29 Luke Gorrie * slime.el (complete-symbol, arglist): Updated test cases for new completion interface. 2003-11-28 Luke Gorrie * slime.el (slime-complete-symbol): Use the new completion support from the Lisp side. Don't obscure minibuffer input with completion messages. * completer.el: Dead and buried! Replaced by half a page of Common Lisp. Thanks Bill Clementson for a motivational and well-deserved taunt. * swank.lisp (longest-completion): Compute the best partial completion for Emacs. * slime.el (slime-swank-port-file): Try (temp-directory), temporary-file-directory, or "/tmp/", depending on what is (f)bound. 2003-11-28 Helmut Eller * swank-lispworks.lisp (make-dspec-location): Handle logical pathnames. Reported by Alain Picard. * swank-sbcl.lisp, swank-cmucl.lisp: Support for output redirection to an Emacs buffer via a dedicated network stream. Can be enabled with *use-dedicated-output-stream*. * swank.lisp (slime-read-string, eval-string): Flush *emacs-io*. (eval-in-emacs): New function. * slime.el: Support for output from a dedicated socket. (slime-open-stream-to-lisp, slime-output-filter): New functions. Reorganized REPL code a bit. (slime-input-complete-p): Use vanilla forward-sexp, because slime-forward-sexp sometimes caused endless loops. (slime-disconnect): Close the output-stream-connection if present. (slime-handle-oob): A new :%apply event. Executes arbitrary code; useful for bootstrapping. (slime-flush-output): New function. (slime-symbol-end-pos): Didn't work at all in Emacs20. Just use point until someone commits a proper fix. Various uses of display-buffer: The second argument is different in XEmacs. (interrupt-bubbling-idiot): Reduce the timeout to 5 seconds. 2003-11-27 Luke Gorrie * slime.el (slime-swank-port-file): Use `temporary-file-directory' instead of hardcoding "/tmp/". 2003-11-27 Helmut Eller * swank-lispworks.lisp: New backend. * slime.el (slime-with-output-to-temp-buffer): Save the window configuration in a buffer local variable instead on a global stack. (slime-show-last-output): Behavior customizable with slime-show-last-output-function. Various tweaking for better multi-frame support. * swank-backend.lisp: List exported symbols explicitly. * swank-cmucl.lisp (function-source-location): Better support for generic functions. * swank.lisp (briefly-describe-symbol-for-emacs): Don't return unbound symbols. (describe-symbol, describe-function): Support package-qualified strings. * swank-loader.lisp: *sysdep-pathnames*: Add Lispworks files. (compile-files-if-needed-serially): Compile all files in a compilation unit. 2003-11-27 Luke Gorrie * slime.el (slime-complete-symbol): Make a bogus alist out of the completion set, for compatibility with XEmacs. * completer.el: Stolen^Wimported from ILISP version 1.4. This is one revision prior to their latest, where they added a (require) for some other ILISP code. I backed down a revision to make it stand-alone, but this may mean that putting SLIME in the load-path before ILISP will break ILISP. So, beware. (completer-message): Cut dependency on undefined ilisp constant testing for xemacs. 2003-11-27 Zach Beane * swank.lisp (completions): Complete compound symbols (see below). * slime.el (slime-complete-symbol): Use `completer' package to handle more sophisticated completions. This includes abbreviations like "m-v-b" => "multiple-value-bind". It also (somewhat scarily) redefines other standard Emacs completion functions with similar capabilities. See commentary in completer.erl for details. 2003-11-25 Luke Gorrie * slime.el (slime-make-typeout-frame): New command to create a frame where commands can print messages that would otherwise go to the echo area. (slime-background-message): Function for printing "background" messages. Uses the "typeout-frame" if it exists. (slime-arglist): Print arglist with `slime-background-message'. (slime-message): Use typeout frame if it exists, but only for multi-line messages. 2003-11-25 Daniel Barlow * swank-sbcl.lisp: delete big chunk of leftover commented-out code * slime.el: arglist command to use slime-read-symbol-name, not slime-read-symbol * README: Minor updates for currency 2003-11-24 Luke Gorrie * swank-backend.lisp (compiler-condition): Removed use of :documentation slot option. That is not portable (to CMUCL 18e). * swank.lisp (eval-string-in-frame): Fixed symbol-visibility problem (thanks Lawrence Mitchell). * swank-sbcl.lisp (function-source-location): Use TRUENAME to resolve source file name (thanks Lawrence Mitchell). * slime.el (slime-goto-source-location): Fixes when finding definition by regexp: open the right file (was missed), and tweaked regexp to match more 'def' forms - especially `defmacro-mundanely' (hyphen wasn't allowed before). 2003-11-23 Luke Gorrie * slime.el (sldb-fetch-more-frames): Call swank:backtrace instead of (renamed) swank:backtrace-for-emacs. * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated to use new debugger interfaces in swank-backend.lisp. * swank-backend.lisp (backtrace, eval-in-frame, frame-catch-tags, frame-locals, frame-source-location-for-emacs): More interface functions. * slime.el (slime-goto-source-location): Added optional `align-p' argument for :file and :emacs-buffer location types. This is for OpenMCL - unlike CMUCL its positions are not character-accurate so it needs to be aligned to the beginning of the sexp. (slime-connect): Don't delete a random window when *inferior-lisp* isn't visible. * swank-cmucl.lisp: Tidied up outline-minor-mode structure and added comments and docstrings. * swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl-lisp: Updated to use new debugger interface in swank-backend.lisp. * swank-backend.lisp (call-with-debugging-environment, sldb-condition, debugger-info-for-emacs): More callbacks defined. * swank.lisp: Tidied up outline-minor-mode structure, added comments and docstrings. (sldb-loop): Took over the main debugger loop. * swank-openmcl.lisp: Updated after refactoring of other backends (was broken). * slime.el (slime-goto-source-location): Align at beginning of sexp after (:file name pos) and (:emacs-buffer buffer pos). * swank-sbcl.lisp (describe-symbol-for-emacs): Don't ask for (documentation SYM 'class), CLHS says there isn't any 'class documentation (and SBCL warns). * swank.lisp, swank-cmucl.lisp, swank-sbcl.lisp: Refactored interface through swank-backend.lisp for: swank-compile-file, swank-compile-string, describe-symbol-for-emacs (apropos), macroexpand-all, arglist-string. * swank-backend.lisp: New file defining the interface between swank.lisp and the swank-*.lisp implementation files. 2003-11-22 Brian Mastenbrook * swank.asd: ASDF definition to load "swank-loader.lisp". This is useful for starting the Swank server in a separate Lisp and later connecting with Emacs. The file includes commentary. 2003-11-22 Luke Gorrie * slime.el (slime-connect): Slightly reordered some window operations to ensure that *slime-repl* is popped up after `M-x slime-connect'. (slime-show-last-output): If the *slime-repl* buffer is already visible in any frame, don't change anything. * swank.lisp (listener-eval): Format results in *buffer-package*. Exporting (CREATE-SWANK-SERVER ). This function can be called directly to start a swank server, which you can then connect to with `M-x slime-connect'. It takes a port number as argument, but this can be zero to use a random available port. The function always returns the actual port number being used. 2003-11-19 Helmut Eller * swank.lisp: Better printing off return values. In the REPL buffer we print now every value in a separate line and in the echo area separated by a comma. We also print "; No value" for the degenerated case (values). A new variable *sldb-pprint-frames* controls the printing of frames in the debugger. (Thanks Raymond Toy for the suggestions.) * swank-cmucl.lisp (format-frame-for-emacs): Bind *pretty-print* to *sldb-pprint-frames*. * slime.el: Window configuration are now saved on a stack, not in a single global variable. (slime-with-output-to-temp-buffer) We use now our own version of with-output-to-temp-buffer. The default version is painfully incompatible between Emacs versions. The version selects the temporary buffer and the behaivor of "q" is now more consistent (as suggested by Jan Rychter). (slime-connect): Hide the *inferior-lisp-buffer* when we are connected. sldb-mode-map: Bind n and p to sldb-down and sldb-up. (slime-edit-fdefinition-other-window): New function. Suggested by Christian Lynbech. * swank-loader.lisp (user-init-file): There is now a user init file (~/.swank.lisp). It is loaded after the other files. 2003-11-16 Helmut Eller * slime.el: [slime-keys] Override C-c C-r with slime-eval-region (reported by Paolo Amoroso). * swank-loader.lisp: Compile and load gray stream stuff for SBCL and OpenMCL. * swank-openmcl.lisp, swank-sbcl.lisp: Import gray stream symbols. (without-interrupts*): New function. * swank.lisp (send-to-emacs): Protect the write operations by a without-interrupts, so that we don't trash the *cl-connection* buffer with partially written messages. * swank-cmucl.lisp (without-interrupts*): New function. * swank-gray.lisp (stream-write-char): Don't flush the buffer on newlines. * slime.el: Add some docstring. (interrupt-bubbling-idiot): New test. [slime-keys]: Don't bind "\C- ". Problematic on LinuxPPC. 2003-11-15 Helmut Eller * slime.el: Some tweaking for better scrolling in the *slime-repl* buffer (suggested by Jan Rychter). (slime-compile-file): Display the output buffer at the beginning. (slime-show-last-output): Include the prompt so that window-point is updated properly. (slime-with-output-at-eob): Update window-point if the buffer is visible. (slime-state/event-panic): Include the *slime-events* and *cl-connection* buffers in the report. * swank-cmucl.lisp (sos/out): Don't flush the buffer on newlines. 2003-11-13 Helmut Eller * slime.el: Imititate an "output-mark". Output from Lisp should move point only if point is at the end of the buffer. (Thanks William Halliburton for the suggestion.) (slime-with-output-at-eob): New function. (slime-output-string, slime-repl-maybe-prompt): Use it. slime-repl-mode-map: Override "\C-\M-x". An experimental scratch buffer: (slime-eval-print-last-expression): New function. (slime-scratch-mode-map, slime-scratch-buffer, slime-switch-to-scratch-buffer, slime-scratch): New functions. * swank-cmucl.lisp (resolve-location): Emacs buffer positions are 1 based. Add 1 to the 0 based file-position. 2003-11-13 Luke Gorrie * slime.el (slime-connect): pop-to-buffer into *slime-repl* when we connect. 2003-11-13 Helmut Eller * slime.el, swank-cmucl.lisp, swank-sbcl.lisp, swank-openmcl: New representation for "source-locations". Compiler notes have now a message, a severity, and a source-location field. Compiler notes, edit-definition, and the debugger all use now the same representation for source-location. CMUCL does the source-path to file-position translation at the Lisp side. This works better with reader macros, in particular with backquote. The SBCL backend still does the translation on the Emacs side. OpenMCL support is probably totally broken at the moment 2003-11-13 Luke Gorrie * slime.el (slime-repl-previous-input, slime-repl-next-input): When partial input has already been entered, the M-{p,n} REPL history commands only match lines that start with the already-entered prefix. This is comint-compatible behaviour which has been requested. The history commands also skip over line identical to the one already entered. (slime-complete-maybe-restore-window-confguration): Catch errors, so that we don't cause `pre-command-hook' to be killed. (slime-truncate-lines): If you set this to nil, slime won't set `truncate-lines' in buffers like sldb, apropos, etc. 2003-11-12 Luke Gorrie * slime.el (slime-show-description): XEmacs portability: don't use `temp-buffer-show-hook'. (slime-inspect): Use `(slime-sexp-at-point)' as default inspection value (thanks Jan Rychter). 2003-11-10 Luke Gorrie * slime.el (slime-post-command-hook): Inhibit unless (still) in slime-mode. Only call `slime-autodoc-post-command-hook' when `slime-autodoc-mode' is non-nil. (slime-setup-command-hooks): Use `make-local-hook' instead of `make-local-variable'. 2003-11-08 Helmut Eller * slime.el: slime-highlight-face: Use the :inherit attribute if possible. (slime-face-inheritance-possible-p): New function. * slime.el (slime-repl-return): Only send the current input to Lisp if it is a complete expression, like inferior-slime-return. * swank.lisp (completions): Use *buffer-package* if no other package is given. * slime.el: Remove the non-working face inheriting stuff. Hardcode colors for slime-highlight-face and specify the :inherit attribute for slime-repl-output-face. So Emacs21 will do the right thing and the others get at least a customizable face. * slime.el (slime-buffer-package): Try to find be the package name before resorting to slime-buffer-package. Return nil and not "CL-USER" if the package cannot be determined. (slime-goto-location): Insert notes with a source path, but without filename or buffername, at point. This can happen for warnings during macro expansion. (The macro expander is a interpreted function and doesn't have a filename or buffername.) (slime-show-note): Display 2 double quotes "" in the echo area for zero length messages. SERIES tends to signal warnings with zero length messages. (slime-print-apropos): Add support for alien types. * swank-cmucl.lisp (briefly-describe-symbol-for-emacs): Add support for alien types. (source-path-file-position): Read the entire expression with a special readtable. The readtable records source positions for each sub-expression in a hashtable. Extract the sub-expression for the source path from the read object and lookup the sub-expression in the hashtable to find its source position. * swank-sbcl.lisp (swank-macroexpand-all): Implemented. 2003-11-06 Luke Gorrie * slime.el (slime-autodoc-mode): When non-nil, display the argument list for the function-call near point each time the point moves in a slime-mode buffer. This is a first-cut; more useful context-sensitive help to follow (e.g. looking up variable documentation). (slime-autodoc-cache-type): Cache policy "autodoc" documentation: either nil (no caching), 'last (the default - cache most recent only), or 'all (cache everything on symbol plists forever). * slime.el: Convenience macros: (when-bind (var exp) &rest body) => (let ((var exp)) (when var . body)) (with-lexical-bindings (var1 ...) . body) => (lexical-let ((var1 var1) ...) . body) * slime.el (slime, slime-lisp-package): Reset `slime-lisp-package' (the REPL package) when reconnecting. (slime-buffer-package): Return `slime-lisp-package' when the major-mode is `slime-repl-mode'. 2003-11-04 Helmut Eller * slime.el (slime-read-string-state): Add support for evaluation requests. (slime-repl-read-break): New command. alternative. slime-keys: XEmacs cannot rebind C-c C-g. Use C-c C-b as an alternative. (slime-selector): XEmacs has no prompt argument for read-char. (slime-underline-color, slime-face-attributes): Make face definitions compatible with XEmacs and Emacs20. (slime-disconnect): Delete the buffer of the socket. (slime-net-connect): Prefix the connection buffer name with a space to avoid accidental deletion. * swank.lisp (slime-read-string): Send a :read-aborted event for non-local exits. (case-convert): Handle :invert case better. 2003-11-03 Helmut Eller * slime.el (slime-display-message-or-view, slime-remove-message-window): Display too long lines in a new window. Add a temporary pre-command-hook to remove the multiline window before the next command is executed. (slime-complete-symbol): Save the window configuration before displaying the completions and try to restore it later. The configuration is restored when: (a) the completion is unique (b) there are no completion. It is also possible to delay the restoration until (c) certain characters, e.g, space or a closing paren, are inserted. (slime-selector): Don't abort when an unkown character is pressed; display a message and continue. Similiar for ?\?. Add a selector for the *sldb* buffer. (slbd-hook, sldb-xemacs-post-command-hook): Emulate Emacs' point-entered text property with a post-command hook. * swank.lisp (case-convert, find-symbol-designator): New functions. * swank-cmucl.lisp, swank-openmcl.lisp, swank-sbcl.lisp (arglist-string): Don't intern the function name. Use find-symbol-designator instead. 2003-11-03 Luke Gorrie * slime.el (slime-display-buffer-region): Hacked to fix completely inexplicable XEmacs problems. 2003-11-2 Helmut Eller * null-swank-impl.lisp, swank-cmucl.lisp, swank-openmcl.lisp, swank.lisp: Input redirection works now on the line level, like a tty. Output streams are now line buffered. We no longer compute the backtrace-length. * slime.el: (slime-repl-read-mode, slime-repl-read-string, slime-repl-return, slime-repl-send-string, slime-read-string-state, slime-activate-state): Reorganize input redirection. We no longer work on the character level but on a line or region; more like a terminal. This works better, because REPLs and debuggers are usually written with a line buffering tty in mind. (sldb-backtrace-length, slime-debugging-state, slime-evaluating-state, sldb-setup, sldb-mode, sldb-insert-frames, sldb-fetch-more-frames): Don't use backtrace-length. Computing the length of the backtrace is (somewhat strangely) an expensive operation in CMUCL, e.g., it takes >30 seconds to compute the length when the yellow zone stack guard is hit. 2003-11-02 Luke Gorrie * slime.el (slime-log-event): Added a *slime-events* buffer recording all state machine events. The buffer uses hideshow-mode to fold messages down to single lines. (slime-show-source-location): Bugfix: only create source-highlight overlay if the source was actually located. (slime-selector): Renamed from `slime-select' because that function name was already in use. Ooops! * swank.lisp (eval-string): force-output on *slime-output* before returning the result. This somewhat works around some trouble where output printed by lisp is being buffered too long. * slime.el (slime-lisp-package-translations): Association list of preferred package nicknames, for the REPL prompt. By default maps COMMON-LISP->CL and COMMON-LISP-USER->CL-USER. 2003-11-01 Luke Gorrie * slime.el (slime-select): Added an extensible "Select" command, which I gather is a LispM/Martin-Cracauer knock-off. When invoked, the select command reads a single character and uses that to decide which buffer to switch to. New characters can be defined, and the currently availables ones can be seen with '?'. I have not assigned a key to Select, because it seems like a command that should have a global binding. I would suggest `C-c s'. * swank.lisp (*slime-features*): Variable remembering the FEATURES list. (sync-state-to-emacs): Update Emacs about any state changes - currently this just means changes to the FEATURES list. (eval-string): Call `sync-state-to-emacs' before sending result. (eval-region): With optional PACKAGE-UPDATE-P, if the evaluation changes the current package, tell Emacs about the new package. (listener-eval): Tell `eval-region' to notify Emacs of package changes, so that e.g. (in-package :swank) does the right thing when evaluated in the REPL. * slime.el (slime-repl-output-face, slime-repl-input-face): Face definitions for output printed by Lisp and for previous REPL user inputs, respectively. Defaulting the input face to bold rather than underline, because it looks better on multi-line input. (slime-handle-oob): Two new out-of-band messages (:new-features FEATURES) and (:new-package PACKAGE-NAME). These are used for Lisp to tell Emacs about changes to *FEATURES* and *PACKAGE* when appropriate. (slime-same-line-p): Better implementation (does what the name suggests). (slime-lisp-package): New variable keeping track of *PACKAGE* in Lisp -- or at least, the package to use for the REPL. (slime-repl-insert-prompt): The prompt now includes the package name. (slime-repl-bol): C-a in the REPL now stops at the prompt. (slime-repl-closing-return): C-RET & C-M-m now close all open lists and then send input in REPL. (slime-repl-newline-and-indent): C-j in REPL is now better with indentation (won't get confused by unmatched quotes etc appearing before the prompt). 2003-11-1 Helmut Eller * slime.el (slime-debugging-state): Save the window configuration in a state variable. sldb-saved-window-configuration: Removed. (slime-repl-mode): Use conservative scrolling. (slime-repl-insert-prompt): Set window-point after the prompt. (slime-repl-add-to-input-history): Don't add subsequent duplicates to the history. * swank.lisp (slime-read-char): Flush the output before reading. (listener-eval): Like eval region but set reader variables (*, **, *** etc.) * swank-openmcl.lisp, swank-sbcl.lisp: Implement stream-line-column. * swank-cmucl.lisp (slime-input-stream-misc-ops): Renamed from slime-input-stream-misc. 2003-10-31 Luke Gorrie * slime.el (slime-repl-mode-map): Bound `slime-interrupt' on both C-c C-c and C-c C-g. * swank.lisp (interactive-eval): Evaluate in *buffer-package*. * slime.el: Tweaked debugger window management somewhat: the window configuration is saved when the debugger is first entered and then restored when the idle state is reached. 2003-10-31 Helmut Eller * slime.el: (slime-repl-read-mode, slime-repl-read-xxx): New minor mode for stream character based input to Lisp. * swank.lisp: *read-input-catch-tag*, take-input, slime-read-char: Moved here from swank-cmucl.lisp. (defslimefun, defslimefun-unimplemented): Move macro definitions to the beginning of the file. * swank-cmucl.lisp: (slime-input-stream, slime-input-stream-read-char, lime-input-stream-misc): Character input stream from Emacs. (slime-input-stream/n-bin): Removed. * swank-openmcl.lisp, swank-sbcl.lisp: Gray stream based input redirection from Emacs. 2003-10-29 Helmut Eller * slime.el: Beginnings of a REPL-mode. Minor debugger cleanups. * swank.lisp: slime-read-error: New condition. (read-next-form): Re-signal the conditions as slime-read-errors. And check the result of read-sequence (i.e. detect CMUCL's read-sequence bug). (sldb-continue, throw-to-toplevel): Was more or less the same in all backends. * swank-openmcl.lisp, swank-sbcl.lisp, swank-cmucl.lisp: (serve-request): Handle slime-read-errors and bind a slime-toplevel catcher. * swank-cmucl.lisp: (sldb-loop): Flush output at the beginning. (inspect-in-frame): New function. (frame-locals): Don't send the validity indicator across wire. Too cmucl specific. 2003-10-29 Luke Gorrie * slime.el (slime-net-sentinel): Only show a message about disconnection if the inferior-lisp is still running. (slime-interrupt, slime-quit): Only send the quit/interrupt message to Lisp if it is in fact evaluating something for us. This fixes a protocol bug reported by Paolo Amoroso. Added (require 'pp). 2003-10-28 James Bielman * null-swank-impl.lisp: New file. * swank-openmcl.lisp: Pre-refactoring updates to the OpenMCL backend: (map-backtrace): Renamed from DO-BACKTRACE. (frame-source-location-for-emacs): New function. (function-source-location-for-emacs): New function, * swank-openmcl.lisp: Docstring updates/additions. 2003-10-25 Luke Gorrie * Everywhere: Changed the connection setup to use a dynamic collision-free TCP port. The new protocol is this: Emacs calls (swank:start-server FILENAME) via the listener. FILENAME is /tmp/slime.${emacspid} Lisp starts a TCP server on a dynamic available port and writes the port number it gets to FILENAME. Emacs asynchronously polls for FILENAME's creation. When it exists, Emacs reads the port number, deletes the file, and makes the connection. The advantage is that you can run multiple Emacsen each with an inferior lisp, and the port numbers will never collide and Emacs will always connect to the right lisp. All backends are updated, but only CMUCL and SBCL are tested. Therefore, OpenMCL is almost certainly broken just now. * slime.el (inferior-slime-closing-return): New command that closes all open lists and sends the result to Lisp. Bound to C-RET and (for people who use C-m for RET) C-M-m. (inferior-slime-indent-line): Improved indentation in the inferior list buffer. 2003-10-24 Luke Gorrie * slime.el (inferior-slime-return): Command bound to RET in inferior-slime-mode: only send the current input to Lisp if it is a complete expression (or prefix argument is given). Two reasons: it makes the input history contain complete expressions, and it lets us nicely indent multiple-line inputs. (Thanks Raymond Toy for the suggestions.) 2003-10-23 Luke Gorrie * slime.el (slime-maybe-start-lisp): Restart inferior-lisp if the process has died. * swank-sbcl.lisp (accept-connection): Use a character stream to match swank.lisp. 2003-10-22 Helmut Eller * swank-cmucl.lisp (setup-request-handler): Create a character stream. (read-next-form): Removed. * swank.lisp (read-next-form, send-to-emacs): Assume *emacs-io* is a character stream. Add the necessary char-code/code-char conversions. * slime.el: slime-keys: Add :sldb keywords for keys useful in the debugger. (slime-init-keymaps): Allow allow :sldb keywords. inferior-lisp-mode-hook: Display the inf-lisp buffer if there is some output. (slime-process-available-input): Start a timer to process any remaining input. (slime-dispatch-event): The timer should take care of any lost input. So don't process the available input here. Remove the process-input argument. (slime-push-state, slime-pop-state, slime-activate-state, slime-idle-state, slime-evaluating-state): Update callers. (slime-debugging-state): Remove the unwind-protect in the :debug-return clause. Should not be necessary. sldb-mode-map: Define more slime-mode keys. (slime-time<, slime-time-add): Removed. Emacs-21 has equivalent time functions. (slime-sync-state-stack): Use Emacs-21 time-date functions. (seconds-to-time, time-less-p, time-add): Compatibility defuns. 2003-10-22 Luke Gorrie * slime.el (slime): With a prefix argument, prompt for the port number to use for communication with Lisp. This is remembered for future connections. 2003-10-22 Hannu Koivisto * slime.el (slime-space): Now allows one to insert several spaces with a prefix argument. 2003-10-21 Luke Gorrie * slime.el (slime-space): Don't give an error when not connected, to avoid feeping. * swank-sbcl.lisp (swank-compile-string): Include only one :SOURCE-PATH attribute in the plist, and replace the front element with a 0 (fixes a problem probably due to recent hacks to the elisp source-path lookups). * slime.el (inferior-slime-mode): New minor mode for use with `inferior-lisp-mode'. Defines a subset of the `slime-mode' keys which don't clash with comint (e.g. doesn't bind M-{p,n}). (slime-keys): List of keybinding specifications. (slime-find-buffer-package): If we don't find the "(in-package" by searching backwards, then try forwards too. * swank.lisp (completions): Fixed semantics: should now consider only/all completions that would not cause a read-error due to symbol visibility. Also avoiding duplicates and sorting on symbol-name. 2003-10-20 Luke Gorrie * swank.lisp (completions): Slight change of semantics: when a prefix-designator is package-qualified, like "swank:", only match symbols whose home-package matches the one given - ignore inherited symbols. * slime.el: Updated test suite to work with the different backends: (find-definition): Lookup definitions in swank.lisp. (arglist): Lookup arglists of functions in swank.lisp. 2003-10-20 Helmut Eller * slime.el (interactive-eval): Make test case independent of *print-case*. 2003-10-20 Luke Gorrie * swank-cmucl.lisp (clear-xref-info): Conditionalised xref:*who-is-called* and xref:*who-macroexpands* with #+CMU19. This makes SLIME compatible with CMUCL 18e, but also disables the `who-macroexpands' command in any CMUCL version that doesn't have the "19A" feature (which does break the command in some snapshot builds that can actually support it). 2003-10-20 Daniel Barlow * swank.lisp (*notes-database*): tyop fix * swank-sbcl.lisp (throw-to-toplevel): select TOPLEVEL restart instead of throwing to a catch that no longer exists * slime.el: change some strings containing 'CMUCL' to more backend-agnostic phrases 2003-10-19 Helmut Eller * slime.el, swank-cmucl.lisp, swank.lisp: First shoot at input redirection. * swank-sbcl.lisp, swank-openmcl.lisp: Bind *slime-input* and *slime-io* to dummy values. 2003-10-19 Luke Gorrie * slime.el (slime): Connection setup is now asynchronous, with retrying on a timer. This makes it possible to bring the server up by hand while debugging. `M-x slime' while already connected will cause the old connection to be dropped and a new one established. (slime-disconnect): New command to disconnect from Swank, or cancel asynchronous connection attempts when not yet connected. (slime-state/event-panic): Illegal events in the communication state machine now trigger a general panic that disconnects from Lisp, and displays a message describing what has happened. This is a bug situation. (slime-connect): Print a message during connection attempts unless the minibuffer is active (it's annoying to get messages while trying to enter commands). 2003-10-18 Helmut Eller * slime.el: Fix some bugs in the state machine and be a bit more careful when processing pending input. (slime-compile-region): New command. Some more tests. 2003-10-17 James Bielman * .cvsignore: Add OpenMCL and SBCL fasl file extensions. * swank-openmcl.lisp (who-calls): Fix bug where we would try to take the TRUENAME of NIL when source information isn't available for a caller. (backtrace-for-emacs): Clean up the backtrace code a bit in preparation for implementing FRAME-LOCALS. (frame-catch-tags): Implement a stub version of this. (frame-locals): Implemented fully for OpenMCL. * swank-loader.lisp (compile-files-if-needed-serially): Be a little more verbose when compiling files. 2003-10-17 Helmut Eller * swank.lisp, swank-sbcl.lisp, swank-openmcl.lisp, swank-cmucl.lisp: Move more stuff to swank.lisp. 2003-10-17 Luke Gorrie * slime.el (slime-post-command-hook): Check that we are connected before trying to process input. (slime-net-connect): Handle `network-error' condition for XEmacs 21.5. (Thanks Raymond Toy.) * swank-sbcl.lisp: Report style-warnings separately from notes (patch from Christophe Rhodes). Use REQUIRE to load sb-introspect instead of loading the source file (requires the sb-introspect library to be installed, which doesn't yet happen in the sourceforge-lagged SBCL anoncvs, but does in the real one). * slime.el (slime-style-warning-face): Added style-warnings, which are between a warning and a note in severity. (Patch from Christophe Rhodes). * test.sh: When the test fails to complete, print "crashed" instead of reporting nonsense. 2003-10-17 James Bielman * swank.lisp (apropos-symbols): Change back to using the standard 2-argument APROPOS-LIST and check symbols explicitly when EXTERNAL-ONLY is true. Move loading of sys-dependent backend code into 'swank-loader'. * swank-sbcl.lisp: Moved declarations of *PREVIOUS-COMPILER-CONDITION* into 'swank.lisp' to kill warnings about undefined variables. * swank-openmcl.lisp (handle-compiler-warning): Use source position instead of function name for warning locations. (swank-compile-string): Compile into a temporary file instead of using COMPILE so finding warning positions works when using C-c C-c. (compute-backtrace): Don't display frames without a function. (apropos-list-for-emacs): Implement APROPOS. (who-calls): Implement WHO-CALLS. (completions): Implement COMPLETIONS. Use NIL instead of zero so FRESH-LINE does the right thing. * slime.el (slime-maybe-compile-swank): Removed function---compile the backend using 'swank-loader.lisp' instead. (slime-backend): Changed default backend to 'slime-loader'. (slime-lisp-binary-extension): Deleted as this is no longer needed. * swank-loader.lisp: New file. 2003-10-17 Luke Gorrie * slime.el (slime-net-connect): Check that `set-process-coding-system' is fbound before calling it. This is needed in the XEmacs I built from sources. 2003-10-17 Daniel Barlow * swank-sbcl.lisp: Transplanted Helmut's serve-event server to replace the existing thread-using server. SLIME now has no dependency on SB-THREAD * slime.el (slime-find-buffer-package): handle errors from (read) for the case where the buffer ends before the in-package form does (slime-set-package): insert missing comma (slime-goto-source-location): sbcl has a disagreement with emacs over the meaning of a character position. Level up with C-M-f C-M-b * assorted typo fixes 2003-10-16 Luke Gorrie * slime.el (slime-forward-source-path): Improved somewhat. Seems to work for all common cases except backquote. Backquote is tricky, because the source-paths are based on the reader's expansion, e.g.: * (let ((*print-pretty* nil)) (print (read-from-string "`(a ,@(b c) d)"))) --> (COMMON-LISP::BACKQ-CONS (QUOTE A) (COMMON-LISP::BACKQ-APPEND (B C) (QUOTE (D)))) Must investigate whether we need to write a hairy backquote-traversing state machine or whether this is something that could be fixed in CMUCL. * swank*.lisp (with-trapping-compiler-notes): This macro is now defined here, and expands to a call to the backend-defined `call-trapping-compiler-notes' with the body wrapped in a lambda. This is to avoid swank.lisp referring to macros in the backends -- it gets compiled first so it thinks they're functions. * slime.el (slime-swank-connection-retries): New default value is `nil', which means unlimited retries (until user aborts). Retry interval also reduced from once per second to four times per second. 2003-10-16 Helmut Eller * swank-cmucl.lisp, swank.lisp: Fix CMUCL support. 2003-10-15 Daniel Barlow * swank.lisp: rearrange the backends. rename swank.lisp to swank-cmucl.lisp, then create new swank.lisp which loads an appropriate backend according to *features*. Next up, identify common functions in the backends and move them into swank.lisp 2003-10-15 Helmut Eller * slime.el: Inspector support. list-callers, list-callees implemented without xref. * swank.lisp: Lisp side for inspector and list-callers, list-calees. Better fdefinition finding for struct-accessors. 2003-10-15 Luke Gorrie * slime.el (slime-point-moves-p): Macro for executing subforms and returning true if they move the point. * test.sh: New file to run the test suite in batch-mode. Will need a little extending to allow configuring the right variables to work with non-CMUCL backends. * slime.el: Set `indent-tabs-mode' to nil. This makes diffs look better. (slime-start-swank-server): Now passing the port number to SWANK:START-SERVER. (slime-evaluating-state): Debugging synchronous evaluations with recursive edits now works. (slime-forward-sexp): Added support for #|...|# reader comments. (sldb-hook): New hook for entry to the debugger (used for the test suite). (slime-run-tests): Reworked the testing framework. Now presents results in an outline-mode buffer, with only the subtrees containing failed tests expanded initially. (slime-check): Check-name can now be a string or format-control. (Test cases have been updated to take advantage of this.) (compile-defun): This test case now works for the case containing #|..|# (async-eval-debugging): New test case for recursively debugging asynchronous evaluation. 2003-10-15 Daniel Barlow * README.sbcl: new file * README: update for new backends, change of hosting provider * swank-sbcl.lisp: new file. New SWANK backend for Steel Bank Common Lisp, adapted from swank.lisp with bits of swank-openmcl.lisp 2003-10-12 Daniel Barlow * slime.el (sldb-mode-map): add mouse-2 clickability for areas in sldb buffers covered by the sldb-default-action property: restarts can now be mouse-activated 2003-09-28 James Bielman * swank-openmcl.lisp: New file, a Slime backend for OpenMCL 0.14.x. (condition-function-name): Figure out the name of methods correctly instead of passing a list to Emacs. * slime.el (slime-goto-location): Try to position notes based on some (questionable) regex searching if the :FUNCTION-NAME property is set. Used in the OpenMCL backend which does not support source paths. 2003-09-29 Luke Gorrie * slime.el: Fairly major hacking. Rewrote the evaluation mechanics: similar design but some macros to make it look more like a push-down automaton (which it really was!). Debugging Lisp no longer uses recursive edits, partly as a side-effect and partly to see if it's better this way. Removed the asynchronous-communication test cases that tested something we decided not to do. (slime-eval-string-async): Give a meaningful error message when trying to make a request while already busy. (slime-lisp-binary-extension): Uh oh, time to start taking out gratuitous CMUCL-isms. This variable renamed from `slime-cmucl-binary-extension'. (slime-backend): Name of the Lisp backend file, defaulting to "swank", but can be set to e.g. "swank-openmcl". * swank.lisp: Minor protocol changes to accomodate slime.el's changes above. 2003-09-28 Helmut Eller * swank.lisp (getpid, set-package, set-default-directory): New functions. (slime-out-misc): Don't send empty strings. (*redirect-output*, read-from-emacs): A new switch to turn output redirection off. Useful for debugging. (interactive-eval, interactive-eval-region, pprint-eval, re-evaluate-defvar): Bind *package* to *buffer-package*. (with-trapping-compilation-notes): Add a dummy argument for better indentation. (measure-time-intervall, call-with-compilation-hooks): Measure compilation time. (frame-locals): Use di::debug-function-debug-variables instead of di:ambiguous-debug-variables. Don't access non-valid variables. * slime.el (slime-display-message-or-view): Delete old multi-line windows. (slime-read-package-name): Added an optional initial-value argument. slime-pid: New variable. (slime-init-dispatcher): Initialize slime-pid. (slime-send-sigint): Use slime-pid instead of inferior-lisp-proc. (slime-eval): Accept debug-condition messages. (slime-output-buffer): Turn slime-mode on. (slime-switch-to-output-buffer): New command. Bound to C-c C-z. (slime-show-note-counts): Display compilation time. (slime-untrace-all, slime-set-package, slime-set-default-directory slime-sync-package-and-default-directory): New commands. (slime-princ-locals): Don't access non-valid variables. This may cause segfaults and severely confuse CMUCL. (slime-define-keys): New macro. 2003-09-28 Luke Gorrie * swank.lisp (create-swank-server): Bind the listen-socket on the loopback interface by default, so that remote machines can't connect to the Swank server. 2003-09-27 Luke Gorrie * swank.lisp (with-trapping-compilation-notes): New macro for bindings the handlers to record compiler notes. Now being used in `compile-string', which I had broken when removing the compilation hook. * slime.el (slime-function-called-at-point): Rewritten to work better. Now considers "((foo ..." _not_ to be a function call to foo because of the double ('s - this will keep it from misfiring in e.g. LET bindings. (def-slime-test): All tests now being with (slime-sync). This fixes some accidental/bogus test failures. * swank.lisp (handle-notification-condition): Rewrote compiler-note collection. Now it uses lower-level condition handlers instead of c:*compiler-notification-function*. This way the error messages are tailored to omit redundant information, like the filename and original source text (which are displayed and highlighted in Emacs already). Much nicer. (sort-contexts-by-source-path): Now sorting xref results by lexical source-path order, so that you're always jumping in the same direction. (*debug-definition-finding*): New variable. You can set this to true if you want to be popped into the debugger when M-. fails to find a definition (for debugging the definition-finding). Otherwise it reports the error to Emacs as a message, like "Error: SETQ is a special form." * slime.el (slime-fetch-features-list): New command to fetch the *FEATURES* list from Lisp and store it away. This is done automatically upon connection, but can also be called manually to update. (slime-forward-reader-conditional): Now does the right things with reader-conditionals (#+ and #-) based on the Lisp features. 2003-09-26 Luke Gorrie * slime.el (sldb-setup): Setting `truncate-lines' to t in the debug buffer. I like having the backtrace take strictly one line per frame, since otherwise a few ugly arguments (e.g. streams) can chew up a lot of space. (Can make this a configurable on request if tastes differ :-) * swank.lisp: Did a little defensive programming so that asking for the definition of an unbound function will return nil to Emacs instead of entering the debugger. (format-frame-for-emacs): Binding *PRETTY-PRINT* to nil when formatting frames (due to truncate-lines change above). 2003-09-24 Helmut Eller * swank.lisp: Support for stream redirection. slime-output-stream: New structure. (slime-out-misc): New function. *slime-output*: New variable. (read-from-emacs): Redirect output to *slime-output*. (read-form): Bind *package* inside the standard-io-syntax macro. (eval-string): Read the string with read-form. (completions): Support for keyword completion. * slime.el (slime-process-available-input, slime-eval): Rewritten once again. Don't use unwind-protect anymore. Didn't work properly when the Lisp side aborted due to too many debug levels. "Continuing" from the Emacs debugger aborts one level on the Lisp side. "Quitting" from the Emacs debugger quits the Lisp side too. Increase stack sizes before entering the recursive edit. (slime-eval-async-state, slime-eval, sldb-state): Support for stream output. slime-last-output-start: New variable. (slime-output-buffer, slime-output-buffer-position, slime-insert-transcript-delimiter, slime-show-last-output, slime-output-string): New functions. (slime-show-evaluation-result, slime-show-evaluation-result-continuation): Use them. (slime-use-inf-lisp-p, slime-insert-transcript-delimiter, slime-inferior-lisp-marker-position, slime-inferior-lisp-show-last-output): Deleted. (slime-use-tty-debugger, slime-debugger-hook, slime-enter-tty-debugger, slime-tty-debugger-state): Deleted. Removed tty debugger support. (def-sldb-invoke-restart): Renamed. (define-sldb-invoke-restart-key, define-sldb-invoke-restart-keys): Version without eval. (defun-if-undefined): New macro. Many indentation fixes. 2003-09-23 Helmut Eller * swank.lisp (completions): Moved most of the completion code to Lisp. (string-prefix-p): Be case insensitive. * slime.el: Make sure define-minor-mode is defined before we use it. (slime-completing-read-internal, slime-completing-read-symbol-name, slime-read-from-minibuffer, slime-completions, slime-complete-symbol): Support for reading symbols and expressions with completion. (slime-read-symbol-name): New function. (slime-read-symbol): Use it. (slime-read-package-name): Case insensitive completion. (slime-edit-symbol-fdefinition, slime-edit-fdefinition): Rename slime-edit-symbol-fdefinition to slime-edit-fdefinition. 2003-09-23 Luke Gorrie * slime.el (slime-show-xrefs): Improved the xrefs buffer, now using a custom minor mode. (slime-next-location): This function goes to the next "something" by funcall'ing slime-next-location-function. Currently that variable is set by xref commands like who-calls to go to the next matching reference. In future it can also be used to go to the next function definition for a generic-function-understanding version of edit-fdefinition. Bound to C-M-. and C-c C-SPC, until we see which binding is better. 2003-09-22 Luke Gorrie * slime.el (slime-symbol-at-point): Now returns a symbol, as the name suggests. (slime-symbol-name-at-point): This one returns a string. (slime-read-symbol): New function for taking the symbol at point, or prompting if there isn't one. (slime-edit-fdefinition): Now uses looks up the symbol at point, not the function being called at point. * swank.lisp (who-calls, who-references, who-binds, who-sets, who-macroexpands): New function. (present-symbol-before-p): Use `*buffer-package*' when checking accessibility of symbols. * slime.el (slime-restore-window-configuration): New command to put the Emacs window configuration back the way it was before SLIME last changed it. (slime-who-calls, etc): Very basic WHO-{CALLS,..} support. Not finished, wrestling around trying to make `view-mode' or `help-mode' help me (I just want to hijack RET and C-m). Bound to "C-c C-w ...". 2003-09-21 Luke Gorrie * slime.el: Rearranged the `outline-mode' structure slightly. (slime-check-connected): Using new function to give a helpful error message if you try to use commands before establishing a connection to CMUCL. (sldb-mode): Keys 0-9 are now shortcuts to invoke restarts. * README, swank.el: Updated commentary. 2003-09-20 Luke Gorrie * slime.el (slime-choose-overlay-region): Tweaked overlay placement. * swank.lisp (handle-notification): Skipping null notifications. For some reason CMUCL occasionally calls us with NIL as each argument. 2003-09-19 Helmut Eller * slime.el (slime-connect): Propose default values when called interactively. (slime-process-available-input): If possible, use while rather than recursion. (slime-compilation-finished-continuation): New function. (slime-compile-file, slime-compile-defun): Use it. (slime-forward-source-path): Id an error is encounter move back to the last valid point. (slime-eval-region): Use append COND. Send the entire string to the Lisp side and read&evaluate it there. (slime-eval-buffer): New function. (sldb-sugar-move, sldb-details-up, sldb-details-down): New functions. * swank.lisp (interactive-eval-region): New function. (re-evaluate-defvar): New function. (compile-defun): Install handler for compiler-errors. (function-first-code-location): Simplified. 2003-09-17 Helmut Eller * slime.el (slime-apropos-all): New command, bound to C-c M-a. (slime-eval): Simplified. (swank:arglist-string): Send a string and not a symbol. It easier to package related thins in CL. (slime-edit-symbol-fdefinition): Prompt when called with prefix-argument. (slime-eval-region): New function. (slime-load-file): New function. (slime-show-description): Set slime minor mode in Help buffer. * swank.lisp: (read-string, from-string): Renamed read-string to from-string. (to-string) New function. (arglist-string): Catch reader errors. (sldb-loop): Also bind *readstrable*. 2003-09-16 Helmut Eller * slime.el (slime-toggle-trace-fdefinition): New command. (slime-symbol-at-point, slime-sexp-at-point): New utility functions. (slime-edit-symbol-fdefinition): Similar to slime-edit-fdefinition but uses swank:function-source-location-for-emacs. (slime-goto-source-location): New function. (sldb-show-source): Use it. (slime-read-package-name): Completing read for package names. (slime-apropos): Use it. * swank.lisp (function-source-location, function-source-location-for-emacs): New functions to extract source locations from compiled code. For struct-accessors we try to find the source location of the corresponding constructor. (list-all-package-names): New function. (toggle-trace-fdefinition, tracedp): New functions. 2003-09-15 Helmut Eller * slime.el: Moved many CL fragments from slime.el to swank.lisp. (slime-compile-file, slime-compile-defun, slime-goto-location): Compiler notes are now represented with a property list. To find the source expression first move to the file offset of the top-level form and then use the source path to find the expression. This should avoid many reader issues. For compile-defun store the start position of the top-level expression from the buffer in the compiler notes and use that to locate error messages. Add error overlays for notes without context to the first available expression. * swank.lisp: Moved many CL fragments from slime.el to swank.lisp. (defslimefun): New macro. 2003-09-15 Luke Gorrie * slime.el (slime-setup-command-hooks): Removed post-command-hook that was used for cleaning up input that was unprocessed due to an error breaking out of the process filter. This is now handled by an `unwind-protect' in the filter. * swank.lisp (apropos-list-for-emacs): Hacked the apropos listing to accept more options and to specially sort results. * slime.el (slime-net-send): Added newlines to messages over the wire. This makes the protocol nicely readable in Ethereal. (slime-sync): New function for blocking until asynchronous requests are complete. (slime-apropos): Hacked the apropos command: by default, only external symbols are shown. With a prefix argument you have the option to include internal symbols and to specify a package. (slime-run-tests): Extended the test suite. Use `M-x slime-run-tests' to run it. 2003-09-14 Luke Gorrie * slime.el, swank.lisp: Added the debugger written by Helmut. * cmucl-wire.el: Removed. The WIRE communication protocol has been replaced by a simple custom TCP protocol based on READ/PRIN1 to send sexps as ascii text. This simplifies the code, makes the protocol nicely debugable with ethereal, and should ease porting to other Lisps. Incremented TCP port number to 4005 in honor of the new protocol. In addition, Lisp now always uses *print-case* of :DOWNCASE when preparing sexps for Emacs. This is in reaction to a bug with Emacs reading the empty list as `NIL' instead of `nil'. * slime.el (slime-net-connect): The Emacs end of the new communication protocol. * swank.lisp (create-swank-server): The Lisp end of the new communication protocol. 2003-09-11 Luke Gorrie * slime.el (slime-mode): Added Helmut's commands to the mode description. (slime-show-apropos): Setting `truncate-lines' to t in apropos listings, to avoid line-wrapping on overly long descriptions. (slime-run-tests): Added the beginnings of an automated test suite. (This is most useful for testing cross-Emacsen compatibility before releases.) * swank.lisp (symbol-external-p): Put back this function which was lost in a merge. 2003-09-10 Luke Gorrie * slime.el, cmucl-wire.el, swank.lisp: Large patch from Helmut Eller. Includes: apropos, describe, compile-defun, fully asynchronous continuation-based wire interface, interactive evaluation, and more. Very nice :-) 2003-09-08 Luke Gorrie * cmucl-wire.el (wire-symbol-name, wire-symbol-package): Fixed to handle internal references (pkg::name). * slime.el (slime-swank-connection-retries): Increased default number of connection retries from 5 to ten. * swank.lisp (find-fdefinition): Support for finding function/macro definitions for Emacs. * slime.el: Indentation "cleanups": somehow I was using `common-lisp-indent-function' for Emacs Lisp code previously. (slime-edit-fdefinition): Added M-. (edit definition) and M-, (pop definition stack) commands. Definitions are found in much the same way Hemlock does it. The user-interface is not the same as TAGS, because I like this one better. We can add TAGS-compatibility as an optional feature in future. 2003-09-04 Luke Gorrie * slime.el (slime-completions): Now supports completing package-internal symbols with "pkg::prefix" syntax. * Everything: imported slime-0.2 sources. ;; Local Variables: ;; coding: utf-8 ;; End: This file has been placed in the public domain. slime-2.18.orig/packages.lisp0000644000175000017500000001246712720104623014314 0ustar pdmpdm(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 ;; 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 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.18.orig/lib/0000755000175000017500000000000012720104623012401 5ustar pdmpdmslime-2.18.orig/lib/cl-lib.el0000644000175000017500000003250212720104623014067 0ustar pdmpdm;;; 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.18.orig/lib/hyperspec.el0000644000175000017500000027022412720104623014734 0ustar pdmpdm;;; 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.18.orig/lib/.nosearch0000644000175000017500000000007512720104623014206 0ustar pdmpdm;; normal-top-level-add-subdirs-to-load-path needs this file slime-2.18.orig/lib/macrostep.el0000644000175000017500000013030112720104623014716 0ustar pdmpdm;;; 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.18.orig/lib/ert.el0000644000175000017500000031661312720104623013527 0ustar pdmpdm;;; 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.18.orig/lib/ert-x.el0000644000175000017500000031661312720104623013774 0ustar pdmpdm;;; 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.18.orig/swank.asd0000644000175000017500000000220112720104623013442 0ustar pdmpdm;;; -*- 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 (asdf::operation-forced o) :delete (asdf::operation-forced o))) (asdf:defsystem :swank :default-component-class swank-loader-file :components ((:file "swank-loader"))) slime-2.18.orig/CONTRIBUTING.md0000644000175000017500000001436112720104623014071 0ustar pdmpdm# 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. ## ChangeLog For each change we make an entry in the `ChangeLog` file. This is typically done using the command `add-change-log-entry-other-window` (`C-x 4 a`). ChangeLog diffs are automatically sent to the slime-devel mailing list each day as a sort of digest summary of the slime-cvs list. There are good tips on writing ChangeLog entries in the [GNU Coding Standards][3]. For information about Emacs's ChangeLog support see the `Change Log' and `Change Logs and VC' nodes of the Emacs manual: * http://www.gnu.org/software/emacs/manual/html_node/emacs/Change-Log.html#Change-Log * http://www.gnu.org/software/emacs/manual/html_node/emacs/Change-Logs-and-VC.html#Change-Logs-and-VC ## 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. * Commit messages should use the syntax of GNU ChangeLog entries. * Open a [pull request][2] that relates to *only* one subject with a clear title and description in grammatically correct, complete sentences. [1]: http://gun.io/blog/how-to-github-fork-branch-and-pull-request [2]: https://help.github.com/articles/using-pull-requests [3]: http://www.gnu.org/prep/standards/html_node/Style-of-Change-Logs.html#Style-of-Change-Logs slime-2.18.orig/.gitref0000644000175000017500000000005012720104623013107 0ustar pdmpdm2da9fef009f2380daf9404022ca69cb87573f509slime-2.18.orig/PROBLEMS0000644000175000017500000000644412720104623013011 0ustar pdmpdmKnown 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.