From mbaringer at common-lisp.net Sun Feb 3 18:00:37 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Sun, 3 Feb 2008 13:00:37 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080203180037.96FC271123@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20408 Modified Files: swank-loader.lisp ChangeLog Log Message: --- /project/slime/cvsroot/slime/swank-loader.lisp 2007/11/24 08:18:59 1.75 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/03 18:00:31 1.76 @@ -18,6 +18,13 @@ ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/") ;; (load ".../swank-loader.lisp") +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-package :swank) + (delete-package :swank) + (delete-package :swank-io-package) + (delete-package :swank-loader) + (delete-package :swank-backend))) + (cl:defpackage :swank-loader (:use :cl) (:export :load-swank @@ -60,14 +67,9 @@ :sparc64 :sparc :hppa64 :hppa)) (defun lisp-version-string () - #+cmu (substitute-if #\_ (lambda (x) (find x " /")) + #+(or openmcl cmu) (substitute-if #\_ (lambda (x) (find x " /")) (lisp-implementation-version)) - #+scl (lisp-implementation-version) - #+sbcl (lisp-implementation-version) - #+ecl (lisp-implementation-version) - #+openmcl (format nil "~d.~d" - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version*) + #+(or cormanlisp scl sbcl ecl) (lisp-implementation-version) #+lispworks (lisp-implementation-version) #+allegro (format nil "~A~A~A" @@ -76,8 +78,7 @@ (if (member :64bit *features*) "-64bit" "")) #+clisp (let ((s (lisp-implementation-version))) (subseq s 0 (position #\space s))) - #+armedbear (lisp-implementation-version) - #+cormanlisp (lisp-implementation-version)) + #+armedbear (lisp-implementation-version)) (defun unique-directory-name () "Return a name that can be used as a directory name that is --- /project/slime/cvsroot/slime/ChangeLog 2008/01/27 15:34:27 1.1274 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/03 18:00:31 1.1275 @@ -1,3 +1,12 @@ +2008-02-03 Marco Baringer + + * swank-loader.lisp: When loading swank delete all swank packages + first. This protects the lisp from broken reloads of swank. + (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. From mbaringer at common-lisp.net Sun Feb 3 18:39:23 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Sun, 3 Feb 2008 13:39:23 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080203183923.52D685F072@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv30436/contrib Modified Files: ChangeLog Added Files: swank-motd.lisp slime-motd.el Log Message: Message Of The Day for slime --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/01/27 10:17:34 1.82 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/03 18:39:23 1.83 @@ -1,3 +1,8 @@ +2008-02-03 Marco Baringer + + * swank-motd.lisp, slime-motd.el: Message Of The Day printing for + slime. + 2008-01-27 Helmut Eller Make autodoc use the correct width of the typeout-window. --- /project/slime/cvsroot/slime/contrib/swank-motd.lisp 2008/02/03 18:39:23 NONE +++ /project/slime/cvsroot/slime/contrib/swank-motd.lisp 2008/02/03 18:39:23 1.1 (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)))) --- /project/slime/cvsroot/slime/contrib/slime-motd.el 2008/02/03 18:39:23 NONE +++ /project/slime/cvsroot/slime/contrib/slime-motd.el 2008/02/03 18:39:23 1.1 ;;; slime-motd.el --- Message Of The Day in a slime repl ;; ;; Authors: Marco Baringer ;; ;; License: GNU GPL (same license as Emacs) ;; ;;; Installation ;; ;; Add slime-motd to your slime-setup call. (require 'slime-banner) (defcustom slime-motd-pathname nil "The local pathnamethe motd is read from." :group 'slime-mode :type '(file :must-match t)) (defun slime-insert-motd () (slime-eval-async `(cl:progn (swank:swank-require :swank-motd) (swank::read-motd ,slime-motd-pathname)) (lambda (motd) (when motd (slime-repl-insert-result (list :values motd)))))) (defun slime-motd-init () (add-hook 'slime-connected-hook 'slime-insert-motd)) (provide 'slime-motd) From mbaringer at common-lisp.net Sun Feb 3 18:45:14 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Sun, 3 Feb 2008 13:45:14 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080203184514.4C0725F074@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv648/contrib Modified Files: ChangeLog Added Files: swank-indentation.lisp slime-indentation.el Log Message: cl-indent integration --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/03 18:39:23 1.83 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/03 18:45:14 1.84 @@ -3,10 +3,16 @@ * 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. @@ -18,7 +24,7 @@ 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 --- /project/slime/cvsroot/slime/contrib/swank-indentation.lisp 2008/02/03 18:45:14 NONE +++ /project/slime/cvsroot/slime/contrib/swank-indentation.lisp 2008/02/03 18:45:14 1.1 (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 (symbol-name 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))) --- /project/slime/cvsroot/slime/contrib/slime-indentation.el 2008/02/03 18:45:14 NONE +++ /project/slime/cvsroot/slime/contrib/slime-indentation.el 2008/02/03 18:45:14 1.1 ;;;; slime-indentation.el - cl-indent.el as a slime-contrib module (defun slime-indentation-install () (slime-eval-async '(swank:swank-require :swank-indentation))) (defun slime-indentation-init () (add-hook 'slime-connected-hook 'slime-indentation-install)) ;; redefine this for cl-indent:method (defun slime-handle-indentation-update (alist) "Update Lisp indent information for slime-indentation.el. ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation settings for `common-lisp-indent-function'. The appropriate property is setup, unless the user already set one explicitly." (dolist (info alist) (let ((symbol (intern (car info))) (indent (cdr info))) (define-cl-indent (cons symbol (etypecase indent (number (list indent)) (cons (labels ((walk (indent) (etypecase indent ((or number null) indent) (cons (cons (walk (car indent)) (walk (cdr indent)))) (string (intern (downcase indent)))))) (list (walk indent)))) (string (intern (downcase indent)))))) (run-hook-with-args 'slime-indentation-update-hooks symbol indent)))) ;; $ITI: cl-indent.el,v 1.6 1995/09/10 14:13:34 schrod Exp $ ;; ---------------------------------------------------------------------- ;; Copyright (C) 1987, 1993 Free Software Foundation, Inc. ;; Written by Richard Mlynarik July 1987 ;; Merged with cl-indent-patches.el by Marco Baringer (2007-11-14) ;; Documented and intensively modified by Joachim Schrod ;; , history at end. ;; Send bug reports, gripes, patches to me. ;; ;; cl-indent.el --- highly configurable indentation for Lisp modes ;; ;; This file 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 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, 675 Mass Ave, Cambridge, MA 02139, USA. ;; ---------------------------------------------------------------------- ;; USAGE: ;; This file delivers highly configurable indentation of Lisp code. ;; Eval (cl-indent) to use this indentation for a specific file, ;; (setq lisp-indent-function 'cl-indent:function) to use it for all ;; Lisp files. ;; The indentation for a specific form may be defined by ;; (define-cl-indent SPEC &optional MODE-METHODS). Indentation specs ;; for Common Lisp constructs are given already. Check the on-line ;; documentation of this function for more information. ;; Actually, the whole (`real') documentation of this source is stored ;; as the documentation strings of respective functions. Start with ;; #'define-cl-indent, you'll find references to all other relevant ;; functions. ;; It's also possible to specify specific indentations for a mode ;; (e.g., some special Lisp-mode) and even specific ones for a file. ;; File specific indentations are taken from the alist bound to ;; cl-indent:local-methods, you can set it in your `Local Variables' ;; section. Mode-specific methods are stored in hash tables, the mode ;; setup must bind cl-indent:mode-methods to the name of that hash ;; table. ;; You may want to override my global indentation specs. If you load ;; this file immediately, just issue some #'define-cl-indent calls. If ;; you use autoload, add an appropriate hook function to ;; 'cl-indent:load-hook. ;; I'm interested in feedback on this module. Do you use it, was it ;; useful to you? (Further development depends on the amount of people ;; who send feedback. :-) ;; Send email to . ;; ------------------------------------------------------------ ;;>> TODO ;; Urgently need better user documentation, it's hard to get a grasp ;; for the overall strategy how this package may be customized. One ;; has to look at too many function documentation strings. ;; Have to check if the usage of hash tables makes this package XEmacs ;; specific. If FSF Emacs doesn't have them, they might be emulated by ;; alists or obarrays. (I don't have FSF Emacs available, may somebody ;; please check this, maybe even send patches?) ;; Realize `parent method tables', to be able to inherit an indentation ;; method table. `(make-method-table &optional size parent)' ?! That's ;; needed before the CL specific indentation is moved to an own table, ;; as some modes (e.g., stil-mode) may inherit their indentation from ;; CL definitions. ;; Common Lisp specific indentation methods should be moved to a ;; method table, it's not good to have them globally for all kinds of ;; Lisp modes. How about a table for Elisp indentations as well? ;; special handling of keywords in forms, e.g., ;; ;; :foo ;; bar ;; :baz ;; zap ;; ;; &key (like &body)?? ;; &rest 1 in lambda-lists doesn't work, really want ;; ;; (foo bar ;; baz) ;; ;; not ;; ;; (foo bar ;; baz) ;; ;; Need something better than &rest for such cases. Perhaps a function ;; that just returns normal-point? Might work... ;;; ------------------------------------------------------------ ;;; ;;; USER TOP-LEVEL FUNCTION ;;; ;;;###autoload (defun cl-indent () "Switch on Common Lisp indentation for the current buffer. May also be used as hook function, e.g., in lisp-mode-hook. If you want to do use this indentation for all Lisp buffers, incl. Emacs Lisp code, simply eval (setq lisp-indent-function 'cl-indent:function) You might want to do this in some setup file, e.g., in ~/.emacs ." (interactive) (make-local-variable 'lisp-indent-function) (setq lisp-indent-function 'cl-indent:function)) ;;; ------------------------------------------------------------ ;;; ;;; Configuration: ;;; (defvar cl-indent::maximum-backtracking 3 "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.") (defvar cl-indent:tag-indentation 1 "*Indentation of tags relative to containing list. This variable is used by the function cl-indent:tagbody.") (defvar cl-indent:tag-body-indentation 3 "*Indentation of non-tagged lines relative to containing list. This variable is used by the function cl-indent:tagbody to indent normal lines (lines without tags). The indentation is relative to the indentation of the parenthesis enclosing he 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.") ;;; ============================================================ ;;; ;;; compute the indentation of the current line ;;; ;;;###autoload (defun common-lisp-indent-function (indent-point state) "Old name of #'cl-indent:function." (cl-indent:function indent-point state)) (make-obsolete #'common-lisp-indent-function #'cl-indent:function) ;;;###autoload (defun cl-indent:function (indent-point state) "Compute the indentation of the current line of Common Lisp code. INDENT-POINT is the current point. STATE is the result of a #'parse-partial-sexp from the start of the current function to the start of the line this function was called. The indentation is determined by the expressions point is in. When this function is called, the column of point may be used as the normal indentation. Therefore we call this position _normal point_. Actually, if the first element of the current expression is a list, it's at the start of this element. Otherwise it's at the start of first expression on the same line as the last complete expression. Within a quoted list or a non-form list, all subsequent lines are indented to the column directly after the opening parenthesis. Quoted lists are those that are prefixed with ?\`, ?\', or ?\#. Note that the quote must be immediately in front of the opening parenthesis. I.e., if you want to use automatic code indentation in a macro expansion formulated with a backquoted list, add a blank between the backquote and the expansion form. Within a list form, the indentation is determined by the indentation method associated to the form symbol. (See #'cl-indent::method.) ** If the indentation method is nil, the form is assumed to be a function call, arguments are aligned beneath each other if the first argument was written behind the function symbol, otherwise they're aligned below the function symbol. ** If the indentation method is a symbol, a function must be bound to that symbol that will compute the current indentation. Such a function is named an _indentation function_ and is called with 5 arguments: (1) PATH is a list of numbers, the path from the top-level form to the current structural element (the first element is number 0). E.g., `foo' has a path of (0 3 1) in `((a b c (d foo) f) g)'. (2) STATE is passed. (3) INDENT-POINT is passed. (4) SEXP-COLUMN is the column where the innermost form starts. (5) NORMAL-INDENT is the column of normal point. ** If the indentation method is a list, this list specifies the form structure and the indentation of each substructure. The possible list structure and elements are described in #'cl-indent::form-method. ** If the indentation method is the number $n$, the first $n$ arguments are _distinguished arguments_; they are indented by 4 spaces. Further arguments are indented by lisp-body-indent. That's roughly equivalent to '(4 4 ... &body)' with $n$ 4s. ** Furthermore values as described for #'lisp-indent-function may be used for upward compatibility." (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 contining lists. ;; `foo' has a path of (0 4 1) in `((a b c (d foo) f) g)' (path ()) ;; set non-nil when somebody works out the indentation to use calculated (last-point indent-point) ;; the position of the open-paren of the innermost containing list (containing-form-start (elt state 1)) ;; 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 cl-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 function method) (if (not (looking-at "\\sw\\|\\s_")) ;; This form doesn't seem to start with a symbol (setq function nil method nil) (setq tem (point)) (forward-sexp 1) (setq function (downcase (buffer-substring tem (point)))) (goto-char tem) (setq tem (intern-soft function) method (get tem 'cl-indent:method)) (cond ((and (null method) (string-match ":[^:]+" function)) ;; The pleblisp package feature (setq function (substring function (1+ (match-beginning 0))) method (get (intern-soft function) 'cl-indent:method))) ((and (null method)) ;; backwards compatibility (setq method (get tem 'lisp-indent-function))))) (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))) ;; backwards compatibility. (cond ((null function)) ((null method) (if (null (cdr path)) ;; (package prefix was stripped off above) (setq method (cond ((string-match "\\`def" [774 lines skipped] From mbaringer at common-lisp.net Sun Feb 3 18:51:56 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Sun, 3 Feb 2008 13:51:56 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080203185156.EF26D28237@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv1370 Modified Files: slime.el ChangeLog Log Message: (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. --- /project/slime/cvsroot/slime/slime.el 2008/01/27 15:34:27 1.896 +++ /project/slime/cvsroot/slime/slime.el 2008/02/03 18:51:56 1.897 @@ -6551,6 +6551,7 @@ (">" '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) @@ -6591,6 +6592,13 @@ (define-sldb-invoke-restart-keys 0 9) +(defun sldb-invoke-restart-by-name (restart-name) + (interactive (list (completing-read "Restart: " + sldb-restarts nil t + "" + 'sldb-invoke-restart-by-name))) + (sldb-invoke-restart (position restart-name sldb-restarts :test 'string= :key 'first))) + ;;;;; SLDB buffer creation & update --- /project/slime/cvsroot/slime/ChangeLog 2008/02/03 18:00:31 1.1275 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/03 18:51:56 1.1276 @@ -1,5 +1,10 @@ 2008-02-03 Marco Baringer + * 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. (lisp-version-string): On openmcl use the full From mbaringer at common-lisp.net Mon Feb 4 12:15:28 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 07:15:28 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204121528.8F2CB232CF@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv14181 Modified Files: swank-loader.lisp ChangeLog Log Message: --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/03 18:00:31 1.76 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/04 12:15:27 1.77 @@ -22,7 +22,6 @@ (when (find-package :swank) (delete-package :swank) (delete-package :swank-io-package) - (delete-package :swank-loader) (delete-package :swank-backend))) (cl:defpackage :swank-loader --- /project/slime/cvsroot/slime/ChangeLog 2008/02/03 18:51:56 1.1276 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/04 12:15:27 1.1277 @@ -6,7 +6,9 @@ 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. + 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 From mbaringer at common-lisp.net Mon Feb 4 16:25:11 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 11:25:11 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204162511.49AAE64048@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv15611 Modified Files: swank.lisp ChangeLog Log Message: (*sldb-condition-printer*): New variable. (safe-condition-message): Use the current binding of *sldb-condition-printer* to print the condition to a string. --- /project/slime/cvsroot/slime/swank.lisp 2007/12/20 10:33:37 1.523 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/04 16:25:08 1.524 @@ -2056,12 +2056,15 @@ ,(princ-to-string real-condition)))) (throw 'sldb-loop-catcher nil)) +(defvar *sldb-condition-printer* #'format-sldb-condition + "Function called to print a condition to an SLDB buffer.") + (defun safe-condition-message (condition) "Safely print condition to a string, handling any errors during printing." (let ((*print-pretty* t) (*print-right-margin* 65)) (handler-case - (format-sldb-condition condition) + (funcall *sldb-condition-printer* condition) (error (cond) ;; Beware of recursive errors in printing, so only use the condition ;; if it is printable itself: --- /project/slime/cvsroot/slime/ChangeLog 2008/02/04 12:15:27 1.1277 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/04 16:25:10 1.1278 @@ -1,5 +1,9 @@ 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 From heller at common-lisp.net Mon Feb 4 16:35:39 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Feb 2008 11:35:39 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204163539.84AA47113E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17056 Modified Files: swank.lisp Log Message: 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. --- /project/slime/cvsroot/slime/swank.lisp 2008/02/04 16:25:08 1.524 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/04 16:35:39 1.525 @@ -415,43 +415,6 @@ (<= (char-code c) 127)) -;;;;; Misc - -(defun length= (seq n) - "Test for whether SEQ contains N number of elements. I.e. it's equivalent - to (= (LENGTH SEQ) N), but besides being more concise, it may also be more - efficiently implemented." - (etypecase seq - (list (do ((i n (1- i)) - (list seq (cdr list))) - ((or (<= i 0) (null list)) - (and (zerop i) (null list))))) - (sequence (= (length seq) n)))) - -(defun ensure-list (thing) - (if (listp thing) thing (list thing))) - -(defun recursively-empty-p (list) - "Returns whether LIST consists only of arbitrarily nested empty lists." - (cond ((not (listp list)) nil) - ((null list) t) - (t (every #'recursively-empty-p list)))) - -(defun maybecall (bool fn &rest args) - "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values." - (if bool (apply fn args) (values-list args))) - -(defun exactly-one-p (&rest values) - "If exactly one value in VALUES is non-NIL, this value is returned. -Otherwise NIL is returned." - (let ((found nil)) - (dolist (v values) - (when v (if found - (return-from exactly-one-p nil) - (setq found v)))) - found)) - - ;;;;; Symbols (defun symbol-status (symbol &optional (package (symbol-package symbol))) @@ -1569,30 +1532,6 @@ (let ((*read-suppress* nil)) (read-from-string string)))) -(defun read-softly-from-string (string) - "Returns three values: - - 1. the object resulting from READing STRING. - - 2. The index of the first character in STRING that was not read. - - 3. T if the object is a symbol that had to be newly interned - in some package. (This does not work for symbols in - compound forms like lists or vectors.)" - (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) - (if found? - (values symbol (length string) nil) - (multiple-value-bind (sexp pos) (read-from-string string) - (values sexp pos - (when (symbolp sexp) - (prog1 t - ;; assert that PARSE-SYMBOL didn't parse incorrectly. - (assert (and (equal symbol-name (symbol-name sexp)) - (eq package (symbol-package sexp))))))))))) - -(defun unintern-in-home-package (symbol) - (unintern symbol (symbol-package symbol))) - ;; FIXME: deal with #\| etc. hard to do portably. (defun tokenize-symbol (string) "STRING is interpreted as the string representation of a symbol @@ -1755,7 +1694,7 @@ (with-buffer-syntax () (let ((*print-readably* nil)) (cond ((null values) "; No value") - ((and (length= values 1) (integerp (car values))) + ((and (integerp (car values)) (null (cdr values))) (let ((i (car values))) (format nil "~A~D (#x~X, #o~O, #b~B)" *echo-area-prefix* i i i i))) @@ -2915,14 +2854,6 @@ *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) -(defun valid-function-name-p (form) - (or (symbolp form) - (and (consp form) - (second form) - (not (third form)) - (eq (first form) 'setf) - (symbolp (second form))))) - (defslimefun init-inspector (string) (with-buffer-syntax () (reset-inspector) From heller at common-lisp.net Mon Feb 4 16:35:40 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Feb 2008 11:35:40 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080204163540.7BDAE72126@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv17056/contrib Modified Files: swank-arglists.lisp Log Message: 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. --- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/01/10 20:00:17 1.18 +++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/02/04 16:35:39 1.19 @@ -12,6 +12,40 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-c-p-c)) +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + +(defun recursively-empty-p (list) + "Returns whether LIST consists only of arbitrarily nested empty lists." + (cond ((not (listp list)) nil) + ((null list) t) + (t (every #'recursively-empty-p list)))) + +(defun maybecall (bool fn &rest args) + "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values." + (if bool (apply fn args) (values-list args))) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + (defun valid-operator-symbol-p (symbol) "Is SYMBOL the name of a function, a macro, or a special-operator?" (or (fboundp symbol) @@ -24,6 +58,14 @@ (let ((symbol (parse-symbol string))) (valid-operator-symbol-p symbol))) +(defun valid-function-name-p (form) + (or (symbolp form) + (and (consp form) + (second form) + (not (third form)) + (eq (first form) 'setf) + (symbolp (second form))))) + (defslimefun arglist-for-echo-area (raw-specs &key arg-indices print-right-margin print-lines) "Return the arglist for the first valid ``form spec'' in @@ -243,6 +285,29 @@ (assert (= pos (length string))) (values sexp interned?))) +(defun read-softly-from-string (string) + "Returns three values: + + 1. the object resulting from READing STRING. + + 2. The index of the first character in STRING that was not read. + + 3. T if the object is a symbol that had to be newly interned + in some package. (This does not work for symbols in + compound forms like lists or vectors.)" + (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string) + (if found? + (values symbol (length string) nil) + (multiple-value-bind (sexp pos) (read-from-string string) + (values sexp pos + (when (symbolp sexp) + (prog1 t + ;; assert that PARSE-SYMBOL didn't parse incorrectly. + (assert (and (equal symbol-name (symbol-name sexp)) + (eq package (symbol-package sexp))))))))))) + +(defun unintern-in-home-package (symbol) + (unintern symbol (symbol-package symbol))) (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) provided-args ; list of the provided actual arguments From heller at common-lisp.net Mon Feb 4 16:36:29 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Feb 2008 11:36:29 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204163629.8EDB470EC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17139 Modified Files: slime.el ChangeLog Log Message: 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. --- /project/slime/cvsroot/slime/slime.el 2008/02/03 18:51:56 1.897 +++ /project/slime/cvsroot/slime/slime.el 2008/02/04 16:36:28 1.898 @@ -6574,30 +6574,14 @@ (define-key sldb-mode-map key command))))) ;; Keys 0-9 are shortcuts to invoke particular restarts. -(defmacro define-sldb-invoke-restart-key (number key) +(dotimes (number 10) (let ((fname (intern (format "sldb-invoke-restart-%S" number))) (docstring (format "Invoke restart numbered %S." number))) - `(progn - (defun ,fname () - ,docstring - (interactive) - (sldb-invoke-restart ,number)) - (define-key sldb-mode-map ,key ',fname)))) - -(defmacro define-sldb-invoke-restart-keys (from to) - `(progn - ,@(loop for n from from to to - collect `(define-sldb-invoke-restart-key ,n - ,(number-to-string n))))) - -(define-sldb-invoke-restart-keys 0 9) - -(defun sldb-invoke-restart-by-name (restart-name) - (interactive (list (completing-read "Restart: " - sldb-restarts nil t - "" - 'sldb-invoke-restart-by-name))) - (sldb-invoke-restart (position restart-name sldb-restarts :test 'string= :key 'first))) + (eval `(defun ,fname () + ,docstring + (interactive) + (sldb-invoke-restart ,number))) + (define-key sldb-mode-map (number-to-string number) fname))) ;;;;; SLDB buffer creation & update @@ -7231,6 +7215,14 @@ ((:ok value) (message "Restart returned: %s" value)) ((:abort))))) +(defun sldb-invoke-restart-by-name (restart-name) + (interactive (list (completing-read "Restart: " + sldb-restarts nil t + "" + 'sldb-invoke-restart-by-name))) + (sldb-invoke-restart (position restart-name sldb-restarts + :test 'string= :key 'first))) + (defun sldb-break-with-default-debugger () "Enter default debugger." (interactive) --- /project/slime/cvsroot/slime/ChangeLog 2008/02/04 16:25:10 1.1278 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/04 16:36:28 1.1279 @@ -1,3 +1,19 @@ +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. @@ -21,7 +37,7 @@ 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: @@ -35,7 +51,7 @@ (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 From heller at common-lisp.net Mon Feb 4 16:36:30 2008 From: heller at common-lisp.net (heller) Date: Mon, 4 Feb 2008 11:36:30 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080204163630.2F18070E1@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv17139/contrib Modified Files: ChangeLog Log Message: 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. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/03 18:45:14 1.84 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/04 16:36:29 1.85 @@ -1,3 +1,12 @@ +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 From mbaringer at common-lisp.net Mon Feb 4 17:35:03 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 12:35:03 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080204173503.7B40328077@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv3104/contrib Modified Files: swank-fancy-inspector.lisp Log Message: Drop second argument from inspect-for-emacs --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2007/11/20 21:29:41 1.5 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/04 17:35:03 1.6 @@ -6,12 +6,7 @@ (in-package :swank) -;; Subclass `backend-inspector' so that backend specific methods are -;; also considered. -(defclass fancy-inspector (backend-inspector) ()) - -(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((symbol symbol)) (let ((package (symbol-package symbol))) (multiple-value-bind (_symbol status) (and package (find-symbol (string symbol) package)) @@ -94,8 +89,7 @@ (t (list label ": " '(:newline) " " docstring '(:newline)))))) -(defmethod inspect-for-emacs ((f function) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((f function)) (values "A function." (append (label-value-line "Name" (function-name f)) @@ -128,8 +122,7 @@ (swank-mop:method-qualifiers method) (method-specializers-for-inspect method))) -(defmethod inspect-for-emacs ((object standard-object) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((object standard-object)) (let ((class (class-of object))) (values "An object." `("Class: " (:value ,class) (:newline) @@ -231,8 +224,7 @@ append slot-presentation collect '(:newline)))))) -(defmethod inspect-for-emacs ((gf standard-generic-function) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((gf standard-generic-function)) (flet ((lv (label value) (label-value-line label value))) (values "A generic function." @@ -257,8 +249,7 @@ `((:newline)) (all-slots-for-inspector gf inspector))))) -(defmethod inspect-for-emacs ((method standard-method) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((method standard-method)) (values "A method." `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) @@ -278,8 +269,7 @@ (:newline) ,@(all-slots-for-inspector method inspector)))) -(defmethod inspect-for-emacs ((class standard-class) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((class standard-class)) (values "A class." `("Name: " (:value ,(class-name class)) (:newline) @@ -338,8 +328,7 @@ (:newline) ,@(all-slots-for-inspector class inspector)))) -(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) - (inspector fancy-inspector)) +(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition)) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) @@ -445,9 +434,7 @@ (:newline) ))))) -(defmethod inspect-for-emacs ((%container %package-symbols-container) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((%container %package-symbols-container)) (with-struct (%container. title description symbols grouping-kind) %container (values title `(, at description @@ -465,9 +452,7 @@ ,@(make-symbols-listing grouping-kind symbols))))) -(defmethod inspect-for-emacs ((package package) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((package package)) (let ((package-name (package-name package)) (package-nicknames (package-nicknames package)) (package-use-list (package-use-list package)) @@ -561,9 +546,7 @@ :description nil))))))) -(defmethod inspect-for-emacs ((pathname pathname) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((pathname pathname)) (values (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") @@ -579,9 +562,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((pathname logical-pathname) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((pathname logical-pathname)) (values "A logical pathname." (append (label-value-line* @@ -601,9 +582,7 @@ ("Truename" (if (not (wild-pathname-p pathname)) (probe-file pathname))))))) -(defmethod inspect-for-emacs ((n number) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((n number)) (values "A number." `("Value: " ,(princ-to-string n)))) (defun format-iso8601-time (time-value &optional include-timezone-p) @@ -626,9 +605,7 @@ year month day hour minute second include-timezone-p (format-iso8601-timezone zone))))) -(defmethod inspect-for-emacs ((i integer) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((i integer)) (values "A number." (append `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" @@ -640,26 +617,20 @@ (ignore-errors (label-value-line "Universal-time" (format-iso8601-time i t)))))) -(defmethod inspect-for-emacs ((c complex) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((c complex)) (values "A complex number." (label-value-line* ("Real part" (realpart c)) ("Imaginary part" (imagpart c))))) -(defmethod inspect-for-emacs ((r ratio) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((r ratio)) (values "A non-integer ratio." (label-value-line* ("Numerator" (numerator r)) ("Denominator" (denominator r)) ("As float" (float r))))) -(defmethod inspect-for-emacs ((f float) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((f float)) (values "A floating point number." (cond ((> f most-positive-long-float) @@ -679,9 +650,7 @@ (label-value-line "Digits" (float-digits f)) (label-value-line "Precision" (float-precision f)))))))) -(defmethod inspect-for-emacs ((stream file-stream) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((stream file-stream)) (multiple-value-bind (title content) (call-next-method) (declare (ignore title)) @@ -699,9 +668,7 @@ (:newline)) content)))) -(defmethod inspect-for-emacs ((condition stream-error) - (inspector fancy-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((condition stream-error)) (multiple-value-bind (title content) (call-next-method) (let ((stream (stream-error-stream condition))) From mbaringer at common-lisp.net Mon Feb 4 17:35:08 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 12:35:08 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204173508.EEEE233088@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3104 Modified Files: swank.lisp swank-scl.lisp swank-sbcl.lisp swank-openmcl.lisp swank-lispworks.lisp swank-ecl.lisp swank-corman.lisp swank-cmucl.lisp swank-clisp.lisp swank-backend.lisp swank-allegro.lisp swank-abcl.lisp ChangeLog Log Message: Drop second argument from inspect-for-emacs --- /project/slime/cvsroot/slime/swank.lisp 2008/02/04 16:35:39 1.525 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/04 17:35:03 1.526 @@ -2692,8 +2692,7 @@ (set-pprint-dispatch '(cons (member function)) nil) (princ-to-string list))) -(defmethod inspect-for-emacs ((object cons) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((object cons)) (if (consp (cdr object)) (inspect-for-emacs-list object) (inspect-for-emacs-simple-cons object))) @@ -2753,8 +2752,7 @@ a hash table or array to show by default. If table has more than this then offer actions to view more. Set to nil for no limit." ) -(defmethod inspect-for-emacs ((ht hash-table) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((ht hash-table)) (values (prin1-to-string ht) (append (label-value-line* @@ -2806,8 +2804,7 @@ (progn (format t "How many elements should be shown? ") (read)))) (swank::inspect-object thing))))) -(defmethod inspect-for-emacs ((array array) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((array array)) (values "An array." (append (label-value-line* @@ -2825,8 +2822,7 @@ (loop for i below (or *slime-inspect-contents-limit* (array-total-size array)) append (label-value-line i (row-major-aref array i)))))) -(defmethod inspect-for-emacs ((char character) inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((char character)) (values "A character." (append (label-value-line* @@ -2894,14 +2890,14 @@ (list :action label (assign-index (list lambda refreshp) *inspectee-actions*))) -(defun inspect-object (object &optional (inspector *default-inspector*)) +(defun inspect-object (object) (push (setq *inspectee* object) *inspector-stack*) (unless (find object *inspector-history*) (vector-push-extend object *inspector-history*)) (let ((*print-pretty* nil) ; print everything in the same line (*print-circle* t) (*print-readably* nil)) - (multiple-value-bind (_ content) (inspect-for-emacs object inspector) + (multiple-value-bind (_ content) (inspect-for-emacs object) (declare (ignore _)) (list :title (with-output-to-string (s) (print-unreadable-object (object s :type t :identity t))) --- /project/slime/cvsroot/slime/swank-scl.lisp 2007/12/22 13:24:49 1.14 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/04 17:35:03 1.15 @@ -1740,7 +1740,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1759,8 +1759,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (values (format nil "~A is a function." o) @@ -1789,8 +1788,7 @@ (call-next-method))))) -(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) - (declare (ignore _)) +(defmethod inspect-for-emacs ((o kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1817,8 +1815,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o kernel:fdefn)) (values (format nil "~A is a fdenf object." o) (label-value-line* ("name" (kernel:fdefn-name o)) @@ -1827,8 +1824,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o array)) (cond ((kernel:array-header-p o) (values (format nil "~A is an array." o) (label-value-line* @@ -1847,8 +1843,7 @@ (:header (describe-primitive-type o)) (:length (length o))))))) -(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o simple-vector)) (values (format nil "~A is a vector." o) (append (label-value-line* --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/01/17 05:53:44 1.187 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/04 17:35:03 1.188 @@ -1006,7 +1006,7 @@ (defimplementation make-default-inspector () (make-instance 'sbcl-inspector)) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (declare (ignore inspector)) (cond ((sb-di::indirect-value-cell-p o) (values "A value cell." (label-value-line* @@ -1019,8 +1019,7 @@ (values text (loop for value in parts for i from 0 append (label-value-line i value)))))))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o function)) (let ((header (sb-kernel:widetag-of o))) (cond ((= header sb-vm:simple-fun-header-widetag) (values "A simple-fun." @@ -1041,8 +1040,7 @@ i (sb-kernel:%closure-index-ref o i)))))) (t (call-next-method o))))) -(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ backend-inspector)) - (declare (ignore _)) +(defmethod inspect-for-emacs ((o sb-kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1070,22 +1068,18 @@ (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o sb-ext:weak-pointer)) (values "A weak pointer." (label-value-line* (:value (sb-ext:weak-pointer-value o))))) -(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o sb-kernel:fdefn)) (values "A fdefn object." (label-value-line* (:name (sb-kernel:fdefn-name o)) (:function (sb-kernel:fdefn-fun o))))) -(defmethod inspect-for-emacs :around ((o generic-function) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs :around ((o generic-function)) (multiple-value-bind (title contents) (call-next-method) (values title (append --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2007/10/22 08:19:58 1.120 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/04 17:35:03 1.121 @@ -795,8 +795,7 @@ (string (gethash typecode *value2tag*)) (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o t)) (let* ((i (inspector::make-inspector o)) (count (inspector::compute-line-count i)) (lines @@ -814,7 +813,7 @@ (pprint o s))) lines))) -(defmethod inspect-for-emacs :around ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs :around ((o t)) (if (or (uvector-inspector-p o) (not (ccl:uvectorp o))) (call-next-method) @@ -834,8 +833,7 @@ (:method ((object t)) nil) (:method ((object uvector-inspector)) t)) -(defmethod inspect-for-emacs ((uv uvector-inspector) - (inspector backend-inspector)) +(defmethod inspect-for-emacs ((uv uvector-inspector) ) (with-slots (object) uv (values (format nil "The UVECTOR for ~S." object) @@ -855,7 +853,7 @@ (cellp (ccl::closed-over-value-p value))) (list label (if cellp (ccl::closed-over-value value) value)))))) -(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure) (inspector t)) +(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure)) (declare (ignore inspector)) (values (format nil "A closure: ~a" c) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2007/11/24 08:18:59 1.93 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/04 17:35:03 1.94 @@ -629,20 +629,15 @@ (defimplementation make-default-inspector () (make-instance 'lispworks-inspector)) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o t)) (lispworks-inspect o)) -(defmethod inspect-for-emacs ((o function) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((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 inspect-for-emacs ((o standard-object) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o standard-object)) (lispworks-inspect o)) (defun lispworks-inspect (o) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/01/19 15:09:33 1.11 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/02/04 17:35:03 1.12 @@ -248,13 +248,7 @@ ;;;; Inspector -(defclass ecl-inspector (inspector) - ()) - -(defimplementation make-default-inspector () - (make-instance 'ecl-inspector)) - -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) ; ecl clos support leaves some to be desired (cond ((streamp o) --- /project/slime/cvsroot/slime/swank-corman.lisp 2007/08/23 19:03:37 1.11 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/04 17:35:03 1.12 @@ -399,9 +399,7 @@ collect (funcall callback e) collect ", "))) -(defmethod inspect-for-emacs ((class standard-class) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((class standard-class)) (values "A class." `("Name: " (:value ,(class-name class)) (:newline) @@ -438,9 +436,8 @@ '("#")) (:newline)))) -(defmethod inspect-for-emacs ((slot cons) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((slot cons)) ;; Inspects slot definitions - (declare (ignore inspector)) (if (eq (car slot) :name) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) @@ -457,9 +454,7 @@ (:newline))) (call-next-method))) -(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal) - inspector) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)) (values (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") @@ -475,7 +470,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (cond ((cl::structurep o) (inspect-structure o)) (t (call-next-method)))) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2007/11/30 13:10:40 1.175 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/04 17:35:03 1.176 @@ -1869,7 +1869,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1887,8 +1887,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (values (format nil "~A is a function." o) @@ -1915,9 +1914,7 @@ (t (call-next-method))))) -(defmethod inspect-for-emacs ((o kernel:funcallable-instance) - (i backend-inspector)) - (declare (ignore i)) +(defmethod inspect-for-emacs ((o kernel:funcallable-instance)) (values (format nil "~A is a funcallable-instance." o) (append (label-value-line* @@ -1926,8 +1923,7 @@ (:layout (kernel:%funcallable-instance-layout o))) (nth-value 1 (cmucl-inspect o))))) -(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector)) - (declare (ignore _)) +(defmethod inspect-for-emacs ((o kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1954,8 +1950,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o kernel:fdefn)) (values (format nil "~A is a fdenf object." o) (label-value-line* ("name" (kernel:fdefn-name o)) @@ -1964,8 +1959,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o array)) (if (typep o 'simple-array) (call-next-method) (values (format nil "~A is an array." o) @@ -1980,8 +1974,7 @@ (:displaced-p (kernel:%array-displaced-p o)) (:dimensions (array-dimensions o)))))) -(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o simple-vector)) (values (format nil "~A is a simple-vector." o) (append (label-value-line* --- /project/slime/cvsroot/slime/swank-clisp.lisp 2007/08/23 19:03:37 1.64 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/04 17:35:04 1.65 @@ -627,12 +627,7 @@ ;;;; Inspecting -(defclass clisp-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () (make-instance 'clisp-inspector)) - -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((o t)) (let* ((*print-array* nil) (*print-pretty* t) (*print-circle* t) (*print-escape* t) (*print-lines* custom:*inspect-print-lines*) --- /project/slime/cvsroot/slime/swank-backend.lisp 2007/09/10 15:39:05 1.126 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/04 17:35:04 1.127 @@ -840,26 +840,10 @@ ;;;; Inspector -(defclass inspector () - () - (:documentation "Super class of inspector objects. - -Implementations should sub class in order to dispatch off of the -inspect-for-emacs method.")) - -(defclass backend-inspector (inspector) ()) - -(definterface make-default-inspector () - "Return an inspector object suitable for passing to inspect-for-emacs.") - -(defgeneric inspect-for-emacs (object inspector) +(defgeneric inspect-for-emacs (object) (:documentation "Explain to Emacs how to inspect OBJECT. -The argument INSPECTOR is an object representing how to get at -the internals of OBJECT, it is usually an implementation specific -class used simply for dispatching to the proper method. - Returns two values: a string which will be used as the title of the inspector buffer and a list specifying how to render the object for inspection. @@ -880,12 +864,11 @@ NIL - do nothing.")) -(defmethod inspect-for-emacs ((object t) (inspector t)) +(defmethod inspect-for-emacs ((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." - (declare (ignore inspector)) (values "A value." `("Type: " (:value ,(type-of object)) (:newline) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2007/09/26 23:15:41 1.98 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/04 17:35:04 1.99 @@ -564,13 +564,7 @@ ;;;; Inspecting -(defclass acl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'acl-inspector)) - -(defmethod inspect-for-emacs ((f function) inspector) - inspector +(defmethod inspect-for-emacs ((f function)) (values "A function." (append (label-value-line "Name" (function-name f)) @@ -579,17 +573,13 @@ (when doc `("Documentation:" (:newline) ,doc)))))) -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o t)) (values "A value." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o function) (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o function)) (values "A function." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o standard-object) - (inspector backend-inspector)) - inspector +(defmethod inspect-for-emacs ((o standard-object)) (values (format nil "~A is a standard-object." o) (allegro-inspect o))) (defun allegro-inspect (o) --- /project/slime/cvsroot/slime/swank-abcl.lisp 2007/10/22 08:36:32 1.44 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/04 17:35:04 1.45 @@ -421,14 +421,7 @@ ;;;; Inspecting -(defclass abcl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'abcl-inspector)) - -(defmethod inspect-for-emacs ((slot mop::slot-definition) - (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((slot mop::slot-definition)) (values "A slot." `("Name: " (:value ,(mop::%slot-definition-name slot)) (:newline) @@ -443,8 +436,7 @@ " Function: " (:value ,(mop::%slot-definition-initfunction slot)) (:newline)))) -(defmethod inspect-for-emacs ((f function) (inspector backend-inspector)) - (declare (ignore inspector)) +(defmethod inspect-for-emacs ((f function)) (values "A function." `(,@(when (function-name f) `("Name: " @@ -461,7 +453,7 @@ #| -(defmethod inspect-for-emacs ((o t) (inspector backend-inspector)) +(defmethod inspect-for-emacs ((o t)) (let* ((class (class-of o)) (slots (mop::class-slots class))) (values (format nil "~A~% is a ~A" o class) --- /project/slime/cvsroot/slime/ChangeLog 2008/02/04 16:36:28 1.1279 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/04 17:35:04 1.1280 @@ -1,3 +1,15 @@ +2008-02-04 Marco Baringer + + + * 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. From mbaringer at common-lisp.net Mon Feb 4 17:39:52 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 12:39:52 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204173952.34A3E240DD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv4817 Modified Files: swank-corman.lisp Log Message: drop corman inspector defclass --- /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/04 17:35:03 1.12 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/04 17:39:52 1.13 @@ -387,12 +387,6 @@ ;; Hack to make swank.lisp load, at least (defclass file-stream ()) -(defclass corman-inspector (backend-inspector) - ()) - -(defimplementation make-default-inspector () - (make-instance 'corman-inspector)) - (defun comma-separated (list &optional (callback (lambda (v) `(:value ,v)))) (butlast (loop for e in list From mbaringer at common-lisp.net Mon Feb 4 17:41:22 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 12:41:22 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204174122.316645F062@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6769 Modified Files: swank-sbcl.lisp Log Message: drop sbcl inspector defclass --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/04 17:35:03 1.188 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/04 17:41:22 1.189 @@ -1001,13 +1001,7 @@ ;;;; Inspector -(defclass sbcl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'sbcl-inspector)) - (defmethod inspect-for-emacs ((o t)) - (declare (ignore inspector)) (cond ((sb-di::indirect-value-cell-p o) (values "A value cell." (label-value-line* (:value (sb-kernel:value-cell-ref o))))) From mbaringer at common-lisp.net Mon Feb 4 17:58:36 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 12:58:36 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080204175836.7CA4E31076@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv9722/contrib Modified Files: swank-arglists.lisp ChangeLog Log Message: (arglist-dispatch): Specialize operator-type so openmcl doesn't warn about unused arguments. (arglist-dispatch): add declare ignore form. --- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/02/04 16:35:39 1.19 +++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp 2008/02/04 17:58:31 1.20 @@ -1087,7 +1087,7 @@ (defgeneric arglist-dispatch (operator-type operator arguments &key remove-args)) -(defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t)) +(defmethod arglist-dispatch ((operator-type t) operator arguments &key (remove-args t)) (when (and (symbolp operator) (valid-operator-symbol-p operator)) (multiple-value-bind (decoded-arglist determining-args any-enrichment) @@ -1140,7 +1140,7 @@ (defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'declare)) arguments &key (remove-args t)) ;; Catching 'DECLARE before SWANK-BACKEND:ARGLIST can barf. - (declare (ignore remove-args)) + (declare (ignore remove-args arguments)) (make-arglist :rest '#:decl-specifiers)) (defmethod arglist-dispatch ((operator-type (eql :declaration)) --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/04 16:36:29 1.85 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/04 17:58:32 1.86 @@ -1,3 +1,9 @@ +2008-02-04 Marco Baringer + + * 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. From mbaringer at common-lisp.net Mon Feb 4 17:59:49 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 12:59:49 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080204175949.6867C3002C@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv10285/contrib Modified Files: swank-fancy-inspector.lisp Log Message: drop second argument from inspect-for-emacs --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/04 17:35:03 1.6 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/04 17:59:49 1.7 @@ -126,7 +126,7 @@ (let ((class (class-of object))) (values "An object." `("Class: " (:value ,class) (:newline) - ,@(all-slots-for-inspector object inspector))))) + ,@(all-slots-for-inspector object))))) (defvar *gf-method-getter* 'methods-by-applicability "This function is called to get the methods of a generic function. @@ -186,8 +186,8 @@ `(" " (:action "[make unbound]" ,(lambda () (swank-mop:slot-makunbound-using-class class object slot))))))))) -(defgeneric all-slots-for-inspector (object inspector) - (:method ((object standard-object) inspector) +(defgeneric all-slots-for-inspector (object) + (:method ((object standard-object)) (declare (ignore inspector)) (append '("--------------------" (:newline) "All Slots:" (:newline)) @@ -247,7 +247,7 @@ (remove-method gf m)))) (:newline))) `((:newline)) - (all-slots-for-inspector gf inspector))))) + (all-slots-for-inspector gf))))) (defmethod inspect-for-emacs ((method standard-method)) (values "A method." @@ -267,7 +267,7 @@ (:newline) "Method function: " (:value ,(swank-mop:method-function method)) (:newline) - ,@(all-slots-for-inspector method inspector)))) + ,@(all-slots-for-inspector method)))) (defmethod inspect-for-emacs ((class standard-class)) (values "A class." @@ -326,7 +326,7 @@ `(:value ,(swank-mop:class-prototype class)) '"#") (:newline) - ,@(all-slots-for-inspector class inspector)))) + ,@(all-slots-for-inspector class)))) (defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition)) (values "A slot." @@ -342,7 +342,7 @@ "#") (:newline) "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline) - ,@(all-slots-for-inspector slot inspector)))) + ,@(all-slots-for-inspector slot)))) ;; Wrapper structure over the list of symbols of a package that should @@ -451,7 +451,6 @@ (:newline) (:newline) ,@(make-symbols-listing grouping-kind symbols))))) - (defmethod inspect-for-emacs ((package package)) (let ((package-name (package-name package)) (package-nicknames (package-nicknames package)) @@ -691,14 +690,10 @@ (defvar *fancy-inpector-undo-list* nil) (defslimefun fancy-inspector-init () - (let ((i *default-inspector*)) - (push (lambda () (setq *default-inspector* i)) - *fancy-inpector-undo-list*)) - (setq *default-inspector* (make-instance 'fancy-inspector)) t) (defslimefun fancy-inspector-unload () (loop while *fancy-inpector-undo-list* do (funcall (pop *fancy-inpector-undo-list*)))) -(provide :swank-fancy-inspector) \ No newline at end of file +(provide :swank-fancy-inspector) From mbaringer at common-lisp.net Mon Feb 4 18:00:37 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 13:00:37 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080204180037.2B2483C015@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv11290/contrib Modified Files: swank-presentation-streams.lisp ChangeLog Log Message: --- /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2007/08/28 16:26:32 1.4 +++ /project/slime/cvsroot/slime/contrib/swank-presentation-streams.lisp 2008/02/04 18:00:36 1.5 @@ -210,6 +210,9 @@ (defun presenting-object-1 (object stream continue) "Uses the bridge mechanism with two messages >id and + * 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. From mbaringer at common-lisp.net Mon Feb 4 20:35:15 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Mon, 4 Feb 2008 15:35:15 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080204203515.591EF2E1D2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv24062 Modified Files: swank.lisp swank-openmcl.lisp slime.el slime-autoloads.el ChangeLog Log Message: --- /project/slime/cvsroot/slime/swank.lisp 2008/02/04 17:35:03 1.526 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/04 20:35:11 1.527 @@ -2841,7 +2841,6 @@ (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) (declaim (type vector *inspector-history*)) (defvar *inspect-length* 30) -(defvar *default-inspector* (make-default-inspector)) (defun reset-inspector () (setq *inspectee* nil --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/04 17:35:03 1.121 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/04 20:35:11 1.122 @@ -211,14 +211,18 @@ (defvar *break-in-sldb* t) + (let ((ccl::*warn-if-redefine-kernel* nil)) - (ccl::advise - cl::break + (ccl::advise + ccl::cbreak-loop (if (and *break-in-sldb* - (find ccl::*current-process* (symbol-value (intern "*CONNECTIONS*" 'swank)) - :key (intern "CONNECTION.REPL-THREAD" 'swank))) + (find ccl::*current-process* + (symbol-value (intern (string :*connections*) :swank)) + :key (intern (string :connection.repl-thread) :swank))) (apply 'break-in-sldb ccl::arglist) - (:do-it)) :when :around :name sldb-break)) + (:do-it)) + :when :around + :name sldb-break)) (defun break-in-sldb (&optional string &rest args) (let ((c (make-condition 'simple-condition @@ -335,8 +339,7 @@ for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp)) when name do (incf varcount) until (= varcount var) - finally (return value)) - ))))))) + finally (return value))))))))) (defun xref-locations (relation name &optional (inverse nil)) (flet ((function-source-location (entry) @@ -345,8 +348,8 @@ (ccl::%db-key-from-xref-entry entry) (if (eql (ccl::xref-entry-type entry) 'macro) - 'function - (ccl::xref-entry-type entry))) + 'function + (ccl::xref-entry-type entry))) (cond ((not info) (list :error (format nil "No source info available for ~A" @@ -466,7 +469,8 @@ (setq ccl::*fasl-save-definitions* nil) (setq ccl::*fasl-save-doc-strings* t) (setq ccl::*fasl-save-local-symbols* t) - (setq ccl::*ppc2-compiler-register-save-label* t) + #+ppc (setq ccl::*ppc2-compiler-register-save-label* t) + #+x86-64 (setq ccl::*x862-compiler-register-save-label* t) (setq ccl::*save-arglist-info* t) (setq ccl::*save-definitions* nil) (setq ccl::*save-doc-strings* t) @@ -513,9 +517,8 @@ (defun frame-arguments (p context lfun pc) "Returns a string representing the arguments of a frame." - (multiple-value-bind (args types names count nclosed) + (multiple-value-bind (args types names) (ccl::frame-supplied-args p lfun pc nil context) - (declare (ignore count nclosed)) (let ((result nil)) (loop named loop for var = (cond @@ -575,7 +578,9 @@ (push (list :name name :id 0 - :value var) + :value (if (typep var 'ccl::value-cell) + (ccl::uvref var 0) + var)) result)))) (return-from frame-locals (nreverse result))))))))) @@ -610,19 +615,24 @@ (when (= frame-number the-frame-number) (setq function-to-disassemble lfun) (return-from find-frame))))) - (ccl::print-ppc-instructions - *standard-output* - (ccl::function-to-dll-header function-to-disassemble) nil))) + #+ppc (ccl::print-ppc-instructions + *standard-output* + (ccl::function-to-dll-header function-to-disassemble) + nil) + #+x86-64 (ccl::x8664-xdisassemble function-to-disassemble))) ;;; -(defun canonicalize-location (file symbol) +(defun canonicalize-location (file symbol &optional snippet) (etypecase file ((or string pathname) (multiple-value-bind (truename c) (ignore-errors (namestring (truename file))) (cond (c (list :error (princ-to-string c))) (t (make-location (list :file (remove-filename-quoting truename)) - (list :function-name (princ-to-string symbol))))))))) + (list :function-name (princ-to-string symbol)) + (if snippet + (list :snippet snippet) + '())))))))) (defun remove-filename-quoting (string) (if (search "\\" string) @@ -644,20 +654,20 @@ (list (list type symbol) (canonicalize-location file symbol)))))) - (defun function-source-location (function) - (multiple-value-bind (info name) (ccl::edit-definition-p function) + (multiple-value-bind (info name) + (ccl::edit-definition-p function) (cond ((not info) (list :error (format nil "No source info available for ~A" function))) ((typep (caar info) 'ccl::method) `(:location (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) ))) (:method ,(princ-to-string (ccl::method-name (caar info))) - ,(mapcar 'princ-to-string - (mapcar #'specializer-name - (ccl::method-specializers (caar info)))) - ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) + ,(mapcar 'princ-to-string + (mapcar #'specializer-name + (ccl::method-specializers (caar info)))) + ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info)))) nil)) - (t (canonicalize-location (cdr (first info)) name))))) + (t (canonicalize-location (second (first info)) name (third (first info))))))) (defimplementation frame-source-location-for-emacs (index) "Return to Emacs the location of the source code for the @@ -693,6 +703,7 @@ ,form))) ))))))) +#+ppc (defimplementation return-from-frame (index form) (let ((values (multiple-value-list (eval-in-frame form index)))) (map-backtrace @@ -700,7 +711,8 @@ (declare (ignore context lfun pc)) (when (= frame-number index) (ccl::apply-in-frame p #'values values)))))) - + +#+ppc (defimplementation restart-frame (index) (map-backtrace (lambda (frame-number p context lfun pc) @@ -784,11 +796,6 @@ ;;;; Inspection -(defclass openmcl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'openmcl-inspector)) - (defimplementation describe-primitive-type (thing) (let ((typecode (ccl::typecode thing))) (if (gethash typecode *value2tag*) @@ -833,7 +840,7 @@ (:method ((object t)) nil) (:method ((object uvector-inspector)) t)) -(defmethod inspect-for-emacs ((uv uvector-inspector) ) +(defmethod inspect-for-emacs ((uv uvector-inspector)) (with-slots (object) uv (values (format nil "The UVECTOR for ~S." object) @@ -854,7 +861,6 @@ (list label (if cellp (ccl::closed-over-value value) value)))))) (defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure)) - (declare (ignore inspector)) (values (format nil "A closure: ~a" c) `(,@(if (arglist c) --- /project/slime/cvsroot/slime/slime.el 2008/02/04 16:36:28 1.898 +++ /project/slime/cvsroot/slime/slime.el 2008/02/04 20:35:11 1.899 @@ -71,11 +71,16 @@ CONTRIBS is a list of contrib packages to load." (when (member 'lisp-mode slime-lisp-modes) (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) - (dolist (c contribs) - (require c) - (let ((init (intern (format "%s-init" c)))) - (when (fboundp init) - (funcall init))))) + (when contribs + (pushnew (file-name-as-directory + (expand-file-name (concat slime-path "contribs"))) + load-path + :test 'string=) + (dolist (c contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init)))))) (defun slime-lisp-mode-hook () (slime-mode 1) --- /project/slime/cvsroot/slime/slime-autoloads.el 2007/09/20 14:59:08 1.3 +++ /project/slime/cvsroot/slime/slime-autoloads.el 2008/02/04 20:35:11 1.4 @@ -39,11 +39,16 @@ (defvar slime-setup-contribs nil) (defun slime-setup-contribs () - (dolist (c slime-setup-contribs) - (require c) - (let ((init (intern (format "%s-init" c)))) - (when (fboundp init) - (funcall init))))) + (when slime-setup-contribs + (pushnew (file-name-as-directory + (expand-file-name (concat slime-path "contribs"))) + load-path + :test 'string=) + (dolist (c slime-setup-contribs) + (require c) + (let ((init (intern (format "%s-init" c)))) + (when (fboundp init) + (funcall init)))))) (provide 'slime-autoloads) --- /project/slime/cvsroot/slime/ChangeLog 2008/02/04 17:35:04 1.1280 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/04 20:35:11 1.1281 @@ -1,5 +1,15 @@ 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, From mbaringer at common-lisp.net Tue Feb 5 12:06:24 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Tue, 5 Feb 2008 07:06:24 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080205120624.63865610E5@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6202 Modified Files: slime.el ChangeLog Log Message: --- /project/slime/cvsroot/slime/slime.el 2008/02/04 20:35:11 1.899 +++ /project/slime/cvsroot/slime/slime.el 2008/02/05 12:06:21 1.900 @@ -2267,7 +2267,9 @@ (save-excursion (when (or (re-search-backward regexp nil t) (re-search-forward regexp nil t)) - (match-string-no-properties 2))))) + ;; package name can be a string designator, convert it to a string. + (slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0)))) + "COMMON-LISP-USER"))))) ;;; Synchronous requests are implemented in terms of asynchronous ;;; ones. We make an asynchronous request with a continuation function @@ -3317,8 +3319,12 @@ (defun slime-repl-set-package (package) "Set the package of the REPL buffer to PACKAGE." - (interactive (list (slime-read-package-name - "Package: " (slime-pretty-find-buffer-package)))) + (interactive (list (slime-read-package-name "Package: " + (if (string= (slime-current-package) + (with-current-buffer (slime-repl-buffer) + (slime-current-package))) + nil + (slime-pretty-find-buffer-package))))) (with-current-buffer (slime-output-buffer) (let ((unfinished-input (slime-repl-current-input))) (destructuring-bind (name prompt-string) --- /project/slime/cvsroot/slime/ChangeLog 2008/02/04 20:35:11 1.1281 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/05 12:06:22 1.1282 @@ -1,3 +1,11 @@ +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 From mbaringer at common-lisp.net Tue Feb 5 12:43:54 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Tue, 5 Feb 2008 07:43:54 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080205124354.0C76C4D0C8@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv14345 Modified Files: slime.el Log Message: Fix previous patch, don't call slime-eval since it seems to break --- /project/slime/cvsroot/slime/slime.el 2008/02/05 12:06:21 1.900 +++ /project/slime/cvsroot/slime/slime.el 2008/02/05 12:43:51 1.901 @@ -2268,8 +2268,10 @@ (when (or (re-search-backward regexp nil t) (re-search-forward regexp nil t)) ;; package name can be a string designator, convert it to a string. - (slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0)))) - "COMMON-LISP-USER"))))) + ;;(slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0)))) + ;; "COMMON-LISP-USER") + (match-string-no-properties 2) + )))) ;;; Synchronous requests are implemented in terms of asynchronous ;;; ones. We make an asynchronous request with a continuation function From heller at common-lisp.net Sat Feb 9 18:32:09 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:32:09 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080209183209.E5633340DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17366 Modified Files: ChangeLog slime.el Log Message: Cleanup slime-repl-set-package. * slime.el (slime-repl-set-package): Make it fit within 80 columns. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/05 12:06:22 1.1282 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:31:58 1.1283 @@ -1,3 +1,9 @@ +2008-02-07 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 --- /project/slime/cvsroot/slime/slime.el 2008/02/05 12:43:51 1.901 +++ /project/slime/cvsroot/slime/slime.el 2008/02/09 18:31:58 1.902 @@ -2267,11 +2267,7 @@ (save-excursion (when (or (re-search-backward regexp nil t) (re-search-forward regexp nil t)) - ;; package name can be a string designator, convert it to a string. - ;;(slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0)))) - ;; "COMMON-LISP-USER") - (match-string-no-properties 2) - )))) + (match-string-no-properties 2))))) ;;; Synchronous requests are implemented in terms of asynchronous ;;; ones. We make an asynchronous request with a continuation function @@ -3321,12 +3317,11 @@ (defun slime-repl-set-package (package) "Set the package of the REPL buffer to PACKAGE." - (interactive (list (slime-read-package-name "Package: " - (if (string= (slime-current-package) - (with-current-buffer (slime-repl-buffer) - (slime-current-package))) - nil - (slime-pretty-find-buffer-package))))) + (interactive (list (slime-read-package-name + "Package: " + (if (equal (slime-current-package) (slime-lisp-package)) + nil + (slime-pretty-find-buffer-package))))) (with-current-buffer (slime-output-buffer) (let ((unfinished-input (slime-repl-current-input))) (destructuring-bind (name prompt-string) @@ -9630,7 +9625,7 @@ ;; Local Variables: ;; outline-regexp: ";;;;+" ;; indent-tabs-mode: nil -;; coding: latin-1-unix! +;; coding: latin-1-unix ;; unibyte: t ;; compile-command: "emacs -batch -L . -eval '(byte-compile-file \"slime.el\")' ; rm -v slime.elc" ;; End: From heller at common-lisp.net Sat Feb 9 18:39:04 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:39:04 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080209183904.58F6F14162@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv18556 Modified Files: ChangeLog 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 Log Message: Inspector cleanups. * swank.lisp (emacs-inspect): Renamed from inspect-for-emacs. Changed all method-defs acordingly. (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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:31:58 1.1283 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:38:58 1.1284 @@ -1,4 +1,24 @@ -2008-02-07 Helmut Eller +2008-02-09 Helmut Eller + + Inspector cleanups. + + * swank.lisp (emacs-inspect): Renamed from inspect-for-emacs. + Changed all method-defs acordingly. + (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. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/04 17:35:04 1.45 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/09 18:38:58 1.46 @@ -421,7 +421,7 @@ ;;;; Inspecting -(defmethod inspect-for-emacs ((slot mop::slot-definition)) +(defmethod emacs-inspect ((slot mop::slot-definition)) (values "A slot." `("Name: " (:value ,(mop::%slot-definition-name slot)) (:newline) @@ -436,7 +436,7 @@ " Function: " (:value ,(mop::%slot-definition-initfunction slot)) (:newline)))) -(defmethod inspect-for-emacs ((f function)) +(defmethod emacs-inspect ((f function)) (values "A function." `(,@(when (function-name f) `("Name: " @@ -453,7 +453,7 @@ #| -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (let* ((class (class-of o)) (slots (mop::class-slots class))) (values (format nil "~A~% is a ~A" o class) --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/04 17:35:04 1.99 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/09 18:38:58 1.100 @@ -564,7 +564,7 @@ ;;;; Inspecting -(defmethod inspect-for-emacs ((f function)) +(defmethod emacs-inspect ((f function)) (values "A function." (append (label-value-line "Name" (function-name f)) @@ -573,13 +573,13 @@ (when doc `("Documentation:" (:newline) ,doc)))))) -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (values "A value." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o function)) +(defmethod emacs-inspect ((o function)) (values "A function." (allegro-inspect o))) -(defmethod inspect-for-emacs ((o standard-object)) +(defmethod emacs-inspect ((o standard-object)) (values (format nil "~A is a standard-object." o) (allegro-inspect o))) (defun allegro-inspect (o) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/04 17:35:04 1.127 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/09 18:38:58 1.128 @@ -33,11 +33,7 @@ #:declaration-arglist #:type-specifier-arglist ;; inspector related symbols - #:inspector - #:backend-inspector - #:inspect-for-emacs - #:raw-inspection - #:fancy-inspection + #:emacs-inspect #:label-value-line #:label-value-line* #:with-struct @@ -840,7 +836,7 @@ ;;;; Inspector -(defgeneric inspect-for-emacs (object) +(defgeneric emacs-inspect (object) (:documentation "Explain to Emacs how to inspect OBJECT. @@ -864,7 +860,7 @@ NIL - do nothing.")) -(defmethod inspect-for-emacs ((object t)) +(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 --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/04 17:35:04 1.65 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/09 18:38:58 1.66 @@ -627,7 +627,7 @@ ;;;; Inspecting -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (let* ((*print-array* nil) (*print-pretty* t) (*print-circle* t) (*print-escape* t) (*print-lines* custom:*inspect-print-lines*) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/04 17:35:03 1.176 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/09 18:38:58 1.177 @@ -1869,7 +1869,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1887,7 +1887,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function)) +(defmethod emacs-inspect ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (values (format nil "~A is a function." o) @@ -1914,7 +1914,7 @@ (t (call-next-method))))) -(defmethod inspect-for-emacs ((o kernel:funcallable-instance)) +(defmethod emacs-inspect ((o kernel:funcallable-instance)) (values (format nil "~A is a funcallable-instance." o) (append (label-value-line* @@ -1923,7 +1923,7 @@ (:layout (kernel:%funcallable-instance-layout o))) (nth-value 1 (cmucl-inspect o))))) -(defmethod inspect-for-emacs ((o kernel:code-component)) +(defmethod emacs-inspect ((o kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1950,7 +1950,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn)) +(defmethod emacs-inspect ((o kernel:fdefn)) (values (format nil "~A is a fdenf object." o) (label-value-line* ("name" (kernel:fdefn-name o)) @@ -1959,7 +1959,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array)) +(defmethod emacs-inspect ((o array)) (if (typep o 'simple-array) (call-next-method) (values (format nil "~A is an array." o) @@ -1974,7 +1974,7 @@ (:displaced-p (kernel:%array-displaced-p o)) (:dimensions (array-dimensions o)))))) -(defmethod inspect-for-emacs ((o simple-vector)) +(defmethod emacs-inspect ((o simple-vector)) (values (format nil "~A is a simple-vector." o) (append (label-value-line* --- /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/04 17:39:52 1.13 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/09 18:38:58 1.14 @@ -393,7 +393,7 @@ collect (funcall callback e) collect ", "))) -(defmethod inspect-for-emacs ((class standard-class)) +(defmethod emacs-inspect ((class standard-class)) (values "A class." `("Name: " (:value ,(class-name class)) (:newline) @@ -430,7 +430,7 @@ '("#")) (:newline)))) -(defmethod inspect-for-emacs ((slot cons)) +(defmethod emacs-inspect ((slot cons)) ;; Inspects slot definitions (if (eq (car slot) :name) (values "A slot." @@ -448,7 +448,7 @@ (:newline))) (call-next-method))) -(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)) +(defmethod emacs-inspect ((pathname pathnames::pathname-internal)) (values (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") @@ -464,7 +464,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (cond ((cl::structurep o) (inspect-structure o)) (t (call-next-method)))) --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/02/04 17:35:03 1.12 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/02/09 18:38:58 1.13 @@ -248,7 +248,7 @@ ;;;; Inspector -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) ; ecl clos support leaves some to be desired (cond ((streamp o) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/04 17:35:03 1.94 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/09 18:39:02 1.95 @@ -629,15 +629,15 @@ (defimplementation make-default-inspector () (make-instance 'lispworks-inspector)) -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (lispworks-inspect o)) -(defmethod inspect-for-emacs ((o function)) +(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 inspect-for-emacs ((o standard-object)) +(defmethod emacs-inspect ((o standard-object)) (lispworks-inspect o)) (defun lispworks-inspect (o) --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/04 20:35:11 1.122 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/09 18:39:02 1.123 @@ -802,7 +802,7 @@ (string (gethash typecode *value2tag*)) (string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm)))))) -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (let* ((i (inspector::make-inspector o)) (count (inspector::compute-line-count i)) (lines @@ -820,7 +820,7 @@ (pprint o s))) lines))) -(defmethod inspect-for-emacs :around ((o t)) +(defmethod emacs-inspect :around ((o t)) (if (or (uvector-inspector-p o) (not (ccl:uvectorp o))) (call-next-method) @@ -840,7 +840,7 @@ (:method ((object t)) nil) (:method ((object uvector-inspector)) t)) -(defmethod inspect-for-emacs ((uv uvector-inspector)) +(defmethod emacs-inspect ((uv uvector-inspector)) (with-slots (object) uv (values (format nil "The UVECTOR for ~S." object) @@ -860,7 +860,7 @@ (cellp (ccl::closed-over-value-p value))) (list label (if cellp (ccl::closed-over-value value) value)))))) -(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure)) +(defmethod emacs-inspect ((c ccl::compiled-lexical-closure)) (values (format nil "A closure: ~a" c) `(,@(if (arglist c) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/04 17:41:22 1.189 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/09 18:39:02 1.190 @@ -1001,7 +1001,7 @@ ;;;; Inspector -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (cond ((sb-di::indirect-value-cell-p o) (values "A value cell." (label-value-line* (:value (sb-kernel:value-cell-ref o))))) @@ -1013,7 +1013,7 @@ (values text (loop for value in parts for i from 0 append (label-value-line i value)))))))) -(defmethod inspect-for-emacs ((o function)) +(defmethod emacs-inspect ((o function)) (let ((header (sb-kernel:widetag-of o))) (cond ((= header sb-vm:simple-fun-header-widetag) (values "A simple-fun." @@ -1034,7 +1034,7 @@ i (sb-kernel:%closure-index-ref o i)))))) (t (call-next-method o))))) -(defmethod inspect-for-emacs ((o sb-kernel:code-component)) +(defmethod emacs-inspect ((o sb-kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1062,18 +1062,18 @@ (ash (sb-kernel:%code-code-size o) sb-vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o sb-ext:weak-pointer)) +(defmethod emacs-inspect ((o sb-ext:weak-pointer)) (values "A weak pointer." (label-value-line* (:value (sb-ext:weak-pointer-value o))))) -(defmethod inspect-for-emacs ((o sb-kernel:fdefn)) +(defmethod emacs-inspect ((o sb-kernel:fdefn)) (values "A fdefn object." (label-value-line* (:name (sb-kernel:fdefn-name o)) (:function (sb-kernel:fdefn-fun o))))) -(defmethod inspect-for-emacs :around ((o generic-function)) +(defmethod emacs-inspect :around ((o generic-function)) (multiple-value-bind (title contents) (call-next-method) (values title (append --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/04 17:35:03 1.15 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/09 18:39:02 1.16 @@ -1740,7 +1740,7 @@ :key #'symbol-value))) (format t ", type: ~A" type-symbol)))))) -(defmethod inspect-for-emacs ((o t)) +(defmethod emacs-inspect ((o t)) (cond ((di::indirect-value-cell-p o) (values (format nil "~A is a value cell." o) `("Value: " (:value ,(c:value-cell-ref o))))) @@ -1759,7 +1759,7 @@ (loop for value in parts for i from 0 append (label-value-line i value)))))) -(defmethod inspect-for-emacs ((o function)) +(defmethod emacs-inspect ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) (values (format nil "~A is a function." o) @@ -1788,7 +1788,7 @@ (call-next-method))))) -(defmethod inspect-for-emacs ((o kernel:code-component)) +(defmethod emacs-inspect ((o kernel:code-component)) (values (format nil "~A is a code data-block." o) (append (label-value-line* @@ -1815,7 +1815,7 @@ (ash (kernel:%code-code-size o) vm:word-shift) :stream s)))))))) -(defmethod inspect-for-emacs ((o kernel:fdefn)) +(defmethod emacs-inspect ((o kernel:fdefn)) (values (format nil "~A is a fdenf object." o) (label-value-line* ("name" (kernel:fdefn-name o)) @@ -1824,7 +1824,7 @@ (sys:int-sap (kernel:get-lisp-obj-address o)) (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) -(defmethod inspect-for-emacs ((o array)) +(defmethod emacs-inspect ((o array)) (cond ((kernel:array-header-p o) (values (format nil "~A is an array." o) (label-value-line* @@ -1843,7 +1843,7 @@ (:header (describe-primitive-type o)) (:length (length o))))))) -(defmethod inspect-for-emacs ((o simple-vector)) +(defmethod emacs-inspect ((o simple-vector)) (values (format nil "~A is a vector." o) (append (label-value-line* --- /project/slime/cvsroot/slime/swank.lisp 2008/02/04 20:35:11 1.527 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:39:02 1.528 @@ -13,7 +13,7 @@ ;;; available to us here via the `SWANK-BACKEND' package. (defpackage :swank - (:use :common-lisp :swank-backend) + (:use :cl :swank-backend) (:export #:startup-multiprocessing #:start-server #:create-server @@ -24,8 +24,8 @@ #:print-indentation-lossage #:swank-debugger-hook #:run-after-init-hook - #:inspect-for-emacs - #:inspect-slot-for-emacs + #:emacs-inspect + ;;#:inspect-slot-for-emacs ;; These are user-configurable variables: #:*communication-style* #:*dont-close* @@ -2677,67 +2677,182 @@ ;;;; Inspecting -(defun common-seperated-spec (list &optional (callback (lambda (v) - `(:value ,v)))) - (butlast - (loop - for i in list - collect (funcall callback i) - collect ", "))) - -(defun inspector-princ (list) - "Like princ-to-string, but don't rewrite (function foo) as #'foo. -Do NOT pass circular lists to this function." - (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) - (set-pprint-dispatch '(cons (member function)) nil) - (princ-to-string list))) - -(defmethod inspect-for-emacs ((object cons)) - (if (consp (cdr object)) - (inspect-for-emacs-list object) - (inspect-for-emacs-simple-cons object))) +(defvar *inspectee*) +(defvar *inspectee-parts*) +(defvar *inspectee-actions*) +(defvar *inspector-stack*) +(defvar *inspector-history*) + +(defun reset-inspector () + (setq *inspectee* nil + *inspector-stack* '() + *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0) + *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) + *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) + +(defslimefun init-inspector (string) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (eval (read-from-string string))))) + +(defun inspect-object (object) + (push (setq *inspectee* object) *inspector-stack*) + (unless (find object *inspector-history*) + (vector-push-extend object *inspector-history*)) + (let ((*print-pretty* nil) ; print everything in the same line + (*print-circle* t) + (*print-readably* nil)) + (multiple-value-bind (_ content) (emacs-inspect object) + (declare (ignore _)) + (list :title (with-output-to-string (s) + (print-unreadable-object (object s :type t :identity t))) + :id (assign-index object *inspectee-parts*) + :content (inspector-content content))))) + +(defun inspector-content (specs) + (loop for part in specs collect + (etypecase part + ;;(null ; XXX encourages sloppy programming + ;; nil) + (string part) + (cons (destructure-case part + ((:newline) + '#.(string #\newline)) + ((:value obj &optional str) + (value-part obj str)) + ((:action label lambda &key (refreshp t)) + (action-part label lambda refreshp))))))) + +(defun assign-index (object vector) + (let ((index (fill-pointer vector))) + (vector-push-extend object vector) + index)) + +(defun value-part (object string) + (list :value + (or string (print-part-to-string object)) + (assign-index object *inspectee-parts*))) + +(defun action-part (label lambda refreshp) + (list :action label (assign-index (list lambda refreshp) + *inspectee-actions*))) + +(defun print-part-to-string (value) + (let ((string (to-string value)) + (pos (position value *inspector-history*))) + (if pos + (format nil "#~D=~A" pos string) + string))) + +(defslimefun inspector-nth-part (index) + (aref *inspectee-parts* index)) + +(defslimefun inspect-nth-part (index) + (with-buffer-syntax () + (inspect-object (inspector-nth-part index)))) + +(defslimefun inspector-call-nth-action (index &rest args) + (destructuring-bind (fun refreshp) (aref *inspectee-actions* index) + (apply fun args) + (if refreshp + (inspect-object (pop *inspector-stack*)) + ;; tell emacs that we don't want to refresh the inspector buffer + nil))) + +(defslimefun inspector-pop () + "Drop the inspector stack and inspect the second element. +Return nil if there's no second element." + (with-buffer-syntax () + (cond ((cdr *inspector-stack*) + (pop *inspector-stack*) + (inspect-object (pop *inspector-stack*))) + (t nil)))) + +(defslimefun inspector-next () + "Inspect the next element in the *inspector-history*." + (with-buffer-syntax () + (let ((position (position *inspectee* *inspector-history*))) + (cond ((= (1+ position) (length *inspector-history*)) + nil) + (t (inspect-object (aref *inspector-history* (1+ position)))))))) -(defun inspect-for-emacs-simple-cons (cons) +(defslimefun inspector-reinspect () + (inspect-object *inspectee*)) + +(defslimefun quit-inspector () + (reset-inspector) + nil) + +(defslimefun describe-inspectee () + "Describe the currently inspected object." + (with-buffer-syntax () + (describe-to-string *inspectee*))) + +(defslimefun pprint-inspector-part (index) + "Pretty-print the currently inspected object." + (with-buffer-syntax () + (swank-pprint (list (inspector-nth-part index))))) + +(defslimefun inspect-in-frame (string index) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index)))) + +(defslimefun inspect-current-condition () + (with-buffer-syntax () + (reset-inspector) + (inspect-object *swank-debugger-condition*))) + +(defslimefun inspect-frame-var (frame var) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (frame-var-value frame var)))) + +;;;;; Lists + +(defmethod emacs-inspect ((o cons)) + (if (consp (cdr o)) + (inspect-list o) + (inspect-cons o))) + +(defun inspect-cons (cons) (values "A cons cell." (label-value-line* ('car (car cons)) ('cdr (cdr cons))))) -(defun inspect-for-emacs-list (list) - (let ((maxlen 40)) - (multiple-value-bind (length tail) (safe-length list) - (flet ((frob (title list) - (let (lines) - (loop for i from 0 for rest on list do - (if (consp (cdr rest)) ; e.g. (A . (B . ...)) - (push (label-value-line i (car rest)) lines) - (progn ; e.g. (A . NIL) or (A . B) - (push (label-value-line i (car rest) :newline nil) lines) - (when (cdr rest) - (push '((:newline)) lines) - (push (label-value-line ':tail () :newline nil) lines)) - (loop-finish))) - finally - (setf lines (reduce #'append (nreverse lines) :from-end t))) - (values title (append '("Elements:" (:newline)) lines))))) - - (cond ((not length) ; circular - (frob "A circular list." - (cons (car list) - (ldiff (cdr list) list)))) - ((and (<= length maxlen) (not tail)) - (frob "A proper list." list)) - (tail - (frob "An improper list." list)) - (t - (frob "A proper list." list))))))) +;; (inspect-list '#1=(a #1# . #1# )) +;; (inspect-list (list* 'a 'b 'c)) +;; (inspect-list (make-list 10000)) + +(defun inspect-list (list) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list) + (values nil (append `(,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)))))) -;; (inspect-for-emacs-list '#1=(a #1# . #1# )) +(defun inspect-list-aux (list) + (loop for i from 0 for rest on list while (consp rest) append + (cond ((consp (cdr rest)) + (label-value-line i (car rest))) + ((cdr rest) + (label-value-line* (i (car rest)) + (:tail (cdr rest)))) + (t + (label-value-line i (car 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. -NIL is returned if the list is circular." +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. @@ -2752,7 +2867,9 @@ a hash table or array to show by default. If table has more than this then offer actions to view more. Set to nil for no limit." ) -(defmethod inspect-for-emacs ((ht hash-table)) +;;;;; Hashtables + +(defmethod emacs-inspect ((ht hash-table)) (values (prin1-to-string ht) (append (label-value-line* @@ -2804,12 +2921,14 @@ (progn (format t "How many elements should be shown? ") (read)))) (swank::inspect-object thing))))) -(defmethod inspect-for-emacs ((array array)) +;;;;; Arrays + +(defmethod emacs-inspect ((array array)) (values "An array." (append (label-value-line* ("Dimensions" (array-dimensions array)) - ("Its element type is" (array-element-type array)) + ("Element type" (array-element-type array)) ("Total size" (array-total-size array)) ("Adjustable" (adjustable-array-p array))) (when (array-has-fill-pointer-p array) @@ -2822,7 +2941,9 @@ (loop for i below (or *slime-inspect-contents-limit* (array-total-size array)) append (label-value-line i (row-major-aref array i)))))) -(defmethod inspect-for-emacs ((char character)) +;;;;; Chars + +(defmethod emacs-inspect ((char character)) (values "A character." (append (label-value-line* @@ -2833,141 +2954,6 @@ `("In the current readtable (" (:value ,*readtable*) ") it is a macro character: " (:value ,(get-macro-character char))))))) - -(defvar *inspectee*) -(defvar *inspectee-parts*) -(defvar *inspectee-actions*) -(defvar *inspector-stack* '()) -(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)) -(declaim (type vector *inspector-history*)) -(defvar *inspect-length* 30) - -(defun reset-inspector () - (setq *inspectee* nil - *inspector-stack* nil - *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0) - *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) - *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) - -(defslimefun init-inspector (string) - (with-buffer-syntax () - (reset-inspector) - (inspect-object (eval (read-from-string string))))) - -(defun print-part-to-string (value) - (let ((string (to-string value)) - (pos (position value *inspector-history*))) - (if pos - (format nil "#~D=~A" pos string) - string))) - -(defun inspector-content-for-emacs (specs) - (loop for part in specs collect - (etypecase part - (null ; XXX encourages sloppy programming - nil) - (string part) - (cons (destructure-case part - ((:newline) - (string #\newline)) - ((:value obj &optional str) - (value-part-for-emacs obj str)) - ((:action label lambda &key (refreshp t)) - (action-part-for-emacs label lambda refreshp))))))) - -(defun assign-index (object vector) - (let ((index (fill-pointer vector))) - (vector-push-extend object vector) - index)) - -(defun value-part-for-emacs (object string) - (list :value - (or string (print-part-to-string object)) - (assign-index object *inspectee-parts*))) - -(defun action-part-for-emacs (label lambda refreshp) - (list :action label (assign-index (list lambda refreshp) - *inspectee-actions*))) - -(defun inspect-object (object) - (push (setq *inspectee* object) *inspector-stack*) - (unless (find object *inspector-history*) - (vector-push-extend object *inspector-history*)) - (let ((*print-pretty* nil) ; print everything in the same line - (*print-circle* t) - (*print-readably* nil)) - (multiple-value-bind (_ content) (inspect-for-emacs object) - (declare (ignore _)) - (list :title (with-output-to-string (s) - (print-unreadable-object (object s :type t :identity t))) - :id (assign-index object *inspectee-parts*) - :content (inspector-content-for-emacs content))))) - -(defslimefun inspector-nth-part (index) - (aref *inspectee-parts* index)) - -(defslimefun inspect-nth-part (index) - (with-buffer-syntax () - (inspect-object (inspector-nth-part index)))) - -(defslimefun inspector-call-nth-action (index &rest args) - (destructuring-bind (action-lambda refreshp) - (aref *inspectee-actions* index) - (apply action-lambda args) - (if refreshp - (inspect-object (pop *inspector-stack*)) - ;; tell emacs that we don't want to refresh the inspector buffer - nil))) - -(defslimefun inspector-pop () - "Drop the inspector stack and inspect the second element. Return -nil if there's no second element." - (with-buffer-syntax () - (cond ((cdr *inspector-stack*) - (pop *inspector-stack*) - (inspect-object (pop *inspector-stack*))) - (t nil)))) - -(defslimefun inspector-next () - "Inspect the next element in the *inspector-history*." - (with-buffer-syntax () - (let ((position (position *inspectee* *inspector-history*))) - (cond ((= (1+ position) (length *inspector-history*)) - nil) - (t (inspect-object (aref *inspector-history* (1+ position)))))))) [36 lines skipped] From heller at common-lisp.net Sat Feb 9 18:39:04 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:39:04 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080209183904.BEBFF340A8@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18556/contrib Modified Files: swank-fancy-inspector.lisp Log Message: Inspector cleanups. * swank.lisp (emacs-inspect): Renamed from inspect-for-emacs. Changed all method-defs acordingly. (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. --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/04 17:59:49 1.7 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/09 18:39:04 1.8 @@ -6,7 +6,7 @@ (in-package :swank) -(defmethod inspect-for-emacs ((symbol symbol)) +(defmethod emacs-inspect ((symbol symbol)) (let ((package (symbol-package symbol))) (multiple-value-bind (_symbol status) (and package (find-symbol (string symbol) package)) @@ -89,7 +89,7 @@ (t (list label ": " '(:newline) " " docstring '(:newline)))))) -(defmethod inspect-for-emacs ((f function)) +(defmethod emacs-inspect ((f function)) (values "A function." (append (label-value-line "Name" (function-name f)) @@ -122,7 +122,7 @@ (swank-mop:method-qualifiers method) (method-specializers-for-inspect method))) -(defmethod inspect-for-emacs ((object standard-object)) +(defmethod emacs-inspect ((object standard-object)) (let ((class (class-of object))) (values "An object." `("Class: " (:value ,class) (:newline) @@ -224,7 +224,7 @@ append slot-presentation collect '(:newline)))))) -(defmethod inspect-for-emacs ((gf standard-generic-function)) +(defmethod emacs-inspect ((gf standard-generic-function)) (flet ((lv (label value) (label-value-line label value))) (values "A generic function." @@ -249,7 +249,7 @@ `((:newline)) (all-slots-for-inspector gf))))) -(defmethod inspect-for-emacs ((method standard-method)) +(defmethod emacs-inspect ((method standard-method)) (values "A method." `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) @@ -269,7 +269,7 @@ (:newline) ,@(all-slots-for-inspector method)))) -(defmethod inspect-for-emacs ((class standard-class)) +(defmethod emacs-inspect ((class standard-class)) (values "A class." `("Name: " (:value ,(class-name class)) (:newline) @@ -328,7 +328,7 @@ (:newline) ,@(all-slots-for-inspector class)))) -(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition)) +(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition)) (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) @@ -434,7 +434,7 @@ (:newline) ))))) -(defmethod inspect-for-emacs ((%container %package-symbols-container)) +(defmethod emacs-inspect ((%container %package-symbols-container)) (with-struct (%container. title description symbols grouping-kind) %container (values title `(, at description @@ -451,7 +451,7 @@ (:newline) (:newline) ,@(make-symbols-listing grouping-kind symbols))))) -(defmethod inspect-for-emacs ((package package)) +(defmethod emacs-inspect ((package package)) (let ((package-name (package-name package)) (package-nicknames (package-nicknames package)) (package-use-list (package-use-list package)) @@ -545,7 +545,7 @@ :description nil))))))) -(defmethod inspect-for-emacs ((pathname pathname)) +(defmethod emacs-inspect ((pathname pathname)) (values (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") @@ -561,7 +561,7 @@ (not (probe-file pathname))) (label-value-line "Truename" (truename pathname)))))) -(defmethod inspect-for-emacs ((pathname logical-pathname)) +(defmethod emacs-inspect ((pathname logical-pathname)) (values "A logical pathname." (append (label-value-line* @@ -581,7 +581,7 @@ ("Truename" (if (not (wild-pathname-p pathname)) (probe-file pathname))))))) -(defmethod inspect-for-emacs ((n number)) +(defmethod emacs-inspect ((n number)) (values "A number." `("Value: " ,(princ-to-string n)))) (defun format-iso8601-time (time-value &optional include-timezone-p) @@ -604,7 +604,7 @@ year month day hour minute second include-timezone-p (format-iso8601-timezone zone))))) -(defmethod inspect-for-emacs ((i integer)) +(defmethod emacs-inspect ((i integer)) (values "A number." (append `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" @@ -616,20 +616,20 @@ (ignore-errors (label-value-line "Universal-time" (format-iso8601-time i t)))))) -(defmethod inspect-for-emacs ((c complex)) +(defmethod emacs-inspect ((c complex)) (values "A complex number." (label-value-line* ("Real part" (realpart c)) ("Imaginary part" (imagpart c))))) -(defmethod inspect-for-emacs ((r ratio)) +(defmethod emacs-inspect ((r ratio)) (values "A non-integer ratio." (label-value-line* ("Numerator" (numerator r)) ("Denominator" (denominator r)) ("As float" (float r))))) -(defmethod inspect-for-emacs ((f float)) +(defmethod emacs-inspect ((f float)) (values "A floating point number." (cond ((> f most-positive-long-float) @@ -649,7 +649,7 @@ (label-value-line "Digits" (float-digits f)) (label-value-line "Precision" (float-precision f)))))))) -(defmethod inspect-for-emacs ((stream file-stream)) +(defmethod emacs-inspect ((stream file-stream)) (multiple-value-bind (title content) (call-next-method) (declare (ignore title)) @@ -667,7 +667,7 @@ (:newline)) content)))) -(defmethod inspect-for-emacs ((condition stream-error)) +(defmethod emacs-inspect ((condition stream-error)) (multiple-value-bind (title content) (call-next-method) (let ((stream (stream-error-stream condition))) @@ -687,6 +687,21 @@ content)) (values title 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))) + (defvar *fancy-inpector-undo-list* nil) (defslimefun fancy-inspector-init () From heller at common-lisp.net Sat Feb 9 18:42:40 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:42:40 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080209184240.73A1168322@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv20847 Modified Files: ChangeLog slime.el Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:38:58 1.1284 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:42:34 1.1285 @@ -1,5 +1,15 @@ 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. --- /project/slime/cvsroot/slime/slime.el 2008/02/09 18:31:58 1.902 +++ /project/slime/cvsroot/slime/slime.el 2008/02/09 18:42:35 1.903 @@ -3172,14 +3172,14 @@ (let ((end (point))) ; end of input, without the newline (slime-repl-add-to-input-history (buffer-substring slime-repl-input-start-mark end)) - (when newline - (insert "\n") - (slime-repl-show-maximum-output)) (let ((inhibit-read-only t)) (add-text-properties slime-repl-input-start-mark (point) `(slime-repl-old-input ,(incf slime-repl-old-input-counter)))) + (when newline + (insert "\n") + (slime-repl-show-maximum-output)) (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. @@ -3212,25 +3212,9 @@ (defun slime-property-bounds (prop) "Return two the positions of the previous and next changes to PROP. PROP is the name of a text property." - (let* ((beg (save-excursion - ;; previous-single-char-property-change searches for a - ;; property change from the previous character, but we - ;; want to look for a change from the point. We step - ;; forward one char to avoid doing the wrong thing if - ;; we're at the beginning of the old input. -luke - ;; (18/Jun/2004) - (unless (not (get-text-property (point) prop)) - ;; alanr unless we are sitting right after it May 19, 2005 - (ignore-errors (forward-char))) - (previous-single-char-property-change (point) prop))) - (end (save-excursion - (if (get-text-property (point) prop) - (progn (goto-char (next-single-char-property-change - (point) prop)) - (skip-chars-backward "\n \t\r" beg) - (point)) - (point))))) - (values beg end))) + (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-repl-closing-return () "Evaluate the current input string after closing all open lists." @@ -6816,11 +6800,7 @@ (get-text-property (point) 'details-visible-p))) (defun sldb-frame-region () - (save-excursion - (goto-char (next-single-property-change (point) 'frame nil (point-max))) - (backward-char) - (values (previous-single-property-change (point) 'frame) - (next-single-property-change (point) 'frame nil (point-max))))) + (slime-property-bounds 'frame)) (defun sldb-forward-frame () (goto-char (next-single-char-property-change (point) 'frame))) From heller at common-lisp.net Sat Feb 9 18:44:13 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:44:13 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080209184413.82020610B4@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21376 Modified Files: ChangeLog slime.el swank.lisp Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:42:34 1.1285 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:44:12 1.1286 @@ -1,5 +1,21 @@ 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 --- /project/slime/cvsroot/slime/slime.el 2008/02/09 18:42:35 1.903 +++ /project/slime/cvsroot/slime/slime.el 2008/02/09 18:44:12 1.904 @@ -7515,8 +7515,8 @@ (while (eq (char-before) ?\n) (backward-delete-char 1)) (insert "\n" (fontify label "--------------------") "\n") - (save-excursion - (mapc slime-inspector-insert-ispec-function content)) + (save-excursion + (slime-inspector-insert-content content)) (pop-to-buffer (current-buffer)) (when point (check-type point cons) @@ -7524,6 +7524,22 @@ (goto-line (car point)) (move-to-column (cdr point))))))))) +(defun slime-inspector-insert-content (content) + (destructuring-bind (ispecs len start end) content + (slime-inspector-insert-range ispecs len start end t t))) + +(defun slime-inspector-insert-range (ispecs len start end prev next) + "Insert ISPECS at point. +LEN is the length of the entire content on the Lisp side. +START and END are the positions of the subsequnce that ISPECS represents. +If PREV resp. NEXT are true insert range-buttons as needed." + (let ((limit 2000)) + (when (and prev (> start 0)) + (slime-inspector-insert-range-button (max 0 (- start limit)) start t)) + (mapc #'slime-inspector-insert-ispec ispecs) + (when (and next (< end len)) + (slime-inspector-insert-range-button end (min len (+ end limit)) nil)))) + (defun slime-inspector-insert-ispec (ispec) (if (stringp ispec) (insert ispec) @@ -7555,10 +7571,14 @@ (current-column)))) (defun slime-inspector-operate-on-point () - "If point is on a value then recursivly call the inspector on - that value. If point is on an action then call that action." + "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 ((part-number (get-text-property (point) 'slime-part-number)) + (range-button (get-text-property (point) 'slime-range-button)) (action-number (get-text-property (point) 'slime-action-number)) (opener (lexical-let ((point (slime-inspector-position))) (lambda (parts) @@ -7568,6 +7588,8 @@ (slime-eval-async `(swank:inspect-nth-part ,part-number) opener) (push (slime-inspector-position) slime-inspector-mark-stack)) + (range-button + (slime-inspector-fetch-range range-button)) (action-number (slime-eval-async `(swank::inspector-call-nth-action ,action-number) opener))))) @@ -7668,7 +7690,6 @@ (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. @@ -7692,6 +7713,25 @@ (lambda (parts) (slime-open-inspector parts point))))) +(defun slime-inspector-insert-range-button (start end previous) + (slime-insert-propertized + (list 'slime-range-button (list start end previous) + 'mouse-face 'highlight + 'face 'slime-inspector-action-face) + (if previous " [--more--]\n" " [--more--]"))) + +(defun slime-inspector-fetch-range (button) + (destructuring-bind (start end previous) button + (slime-eval-async + `(swank:inspector-range ,start ,end) + (slime-rcurry + (lambda (content prev) + (let ((inhibit-read-only t)) + (apply #'delete-region (slime-property-bounds 'slime-range-button)) + (destructuring-bind (i l s e) content + (slime-inspector-insert-range i l s e prev (not prev))))) + previous)))) + (slime-define-keys slime-inspector-mode-map ([return] 'slime-inspector-operate-on-point) ((kbd "M-RET") 'slime-inspector-copy-down) --- /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:39:02 1.528 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:44:13 1.529 @@ -2678,6 +2678,7 @@ ;;;; Inspecting (defvar *inspectee*) +(defvar *inspectee-content*) (defvar *inspectee-parts*) (defvar *inspectee-actions*) (defvar *inspector-stack*) @@ -2685,9 +2686,10 @@ (defun reset-inspector () (setq *inspectee* nil - *inspector-stack* '() + *inspectee-content* nil *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0) *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0) + *inspector-stack* '() *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))) (defslimefun init-inspector (string) @@ -2695,19 +2697,19 @@ (reset-inspector) (inspect-object (eval (read-from-string string))))) -(defun inspect-object (object) - (push (setq *inspectee* object) *inspector-stack*) - (unless (find object *inspector-history*) - (vector-push-extend object *inspector-history*)) - (let ((*print-pretty* nil) ; print everything in the same line +(defun inspect-object (o) + (push (setq *inspectee* o) *inspector-stack*) + (unless (find o *inspector-history*) + (vector-push-extend o *inspector-history*)) + (let ((*print-pretty* nil) ; print everything in the same line (*print-circle* t) (*print-readably* nil)) - (multiple-value-bind (_ content) (emacs-inspect object) - (declare (ignore _)) - (list :title (with-output-to-string (s) - (print-unreadable-object (object s :type t :identity t))) - :id (assign-index object *inspectee-parts*) - :content (inspector-content content))))) + (setq *inspectee-content* + (inspector-content (nth-value 1 (emacs-inspect o))))) + (list :title (with-output-to-string (s) + (print-unreadable-object (o s :type t :identity t))) + :id (assign-index o *inspectee-parts*) + :content (content-range *inspectee-content* 0 500))) (defun inspector-content (specs) (loop for part in specs collect @@ -2744,6 +2746,10 @@ (format nil "#~D=~A" pos string) string))) +(defun content-range (list start end) + (let* ((len (length list)) (end (min len end))) + (list (subseq list start end) len start end))) + (defslimefun inspector-nth-part (index) (aref *inspectee-parts* index)) @@ -2751,6 +2757,9 @@ (with-buffer-syntax () (inspect-object (inspector-nth-part index)))) +(defslimefun inspector-range (from to) + (content-range *inspectee-content* from to)) + (defslimefun inspector-call-nth-action (index &rest args) (destructuring-bind (fun refreshp) (aref *inspectee-actions* index) (apply fun args) From heller at common-lisp.net Sat Feb 9 18:45:39 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:45:39 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080209184539.9B7F9691A4@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21660 Modified Files: ChangeLog swank.lisp Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:44:12 1.1286 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:45:39 1.1287 @@ -1,5 +1,13 @@ 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. --- /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:44:13 1.529 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:45:39 1.530 @@ -2872,10 +2872,6 @@ ((and (eq fast slow) (> n 0)) (return nil)) ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) -(defvar *slime-inspect-contents-limit* nil "How many elements of - a hash table or array to show by default. If table has more than - this then offer actions to view more. Set to nil for no limit." ) - ;;;;; Hashtables (defmethod emacs-inspect ((ht hash-table)) @@ -2891,45 +2887,17 @@ (when weakness `("Weakness: " (:value ,weakness) (:newline)))) (unless (zerop (hash-table-count ht)) - `((:action "[clear hashtable]" ,(lambda () (clrhash ht))) (:newline) + `((:action "[clear hashtable]" + ,(lambda () (clrhash ht))) (:newline) "Contents: " (:newline))) - (if (and *slime-inspect-contents-limit* - (>= (hash-table-count ht) *slime-inspect-contents-limit*)) - (inspect-bigger-piece-actions ht (hash-table-count ht)) - nil) (loop for key being the hash-keys of ht for value being the hash-values of ht - repeat (or *slime-inspect-contents-limit* most-positive-fixnum) append `((:value ,key) " = " (:value ,value) " " (:action "[remove entry]" ,(let ((key key)) (lambda () (remhash key ht)))) (:newline)))))) -(defun inspect-bigger-piece-actions (thing size) - (append - (if (> size *slime-inspect-contents-limit*) - (list (inspect-show-more-action thing) - '(:newline)) - nil) - (list (inspect-whole-thing-action thing size) - '(:newline)))) - -(defun inspect-whole-thing-action (thing size) - `(:action ,(format nil "Inspect all ~a elements." - size) - ,(lambda() - (let ((*slime-inspect-contents-limit* nil)) - (swank::inspect-object thing))))) - -(defun inspect-show-more-action (thing) - `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..." - *slime-inspect-contents-limit* ) - ,(lambda() - (let ((*slime-inspect-contents-limit* - (progn (format t "How many elements should be shown? ") (read)))) - (swank::inspect-object thing))))) - ;;;;; Arrays (defmethod emacs-inspect ((array array)) @@ -2943,11 +2911,7 @@ (when (array-has-fill-pointer-p array) (label-value-line "Fill pointer" (fill-pointer array))) '("Contents:" (:newline)) - (if (and *slime-inspect-contents-limit* - (>= (array-total-size array) *slime-inspect-contents-limit*)) - (inspect-bigger-piece-actions array (length array)) - nil) - (loop for i below (or *slime-inspect-contents-limit* (array-total-size array)) + (loop for i below (array-total-size array) append (label-value-line i (row-major-aref array i)))))) ;;;;; Chars From heller at common-lisp.net Sat Feb 9 18:47:09 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:47:09 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080209184709.17F7A610B2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21820 Modified Files: ChangeLog 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 Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:45:39 1.1287 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:47:05 1.1288 @@ -1,5 +1,12 @@ 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 @@ -37,7 +44,7 @@ Inspector cleanups. * swank.lisp (emacs-inspect): Renamed from inspect-for-emacs. - Changed all method-defs acordingly. + Changed all method-defs accordingly. (common-seperated-spec, inspector-princ): Moved to swank-fancy-inspector.lisp. (inspector-content): Renamed from inspector-content-for-emacs. --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/09 18:38:58 1.46 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/09 18:47:05 1.47 @@ -422,7 +422,6 @@ ;;;; Inspecting (defmethod emacs-inspect ((slot mop::slot-definition)) - (values "A slot." `("Name: " (:value ,(mop::%slot-definition-name slot)) (:newline) "Documentation:" (:newline) @@ -434,10 +433,9 @@ `(:value ,(mop::%slot-definition-initform slot)) "#") (:newline) " Function: " (:value ,(mop::%slot-definition-initfunction slot)) - (:newline)))) + (:newline))) (defmethod emacs-inspect ((f function)) - (values "A function." `(,@(when (function-name f) `("Name: " ,(princ-to-string (function-name f)) (:newline))) @@ -449,19 +447,18 @@ `("Documentation:" (:newline) ,(documentation f t) (:newline))) ,@(when (function-lambda-expression f) `("Lambda expression:" - (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))) + (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))) #| (defmethod emacs-inspect ((o t)) (let* ((class (class-of o)) (slots (mop::class-slots class))) - (values (format nil "~A~% is a ~A" o class) (mapcar (lambda (slot) (let ((name (mop::slot-definition-name slot))) (cons (princ-to-string name) (slot-value o name)))) - slots)))) + slots))) |# ;;;; Multithreading --- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/09 18:38:58 1.100 +++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/02/09 18:47:05 1.101 @@ -565,22 +565,21 @@ ;;;; Inspecting (defmethod emacs-inspect ((f function)) - (values "A function." (append (label-value-line "Name" (function-name f)) `("Formals" ,(princ-to-string (arglist f)) (:newline)) (let ((doc (documentation (excl::external-fn_symdef f) 'function))) (when doc - `("Documentation:" (:newline) ,doc)))))) + `("Documentation:" (:newline) ,doc))))) (defmethod emacs-inspect ((o t)) - (values "A value." (allegro-inspect o))) + (allegro-inspect o)) (defmethod emacs-inspect ((o function)) - (values "A function." (allegro-inspect o))) + (allegro-inspect o)) (defmethod emacs-inspect ((o standard-object)) - (values (format nil "~A is a standard-object." o) (allegro-inspect o))) + (allegro-inspect o)) (defun allegro-inspect (o) (loop for (d dd) on (inspect::inspect-ctl o) --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/09 18:38:58 1.128 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/09 18:47:05 1.129 @@ -840,9 +840,7 @@ (:documentation "Explain to Emacs how to inspect OBJECT. -Returns two values: a string which will be used as the title of -the inspector buffer and a list specifying how to render the -object for inspection. +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: @@ -857,20 +855,17 @@ string) which when clicked will call LAMBDA. If REFRESH is non-NIL the currently inspected object will be re-inspected after calling the lambda. - - NIL - do nothing.")) +")) (defmethod 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." - (values - "A value." `("Type: " (:value ,(type-of object)) (:newline) "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" (:newline) (:newline) - ,(with-output-to-string (desc) (describe object desc))))) + ,(with-output-to-string (desc) (describe object desc)))) ;;; Utilities for inspector methods. ;;; --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/09 18:38:58 1.66 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/09 18:47:05 1.67 @@ -638,9 +638,10 @@ (*package* tmp-pack) (sys::*inspect-unbound-value* (intern "#" tmp-pack))) (let ((inspection (sys::inspect-backend o))) - (values (format nil "~S~% ~A~{~%~A~}" o + (append (list + (format nil "~S~% ~A~{~%~A~}~%" o (sys::insp-title inspection) - (sys::insp-blurb inspection)) + (sys::insp-blurb inspection))) (loop with count = (sys::insp-num-slots inspection) for i below count append (multiple-value-bind (value name) --- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/09 18:38:58 1.177 +++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/02/09 18:47:05 1.178 @@ -1822,11 +1822,6 @@ ;;;; Inspecting -(defclass cmucl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'cmucl-inspector)) - (defconstant +lowtag-symbols+ '(vm:even-fixnum-type vm:function-pointer-type @@ -1871,8 +1866,7 @@ (defmethod emacs-inspect ((o t)) (cond ((di::indirect-value-cell-p o) - (values (format nil "~A is a value cell." o) - `("Value: " (:value ,(c:value-cell-ref o))))) + `("Value: " (:value ,(c:value-cell-ref o)))) ((alien::alien-value-p o) (inspect-alien-value o)) (t @@ -1880,63 +1874,59 @@ (defun cmucl-inspect (o) (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) - (values (format nil "~A~%" text) - (if labeledp - (loop for (label . value) in parts - append (label-value-line label value)) - (loop for value in parts for i from 0 - append (label-value-line i value)))))) + (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) - (values (format nil "~A is a function." o) - (append (label-value-line* - ("Self" (kernel:%function-self o)) - ("Next" (kernel:%function-next o)) - ("Name" (kernel:%function-name o)) - ("Arglist" (kernel:%function-arglist o)) - ("Type" (kernel:%function-type o)) - ("Code" (kernel:function-code-header o))) - (list - (with-output-to-string (s) - (disassem:disassemble-function o :stream s)))))) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s))))) ((= header vm:closure-header-type) - (values (format nil "~A is a closure" o) - (append - (label-value-line "Function" (kernel:%closure-function o)) - `("Environment:" (:newline)) - (loop for i from 0 below (1- (kernel:get-closure-length o)) - append (label-value-line - i (kernel:%closure-index-ref o i)))))) + (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)) - (values - (format nil "~A is a funcallable-instance." o) - (append (label-value-line* - (:function (kernel:%funcallable-instance-function o)) - (:lexenv (kernel:%funcallable-instance-lexenv o)) - (:layout (kernel:%funcallable-instance-layout o))) - (nth-value 1 (cmucl-inspect o))))) + (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)) - (values (format nil "~A is a code data-block." o) - (append - (label-value-line* - ("code-size" (kernel:%code-code-size o)) - ("entry-points" (kernel:%code-entry-points o)) - ("debug-info" (kernel:%code-debug-info o)) - ("trace-table-offset" (kernel:code-header-ref - o vm:code-trace-table-offset-slot))) - `("Constants:" (:newline)) - (loop for i from vm:code-constants-offset - below (kernel:get-header-data o) - append (label-value-line i (kernel:code-header-ref o i))) - `("Code:" (:newline) + (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)) @@ -1948,63 +1938,57 @@ (* vm:code-constants-offset vm:word-bytes)) (ash 1 vm:lowtag-bits)) (ash (kernel:%code-code-size o) vm:word-shift) - :stream s)))))))) + :stream s))))))) (defmethod emacs-inspect ((o kernel:fdefn)) - (values (format nil "~A is a fdenf object." o) - (label-value-line* - ("name" (kernel:fdefn-name o)) - ("function" (kernel:fdefn-function o)) - ("raw-addr" (sys:sap-ref-32 - (sys:int-sap (kernel:get-lisp-obj-address o)) - (* vm:fdefn-raw-addr-slot vm:word-bytes)))))) + (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) - (values (format nil "~A is an array." o) - (label-value-line* - (:header (describe-primitive-type o)) - (:rank (array-rank o)) - (:fill-pointer (kernel:%array-fill-pointer o)) - (:fill-pointer-p (kernel:%array-fill-pointer-p o)) - (:elements (kernel:%array-available-elements o)) - (:data (kernel:%array-data-vector o)) - (:displacement (kernel:%array-displacement o)) - (:displaced-p (kernel:%array-displaced-p o)) - (:dimensions (array-dimensions o)))))) + (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)) - (values (format nil "~A is a simple-vector." o) - (append - (label-value-line* - (:header (describe-primitive-type o)) - (:length (c::vector-length o))) - (loop for i below (length o) - append (label-value-line i (aref o i)))))) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i))))) (defun inspect-alien-record (alien) - (values - (format nil "~A is an alien value." alien) - (with-struct (alien::alien-value- sap type) alien - (with-struct (alien::alien-record-type- kind name fields) type - (append - (label-value-line* - (:sap sap) - (:kind kind) - (:name name)) - (loop for field in fields - append (let ((slot (alien::alien-record-field-name field))) - (label-value-line slot (alien:slot alien slot))))))))) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot)))))))) (defun inspect-alien-pointer (alien) - (values - (format nil "~A is an alien value." alien) - (with-struct (alien::alien-value- sap type) alien - (label-value-line* - (:sap sap) - (:type type) - (:to (alien::deref alien)))))) + (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) --- /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/09 18:38:58 1.14 +++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/02/09 18:47:05 1.15 @@ -394,7 +394,6 @@ collect ", "))) (defmethod emacs-inspect ((class standard-class)) - (values "A class." `("Name: " (:value ,(class-name class)) (:newline) "Super classes: " @@ -428,12 +427,11 @@ (lambda (class) `(:value ,class ,(princ-to-string (class-name class))))) '("#")) - (:newline)))) + (:newline))) (defmethod emacs-inspect ((slot cons)) ;; Inspects slot definitions (if (eq (car slot) :name) - (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) ,@(when (swank-mop:slot-definition-documentation slot) @@ -445,13 +443,14 @@ `(:value ,(swank-mop:slot-definition-initform slot)) "#") (:newline) "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) - (:newline))) + (:newline)) (call-next-method))) (defmethod emacs-inspect ((pathname pathnames::pathname-internal)) - (values (if (wild-pathname-p pathname) + (list* (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") + '(:newline) (append (label-value-line* ("Namestring" (namestring pathname)) ("Host" (pathname-host pathname)) @@ -469,8 +468,6 @@ (t (call-next-method)))) (defun inspect-structure (o) - (values - (format nil "~A is a structure" o) (let* ((template (cl::uref o 1)) (num-slots (cl::struct-template-num-slots template))) (cond ((symbolp template) @@ -479,7 +476,7 @@ (t (loop for i below num-slots append (label-value-line (elt template (+ 6 (* i 5))) - (cl::uref o (+ 2 i))))))))) + (cl::uref o (+ 2 i)))))))) ;;; Threads --- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/02/09 18:38:58 1.13 +++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/02/09 18:47:05 1.14 @@ -252,8 +252,8 @@ ; ecl clos support leaves some to be desired (cond ((streamp o) - (values - (format nil "~S is an ordinary stream" o) + (list* + (format nil "~S is an ordinary stream~%" o) (append (list "Open for " @@ -285,7 +285,7 @@ (t (let* ((cl (si:instance-class o)) (slots (clos:class-slots cl))) - (values (format nil "~S is an instance of class ~A" + (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)) --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/09 18:39:02 1.95 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/09 18:47:05 1.96 @@ -644,12 +644,11 @@ (multiple-value-bind (names values _getter _setter type) (lw:get-inspector-values o nil) (declare (ignore _getter _setter)) - (values "A value." (append (label-value-line "Type" type) (loop for name in names for value in values - append (label-value-line name value)))))) + append (label-value-line name value))))) ;;; Miscellaneous --- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/09 18:39:02 1.123 +++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/02/09 18:47:05 1.124 @@ -814,24 +814,16 @@ collect " = " collect `(:value ,value) collect '(:newline)))) - (values (with-output-to-string (s) - (let ((*print-lines* 1) - (*print-right-margin* 80)) - (pprint o s))) - lines))) + lines)) (defmethod emacs-inspect :around ((o t)) (if (or (uvector-inspector-p o) (not (ccl:uvectorp o))) (call-next-method) - (multiple-value-bind (title content) - (call-next-method) - (values - title - (append content + (append (call-next-method) `((:newline) (:value ,(make-instance 'uvector-inspector :object o) - "Underlying UVECTOR"))))))) + "Underlying UVECTOR"))))) (defclass uvector-inspector () ((object :initarg :object))) @@ -843,12 +835,11 @@ (defmethod emacs-inspect ((uv uvector-inspector)) (with-slots (object) uv - (values (format nil "The UVECTOR for ~S." object) (loop for index below (ccl::uvsize object) collect (format nil "~D: " index) collect `(:value ,(ccl::uvref object index)) - collect `(:newline))))) + collect `(:newline)))) (defun closure-closed-over-values (closure) (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure))))) @@ -861,8 +852,8 @@ (list label (if cellp (ccl::closed-over-value value) value)))))) (defmethod emacs-inspect ((c ccl::compiled-lexical-closure)) - (values - (format nil "A closure: ~a" c) + (list* + (format nil "A closure: ~a~%" c) `(,@(if (arglist c) (list "Its argument list is: " (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c))) --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/09 18:39:02 1.190 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/09 18:47:05 1.191 @@ -1003,39 +1003,36 @@ (defmethod emacs-inspect ((o t)) (cond ((sb-di::indirect-value-cell-p o) - (values "A value cell." (label-value-line* - (:value (sb-kernel:value-cell-ref o))))) + (label-value-line* (:value (sb-kernel:value-cell-ref o)))) (t (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) - (if label - (values text (loop for (l . v) in parts - append (label-value-line l v))) - (values text (loop for value in parts for i from 0 - append (label-value-line i value)))))))) + (list* (format nil "~a~%" text) + (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) - (values "A simple-fun." (label-value-line* (:name (sb-kernel:%simple-fun-name o)) (:arglist (sb-kernel:%simple-fun-arglist o)) (:self (sb-kernel:%simple-fun-self o)) (:next (sb-kernel:%simple-fun-next o)) (:type (sb-kernel:%simple-fun-type o)) - (:code (sb-kernel:fun-code-header o))))) + (:code (sb-kernel:fun-code-header o)))) ((= header sb-vm:closure-header-widetag) - (values "A closure." (append (label-value-line :function (sb-kernel:%closure-fun o)) `("Closed over values:" (:newline)) (loop for i below (1- (sb-kernel:get-closure-length o)) append (label-value-line - i (sb-kernel:%closure-index-ref o i)))))) + i (sb-kernel:%closure-index-ref o i))))) (t (call-next-method o))))) (defmethod emacs-inspect ((o sb-kernel:code-component)) - (values (format nil "~A is a code data-block." o) (append (label-value-line* (:code-size (sb-kernel:%code-code-size o)) @@ -1060,28 +1057,24 @@ 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)))))))) + :stream s))))))) (defmethod emacs-inspect ((o sb-ext:weak-pointer)) - (values "A weak pointer." (label-value-line* - (:value (sb-ext:weak-pointer-value o))))) + (:value (sb-ext:weak-pointer-value o)))) (defmethod emacs-inspect ((o sb-kernel:fdefn)) - (values "A fdefn object." (label-value-line* (:name (sb-kernel:fdefn-name o)) - (:function (sb-kernel:fdefn-fun o))))) + (:function (sb-kernel:fdefn-fun o)))) (defmethod emacs-inspect :around ((o generic-function)) - (multiple-value-bind (title contents) (call-next-method) - (values title (append - contents + (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 --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/09 18:39:02 1.16 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/09 18:47:05 1.17 @@ -1742,8 +1742,7 @@ (defmethod emacs-inspect ((o t)) (cond ((di::indirect-value-cell-p o) - (values (format nil "~A is a value cell." o) - `("Value: " (:value ,(c:value-cell-ref o))))) + `("Value: " (:value ,(c:value-cell-ref o)))) ((alien::alien-value-p o) (inspect-alien-value o)) (t @@ -1752,7 +1751,7 @@ (defun scl-inspect (o) (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) - (values (format nil "~A~%" text) + (list* (format nil "~A~%" text) (if labeledp (loop for (label . value) in parts append (label-value-line label value)) @@ -1762,7 +1761,7 @@ (defmethod emacs-inspect ((o function)) (let ((header (kernel:get-type o))) (cond ((= header vm:function-header-type) - (values (format nil "~A is a function." o) + (list* (format nil "~A is a function.~%" o) (append (label-value-line* ("Self" (kernel:%function-self o)) ("Next" (kernel:%function-next o)) @@ -1774,7 +1773,7 @@ (with-output-to-string (s) (disassem:disassemble-function o :stream s)))))) ((= header vm:closure-header-type) - (values (format nil "~A is a closure" o) + (list* (format nil "~A is a closure.~%" o) (append (label-value-line "Function" (kernel:%closure-function o)) `("Environment:" (:newline)) @@ -1789,7 +1788,6 @@ (defmethod emacs-inspect ((o kernel:code-component)) - (values (format nil "~A is a code data-block." o) (append (label-value-line* ("code-size" (kernel:%code-code-size o)) @@ -1813,20 +1811,19 @@ (* vm:code-constants-offset vm:word-bytes)) (ash 1 vm:lowtag-bits)) (ash (kernel:%code-code-size o) vm:word-shift) - :stream s)))))))) + :stream s))))))) (defmethod emacs-inspect ((o kernel:fdefn)) - (values (format nil "~A is a fdenf object." o) - (label-value-line* + (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)))))) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) (defmethod emacs-inspect ((o array)) (cond ((kernel:array-header-p o) - (values (format nil "~A is an array." o) + (list* (format nil "~A is an array.~%" o) (label-value-line* (:header (describe-primitive-type o)) (:rank (array-rank o)) @@ -1838,13 +1835,13 @@ (:displaced-p (kernel:%array-displaced-p o)) (:dimensions (array-dimensions o))))) (t - (values (format nil "~A is an simple-array." o) + (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)) - (values (format nil "~A is a vector." o) + (list* (format nil "~A is a vector.~%" o) (append (label-value-line* (:header (describe-primitive-type o)) @@ -1854,8 +1851,6 @@ append (label-value-line i (aref o i))))))) (defun inspect-alien-record (alien) - (values - (format nil "~A is an alien value." alien) (with-struct (alien::alien-value- sap type) alien (with-struct (alien::alien-record-type- kind name fields) type (append @@ -1865,16 +1860,14 @@ (:name name)) (loop for field in fields append (let ((slot (alien::alien-record-field-name field))) - (label-value-line slot (alien:slot alien slot))))))))) + (label-value-line slot (alien:slot alien slot)))))))) (defun inspect-alien-pointer (alien) - (values - (format nil "~A is an alien value." alien) - (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-value- sap type) alien (label-value-line* (:sap sap) (:type type) - (:to (alien::deref alien)))))) + (:to (alien::deref alien))))) (defun inspect-alien-value (alien) (typecase (alien::alien-value-type alien) --- /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:45:39 1.530 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:47:05 1.531 @@ -2704,8 +2704,7 @@ (let ((*print-pretty* nil) ; print everything in the same line (*print-circle* t) (*print-readably* nil)) - (setq *inspectee-content* - (inspector-content (nth-value 1 (emacs-inspect o))))) + (setq *inspectee-content* (inspector-content (emacs-inspect o)))) (list :title (with-output-to-string (s) (print-unreadable-object (o s :type t :identity t))) :id (assign-index o *inspectee-parts*) @@ -2780,10 +2779,10 @@ (defslimefun inspector-next () "Inspect the next element in the *inspector-history*." (with-buffer-syntax () - (let ((position (position *inspectee* *inspector-history*))) - (cond ((= (1+ position) (length *inspector-history*)) + (let ((pos (position *inspectee* *inspector-history*))) + (cond ((= (1+ pos) (length *inspector-history*)) nil) - (t (inspect-object (aref *inspector-history* (1+ position)))))))) + (t (inspect-object (aref *inspector-history* (1+ pos)))))))) (defslimefun inspector-reinspect () (inspect-object *inspectee*)) @@ -2825,10 +2824,9 @@ (inspect-cons o))) (defun inspect-cons (cons) - (values "A cons cell." - (label-value-line* - ('car (car cons)) - ('cdr (cdr cons))))) + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons)))) ;; (inspect-list '#1=(a #1# . #1# )) ;; (inspect-list (list* 'a 'b 'c)) @@ -2837,8 +2835,7 @@ (defun inspect-list (list) (multiple-value-bind (length tail) (safe-length list) (flet ((frob (title list) - (values nil (append `(,title (:newline)) - (inspect-list-aux list))))) + (list* title '(:newline) (inspect-list-aux list)))) (cond ((not length) (frob "A circular list:" (cons (car list) @@ -2875,58 +2872,55 @@ ;;;;; Hashtables (defmethod emacs-inspect ((ht hash-table)) - (values (prin1-to-string ht) - (append - (label-value-line* - ("Count" (hash-table-count ht)) - ("Size" (hash-table-size ht)) - ("Test" (hash-table-test ht)) - ("Rehash size" (hash-table-rehash-size ht)) - ("Rehash threshold" (hash-table-rehash-threshold ht))) - (let ((weakness (hash-table-weakness ht))) - (when weakness - `("Weakness: " (:value ,weakness) (:newline)))) - (unless (zerop (hash-table-count ht)) - `((:action "[clear hashtable]" - ,(lambda () (clrhash ht))) (:newline) - "Contents: " (:newline))) - (loop for key being the hash-keys of ht - for value being the hash-values of ht - append `((:value ,key) " = " (:value ,value) - " " (:action "[remove entry]" + (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))) + (loop for key being the hash-keys of ht + for value being the hash-values of ht + append `((:value ,key) " = " (:value ,value) + " " (:action "[remove entry]" ,(let ((key key)) - (lambda () (remhash key ht)))) - (:newline)))))) + (lambda () (remhash key ht)))) + (:newline))))) ;;;;; Arrays (defmethod emacs-inspect ((array array)) - (values "An array." - (append - (label-value-line* - ("Dimensions" (array-dimensions array)) - ("Element type" (array-element-type array)) - ("Total size" (array-total-size array)) - ("Adjustable" (adjustable-array-p array))) - (when (array-has-fill-pointer-p array) - (label-value-line "Fill pointer" (fill-pointer array))) - '("Contents:" (:newline)) - (loop for i below (array-total-size array) - append (label-value-line i (row-major-aref array i)))))) + (append + (label-value-line* + ("Dimensions" (array-dimensions array)) + ("Element type" (array-element-type array)) + ("Total size" (array-total-size array)) + ("Adjustable" (adjustable-array-p array))) + (when (array-has-fill-pointer-p array) + (label-value-line "Fill pointer" (fill-pointer array))) + '("Contents:" (:newline)) + (loop for i below (array-total-size array) + append (label-value-line i (row-major-aref array i))))) ;;;;; Chars (defmethod emacs-inspect ((char character)) - (values "A character." - (append - (label-value-line* - ("Char code" (char-code char)) - ("Lower cased" (char-downcase char)) - ("Upper cased" (char-upcase char))) - (if (get-macro-character char) - `("In the current readtable (" - (:value ,*readtable*) ") it is a macro character: " - (:value ,(get-macro-character char))))))) + (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 From heller at common-lisp.net Sat Feb 9 18:47:09 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 13:47:09 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080209184709.D96C464044@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv21820/contrib Modified Files: swank-fancy-inspector.lisp Log Message: 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. --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/09 18:39:04 1.8 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/09 18:47:09 1.9 @@ -11,9 +11,7 @@ (multiple-value-bind (_symbol status) (and package (find-symbol (string symbol) package)) (declare (ignore _symbol)) - (values - "A symbol." - (append + (append (label-value-line "Its name is" (symbol-name symbol)) ;; ;; Value @@ -77,7 +75,7 @@ ;; More package (if (find-package symbol) (label-value-line "It names the package" (find-package symbol))) - ))))) + )))) (defun docstring-ispec (label object kind) "Return a inspector spec if OBJECT has a docstring of of kind KIND." @@ -90,15 +88,14 @@ (list label ": " '(:newline) " " docstring '(:newline)))))) (defmethod emacs-inspect ((f function)) - (values "A function." - (append + (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)))))) + (function-lambda-expression f))))) (defun method-specializers-for-inspect (method) "Return a \"pretty\" list of the method's specializers. Normal @@ -124,9 +121,8 @@ (defmethod emacs-inspect ((object standard-object)) (let ((class (class-of object))) - (values "An object." `("Class: " (:value ,class) (:newline) - ,@(all-slots-for-inspector object))))) + ,@(all-slots-for-inspector object)))) (defvar *gf-method-getter* 'methods-by-applicability "This function is called to get the methods of a generic function. @@ -226,9 +222,7 @@ (defmethod emacs-inspect ((gf standard-generic-function)) (flet ((lv (label value) (label-value-line label value))) - (values - "A generic function." - (append + (append (lv "Name" (swank-mop:generic-function-name gf)) (lv "Arguments" (swank-mop:generic-function-lambda-list gf)) (docstring-ispec "Documentation" gf t) @@ -247,10 +241,9 @@ (remove-method gf m)))) (:newline))) `((:newline)) - (all-slots-for-inspector gf))))) + (all-slots-for-inspector gf)))) (defmethod emacs-inspect ((method standard-method)) - (values "A method." `("Method defined on the generic function " (:value ,(swank-mop:method-generic-function method) ,(inspector-princ @@ -267,10 +260,9 @@ (:newline) "Method function: " (:value ,(swank-mop:method-function method)) (:newline) - ,@(all-slots-for-inspector method)))) + ,@(all-slots-for-inspector method))) (defmethod emacs-inspect ((class standard-class)) - (values "A class." `("Name: " (:value ,(class-name class)) (:newline) "Super classes: " @@ -326,10 +318,9 @@ `(:value ,(swank-mop:class-prototype class)) '"#") (:newline) - ,@(all-slots-for-inspector class)))) + ,@(all-slots-for-inspector class))) (defmethod emacs-inspect ((slot swank-mop:standard-slot-definition)) - (values "A slot." `("Name: " (:value ,(swank-mop:slot-definition-name slot)) (:newline) ,@(when (swank-mop:slot-definition-documentation slot) @@ -342,7 +333,7 @@ "#") (:newline) "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot)) (:newline) - ,@(all-slots-for-inspector slot)))) + ,@(all-slots-for-inspector slot))) ;; Wrapper structure over the list of symbols of a package that should @@ -436,8 +427,8 @@ (defmethod emacs-inspect ((%container %package-symbols-container)) (with-struct (%container. title description symbols grouping-kind) %container - (values title - `(, at description + `(,title (:newline) + , at description (:newline) " " ,(ecase grouping-kind (:symbol @@ -449,7 +440,7 @@ ,(lambda () (setf grouping-kind :symbol)) :refreshp t))) (:newline) (:newline) - ,@(make-symbols-listing grouping-kind symbols))))) + ,@(make-symbols-listing grouping-kind symbols)))) (defmethod emacs-inspect ((package package)) (let ((package-name (package-name package)) @@ -479,8 +470,6 @@ external-symbols (sort external-symbols #'string<)) ; SBCL 0.9.18. - (values - "A package." `("" ; dummy to preserve indentation. "Name: " (:value ,package-name) (:newline) @@ -542,14 +531,15 @@ (:newline) ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) :title (format nil "All shadowed symbols of package \"~A\"" package-name) - :description nil))))))) + :description nil)))))) (defmethod emacs-inspect ((pathname pathname)) - (values (if (wild-pathname-p pathname) - "A wild pathname." - "A pathname.") - (append (label-value-line* + (append (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)) @@ -559,10 +549,9 @@ ("Version" (pathname-version pathname))) (unless (or (wild-pathname-p pathname) (not (probe-file pathname))) - (label-value-line "Truename" (truename pathname)))))) + (label-value-line "Truename" (truename pathname))))) (defmethod emacs-inspect ((pathname logical-pathname)) - (values "A logical pathname." (append (label-value-line* ("Namestring" (namestring pathname)) @@ -579,10 +568,10 @@ ("Type" (pathname-type pathname)) ("Version" (pathname-version pathname)) ("Truename" (if (not (wild-pathname-p pathname)) - (probe-file pathname))))))) + (probe-file pathname)))))) (defmethod emacs-inspect ((n number)) - (values "A number." `("Value: " ,(princ-to-string n)))) + `("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 @@ -605,7 +594,6 @@ include-timezone-p (format-iso8601-timezone zone))))) (defmethod emacs-inspect ((i integer)) - (values "A number." (append `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" i i i i (ignore-errors (coerce i 'float))) @@ -614,23 +602,20 @@ (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)))))) + (label-value-line "Universal-time" (format-iso8601-time i t))))) (defmethod emacs-inspect ((c complex)) - (values "A complex number." (label-value-line* ("Real part" (realpart c)) - ("Imaginary part" (imagpart c))))) + ("Imaginary part" (imagpart c)))) (defmethod emacs-inspect ((r ratio)) - (values "A non-integer ratio." (label-value-line* ("Numerator" (numerator r)) ("Denominator" (denominator r)) - ("As float" (float r))))) + ("As float" (float r)))) (defmethod emacs-inspect ((f float)) - (values "A floating point number." (cond ((> f most-positive-long-float) (list "Positive infinity.")) @@ -647,13 +632,11 @@ (:value ,significand) " * " (:value ,(float-radix f)) "^" (:value ,exponent) (:newline)) (label-value-line "Digits" (float-digits f)) - (label-value-line "Precision" (float-precision f)))))))) + (label-value-line "Precision" (float-precision f))))))) (defmethod emacs-inspect ((stream file-stream)) - (multiple-value-bind (title content) + (multiple-value-bind (content) (call-next-method) - (declare (ignore title)) - (values "A file stream." (append `("Pathname: " (:value ,(pathname stream)) @@ -665,14 +648,13 @@ (ed-in-emacs `(,pathname :charpos ,position)))) :refreshp nil) (:newline)) - content)))) + content))) (defmethod emacs-inspect ((condition stream-error)) (multiple-value-bind (title content) (call-next-method) (let ((stream (stream-error-stream condition))) (if (typep stream 'file-stream) - (values "A stream error." (append `("Pathname: " (:value ,(pathname stream)) @@ -684,8 +666,8 @@ (ed-in-emacs `(,pathname :charpos ,position)))) :refreshp nil) (:newline)) - content)) - (values title content))))) + content) + content)))) (defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v)))) From heller at common-lisp.net Sat Feb 9 19:23:42 2008 From: heller at common-lisp.net (heller) Date: Sat, 9 Feb 2008 14:23:42 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080209192342.1B2F5340CC@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv30901 Modified Files: swank-fancy-inspector.lisp Log Message: (emacs-inspect pathname): Fix last change. --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/09 18:47:09 1.9 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/09 19:23:41 1.10 @@ -535,10 +535,10 @@ (defmethod emacs-inspect ((pathname pathname)) - (append (if (wild-pathname-p pathname) + (list* (if (wild-pathname-p pathname) "A wild pathname." "A pathname.") - '((:newline)) + '(:newline) (label-value-line* ("Namestring" (namestring pathname)) ("Host" (pathname-host pathname)) From heller at common-lisp.net Sun Feb 10 08:31:25 2008 From: heller at common-lisp.net (heller) Date: Sun, 10 Feb 2008 03:31:25 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080210083125.42432340A8@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv26239 Modified Files: ChangeLog slime-fancy-inspector.el swank-fancy-inspector.lisp Log Message: 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. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/04 18:00:36 1.87 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/10 08:31:21 1.88 @@ -1,3 +1,12 @@ +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. + 2008-02-04 Marco Baringer * swank-presentation-streams.lisp (presenting-object-1): Add --- /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2007/09/20 14:55:53 1.2 +++ /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2008/02/10 08:31:21 1.3 @@ -3,26 +3,7 @@ ;; Author: Marco Baringer and others ;; 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-fancy-inspector))) -;; (add-hook 'slime-connected-hook 'slime-install-fancy-inspector) - -(defun slime-install-fancy-inspector () - (slime-eval-async '(swank:swank-require :swank-fancy-inspector) - (lambda (_) - (slime-eval-async '(swank:fancy-inspector-init))))) - -(defun slime-deinstall-fancy-inspector () - (slime-eval-async '(swank:fancy-inspector-unload))) - -(defun slime-fancy-inspector-init () - (add-hook 'slime-connected-hook 'slime-install-fancy-inspector)) -(defun slime-fancy-inspector-unload () - (remove-hook 'slime-connected-hook 'slime-install-fancy-inspector)) +(slime-require :swank-fancy-inspector) (provide 'slime-fancy-inspector) \ No newline at end of file --- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/09 19:23:41 1.10 +++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2008/02/10 08:31:21 1.11 @@ -535,21 +535,21 @@ (defmethod emacs-inspect ((pathname pathname)) - (list* (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))))) + `(,(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 @@ -651,7 +651,7 @@ content))) (defmethod emacs-inspect ((condition stream-error)) - (multiple-value-bind (title content) + (multiple-value-bind (content) (call-next-method) (let ((stream (stream-error-stream condition))) (if (typep stream 'file-stream) @@ -684,13 +684,4 @@ (set-pprint-dispatch '(cons (member function)) nil) (princ-to-string list))) -(defvar *fancy-inpector-undo-list* nil) - -(defslimefun fancy-inspector-init () - t) - -(defslimefun fancy-inspector-unload () - (loop while *fancy-inpector-undo-list* do - (funcall (pop *fancy-inpector-undo-list*)))) - (provide :swank-fancy-inspector) From heller at common-lisp.net Sun Feb 10 08:32:05 2008 From: heller at common-lisp.net (heller) Date: Sun, 10 Feb 2008 03:32:05 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080210083205.687346B585@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv26291 Modified Files: ChangeLog swank-lispworks.lisp swank-scl.lisp Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/09 18:47:05 1.1288 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/10 08:32:04 1.1289 @@ -1,3 +1,11 @@ +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. --- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/09 18:47:05 1.96 +++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/02/10 08:32:04 1.97 @@ -624,10 +624,6 @@ append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) ;;; Inspector -(defclass lispworks-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'lispworks-inspector)) (defmethod emacs-inspect ((o t)) (lispworks-inspect o)) --- /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/09 18:47:05 1.17 +++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/02/10 08:32:04 1.18 @@ -1693,11 +1693,6 @@ ;;;; Inspecting -(defclass scl-inspector (backend-inspector) ()) - -(defimplementation make-default-inspector () - (make-instance 'scl-inspector)) - (defconstant +lowtag-symbols+ '(vm:even-fixnum-type vm:instance-pointer-type From heller at common-lisp.net Sun Feb 10 17:09:49 2008 From: heller at common-lisp.net (heller) Date: Sun, 10 Feb 2008 12:09:49 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080210170949.74FA44908D@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18166 Modified Files: ChangeLog Log Message: * 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. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/10 08:31:21 1.88 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/10 17:09:49 1.89 @@ -7,6 +7,10 @@ * 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 From heller at common-lisp.net Sun Feb 10 17:09:51 2008 From: heller at common-lisp.net (heller) Date: Sun, 10 Feb 2008 12:09:51 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080210170951.62CB249092@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv18182 Modified Files: slime-fancy.el Log Message: * 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. --- /project/slime/cvsroot/slime/contrib/slime-fancy.el 2007/09/28 13:05:35 1.4 +++ /project/slime/cvsroot/slime/contrib/slime-fancy.el 2008/02/10 17:09:51 1.5 @@ -31,9 +31,8 @@ (require 'slime-editing-commands) (slime-editing-commands-init) -;; Makes the inspector fancier. +;; Makes the inspector fancier. (Once loaded, can't be turned off.) (require 'slime-fancy-inspector) -(slime-fancy-inspector-init) ;; Just adds the command C-c M-i. We do not make fuzzy completion the ;; default completion invoked by TAB. --mkoeppe From heller at common-lisp.net Wed Feb 13 11:27:08 2008 From: heller at common-lisp.net (heller) Date: Wed, 13 Feb 2008 06:27:08 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080213112708.E1C586408D@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv14625 Modified Files: ChangeLog slime-xref-browser.el Log Message: 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. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/10 17:09:49 1.89 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/13 11:27:08 1.90 @@ -1,3 +1,11 @@ +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. @@ -10,7 +18,7 @@ * 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 --- /project/slime/cvsroot/slime/contrib/slime-xref-browser.el 2007/08/24 14:47:11 1.1 +++ /project/slime/cvsroot/slime/contrib/slime-xref-browser.el 2008/02/13 11:27:08 1.2 @@ -8,7 +8,7 @@ ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "") -;; (add-hook 'slime-load-hook (lambda () (require 'slime-xref-browser))) +;; (slime-setup '(slime-xref-browser ... possibly other packages ...)) ;; @@ -19,7 +19,7 @@ (let ((name (widget-get widget :tag))) (loop for kid in (slime-eval `(swank:mop :subclasses ,name)) collect `(tree-widget :tag ,kid - :dynargs slime-expand-class-node + :expander slime-expand-class-node :has-children t))))) (defun slime-browse-classes (name) @@ -29,7 +29,7 @@ "*slime class browser*" (slime-current-package) "Class Browser" (lambda () (widget-create 'tree-widget :tag name - :dynargs 'slime-expand-class-node + :expander 'slime-expand-class-node :has-echildren t)))) (defvar slime-browser-map nil @@ -84,7 +84,7 @@ collect `(tree-widget :tag ,label :xref-type ,type :xref-dspec ,dspec - :dynargs slime-expand-xrefs + :expander slime-expand-xrefs :has-children t))))) (defun slime-browse-xrefs (name type) @@ -99,6 +99,6 @@ "*slime xref browser*" (slime-current-package) "Xref Browser" (lambda () (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name - :dynargs 'slime-expand-xrefs :has-echildren t)))) + :expander 'slime-expand-xrefs :has-echildren t)))) -(provide 'slime-xref-browser) \ No newline at end of file +(provide 'slime-xref-browser) From heller at common-lisp.net Wed Feb 13 11:27:56 2008 From: heller at common-lisp.net (heller) Date: Wed, 13 Feb 2008 06:27:56 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080213112756.118DF44055@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv14706 Modified Files: ChangeLog slime-c-p-c.el Log Message: * slime-c-p-c.el (slime-c-p-c-init): Use slime-require instead of a connected-hook. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/13 11:27:08 1.90 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/13 11:27:55 1.91 @@ -1,5 +1,10 @@ 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) --- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2007/09/20 14:55:53 1.8 +++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el 2008/02/13 11:27:55 1.9 @@ -13,7 +13,7 @@ ;; Add this to your .emacs: ;; ;; (add-to-list 'load-path "") -;; (add-hook 'slime-load-hook (lambda () (require 'slime-c-p-c))) +;; (slime-setup '(slime-c-p-c ... possibly other packages ...)) ;; @@ -177,6 +177,7 @@ (defvar slime-c-p-c-init-undo-stack nil) (defun slime-c-p-c-init () + (slime-require :swank-arglists) ;; save current state for unload (push `(progn @@ -188,13 +189,9 @@ ',(lookup-key slime-repl-mode-map "\C-c\C-s"))) slime-c-p-c-init-undo-stack) (setq slime-complete-symbol-function 'slime-complete-symbol*) - (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect) (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form) (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)) -(defun slime-c-p-c-on-connect () - (slime-eval-async '(swank:swank-require :swank-arglists))) - (defun slime-c-p-c-unload () (while slime-c-p-c-init-undo-stack (eval (pop slime-c-p-c-init-undo-stack)))) From mkoeppe at common-lisp.net Fri Feb 15 17:35:20 2008 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 15 Feb 2008 12:35:20 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080215173520.1FD2815026@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv10387 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/13 11:27:55 1.91 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/15 17:35:19 1.92 @@ -1,3 +1,8 @@ +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 From mkoeppe at common-lisp.net Fri Feb 15 17:35:31 2008 From: mkoeppe at common-lisp.net (mkoeppe) Date: Fri, 15 Feb 2008 12:35:31 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080215173531.239D34D056@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv10411 Modified Files: slime-presentations.el Log Message: (slime-previous-presentation) (slime-next-presentation): Accept a standard prefix argument. --- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/01/20 16:14:45 1.12 +++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2008/02/15 17:35:29 1.13 @@ -479,35 +479,47 @@ (goto-char start) (push-mark end nil t))) -(defun slime-previous-presentation () - "Move point to the beginning of the first presentation before point." - (interactive) - ;; 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)))) - -(defun slime-next-presentation () - "Move point to the beginning of the next presentation after point." - (interactive) - ;; 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)))) +(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))))))) (defvar slime-presentation-map (make-sparse-keymap)) From heller at common-lisp.net Sat Feb 16 19:26:23 2008 From: heller at common-lisp.net (heller) Date: Sat, 16 Feb 2008 14:26:23 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080216192623.B936D16046@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9557 Modified Files: ChangeLog swank-loader.lisp slime.el swank.lisp Log Message: 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. 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/10 08:32:04 1.1289 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/16 19:26:22 1.1290 @@ -1,3 +1,25 @@ +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. @@ -2875,15 +2897,15 @@ * 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-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 + instead of a RPC to swank:simple-break. Suggested by Taylor R. Campbell. 2006-11-24 Helmut Eller @@ -3428,7 +3450,7 @@ * swank.lisp (format-iso8601-time): Properly handle non integer time zones. -2006-09-13 Taylor R Campbell +2006-09-13 Taylor R. Campbell * slime.el (slime-init-output-buffer): Initial directory and package stacks should be empty. @@ -3613,7 +3635,7 @@ 2006-07-28 Helmut Eller * slime.el (slime-thread-quit): Call swank:quit-thread-browser. - Reported by Taylor R Campbell. + Reported by Taylor R. Campbell. 2006-07-28 Willem Broekema @@ -4970,7 +4992,7 @@ * slime.el (slime48): New command. -2005-09-19 Taylor Campbell +2005-09-19 Taylor R. Campbell * swank-scheme48/: New backend. --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/04 12:15:27 1.77 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/16 19:26:22 1.78 @@ -18,15 +18,10 @@ ;; (defparameter swank-loader::*fasl-directory* "/tmp/fasl/") ;; (load ".../swank-loader.lisp") -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (find-package :swank) - (delete-package :swank) - (delete-package :swank-io-package) - (delete-package :swank-backend))) - (cl:defpackage :swank-loader (:use :cl) (:export :load-swank + :init :*source-directory* :*fasl-directory*)) @@ -79,7 +74,7 @@ (subseq s 0 (position #\space s))) #+armedbear (lisp-implementation-version)) -(defun unique-directory-name () +(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." @@ -114,20 +109,20 @@ :if-does-not-exist nil) (and s (symbol-name (read s))))) -(defun default-fasl-directory () +(defun default-fasl-dir () (merge-pathnames (make-pathname :directory `(:relative ".slime" "fasl" ,@(if (slime-version-string) (list (slime-version-string))) - ,(unique-directory-name))) + ,(unique-dir-name))) (user-homedir-pathname))) -(defun binary-pathname (source-pathname binary-directory) - "Return the pathname where SOURCE-PATHNAME's binary should be compiled." - (let ((cfp (compile-file-pathname source-pathname))) +(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-directory))) + binary-dir))) (defun handle-loadtime-error (condition binary-pathname) (pprint-logical-block (*error-output* () :per-line-prefix ";; ") @@ -135,40 +130,37 @@ "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%" binary-pathname condition)) (when (equal (directory-namestring binary-pathname) - (directory-namestring (default-fasl-directory))) + (directory-namestring (default-fasl-dir))) (ignore-errors (delete-file binary-pathname))) (abort)) -(defun compile-files-if-needed-serially (files fasl-directory load) +(defun compile-files (files fasl-dir load) "Compile each file in FILES if the source is newer than its corresponding binary, or the file preceding it was recompiled." (let ((needs-recompile nil)) - (dolist (source-pathname files) - (let ((binary-pathname (binary-pathname source-pathname - fasl-directory))) + (dolist (src files) + (let ((dest (binary-pathname src fasl-dir))) (handler-case (progn (when (or needs-recompile - (not (probe-file binary-pathname)) - (file-newer-p source-pathname binary-pathname)) - ;; need a to recompile source-pathname, so we'll + (not (probe-file dest)) + (file-newer-p src dest)) + ;; need a to recompile src-pathname, so we'll ;; need to recompile everything after this too. (setq needs-recompile t) - (ensure-directories-exist binary-pathname) - (compile-file source-pathname :output-file binary-pathname - :print nil - :verbose t)) + (ensure-directories-exist dest) + (compile-file src :output-file dest :print nil :verbose t)) (when load - (load binary-pathname :verbose t))) + (load dest :verbose t))) ;; Fail as early as possible (serious-condition (c) - (handle-loadtime-error c binary-pathname))))))) + (handle-loadtime-error c dest))))))) #+(or cormanlisp ecl) -(defun compile-files-if-needed-serially (files fasl-directory load) +(defun compile-files (files fasl-dir load) "Corman Lisp and ECL have trouble with compiled files." - (declare (ignore fasl-directory)) + (declare (ignore fasl-dir)) (when load (dolist (file files) (load file :verbose t) @@ -180,22 +172,22 @@ (make-pathname :name ".swank" :type "lisp")) :if-does-not-exist nil)) -(defun load-site-init-file (directory) +(defun load-site-init-file (dir) (load (make-pathname :name "site-init" :type "lisp" - :defaults directory) + :defaults dir) :if-does-not-exist nil)) -(defun source-files (names src-dir) +(defun src-files (names src-dir) (mapcar (lambda (name) (make-pathname :name (string-downcase name) :type "lisp" :defaults src-dir)) names)) -(defun swank-source-files (src-dir) - (source-files `("swank-backend" ,@*sysdep-files* "swank") - src-dir)) +(defun swank-src-files (src-dir) + (src-files `("swank-backend" ,@*sysdep-files* "swank") + src-dir)) -(defvar *fasl-directory* (default-fasl-directory) +(defvar *fasl-directory* (default-fasl-dir) "The directory where fasl files should be placed.") (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy @@ -210,28 +202,30 @@ (make-pathname :directory `(:relative ,name) :defaults absolute) absolute)) -(defun contrib-src-dir (src-dir) - (append-dir src-dir "contrib")) - -(defun contrib-source-files (src-dir) - (source-files *contribs* (contrib-src-dir src-dir))) +(defun contrib-dir (base-dir) + (append-dir base-dir "contrib")) -(defun load-swank (&key - (source-directory *source-directory*) - (fasl-directory *fasl-directory*) - (contrib-fasl-directory - (append-dir fasl-directory "contrib"))) - (compile-files-if-needed-serially (swank-source-files source-directory) - fasl-directory t) - (compile-files-if-needed-serially (contrib-source-files source-directory) - contrib-fasl-directory nil)) - -(load-swank) - -(setq swank::*swank-wire-protocol-version* (slime-version-string)) -(setq swank::*load-path* - (append swank::*load-path* (list (contrib-src-dir *source-directory*)))) -(swank-backend::warn-unimplemented-interfaces) -(load-site-init-file *source-directory*) -(load-user-init-file) -(swank:run-after-init-hook) +(defun load-swank (&key (src-dir *source-directory*) + (fasl-dir *fasl-directory*)) + (compile-files (swank-src-files src-dir) fasl-dir t)) + +(defun compile-contribs (&key (src-dir (contrib-dir *source-directory*)) + (fasl-dir (contrib-dir *fasl-directory*))) + (compile-files (src-files *contribs* src-dir) fasl-dir nil)) + +(defun setup () + (flet ((q (s) (read-from-string s))) + (load-site-init-file *source-directory*) + (load-user-init-file) + (eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*"))) + (funcall (q "swank::setup") + (slime-version-string) + (list (contrib-dir *fasl-directory*) + (contrib-dir *source-directory*))))) + +(defun init (&key delete reload) + (when (and delete (find-package :swank)) + (mapc #'delete-package '(:swank :swank-io-package :swank-backend))) + (when (or (not (find-package :swank)) reload) + (load-swank)) + (setup)) --- /project/slime/cvsroot/slime/slime.el 2008/02/09 18:44:12 1.904 +++ /project/slime/cvsroot/slime/slime.el 2008/02/16 19:26:22 1.905 @@ -1432,6 +1432,7 @@ (format "%S\n\n" `(progn (load ,(expand-file-name loader) :verbose t) + (funcall (read-from-string "swank-loader:init")) (funcall (read-from-string "swank:start-server") ,port-filename :coding-system ,encoding))))) @@ -3172,14 +3173,13 @@ (let ((end (point))) ; end of input, without the newline (slime-repl-add-to-input-history (buffer-substring slime-repl-input-start-mark end)) - (let ((inhibit-read-only t)) - (add-text-properties slime-repl-input-start-mark - (point) - `(slime-repl-old-input - ,(incf slime-repl-old-input-counter)))) (when newline (insert "\n") (slime-repl-show-maximum-output)) + (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. @@ -3206,7 +3206,10 @@ (unless (eq (char-before) ?\ ) (insert " ")))) (delete-region (point) slime-repl-input-end-mark) - (save-excursion (insert old-input)) + (save-excursion + (insert old-input) + (when (equal (char-before) ?\n) + (delete-char -1))) (forward-char offset)))) (defun slime-property-bounds (prop) --- /project/slime/cvsroot/slime/swank.lisp 2008/02/09 18:47:05 1.531 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/16 19:26:23 1.532 @@ -23,7 +23,6 @@ #:inspect-in-emacs #:print-indentation-lossage #:swank-debugger-hook - #:run-after-init-hook #:emacs-inspect ;;#:inspect-slot-for-emacs ;; These are user-configurable variables: @@ -182,9 +181,6 @@ (defvar *after-init-hook* '() "Hook run after user init files are loaded.") -(defun run-after-init-hook () - (run-hook *after-init-hook*)) - ;;;; Connections ;;; @@ -2291,10 +2287,7 @@ (make-pathname :directory `(:relative ,dirname) :defaults defaults) defaults))) -(defvar *load-path* - (list (make-pathname :directory (merged-directory "contrib" *load-truename*) - :name nil :type nil :version nil - :defaults *load-truename*)) +(defvar *load-path* '() "A list of directories to search for modules.") (defun module-canditates (name dir) @@ -3141,4 +3134,10 @@ (add-hook *pre-reply-hook* 'sync-indentation-to-emacs) +(defun setup (version load-path) + (setq *swank-wire-protocol-version* version) + (setq *load-path* load-path) + (swank-backend::warn-unimplemented-interfaces) + (run-hook *after-init-hook*)) + ;;; swank.lisp ends here From heller at common-lisp.net Sun Feb 17 08:17:24 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Feb 2008 03:17:24 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080217081724.9C950140F2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7457 Modified Files: swank-loader.lisp Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/16 19:26:22 1.78 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/17 08:17:24 1.79 @@ -135,9 +135,8 @@ (abort)) (defun compile-files (files fasl-dir load) - "Compile each file in FILES if the source is newer than -its corresponding binary, or the file preceding it was -recompiled." + "Compile each file in FILES if the source is newer than its +corresponding binary, or the file preceding it was recompiled." (let ((needs-recompile nil)) (dolist (src files) (let ((dest (binary-pathname src fasl-dir))) From heller at common-lisp.net Sun Feb 17 08:20:34 2008 From: heller at common-lisp.net (heller) Date: Sun, 17 Feb 2008 03:20:34 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080217082034.397B4140F2@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv9443 Modified Files: swank-loader.lisp Log Message: *** empty log message *** --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/17 08:17:24 1.79 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/17 08:20:34 1.80 @@ -136,7 +136,8 @@ (defun compile-files (files fasl-dir load) "Compile each file in FILES if the source is newer than its -corresponding binary, or the file preceding it was recompiled." +corresponding binary, or the file preceding it was recompiled. +If LOAD is true, load the fasl file." (let ((needs-recompile nil)) (dolist (src files) (let ((dest (binary-pathname src fasl-dir))) From mbaringer at common-lisp.net Sun Feb 17 12:28:27 2008 From: mbaringer at common-lisp.net (mbaringer) Date: Sun, 17 Feb 2008 07:28:27 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080217122827.CC0531704E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv21556 Modified Files: swank.asd ChangeLog Log Message: Update for recent changes to swank-loader.lisp, we need to call swank-loader::init after loading. --- /project/slime/cvsroot/slime/swank.asd 2007/09/14 12:41:28 1.5 +++ /project/slime/cvsroot/slime/swank.asd 2008/02/17 12:28:27 1.6 @@ -24,25 +24,21 @@ (in-package :swank-loader) -(defclass cl-script-file (asdf:source-file) ()) +(defclass swank-loader-file (asdf:cl-source-file) ()) -(defmethod asdf:perform ((o asdf:compile-op) (f cl-script-file)) - t) -(defmethod asdf:perform ((o asdf:load-op) (f cl-script-file)) - (mapcar #'load (asdf:input-files o f))) -(defmethod asdf:output-files ((o asdf:compile-op) (f cl-script-file)) - nil) -(defmethod asdf:input-files ((o asdf:load-op) (c cl-script-file)) - (list (asdf:component-pathname c))) -(defmethod asdf:operation-done-p ((o asdf:compile-op) (c cl-script-file)) +;;;; make compile-op a nop + +(defmethod asdf:operation-done-p ((o asdf:compile-op) (f swank-loader-file)) t) -(defmethod asdf:source-file-type ((c cl-script-file) (s asdf:module)) - "lisp") -(asdf:defsystem :swank - :default-component-class cl-script-file - :components ((:file "swank-loader"))) +;;;; after loading run init -(defparameter *source-directory* - (asdf:component-pathname (asdf:find-system :swank))) +(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"))) --- /project/slime/cvsroot/slime/ChangeLog 2008/02/16 19:26:22 1.1290 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/17 12:28:27 1.1291 @@ -1,3 +1,8 @@ +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. From heller at common-lisp.net Wed Feb 20 22:05:24 2008 From: heller at common-lisp.net (heller) Date: Wed, 20 Feb 2008 17:05:24 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080220220524.40928392D2@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv10328 Modified Files: ChangeLog swank-kawa.scm Log Message: 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. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/15 17:35:19 1.92 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/20 22:05:24 1.93 @@ -1,3 +1,12 @@ +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) --- /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/01/19 14:08:27 1.1 +++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm 2008/02/20 22:05:24 1.2 @@ -916,7 +916,8 @@ (define-simple-class () (object :init #!null) (parts :: :init () ) - (stack :: :init '())) + (stack :: :init '()) + (content :: :init '())) (df make-inspector (env (vm ) => ) (car (spawn/chan (fun (c) (inspector c env vm))))) @@ -950,14 +951,16 @@ (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 (inspector-content - `("class: " (:value ,(! getClass obj)) "\n" - ,@(inspect obj vm)) - state))))) + :content (let ((c (@ content state))) + (content-range c 0 (len c))))))) (df inspect (obj vm) (let* ((obj (as (vm-mirror vm obj)))) @@ -996,6 +999,10 @@ (! 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)))) @@ -1840,6 +1847,12 @@ (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)))) + (df to-string (obj => ) (cond ((instance? obj ) ( (as obj))) ((string? obj) obj) From heller at common-lisp.net Wed Feb 20 22:07:36 2008 From: heller at common-lisp.net (heller) Date: Wed, 20 Feb 2008 17:07:36 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080220220736.CD72E490A0@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11301 Modified Files: swank.lisp Log Message: Minor cleanups for inspector code. * swank.lisp (inspector-content, inspect-list-aux): Slight cleanups. --- /project/slime/cvsroot/slime/swank.lisp 2008/02/16 19:26:23 1.532 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/20 22:07:35 1.533 @@ -2706,8 +2706,6 @@ (defun inspector-content (specs) (loop for part in specs collect (etypecase part - ;;(null ; XXX encourages sloppy programming - ;; nil) (string part) (cons (destructure-case part ((:newline) @@ -2840,13 +2838,9 @@ (defun inspect-list-aux (list) (loop for i from 0 for rest on list while (consp rest) append - (cond ((consp (cdr rest)) - (label-value-line i (car rest))) - ((cdr rest) - (label-value-line* (i (car rest)) - (:tail (cdr rest)))) - (t - (label-value-line i (car rest)))))) + (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. From heller at common-lisp.net Wed Feb 20 22:10:38 2008 From: heller at common-lisp.net (heller) Date: Wed, 20 Feb 2008 17:10:38 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080220221038.B670C5D181@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11697 Modified Files: ChangeLog swank-loader.lisp Log Message: Emit a warning if the SWANK package already exists. * swank-loader.lisp (init): Issue a warning when SWANK will not be reloaded. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/17 12:28:27 1.1291 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/20 22:10:38 1.1292 @@ -1,3 +1,17 @@ +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 --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/17 08:20:34 1.80 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/20 22:10:38 1.81 @@ -1,4 +1,4 @@ -;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;;; -*- indent-tabs-mode: nil -*- ;;; ;;; swank-loader.lisp --- Compile and load the Slime backend. ;;; @@ -226,6 +226,8 @@ (defun init (&key delete reload) (when (and delete (find-package :swank)) (mapc #'delete-package '(:swank :swank-io-package :swank-backend))) - (when (or (not (find-package :swank)) reload) - (load-swank)) + (cond ((or (not (find-package :swank)) reload) + (load-swank)) + (t + (warn "Not reloading SWANK. Package already exists."))) (setup)) From heller at common-lisp.net Wed Feb 20 22:12:37 2008 From: heller at common-lisp.net (heller) Date: Wed, 20 Feb 2008 17:12:37 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080220221237.68E5A6200B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11860 Modified Files: ChangeLog slime.el swank.lisp Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/20 22:10:38 1.1292 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/20 22:12:37 1.1293 @@ -1,5 +1,29 @@ 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 --- /project/slime/cvsroot/slime/slime.el 2008/02/16 19:26:22 1.905 +++ /project/slime/cvsroot/slime/slime.el 2008/02/20 22:12:37 1.906 @@ -4107,8 +4107,9 @@ (goto-char (point-min))))) (defun slime-alistify (list key test) - "Partition the elements of LIST into an alist. -KEY extracts the key from an element and TEST is used to compare keys." + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." (declare (type function key)) (let ((alist '())) (dolist (e list) @@ -4118,7 +4119,7 @@ (push e (cdr probe)) (push (cons k (list e)) alist)))) ;; Put them back in order. - (loop for (key . value) in alist + (loop for (key . value) in (reverse alist) collect (cons key (reverse value))))) (defun slime-note.severity (note) @@ -5141,28 +5142,79 @@ ;; If this buffer was deleted, recurse to try the next one (slime-pop-find-definition-stack)))))) -(defstruct (slime-definition (:conc-name slime-definition.) - (:type list)) +(defstruct (slime-xref (:conc-name slime-xref.) (:type list)) dspec location) +(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 slime-edit-definition (name &optional where) "Lookup the definition of the name at point. If there's no name at point, or a prefix argument is given, then the function name is prompted." (interactive (list (slime-read-symbol-name "Name: "))) - (let ((definitions (slime-eval `(swank:find-definitions-for-emacs ,name)))) - (cond - ((null definitions) - (if slime-edit-definition-fallback-function - (funcall slime-edit-definition-fallback-function name) - (error "No known definition for: %s" name))) - ((and (slime-length= definitions 1) - (eql (car (slime-definition.location (car definitions))) :error)) - (if slime-edit-definition-fallback-function - (funcall slime-edit-definition-fallback-function name) - (error "%s" (cadr (slime-definition.location (car definitions)))))) - (t - (slime-goto-definition name definitions where))))) + (slime-find-definitions name + (slime-rcurry + #'slime-edit-definition-cont name where))) + +(defun slime-edit-definition-cont (xrefs name where) + (destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs) + (cond ((null xrefs) + (error "No known definition for: %s" name)) + (1loc + (slime-push-definition-stack) + (slime-pop-to-location (slime-xref.location (car xrefs)) where)) + ((= (length xrefs) 1) + (error "%s" (cadr (slime-xref.location (car xrefs))))) + (t + (slime-push-definition-stack) + (slime-show-xrefs file-alist 'definition name + (slime-current-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) + (every (lambda (x) (equal (slime-xref.location x) loc)) + (cdr xrefs))))) + (slime-alistify xrefs + (lambda (x) + (if (slime-xref-has-location-p x) + (cadr + (slime-location.buffer (slime-xref.location x))) + "Error")) + #'equal))) + +(defun slime-pop-to-location (location &optional where) + (ecase where + ((nil) + (slime-goto-source-location location) + (switch-to-buffer (current-buffer))) + (window + (pop-to-buffer (current-buffer) t) + (slime-goto-source-location location) + (switch-to-buffer (current-buffer))) + (frame + (let ((pop-up-frames t)) + (pop-to-buffer (current-buffer) t) + (slime-goto-source-location location) + (switch-to-buffer (current-buffer)))))) + +(defun slime-find-definitions (name cont) + "Find definitions for NAME and pass them to CONT." + ;; FIXME: append SWANK xrefs and etags xrefs + (funcall cont + (or (slime-eval `(swank:find-definitions-for-emacs ,name)) + (funcall slime-edit-definition-fallback-function name)))) (defun slime-find-tag-if-tags-table-visited (name) "Find tag (in current tags table) whose name contains NAME. @@ -5171,44 +5223,7 @@ (if tags-table-list (find-tag name) (error "No known definition for: %s; use M-x visit-tags-table RET" name))) - -(defun slime-goto-definition (name definitions &optional where) - (slime-push-definition-stack) - (let ((all-locations-equal - (or (null definitions) - (let ((first-location (slime-definition.location (first definitions)))) - (every (lambda (definition) - (equal (slime-definition.location definition) - first-location)) - (rest definitions)))))) - (if (and (slime-length> definitions 1) - (not all-locations-equal)) - (slime-show-definitions name definitions) - (let ((def (car definitions))) - (destructure-case (slime-definition.location def) - ;; Take care of errors before switching any windows/buffers. - ((:error message) - (error "%s" message)) - (t - (cond ((equal where 'window) - (slime-goto-definition-other-window (car definitions))) - ((equal where 'frame) - (let ((pop-up-frames t)) - (slime-goto-definition-other-window (car definitions)))) - (t - (slime-goto-source-location (slime-definition.location - (car definitions))) - (switch-to-buffer (current-buffer)))))))))) - -(defun slime-goto-definition-other-window (definition) - (slime-pop-to-other-window) - (slime-goto-source-location (slime-definition.location definition)) - (switch-to-buffer (current-buffer))) - -(defun slime-pop-to-other-window () - "Pop to the other window, but not to any particular buffer." - (pop-to-buffer (current-buffer) t)) - + (defun slime-edit-definition-other-window (name) "Like `slime-edit-definition' but switch to the other window." (interactive (list (slime-read-symbol-name "Symbol: "))) @@ -5221,10 +5236,10 @@ (defun slime-edit-definition-with-etags (name) (interactive (list (slime-read-symbol-name "Symbol: "))) - (let ((tagdefs (slime-etags-definitions name))) - (cond (tagdefs + (let ((xrefs (slime-etags-definitions name))) + (cond (xrefs (message "Using tag file...") - (slime-goto-definition name tagdefs)) + (slime-edit-definition-cont xrefs name nil)) (t (error "No known definition for: %s" name))))) @@ -5249,14 +5264,6 @@ (push (list hint loc) defs)))))))) (reverse defs)))) -(defun slime-show-definitions (name definitions) - (slime-show-xrefs - `((,name . ,(loop for (dspec location) in definitions - collect (cons dspec location)))) - 'definition - name - (slime-current-package))) - ;;;;; first-change-hook (defun slime-first-change-hook () @@ -6060,36 +6067,19 @@ (put 'slime-with-xref-buffer 'lisp-indent-function 1) -(defun slime-insert-xrefs (xrefs) - "Insert XREFS in the current-buffer. -XREFS is a list of the form ((GROUP . ((LABEL . LOCATION) ...)) ...) -GROUP and LABEL are for decoration purposes. LOCATION is a source-location." - (unless (bobp) (insert "\n")) +(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." (loop for (group . refs) in xrefs do - (progn - (slime-insert-propertized '(face bold) group "\n") - (loop - for (label . location) in refs - do (slime-insert-propertized - (list 'slime-location location - 'face 'font-lock-keyword-face) - " " (slime-one-line-ify label)) - do (insert " - " (slime-insert-xref-location location) "\n")))) + (slime-insert-propertized '(face bold) group "\n") + (loop for (label location) in refs do + (slime-insert-propertized (list 'slime-location location + 'face 'font-lock-keyword-face) + " " (slime-one-line-ify label) "\n"))) ;; Remove the final newline to prevent accidental window-scrolling - (backward-char 1) - (delete-char 1)) - -(defun slime-insert-xref-location (location) - (if (eql :location (car location)) - (cond ((assoc :file (cdr location)) - (second (assoc :file (cdr location)))) - ((assoc :buffer (cdr location)) - (let* ((name (second (assoc :buffer (cdr location)))) - (buffer (get-buffer name))) - (if buffer - (format "%S" buffer) - (format "%s (previously existing buffer)" name))))) - "file unknown")) + (backward-delete-char 1)) (defvar slime-next-location-function nil "Function to call for going to the next location.") @@ -6165,7 +6155,8 @@ ;; buffer. (2007-08-14) (snapshot (slime-current-emacs-snapshot))) (lambda (result) - (slime-show-xrefs result type symbol package snapshot))))) + (let ((file-alist (cadr (slime-analyze-xrefs result)))) + (slime-show-xrefs file-alist type symbol package snapshot)))))) ;;;;; XREF navigation --- /project/slime/cvsroot/slime/swank.lisp 2008/02/20 22:07:35 1.533 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/20 22:12:37 1.534 @@ -2587,85 +2587,27 @@ (defslimefun find-definitions-for-emacs (name) "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. DSPEC is a string and LOCATION a source location. NAME is a string." - (multiple-value-bind (sexp error) - (ignore-errors (values (from-string name))) + (multiple-value-bind (sexp error) (ignore-errors (values (from-string name))) (unless error - (loop for (dspec loc) in (find-definitions sexp) - collect (list (to-string dspec) loc))))) + (mapcar #'xref>elisp (find-definitions sexp))))) -(defun alistify (list key test) - "Partition the elements of LIST into an alist. KEY extracts the key -from an element and TEST is used to compare keys." - (declare (type function key)) - (let ((alist '())) - (dolist (e list) - (let* ((k (funcall key e)) - (probe (assoc k alist :test test))) - (if probe - (push e (cdr probe)) - (push (cons k (list e)) alist)))) - alist)) - -(defun location-position< (pos1 pos2) - (cond ((and (position-p pos1) (position-p pos2)) - (< (position-pos pos1) - (position-pos pos2))) - (t nil))) - -(defun partition (list test key) - (declare (type function test key)) - (loop for e in list - if (funcall test (funcall key e)) collect e into yes - else collect e into no - finally (return (values yes no)))) - -(defstruct (xref (:conc-name xref.) - (:type list)) - dspec location) - -(defun location-valid-p (location) - (eq (car location) :location)) - -(defun xref-buffer (xref) - (location-buffer (xref.location xref))) - -(defun xref-position (xref) - (location-buffer (xref.location xref))) - -(defun group-xrefs (xrefs) - "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location. -The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)." - (multiple-value-bind (resolved errors) - (partition xrefs #'location-valid-p #'xref.location) - (let ((alist (alistify resolved #'xref-buffer #'equal))) - (append - (loop for (buffer . list) in alist - collect (cons (second buffer) - (mapcar (lambda (xref) - (cons (to-string (xref.dspec xref)) - (xref.location xref))) - (sort list #'location-position< - :key #'xref-position)))) - (if errors - (list (cons "Unresolved" - (mapcar (lambda (xref) - (cons (to-string (xref.dspec xref)) - (xref.location xref))) - errors)))))))) - -(defslimefun xref (type symbol-name) - (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*))) - (group-xrefs - (ecase type - (:calls (who-calls symbol)) - (:calls-who (calls-who symbol)) - (:references (who-references symbol)) - (:binds (who-binds symbol)) - (:sets (who-sets symbol)) - (:macroexpands (who-macroexpands symbol)) - (:specializes (who-specializes symbol)) - (:callers (list-callers symbol)) - (:callees (list-callees symbol)))))) +(defslimefun xref (type name) + (let ((symbol (parse-symbol-or-lose name *buffer-package*))) + (mapcar #'xref>elisp + (ecase type + (:calls (who-calls symbol)) + (:calls-who (calls-who symbol)) + (:references (who-references symbol)) + (:binds (who-binds symbol)) + (:sets (who-sets symbol)) + (:macroexpands (who-macroexpands symbol)) + (:specializes (who-specializes symbol)) + (:callers (list-callers symbol)) + (:callees (list-callees symbol)))))) + +(defun xref>elisp (xref) + (destructuring-bind (name loc) xref + (list (to-string name) loc))) ;;;; Inspecting From trittweiler at common-lisp.net Thu Feb 21 12:55:58 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 21 Feb 2008 07:55:58 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080221125558.1AF952F048@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22544 Modified Files: slime.el Log Message: 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. --- /project/slime/cvsroot/slime/slime.el 2008/02/20 22:12:37 1.906 +++ /project/slime/cvsroot/slime/slime.el 2008/02/21 12:55:57 1.907 @@ -5189,11 +5189,19 @@ (slime-alistify xrefs (lambda (x) (if (slime-xref-has-location-p x) - (cadr - (slime-location.buffer (slime-xref.location x))) + (slime-location-to-string (slime-xref.location x)) "Error")) #'equal))) +(defun slime-location-to-string (location) + (destructure-case (slime-location.buffer location) + ((:file filename) filename) + ((:buffer bufname) + (let ((buffer (get-buffer bufname))) + (if buffer + (format "%S" buffer) ; "#" + (format "%s (previously existing buffer)" bufname)))))) + (defun slime-pop-to-location (location &optional where) (ecase where ((nil) From trittweiler at common-lisp.net Thu Feb 21 12:56:21 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 21 Feb 2008 07:56:21 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080221125621.4CD974821B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv22784 Modified Files: ChangeLog Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/20 22:12:37 1.1293 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/21 12:56:21 1.1294 @@ -1,3 +1,24 @@ +2008-02-21 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-20 Helmut Eller Better factorization for M-. and xref commands. From trittweiler at common-lisp.net Thu Feb 21 20:49:10 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 21 Feb 2008 15:49:10 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080221204910.4536E490A0@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv713/contrib Modified Files: swank-presentations.lisp Log Message: 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. --- /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2007/09/04 09:49:10 1.4 +++ /project/slime/cvsroot/slime/contrib/swank-presentations.lisp 2008/02/21 20:49:10 1.5 @@ -104,6 +104,8 @@ (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)))) From trittweiler at common-lisp.net Thu Feb 21 20:49:31 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 21 Feb 2008 15:49:31 -0500 (EST) Subject: [slime-cvs] CVS slime/contrib Message-ID: <20080221204931.23C877914E@common-lisp.net> Update of /project/slime/cvsroot/slime/contrib In directory clnet:/tmp/cvs-serv767/contrib Modified Files: ChangeLog Log Message: 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. --- /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/20 22:05:24 1.93 +++ /project/slime/cvsroot/slime/contrib/ChangeLog 2008/02/21 20:49:31 1.94 @@ -1,3 +1,12 @@ +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. From heller at common-lisp.net Fri Feb 22 14:09:00 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Feb 2008 09:09:00 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080222140900.A31FE7A01B@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv6889 Modified Files: ChangeLog slime.el Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/21 12:56:21 1.1294 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:09:00 1.1295 @@ -1,3 +1,12 @@ +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 Fix regressions in the `find-definition' test case on SBCL: --- /project/slime/cvsroot/slime/slime.el 2008/02/21 12:55:57 1.907 +++ /project/slime/cvsroot/slime/slime.el 2008/02/22 14:09:00 1.908 @@ -977,40 +977,6 @@ collect window until (eq window last-window))) - -(defmacro save-restriction-if-possible (&rest body) - "Very similiarly to `save-restriction'. The only difference is -that it's not enforcing the restriction as strictly: It's only -enforced if `point' was not moved outside of the restriction -after executing BODY. - -Example: - - (progn (goto-line 1000) - (narrow-to-page) - (save-restriction-if-possible (widen) (goto-line 999))) - - In this case, the buffer is narrowed to the current page, and - point is on line 999. - - (progn (goto-char 1000) - (narrow-to-page) - (save-restriction-if-possible (widen) (goto-line 1))) - - Whereas in this case, the buffer is widened and point is on - line 1." - (let ((gcfg (gensym "NARROWING-CFG+")) - (gbeg (gensym "OLDBEG+")) - (gend (gensym "OLDEND+"))) - `(let ((,gcfg (slime-current-narrowing-configuration))) - (unwind-protect (progn , at body) - (let ((,gbeg (slime-narrowing-configuration.beg ,gcfg)) - (,gend (slime-narrowing-configuration.end ,gcfg))) - (when (and (>= (point) ,gbeg) (<= (point) ,gend)) - (slime-set-narrowing-configuration ,gcfg))))))) - -(put 'save-restriction-if-possible 'lisp-indent-function 0) - ;;;;; Temporary popup buffers (make-variable-buffer-local @@ -4562,43 +4528,41 @@ (goto-char (point-min))))))) (defun slime-goto-location-position (position) - (save-restriction-if-possible ; try to keep restriction if possible. - (widen) - (destructure-case position - ((:position pos &optional align-p) - (goto-char pos) - (when align-p - (slime-forward-sexp) - (beginning-of-sexp))) - ((:line start &optional column) - (goto-line start) - (cond (column (move-to-column column)) - (t (skip-chars-forward " \t")))) - ((:function-name name) - (let ((case-fold-search t) - (name (regexp-quote name))) - (or - (re-search-forward - (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t) - (re-search-forward - (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t) - (re-search-forward - (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))) - (goto-char (match-beginning 0))) - ((:method name specializers &rest qualifiers) - (slime-search-method-location name specializers qualifiers)) - ((:source-path source-path start-position) - (cond (start-position - (goto-char start-position) - (slime-forward-positioned-source-path source-path)) - (t - (slime-forward-source-path source-path)))) - ;; Goes to "start" then looks for the anchor text, then moves - ;; delta from that position. - ((:text-anchored start text delta) - (goto-char start) - (slime-isearch text) - (forward-char delta))))) + (destructure-case position + ((:position pos &optional align-p) + (goto-char pos) + (when align-p + (slime-forward-sexp) + (beginning-of-sexp))) + ((:line start &optional column) + (goto-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (or + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t) + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t) + (re-search-forward + (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))) + (goto-char (match-beginning 0))) + ((:method name specializers &rest qualifiers) + (slime-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (slime-forward-positioned-source-path source-path)) + (t + (slime-forward-source-path source-path)))) + ;; Goes to "start" then looks for the anchor text, then moves + ;; delta from that position. + ((:text-anchored start text delta) + (goto-char start) + (slime-isearch text) + (forward-char delta)))) (defun slime-search-method-location (name specializers qualifiers) ;; Look for a sequence of words (def method name @@ -4656,16 +4620,28 @@ (destructure-case location ((:location buffer position hints) (slime-goto-location-buffer buffer) - (slime-goto-location-position position) - (when-let (snippet (getf hints :snippet)) - (slime-isearch snippet)) - (when-let (fname (getf hints :call-site)) - (slime-search-call-site fname))) + (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) + (slime-goto-location-position (slime-location.position location)) + (let ((hints (slime-location.hints location))) + (when-let (snippet (getf hints :snippet)) + (slime-isearch snippet)) + (when-let (fname (getf hints :call-site)) + (slime-search-call-site fname))) + (point))) + (defmacro slime-point-moves-p (&rest body) "Execute BODY and return true if the current buffer's point moved." (let ((pointvar (gensym "point-"))) @@ -5208,14 +5184,12 @@ (slime-goto-source-location location) (switch-to-buffer (current-buffer))) (window - (pop-to-buffer (current-buffer) t) (slime-goto-source-location location) - (switch-to-buffer (current-buffer))) + (pop-to-buffer (current-buffer) t)) (frame (let ((pop-up-frames t)) - (pop-to-buffer (current-buffer) t) (slime-goto-source-location location) - (switch-to-buffer (current-buffer)))))) + (pop-to-buffer (current-buffer) t))))) (defun slime-find-definitions (name cont) "Find definitions for NAME and pass them to CONT." From heller at common-lisp.net Fri Feb 22 14:10:38 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Feb 2008 09:10:38 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080222141038.C1A477A01C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7095 Modified Files: ChangeLog slime.el Log Message: * slime.el (slime-pop-to-location): Slight cleanups. (slime-goto-xref, slime-goto-next-xref): Use it. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:09:00 1.1295 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:10:36 1.1296 @@ -1,5 +1,10 @@ 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 --- /project/slime/cvsroot/slime/slime.el 2008/02/22 14:09:00 1.908 +++ /project/slime/cvsroot/slime/slime.el 2008/02/22 14:10:36 1.909 @@ -5179,17 +5179,11 @@ (format "%s (previously existing buffer)" bufname)))))) (defun slime-pop-to-location (location &optional where) + (slime-goto-source-location location) (ecase where - ((nil) - (slime-goto-source-location location) - (switch-to-buffer (current-buffer))) - (window - (slime-goto-source-location location) - (pop-to-buffer (current-buffer) t)) - (frame - (let ((pop-up-frames t)) - (slime-goto-source-location location) - (pop-to-buffer (current-buffer) t))))) + ((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-find-definitions (name cont) "Find definitions for NAME and pass them to CONT." @@ -6156,8 +6150,7 @@ (interactive) (let ((location (slime-xref-location-at-point))) (slime-xref-cleanup) - (slime-goto-source-location location) - (switch-to-buffer (current-buffer)))) + (slime-pop-to-location location))) (defun slime-show-xref () "Display the xref at point in the other window." @@ -6178,8 +6171,7 @@ (t (slime-xref-location-at-point)))))) (when location - (slime-goto-source-location location) - (switch-to-buffer (current-buffer))))) + (slime-pop-to-location location)))) (defun slime-next-location () "Go to the next location, depending on context. From heller at common-lisp.net Fri Feb 22 14:11:52 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Feb 2008 09:11:52 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080222141152.7F90123330@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv7159 Modified Files: ChangeLog swank-clisp.lisp Log Message: Fixes for CLISP 2.44. (Patch by Mark Harig.) * swank-clisp.lisp (sldb-backtrace, %parse-stack-values): sys::frame-up-1 no longer exists; use sys::frame-up instead. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:10:36 1.1296 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:11:52 1.1297 @@ -1,3 +1,10 @@ +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. --- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/09 18:47:05 1.67 +++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/02/22 14:11:52 1.68 @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- +;;;; -*- indent-tabs-mode: nil -*- ;;;; SWANK support for CLISP. @@ -249,6 +249,21 @@ (defvar *sldb-backtrace*) +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (string< "2.44" (lisp-implementation-version)) + (pushnew :clisp-2.44+ *features*))) + +(defun sldb-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) + #+clisp-2.44+ (sys::frame-up 1 frame 1) + #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames" + ((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) @@ -260,15 +275,6 @@ (defun nth-frame (index) (nth index *sldb-backtrace*)) -(defun sldb-backtrace () - "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." - (do ((frames '()) - (last nil frame) - (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames" - ((eq frame last) (nreverse frames)) - (unless (boring-frame-p frame) - (push frame frames)))) - (defun boring-frame-p (frame) (member (frame-type frame) '(stack-value bind-var bind-env))) @@ -276,6 +282,8 @@ (with-output-to-string (s) (sys::describe-frame s frame))) +;; FIXME: they changed the layout in 2.44 so the frame-to-string & +;; string-matching silliness no longer works. (defun frame-type (frame) ;; FIXME: should bind *print-length* etc. to small values. (frame-string-type (frame-to-string frame))) @@ -418,7 +426,9 @@ (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) (defun %parse-stack-values (frame) - (labels ((next (fp) (sys::frame-down-1 fp 1)) + (labels ((next (fp) + #+clisp-2.44+ (sys::frame-down 1 fp 1) + #-clisp-2.44+ (sys::frame-down-1 fp 1)) (parse (fp accu) (let ((str (frame-to-string fp))) (cond ((is-prefix-p "- " str) @@ -433,6 +443,8 @@ (t (parse (next fp) accu)))))) (parse (next frame) '()))) +(setq *features* (remove :clisp-2.44+ *features*)) + (defun is-prefix-p (pattern string) (not (mismatch pattern string :end2 (min (length pattern) (length string))))) From heller at common-lisp.net Fri Feb 22 14:24:53 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Feb 2008 09:24:53 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080222142453.694CB49114@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv11059 Modified Files: ChangeLog slime.el slime-autoloads.el Log Message: Fix typos: "contribs" -> "contrib". * slime-autoloads.el (slime-setup-contribs): * slime.el (slime-setup): --- /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:11:52 1.1297 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:24:52 1.1298 @@ -1,5 +1,12 @@ 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): --- /project/slime/cvsroot/slime/slime.el 2008/02/22 14:10:36 1.909 +++ /project/slime/cvsroot/slime/slime.el 2008/02/22 14:24:52 1.910 @@ -72,10 +72,7 @@ (when (member 'lisp-mode slime-lisp-modes) (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)) (when contribs - (pushnew (file-name-as-directory - (expand-file-name (concat slime-path "contribs"))) - load-path - :test 'string=) + (add-to-list 'load-path (expand-file-name "contrib" slime-path)) (dolist (c contribs) (require c) (let ((init (intern (format "%s-init" c)))) --- /project/slime/cvsroot/slime/slime-autoloads.el 2008/02/04 20:35:11 1.4 +++ /project/slime/cvsroot/slime/slime-autoloads.el 2008/02/22 14:24:52 1.5 @@ -40,10 +40,7 @@ (defun slime-setup-contribs () (when slime-setup-contribs - (pushnew (file-name-as-directory - (expand-file-name (concat slime-path "contribs"))) - load-path - :test 'string=) + (add-to-list 'load-path (expand-file-name "contrib" slime-path)) (dolist (c slime-setup-contribs) (require c) (let ((init (intern (format "%s-init" c)))) From heller at common-lisp.net Fri Feb 22 14:38:39 2008 From: heller at common-lisp.net (heller) Date: Fri, 22 Feb 2008 09:38:39 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080222143839.9636B56223@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13398 Modified Files: ChangeLog swank-abcl.lisp Log Message: * 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." (Patch from Mark Evenson.) --- /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:24:52 1.1298 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:38:39 1.1299 @@ -1,8 +1,15 @@ +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-autoloads.el (slime-setup-contribs): * slime.el (slime-setup): 2008-02-22 Mark Harig --- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/09 18:47:05 1.47 +++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/02/22 14:38:39 1.48 @@ -143,8 +143,7 @@ (funcall fn)) (defimplementation getpid () - (if (not (find :unix *features*)) - 0 + (handler-case (let* ((runtime (java:jstatic "getRuntime" "java.lang.Runtime")) (command @@ -153,8 +152,8 @@ (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.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") @@ -162,19 +161,19 @@ (process (java:jcall runtime-exec-jmethod runtime command)) (output - (java:jcall (java:jmethod "java.lang.Process" "getInputStream") + (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 - (values - (parse-integer (coerce result 'string)))))))) + (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") From trittweiler at common-lisp.net Fri Feb 22 15:19:37 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Fri, 22 Feb 2008 10:19:37 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080222151937.E97216D075@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv24933 Modified Files: ChangeLog Log Message: Fixing ChangeLog. I mistakenly commited revision 1.907 of slime.el without documentating the change. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/22 14:38:39 1.1299 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/22 15:19:37 1.1300 @@ -35,6 +35,13 @@ 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-21 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 From heller at common-lisp.net Sat Feb 23 10:26:50 2008 From: heller at common-lisp.net (heller) Date: Sat, 23 Feb 2008 05:26:50 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080223102650.CD95512064@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv14607 Modified Files: ChangeLog slime.el Log Message: Add customization variable for the `slime-connect' port. * slime.el (slime-port): New variable. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/22 15:19:37 1.1300 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/23 10:26:48 1.1301 @@ -1,3 +1,9 @@ +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. --- /project/slime/cvsroot/slime/slime.el 2008/02/22 14:24:52 1.910 +++ /project/slime/cvsroot/slime/slime.el 2008/02/23 10:26:49 1.911 @@ -209,6 +209,16 @@ :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) + ;;;;; slime-mode (defgroup slime-mode nil @@ -1134,9 +1144,6 @@ "*The name of the default Lisp implementation. See `slime-lisp-implementations'") -(defvar slime-lisp-host "127.0.0.1" - "The default hostname (or IP address) to connect to.") - ;; dummy definitions for the compiler (defvar slime-net-coding-system) (defvar slime-net-processes) @@ -1232,7 +1239,8 @@ (defun slime-connect (host port &optional coding-system) "Connect to a running Swank server." (interactive (list (read-from-minibuffer "Host: " slime-lisp-host) - (read-from-minibuffer "Port: " "4005" nil t))) + (read-from-minibuffer "Port: " (format "%d" slime-port) + nil t))) (when (and (interactive-p) slime-net-processes (y-or-n-p "Close old connections first? ")) (slime-disconnect)) From heller at common-lisp.net Sat Feb 23 10:28:01 2008 From: heller at common-lisp.net (heller) Date: Sat, 23 Feb 2008 05:28:01 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080223102801.971C27918E@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv14721 Modified Files: ChangeLog swank.lisp Log Message: In the inspector, show one-element lists as list not as pair. * swank.lisp (emacs-inspect cons) --- /project/slime/cvsroot/slime/ChangeLog 2008/02/23 10:26:48 1.1301 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/23 10:28:01 1.1302 @@ -1,3 +1,9 @@ +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. --- /project/slime/cvsroot/slime/swank.lisp 2008/02/20 22:12:37 1.534 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/23 10:28:01 1.535 @@ -2752,7 +2752,7 @@ ;;;;; Lists (defmethod emacs-inspect ((o cons)) - (if (consp (cdr o)) + (if (listp (cdr o)) (inspect-list o) (inspect-cons o))) From heller at common-lisp.net Sat Feb 23 10:29:07 2008 From: heller at common-lisp.net (heller) Date: Sat, 23 Feb 2008 05:29:07 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080223102907.EB3F970EB@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv14790 Modified Files: ChangeLog slime.el Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/23 10:28:01 1.1302 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/23 10:29:06 1.1303 @@ -1,3 +1,10 @@ +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. --- /project/slime/cvsroot/slime/slime.el 2008/02/23 10:26:49 1.911 +++ /project/slime/cvsroot/slime/slime.el 2008/02/23 10:29:06 1.912 @@ -1839,7 +1839,13 @@ (cond ((and (not conn) slime-net-processes) (error "No default connection selected.")) ((not conn) - (error "Not connected.")) + (cond ((y-or-n-p "No connection. Start Slime? ") + (save-window-excursion + (slime) + (while (not (slime-current-connection)) + (sleep-for 1)) + (slime-connection))) + (t (error "Not connected.")))) ((not (eq (process-status conn) 'open)) (error "Connection closed.")) (t conn)))) @@ -7791,10 +7797,7 @@ (def-slime-selector-method ?r "SLIME Read-Eval-Print-Loop." - (cond ((slime-current-connection) - (slime-output-buffer)) - ((y-or-n-p "No connection: start Slime? ") - (slime)))) + (slime-output-buffer)) (def-slime-selector-method ?i "*inferior-lisp* buffer." From heller at common-lisp.net Sun Feb 24 16:49:50 2008 From: heller at common-lisp.net (heller) Date: Sun, 24 Feb 2008 11:49:50 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080224164950.3909239167@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17262 Modified Files: ChangeLog swank.lisp Log Message: Allow ED-IN-EMACS to edit new files. * swank.lisp (ed-in-emacs): Make it possible to canonicalize filenames of non-existing files. (canonicalize-filename): Merged into ed-in-emacs. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/23 10:29:06 1.1303 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/24 16:49:49 1.1304 @@ -1,3 +1,11 @@ +2008-02-23 Ariel Badichi + + Allow ED-IN-EMACS to edit new files. + + * swank.lisp (ed-in-emacs): Make it possible to canonicalize + filenames of 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. --- /project/slime/cvsroot/slime/swank.lisp 2008/02/23 10:28:01 1.535 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/24 16:49:49 1.536 @@ -1855,7 +1855,9 @@ Returns true if it actually called emacs, or NIL if not." (flet ((pathname-or-string-p (thing) - (or (pathnamep thing) (typep thing 'string)))) + (or (pathnamep thing) (typep thing 'string))) + (canonicalize-filename (filename) + (namestring (or (probe-file filename) filename)))) (let ((target (cond ((and (listp what) (pathname-or-string-p (first what))) (cons (canonicalize-filename (car what)) (cdr what))) @@ -2166,9 +2168,6 @@ (defun clear-compiler-notes () (setf *compiler-notes* '())) -(defun canonicalize-filename (filename) - (namestring (truename filename))) - (defslimefun compiler-notes-for-emacs () "Return the list of compiler notes for the last compilation unit." (reverse *compiler-notes*)) From heller at common-lisp.net Sun Feb 24 16:50:48 2008 From: heller at common-lisp.net (heller) Date: Sun, 24 Feb 2008 11:50:48 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080224165048.6F62C601A9@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv17459 Modified Files: ChangeLog slime.el Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/24 16:49:49 1.1304 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/24 16:50:47 1.1305 @@ -1,9 +1,17 @@ +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): Make it possible to canonicalize - filenames of non-existing files. + * swank.lisp (ed-in-emacs): Accept non-existing files. (canonicalize-filename): Merged into ed-in-emacs. 2008-02-23 Nikodemus Siivola --- /project/slime/cvsroot/slime/slime.el 2008/02/23 10:29:06 1.912 +++ /project/slime/cvsroot/slime/slime.el 2008/02/24 16:50:48 1.913 @@ -3281,11 +3281,10 @@ (defun slime-repl-set-package (package) "Set the package of the REPL buffer to PACKAGE." - (interactive (list (slime-read-package-name - "Package: " - (if (equal (slime-current-package) (slime-lisp-package)) - nil - (slime-pretty-find-buffer-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 ((unfinished-input (slime-repl-current-input))) (destructuring-bind (name prompt-string) @@ -5201,7 +5200,8 @@ ;; FIXME: append SWANK xrefs and etags xrefs (funcall cont (or (slime-eval `(swank:find-definitions-for-emacs ,name)) - (funcall slime-edit-definition-fallback-function name)))) + (and slime-edit-definition-fallback-function + (funcall slime-edit-definition-fallback-function name))))) (defun slime-find-tag-if-tags-table-visited (name) "Find tag (in current tags table) whose name contains NAME. From heller at common-lisp.net Mon Feb 25 17:17:58 2008 From: heller at common-lisp.net (heller) Date: Mon, 25 Feb 2008 12:17:58 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080225171758.4E7AC340A3@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv31496 Modified Files: ChangeLog swank-loader.lisp swank.asd swank.lisp Log Message: 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/24 16:50:47 1.1305 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/25 17:17:56 1.1306 @@ -1,3 +1,16 @@ +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. --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/20 22:10:38 1.81 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/25 17:17:56 1.82 @@ -20,8 +20,7 @@ (cl:defpackage :swank-loader (:use :cl) - (:export :load-swank - :init + (:export :init :*source-directory* :*fasl-directory*)) @@ -32,21 +31,18 @@ :defaults (or *load-pathname* *default-pathname-defaults*)) "The directory where to look for the source.") -(defparameter *sysdep-files* - (append - '() - #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl") - #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl") - #+sbcl '("swank-source-path-parser" "swank-source-file-cache" - "swank-sbcl" "swank-gray") - #+openmcl '("metering" "swank-openmcl" "swank-gray") - #+lispworks '("swank-lispworks" "swank-gray") - #+allegro '("swank-allegro" "swank-gray") - #+clisp '("xref" "metering" "swank-clisp" "swank-gray") - #+armedbear '("swank-abcl") - #+cormanlisp '("swank-corman" "swank-gray") - #+ecl '("swank-ecl" "swank-gray") - )) +(defparameter *sysdeps* + #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl) + #+scl '(swank-source-path-parser swank-source-file-cache swank-scl) + #+sbcl '(swank-source-path-parser swank-source-file-cache + swank-sbcl swank-gray) + #+openmcl '(metering swank-openmcl swank-gray) + #+lispworks '(swank-lispworks swank-gray) + #+allegro '(swank-allegro swank-gray) + #+clisp '(xref metering swank-clisp swank-gray) + #+armedbear '(swank-abcl) + #+cormanlisp '(swank-corman swank-gray) + #+ecl '(swank-ecl swank-gray)) (defparameter *implementation-features* '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp @@ -183,12 +179,7 @@ :defaults src-dir)) names)) -(defun swank-src-files (src-dir) - (src-files `("swank-backend" ,@*sysdep-files* "swank") - src-dir)) - -(defvar *fasl-directory* (default-fasl-dir) - "The directory where fasl files should be placed.") +(defvar *swank-files* `(swank-backend ,@*sysdep-files* swank)) (defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy swank-fancy-inspector @@ -197,6 +188,9 @@ ) "List of names for contrib modules.") +(defvar *fasl-directory* (default-fasl-dir) + "The directory where fasl files should be placed.") + (defun append-dir (absolute name) (merge-pathnames (make-pathname :directory `(:relative ,name) :defaults absolute) @@ -207,11 +201,16 @@ (defun load-swank (&key (src-dir *source-directory*) (fasl-dir *fasl-directory*)) - (compile-files (swank-src-files src-dir) fasl-dir t)) + (compile-files (src-files *swank-files* src-dir) fasl-dir t)) (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*)) - (fasl-dir (contrib-dir *fasl-directory*))) - (compile-files (src-files *contribs* src-dir) fasl-dir nil)) + (fasl-dir (contrib-dir *fasl-directory*)) + load) + (compile-files (src-files *contribs* src-dir) fasl-dir load)) + +(defun loadup () + (load-swank) + (compile-contribs :load t)) (defun setup () (flet ((q (s) (read-from-string s))) @@ -223,11 +222,14 @@ (list (contrib-dir *fasl-directory*) (contrib-dir *source-directory*))))) -(defun init (&key delete reload) +(defun init (&key delete reload load-contribs (setup t)) (when (and delete (find-package :swank)) (mapc #'delete-package '(:swank :swank-io-package :swank-backend))) (cond ((or (not (find-package :swank)) reload) (load-swank)) (t (warn "Not reloading SWANK. Package already exists."))) - (setup)) + (when load-contribs + (compile-contribs :load t)) + (when setup + (setup))) --- /project/slime/cvsroot/slime/swank.asd 2008/02/17 12:28:27 1.6 +++ /project/slime/cvsroot/slime/swank.asd 2008/02/25 17:17:56 1.7 @@ -37,7 +37,8 @@ (load (asdf::component-pathname f)) (funcall (read-from-string "swank-loader::init") :reload (asdf::operation-forced o) - :delete (asdf::operation-forced o))) + :delete (asdf::operation-forced o) + :setup nil)) (asdf:defsystem :swank :default-component-class swank-loader-file --- /project/slime/cvsroot/slime/swank.lisp 2008/02/24 16:49:49 1.536 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/25 17:17:56 1.537 @@ -587,9 +587,9 @@ (initialize-multiprocessing (lambda () (spawn (lambda () - (loop do (ignore-errors (serve)) while dont-close)) - :name (concatenate 'string "Swank " - (princ-to-string port)))))) + (cond ((not dont-close) (serve)) + (t (loop (ignore-errors (serve)))))) + :name (cat "Swank " (princ-to-string port)))))) ((:fd-handler :sigio) (add-fd-handler socket (lambda () (serve)))) ((nil) (loop do (serve) while dont-close))) @@ -1210,7 +1210,8 @@ (defun init-global-stream-redirection () (when *globally-redirect-io* - (mapc #'setup-stream-indirection + (assert (not *saved-global-streams*) () "Streams already redirected.") + (mapc #'setup-stream-indirection (append *standard-output-streams* *standard-input-streams* *standard-io-streams*)))) From heller at common-lisp.net Mon Feb 25 17:23:00 2008 From: heller at common-lisp.net (heller) Date: Mon, 25 Feb 2008 12:23:00 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080225172300.7F61A3001A@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv3057 Modified Files: swank-loader.lisp Log Message: Fix typo. --- /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/25 17:17:56 1.82 +++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/02/25 17:23:00 1.83 @@ -31,7 +31,7 @@ :defaults (or *load-pathname* *default-pathname-defaults*)) "The directory where to look for the source.") -(defparameter *sysdeps* +(defparameter *sysdep-files* #+cmu '(swank-source-path-parser swank-source-file-cache swank-cmucl) #+scl '(swank-source-path-parser swank-source-file-cache swank-scl) #+sbcl '(swank-source-path-parser swank-source-file-cache From trittweiler at common-lisp.net Thu Feb 28 19:37:35 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 28 Feb 2008 14:37:35 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080228193735.38B35111DC@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13165 Modified Files: ChangeLog Log Message: This change has been advertized in the Changelog on 2008-02-21. But it was in fact never committed. 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. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/25 17:17:56 1.1306 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/28 19:37:34 1.1307 @@ -1,3 +1,24 @@ +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. @@ -87,28 +108,7 @@ (slime-analyze-xrefs): Use it; display definitions defined interactively via C-c C-c as comming from # instead of foo.lisp. - -2008-02-21 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-20 Helmut Eller Better factorization for M-. and xref commands. From trittweiler at common-lisp.net Thu Feb 28 19:37:57 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 28 Feb 2008 14:37:57 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080228193757.9FF6F53019@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv13219 Modified Files: swank-sbcl.lisp Log Message: This change has been advertized in the Changelog on 2008-02-21. But it was in fact never committed. 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. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/09 18:47:05 1.191 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/28 19:37:57 1.192 @@ -525,7 +525,7 @@ `(:position ,(+ pos emacs-position)) `(:snippet ,snippet)))) ((not pathname) - `(:error ,(format nil "Source of ~A ~A not found" + `(:error ,(format nil "Source definition of ~A ~A not found" (string-downcase type) name))) (t (let* ((namestring (namestring (translate-logical-pathname pathname))) @@ -533,7 +533,9 @@ character-offset)) (snippet (source-hint-snippet namestring file-write-date pos))) (make-location `(:file ,namestring) - `(:position ,pos) + ;; /file positions/ in Common Lisp start + ;; from 0, in Emacs they start from 1. + `(:position ,(1+ pos)) `(:snippet ,snippet)))))))) (defun string-path-snippet (string form-path position) @@ -551,10 +553,10 @@ (defun source-file-position (filename write-date form-path character-offset) (let ((source (get-source-code filename write-date)) (*readtable* (guess-readtable-for-filename filename))) - (1+ (with-debootstrapping - (if form-path - (source-path-string-position form-path source) - (or character-offset 0)))))) + (with-debootstrapping + (if form-path + (source-path-string-position form-path source) + (or character-offset 0))))) (defun source-hint-snippet (filename write-date position) (let ((source (get-source-code filename write-date))) From trittweiler at common-lisp.net Thu Feb 28 19:43:59 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 28 Feb 2008 14:43:59 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080228194359.44E555F079@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16242 Modified Files: swank.lisp Log Message: * 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='. --- /project/slime/cvsroot/slime/swank.lisp 2008/02/25 17:17:56 1.537 +++ /project/slime/cvsroot/slime/swank.lisp 2008/02/28 19:43:58 1.538 @@ -2584,6 +2584,9 @@ ;;;; Source Locations +(defslimefun find-definition-for-thing (thing) + (find-source-location thing)) + (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." From trittweiler at common-lisp.net Thu Feb 28 19:44:14 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 28 Feb 2008 14:44:14 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080228194414.BB7195301C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16318 Modified Files: swank-sbcl.lisp Log Message: * 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='. --- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/28 19:37:57 1.192 +++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/02/28 19:44:14 1.193 @@ -494,6 +494,32 @@ (make-source-location-specification type name source-location)))) +(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) + (structure-object :structure-object) + (standard-object :standard-object) + (condition :condition) + (t :thing))) + (to-string (obj) + (typecase obj + ((or structure-object standard-object condition) + (with-output-to-string (s) + (print-unreadable-object (obj s :type t :identity t)))) + (t (format nil "~A" obj))))) + (handler-case + (make-definition-source-location + (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj)) + (error (e) + (list :error (format nil "Error: ~A" e)))))) + + (defun make-source-location-specification (type name source-location) (list (list* (getf *definition-types* type) name From trittweiler at common-lisp.net Thu Feb 28 19:44:29 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 28 Feb 2008 14:44:29 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080228194429.7AABA5832C@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16355 Modified Files: swank-backend.lisp Log Message: * 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='. --- /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/09 18:47:05 1.129 +++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/02/28 19:44:29 1.130 @@ -745,11 +745,25 @@ 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 _ source location and not a list of locations. It's + ;; supposed to return the location of the DEFGENERIC definition on + ;; #'SOME-GENERIC-FUNCTION. + ) + + (definterface buffer-first-change (filename) "Called for effect the first time FILENAME's buffer is modified." (declare (ignore filename)) nil) + ;;;; XREF From trittweiler at common-lisp.net Thu Feb 28 19:45:32 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 28 Feb 2008 14:45:32 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080228194532.430C2601AD@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16501 Modified Files: slime.el Log Message: * 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='. --- /project/slime/cvsroot/slime/slime.el 2008/02/24 16:50:48 1.913 +++ /project/slime/cvsroot/slime/slime.el 2008/02/28 19:45:32 1.914 @@ -2935,7 +2935,7 @@ (cond ((null strings) (slime-repl-emit-result "; No value\n" t)) (t - (dolist (s strings) + (dolist (s strings) (slime-repl-emit-result s t))))))) (slime-repl-insert-prompt))) @@ -5155,7 +5155,7 @@ (1loc (slime-push-definition-stack) (slime-pop-to-location (slime-xref.location (car xrefs)) where)) - ((= (length xrefs) 1) + ((slime-length= xrefs 1) ; ((:error "...")) (error "%s" (cadr (slime-xref.location (car xrefs))))) (t (slime-push-definition-stack) From trittweiler at common-lisp.net Thu Feb 28 19:46:13 2008 From: trittweiler at common-lisp.net (trittweiler) Date: Thu, 28 Feb 2008 14:46:13 -0500 (EST) Subject: [slime-cvs] CVS slime Message-ID: <20080228194613.661DD12067@common-lisp.net> Update of /project/slime/cvsroot/slime In directory clnet:/tmp/cvs-serv16544 Modified Files: ChangeLog Log Message: * 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='. --- /project/slime/cvsroot/slime/ChangeLog 2008/02/28 19:37:34 1.1307 +++ /project/slime/cvsroot/slime/ChangeLog 2008/02/28 19:46:13 1.1308 @@ -1,3 +1,13 @@ +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: