From sboukarev at common-lisp.net  Tue Dec  1 08:36:12 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 01 Dec 2009 03:36:12 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NFODU-0006vR-JN@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv26622/contrib

Modified Files:
	ChangeLog swank-asdf.lisp 
Log Message:
* contrib/swank-asdf.lisp (asdf-system-files): Include the .asd file too.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/11/30 14:47:40	1.290
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/01 08:36:12	1.291
@@ -1,3 +1,7 @@
+2009-12-01  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-asdf.lisp (asdf-system-files): Include the .asd file too.
+
 2009-11-30  Helmut Eller  <heller at common-lisp.net>
 
 	* slime-repl.el (slime-repl-mode-map): Don't copy
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/11/23 12:23:35	1.15
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/01 08:36:12	1.16
@@ -77,13 +77,16 @@
           (asdf:module-components module)))
 
 (defslimefun asdf-system-files (name)
-  (let* ((files (mapcar #'namestring
-                        (asdf-module-files (asdf:find-system name))))
+  (let* ((system (asdf:find-system name))
+         (files (mapcar #'namestring
+                        (cons
+                         (asdf:system-definition-pathname system)
+                         (asdf-module-files system))))
          (main-file (find name files
-                          :test #'string-equal
-                          :key #'pathname-name)))
+                          :test #'equalp :key #'pathname-name :start 1)))
     (if main-file
-        (cons main-file (remove main-file files :test #'equalp))
+        (cons main-file (remove main-file files
+                                :test #'equal :count 1))
         files)))
 
 (defslimefun asdf-system-loaded-p (name)




From sboukarev at common-lisp.net  Tue Dec  1 08:52:20 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 01 Dec 2009 03:52:20 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NFOT6-00081B-5a@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv30821/contrib

Modified Files:
	ChangeLog swank-asdf.lisp 
Log Message:
contrib/swan-asdf.lisp:
(asdf-system-files): Include the .asd file too.
(asdf-module-files): Include non-cl files too.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/01 08:36:12	1.291
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/01 08:52:20	1.292
@@ -1,6 +1,7 @@
 2009-12-01  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-asdf.lisp (asdf-system-files): Include the .asd file too.
+	(asdf-module-files): Include non-cl files too.
 
 2009-11-30  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/01 08:36:12	1.16
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/01 08:52:20	1.17
@@ -70,7 +70,7 @@
 (defun asdf-module-files (module)
   (mapcan (lambda (component)
             (typecase component
-              (asdf:cl-source-file
+              (asdf:source-file
                (list (asdf:component-pathname component)))
               (asdf:module
                (asdf-module-files component))))




From sboukarev at common-lisp.net  Wed Dec  2 17:34:37 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 02 Dec 2009 12:34:37 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NFt65-0004Yv-QX@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv17496

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
swan-sbcl.lisp(frame-locals): `frame-debug-vars' can return NIL,
so check before using it as a vector.
Patch by Nathan Bird.


--- /project/slime/cvsroot/slime/ChangeLog	2009/11/30 14:47:49	1.1925
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/02 17:34:37	1.1926
@@ -1,3 +1,9 @@
+2009-12-02  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-sbcl.lisp (frame-locals): `frame-debug-vars' can return NIL,
+	so check before using it as a vector.
+	Patch by Nathan Bird.
+
 2009-11-30  Helmut Eller  <heller at common-lisp.net>
 
 	Add a slime-editing-map as suggested by Attila Lendvai.  The main
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/11/21 21:32:57	1.255
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/02 17:34:37	1.256
@@ -1142,10 +1142,11 @@
   (let* ((frame (nth-frame index))
 	 (loc (sb-di:frame-code-location frame))
 	 (vars (frame-debug-vars frame)))
-    (loop for v across vars collect
-          (list :name (sb-di:debug-var-symbol v)
-                :id (sb-di:debug-var-id v)
-                :value (debug-var-value v frame loc)))))
+    (when vars
+      (loop for v across vars collect
+            (list :name (sb-di:debug-var-symbol v)
+                  :id (sb-di:debug-var-id v)
+                  :value (debug-var-value v frame loc))))))
 
 (defimplementation frame-var-value (frame var)
   (let* ((frame (nth-frame frame))




From trittweiler at common-lisp.net  Thu Dec  3 12:46:12 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 03 Dec 2009 07:46:12 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NGB4W-0004IK-Q1@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv16508/contrib

Modified Files:
	ChangeLog slime-asdf.el 
Log Message:
	* slime-asdf.el (slime-query-replace-regexp): Quote `from'
	argument because `tags-query-replace' actually uses
	`query-replace-regexp' internally.

	Reported by David O'Toole.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/01 08:52:20	1.292
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/03 12:46:12	1.293
@@ -1,3 +1,11 @@
+2009-12-03  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-asdf.el (slime-query-replace-regexp): Quote `from'
+	argument because `tags-query-replace' actually uses
+	`query-replace-regexp' internally.
+
+	Reported by David O'Toole.
+
 2009-12-01  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-asdf.lisp (asdf-system-files): Include the .asd file too.
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/11/23 21:48:52	1.18
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/03 12:46:12	1.19
@@ -161,7 +161,9 @@
           (common (query-replace-read-args 
                    (format "Query replace throughout `%s'" system) t t)))
      (list system (nth 0 common) (nth 1 common) (nth 2 common))))
-  (tags-query-replace from to delimited 
+  ;; `tags-query-replace' actually uses `query-replace-regexp'
+  ;; internally.
+  (tags-query-replace (regexp-quote from) to delimited
 		      '(slime-eval `(swank:asdf-system-files ,name))))
 
 




From trittweiler at common-lisp.net  Thu Dec  3 15:36:59 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 03 Dec 2009 10:36:59 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NGDjn-0001br-Fp@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv6186/contrib

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
	* swank-arglists.lisp (arglist-available-p): New helper.
	(arglist-dispatch [eql 'declaim]): New.
	(arglist-dispatch [eql 'declare]): First try to lookup arglist of
	a typespec if it's a type-declaration, if not default to looking
	up arglist of declaration specifier.
	(arglist-for-type-declaration): Extracted out.
	(decoded-arglist-for-type-specifier): Make sure not to call
	TYPE-SPECIFIER-ARGLIST with an ARGLIST-DUMMY.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/03 12:46:12	1.293
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/03 15:36:59	1.294
@@ -1,5 +1,16 @@
 2009-12-03  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-arglists.lisp (arglist-available-p): New helper.
+	(arglist-dispatch [eql 'declaim]): New.
+	(arglist-dispatch [eql 'declare]): First try to lookup arglist of
+	a typespec if it's a type-declaration, if not default to looking
+	up arglist of declaration specifier.
+	(arglist-for-type-declaration): Extracted out.
+	(decoded-arglist-for-type-specifier): Make sure not to call
+	TYPE-SPECIFIER-ARGLIST with an ARGLIST-DUMMY.
+
+2009-12-03  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-asdf.el (slime-query-replace-regexp): Quote `from'
 	argument because `tags-query-replace' actually uses
 	`query-replace-regexp' internally.
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/11/24 13:17:00	1.43
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/03 15:36:59	1.44
@@ -68,7 +68,7 @@
   (or (fboundp symbol)
       (macro-function symbol)
       (special-operator-p symbol)
-      (eq symbol 'declare)))
+      (member symbol '(declare declaim))))
 
 (defun valid-operator-name-p (string)
   "Is STRING the name of a function, macro, or special-operator?"
@@ -95,11 +95,14 @@
               (values-list values)
               (multiple-value-or , at rest))))))
 
+(defun arglist-available-p (arglist)
+  (not (eql arglist :not-available)))
+
 (defmacro with-available-arglist ((var &rest more-vars) form &body body)
   `(multiple-value-bind (,var , at more-vars) ,form
      (if (eql ,var :not-available)
          :not-available
-         (progn #+ignore (assert (arglist-p ,var)) , at body))))
+         (progn , at body))))
 
 
 ;;;; Arglist Definition
@@ -1008,7 +1011,28 @@
 
 
 (defmethod arglist-dispatch ((operator (eql 'declare)) arguments)
-  (flet ((arglist-for-type-declaration (identifier typespec rest-var-name)
+  (let* ((declaration      (cons operator (last arguments)))
+         (typedecl-arglist (arglist-for-type-declaration declaration)))
+    (if (arglist-available-p typedecl-arglist)
+        typedecl-arglist
+        (match declaration
+          (('declare ((#'consp typespec) . decl-args)) 
+           (with-available-arglist (typespec-arglist) 
+               (decoded-arglist-for-type-specifier typespec)
+             (make-arglist
+              :required-args (list (make-arglist
+                                    :required-args (list typespec-arglist)
+                                    :rest '#:vars)))))
+          (('declare (decl-identifier . decl-args))
+           (decoded-arglist-for-declaration decl-identifier decl-args))
+          (_ (make-arglist :rest '#:declaration-specifiers))))))
+
+(defmethod arglist-dispatch ((operator (eql 'declaim)) arguments)
+  (arglist-dispatch 'declare arguments))
+
+
+(defun arglist-for-type-declaration (declaration)
+  (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name)
            (with-available-arglist (typespec-arglist) 
                (decoded-arglist-for-type-specifier typespec)
              (make-arglist 
@@ -1016,11 +1040,11 @@
                                     :provided-args (list identifier)
                                     :required-args (list typespec-arglist)
                                     :rest rest-var-name))))))
-    (match (cons operator (last arguments))
+    (match declaration
       (('declare ('type (#'consp typespec) . decl-args)) 
-       (arglist-for-type-declaration 'type typespec '#:variables))
+       (%arglist-for-type-declaration 'type typespec '#:variables))
       (('declare ('ftype (#'consp typespec) . decl-args)) 
-       (arglist-for-type-declaration 'ftype typespec '#:function-names))
+       (%arglist-for-type-declaration 'ftype typespec '#:function-names))
       (('declare ((#'consp typespec) . decl-args)) 
        (with-available-arglist (typespec-arglist) 
            (decoded-arglist-for-type-specifier typespec)
@@ -1028,9 +1052,7 @@
           :required-args (list (make-arglist
                                 :required-args (list typespec-arglist)
                                 :rest '#:vars)))))
-      (('declare (decl-identifier . decl-args))
-       (decoded-arglist-for-declaration decl-identifier decl-args))
-      (_ (make-arglist :rest '#:declaration-specifiers)))))
+      (_ :not-available))))
 
 (defun decoded-arglist-for-declaration (decl-identifier decl-args)
   (declare (ignore decl-args))
@@ -1040,12 +1062,14 @@
     (make-arglist :required-args (list arglist))))
 
 (defun decoded-arglist-for-type-specifier (type-specifier)
-  (when (consp type-specifier)
-    (setq type-specifier (car type-specifier)))
-    (with-available-arglist (arglist)
-      (decode-arglist (type-specifier-arglist type-specifier))
-    (setf (arglist.provided-args arglist) (list type-specifier))
-    arglist))
+  (etypecase type-specifier
+    (arglist-dummy :not-available)
+    (cons (decoded-arglist-for-type-specifier (car type-specifier)))
+    (symbol
+     (with-available-arglist (arglist)
+         (decode-arglist (type-specifier-arglist type-specifier))
+       (setf (arglist.provided-args arglist) (list type-specifier))
+       arglist))))
 
 
 ;;; Slimefuns
@@ -1083,11 +1107,19 @@
 ;;; %CURSOR-MARKER%)). Only the forms up to point should be
 ;;; considered.
 
+(defvar *swank-debug-arglists* nil)
+
 (defslimefun arglist-for-echo-area (raw-form &key print-right-margin print-lines)
   "Return a string representing the arglist for the deepest subform in
 RAW-FORM that does have an arglist. The highlighted parameter is
 wrapped in ===> X <===."
-  (handler-case
+  (handler-bind ((serious-condition
+                  #'(lambda (c)
+                      (unless *swank-debug-arglists*
+                        (let ((*print-right-margin* print-right-margin)
+                              (*print-lines* print-lines))
+                          (return-from arglist-for-echo-area
+                            (format nil "Arglist Error: \"~A\"" c)))))))
       (with-buffer-syntax ()
         (multiple-value-bind (form arglist)
             (find-subform-with-arglist (parse-raw-form raw-form))
@@ -1098,11 +1130,7 @@
                :print-right-margin print-right-margin
                :print-lines print-lines
                :operator operator
-               :highlight (arglist-path-to-parameter arglist args))))))
-    (serious-condition (c)
-      (let ((*print-right-margin* print-right-margin)
-            (*print-lines* print-lines))
-        (format nil "Arglist Error: \"~A\"" c)))))
+               :highlight (arglist-path-to-parameter arglist args))))))))
 
 (defslimefun complete-form (raw-form)
   "Read FORM-STRING in the current buffer package, then complete it
@@ -1191,7 +1219,7 @@
                                    (yield form local-ops)))
                ;; Some typespecs clash with function names, so we make
                ;; sure to bail out early.
-               ((eq operator 'cl:declare)
+               ((member operator '(cl:declare cl:declaim))
                 (yield form local-ops))
                ;; Mostly uninteresting, hence skip.
                ((memq operator '(cl:quote cl:function))




From trittweiler at common-lisp.net  Thu Dec  3 15:41:05 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 03 Dec 2009 10:41:05 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NGDnl-0002Fs-R7@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv8548

Modified Files:
	ChangeLog slime.el swank-loader.lisp 
Log Message:
	* slime.el (slime-documentation-lookup-function): New hook,
	defaults to `slime-hyperspec-lookup'.
	(slime-documentation-lookup): Invoke hook.
	(slime-prefix-bindings): Bind `C-c C-d h' to it.

	* slime-hyperdoc.el, swank-hyperdoc.lisp: New contrib.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/02 17:34:37	1.1926
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/03 15:41:05	1.1927
@@ -1,3 +1,10 @@
+2009-12-03  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (slime-documentation-lookup-function): New hook,
+	defaults to `slime-hyperspec-lookup'.
+	(slime-documentation-lookup): Invoke hook.
+	(slime-prefix-bindings): Bind `C-c C-d h' to it.
+
 2009-12-02  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-sbcl.lisp (frame-locals): `frame-debug-vars' can return NIL,
--- /project/slime/cvsroot/slime/slime.el	2009/11/30 14:47:39	1.1253
+++ /project/slime/cvsroot/slime/slime.el	2009/12/03 15:41:05	1.1254
@@ -564,7 +564,7 @@
     (?p slime-apropos-package)
     (?d slime-describe-symbol)
     (?f slime-describe-function)
-    (?h slime-hyperspec-lookup)
+    (?h slime-documentation-lookup)
     (?~ common-lisp-hyperspec-format)
     (?# common-lisp-hyperspec-lookup-reader-macro)))
   
@@ -4528,6 +4528,14 @@
 
 ;;;; Documentation
 
+(defvar slime-documentation-lookup-function 
+  'slime-hyperspec-lookup)
+
+(defun slime-documentation-lookup ()
+  "Generalized documentation lookup. Defaults to hyperspec lookup."
+  (interactive)
+  (call-interactively slime-documentation-lookup-function))
+
 (defun slime-hyperspec-lookup (symbol-name)
   "A wrapper for `hyperspec-lookup'"
   (interactive (list (let* ((symbol-at-point (slime-symbol-at-point))
@@ -6895,6 +6903,7 @@
        [ "Reset Counters"          slime-profile-reset ,C ])
       ("Documentation"
        [ "Describe Symbol..."      slime-describe-symbol ,C ]
+       [ "Lookup Documentation..." slime-documentation-lookup t ]
        [ "Apropos..."              slime-apropos ,C ]
        [ "Apropos all..."          slime-apropos-all ,C ]
        [ "Apropos Package..."      slime-apropos-package ,C ]
@@ -6961,7 +6970,7 @@
                 (slime-next-note "Next compiler note")
                 (slime-previous-note "Previous compiler note")
                 (slime-remove-notes "Remove notes")
-                slime-hyperspec-lookup))
+                slime-documentation-lookup))
     (:title "Completion"
      :map slime-mode-map
      :bindings (slime-indent-and-complete-symbol
--- /project/slime/cvsroot/slime/swank-loader.lisp	2009/10/31 22:13:55	1.95
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2009/12/03 15:41:05	1.96
@@ -189,6 +189,7 @@
                      swank-presentations swank-presentation-streams
                      #+(or asdf sbcl) swank-asdf
                      swank-package-fu
+                     swank-hyperdoc
                      swank-sbcl-exts
                      )
   "List of names for contrib modules.")




From trittweiler at common-lisp.net  Thu Dec  3 15:41:06 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 03 Dec 2009 10:41:06 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NGDnm-0002GF-3g@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv8548/contrib

Modified Files:
	ChangeLog 
Log Message:
	* slime.el (slime-documentation-lookup-function): New hook,
	defaults to `slime-hyperspec-lookup'.
	(slime-documentation-lookup): Invoke hook.
	(slime-prefix-bindings): Bind `C-c C-d h' to it.

	* slime-hyperdoc.el, swank-hyperdoc.lisp: New contrib.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/03 15:36:59	1.294
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/03 15:41:06	1.295
@@ -1,5 +1,11 @@
 2009-12-03  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	http://common-lisp.net/project/hyperdoc/
+
+	* slime-hyperdoc.el, swank-hyperdoc.lisp: New contrib.
+
+2009-12-03  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank-arglists.lisp (arglist-available-p): New helper.
 	(arglist-dispatch [eql 'declaim]): New.
 	(arglist-dispatch [eql 'declare]): First try to lookup arglist of




From trittweiler at common-lisp.net  Thu Dec  3 15:54:49 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 03 Dec 2009 10:54:49 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NGE13-0002kS-GB@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv10564/contrib

Added Files:
	slime-hyperdoc.el swank-hyperdoc.lisp 
Log Message:
oops forgot to commit added files



--- /project/slime/cvsroot/slime/contrib/slime-hyperdoc.el	2009/12/03 15:54:49	NONE
+++ /project/slime/cvsroot/slime/contrib/slime-hyperdoc.el	2009/12/03 15:54:49	1.1

;;; TODO: `url-http-file-exists-p' is slow, make it optional behaviour.

(require 'url-http)
(require 'browse-url)

(defun slime-hyperdoc-lookup-rpc (symbol-name)
  (slime-eval-async `(swank:hyperdoc ,symbol-name)
    (lexical-let ((symbol-name symbol-name))
      #'(lambda (result)
          (slime-log-event result)
          (loop with foundp = nil
                for (doc-type . url) in result do
                (when (and url (stringp url)
                           (let ((url-show-status nil))
                             (url-http-file-exists-p url)))
                  (message "Visiting documentation for %s `%s'..."
                           (substring (symbol-name doc-type) 1)
                           symbol-name)
                  (browse-url url)
                  (setq foundp t))
                finally
                (unless foundp
                  (error "Could not find documentation for `%s'." 
                         symbol-name)))))))

(defun slime-hyperdoc-lookup (symbol-name)
  (interactive (list (slime-read-symbol-name "Symbol: ")))
  (if (memq :hyperdoc (slime-lisp-features))
      (slime-hyperdoc-lookup-rpc symbol-name)
      (slime-hyperspec-lookup symbol-name)))

(defvar slime-old-documentation-lookup-function 
  slime-documentation-lookup-function)

(defun slime-hyperdoc-init ()
  (slime-require :swank-hyperdoc)
  (setq slime-documentation-lookup-function 'slime-hyperdoc-lookup))

(defun slime-hyperdoc-unload ()
  (setq slime-documentation-lookup-function 
        slime-old-documentation-lookup-function))

(provide 'slime-hyperdoc)--- /project/slime/cvsroot/slime/contrib/swank-hyperdoc.lisp	2009/12/03 15:54:49	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-hyperdoc.lisp	2009/12/03 15:54:49	1.1
(in-package :swank)

(defslimefun hyperdoc (string)
  (let ((hyperdoc-package (find-package :hyperdoc)))
    (when hyperdoc-package
      (multiple-value-bind (symbol foundp symbol-name package)
          (parse-symbol string *buffer-package*)
        (declare (ignore symbol))
        (when foundp
          (funcall (find-symbol (string :lookup) hyperdoc-package)
                   (package-name (if (member package (cons *buffer-package*
                                                           (package-use-list
                                                            *buffer-package*)))
                                     *buffer-package*
                                     package))
                   symbol-name))))))



From sboukarev at common-lisp.net  Fri Dec  4 01:15:23 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 03 Dec 2009 20:15:23 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NGMlX-0005Ap-DV@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv19873/contrib

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
contrib/swank-arglists.lisp(find-subform-with-arglist): Return
 (values nil :not-available), not just NIL, when operator is
`quote' or `function'.
Fixes bug reported by Mark Harig.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/03 15:41:06	1.295
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/04 01:15:22	1.296
@@ -1,3 +1,10 @@
+2009-12-04  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-arglists.lisp (find-subform-with-arglist): Return
+	 (values nil :not-available), not just NIL, when operator is
+	`quote' or `function'.
+	Fixes bug reported by Mark Harig.
+
 2009-12-03  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	http://common-lisp.net/project/hyperdoc/
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/03 15:36:59	1.44
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/04 01:15:22	1.45
@@ -1223,7 +1223,7 @@
                 (yield form local-ops))
                ;; Mostly uninteresting, hence skip.
                ((memq operator '(cl:quote cl:function))
-                nil)
+                (values nil :not-available))
                (t
                 (multiple-value-or (grovel-form last-subform local-ops)
                                    (yield form local-ops))))))))




From sboukarev at common-lisp.net  Mon Dec  7 05:55:37 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 07 Dec 2009 00:55:37 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NHWZN-0004VC-Le@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv17255

Modified Files:
	ChangeLog slime.el 
Log Message:
slime.el(slime-parse-toplevel-form): Use
`slime-region-for-defun-at-point' instead of `beginning-of-defun'.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/03 15:41:05	1.1927
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/07 05:55:37	1.1928
@@ -1,3 +1,8 @@
+2009-12-07  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-parse-toplevel-form): Use
+	`slime-region-for-defun-at-point' instead of `beginning-of-defun'.
+
 2009-12-03  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-documentation-lookup-function): New hook,
--- /project/slime/cvsroot/slime/slime.el	2009/12/03 15:41:05	1.1254
+++ /project/slime/cvsroot/slime/slime.el	2009/12/07 05:55:37	1.1255
@@ -4406,7 +4406,7 @@
 (defun slime-parse-toplevel-form ()
   (ignore-errors                        ; (foo)
     (save-excursion
-      (beginning-of-defun)
+      (goto-char (car (slime-region-for-defun-at-point)))
       (down-list 1)
       (forward-sexp 1)
       (slime-parse-context (read (current-buffer))))))




From sboukarev at common-lisp.net  Wed Dec  9 19:33:56 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 09 Dec 2009 14:33:56 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NISIO-0007Hj-1e@common-lisp.net>

Update of /project/slime/cvsroot/slime/doc
In directory cl-net:/tmp/cvs-serv27995

Modified Files:
	slime.texi 
Log Message:
* doc/slime.texi (Setting up pathname translations): Arguments were swapped. Reported by Josh March??n.


--- /project/slime/cvsroot/slime/doc/slime.texi	2009/11/18 10:51:34	1.86
+++ /project/slime/cvsroot/slime/doc/slime.texi	2009/12/09 19:33:55	1.87
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2009/11/18 10:51:34 $}
+ at set UPDATED @code{$Date: 2009/12/09 19:33:55 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -2028,8 +2028,8 @@
 contrib to setup the proper translations by simply doing:
 
 @example
-(push (slime-create-filename-translator :machine-instance "remote.example.com"
-                                        :remote-host "remote"
+(push (slime-create-filename-translator :machine-instance "remote"
+                                        :remote-host "remote.example.com"
                                         :username "user")
       slime-filename-translations)
 @end example




From trittweiler at common-lisp.net  Thu Dec 10 20:51:33 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 10 Dec 2009 15:51:33 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NIpz3-0000Qy-Ji@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv1637

Modified Files:
	swank-sbcl.lisp ChangeLog 
Log Message:
	* swank-sbcl.lisp (set-break-hook): New.
	(call-with-break-hook): New, too. Both extracted from elsewhere.
	(install-debugger-globally, call-with-debugger-hook): Use them.
	(make-invoke-debugger-hook): Adapted not to call *debugger-hook*
	on its own; it should rather decline because *debugger-hook* is
	tried after *invoke-debugger-hook* anyway. Previously, a
	custom *debugger-hook* (which declines itself) would have been
	executed twice.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/02 17:34:37	1.256
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/10 20:51:33	1.257
@@ -911,20 +911,29 @@
 
 ;;; Debugging
 
-(defvar *sldb-stack-top*)
+;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
+;;; than just a hook into BREAK. In particular, it'll make
+;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
+;;; than the native debugger. That should probably be considered a
+;;; feature.
 
 (defun make-invoke-debugger-hook (hook)
-  #'(lambda (condition old-hook)
-      ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
-      ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
-      ;; run when it was established locally by a user (i.e. changed meanwhile.)
+  #'(sb-int:named-lambda swank-invoke-debugger-hook
+        (condition old-hook)
       (if *debugger-hook*
-          (funcall *debugger-hook* condition old-hook)
+          nil           ; decline, *DEBUGGER-HOOK* will be tried next.
           (funcall hook condition old-hook))))
 
+(defun set-break-hook (hook)
+  (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+
+(defun call-with-break-hook (hook continuation)
+  (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
+    (funcall continuation)))
+
 (defimplementation install-debugger-globally (function)
   (setq *debugger-hook* function)
-  (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
+  (set-break-hook function))
 
 (defimplementation condition-extras (condition)
   (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
@@ -946,6 +955,8 @@
             ref)
            (t (symbol-name ref))))))
 
+(defvar *sldb-stack-top*)
+
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
   (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
@@ -972,9 +983,7 @@
     (invoke-restart 'sb-ext:step-out)))
 
 (defimplementation call-with-debugger-hook (hook fun)
-  (let ((*debugger-hook* hook)
-        (sb-ext:*invoke-debugger-hook* (and hook (make-invoke-debugger-hook hook)))
-        #+#.(swank-backend::sbcl-with-new-stepper-p)
+  (let (#+#.(swank-backend::sbcl-with-new-stepper-p)
         (sb-ext:*stepper-hook*
          (lambda (condition)
            (typecase condition
@@ -983,7 +992,7 @@
                 (sb-impl::invoke-debugger condition)))))))
     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
                    (sb-ext:step-condition #'sb-impl::invoke-stepper))
-      (funcall fun))))
+      (call-with-break-hook hook fun))))
 
 (defun nth-frame (index)
   (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/07 05:55:37	1.1928
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/10 20:51:33	1.1929
@@ -1,3 +1,14 @@
+2009-12-10  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-sbcl.lisp (set-break-hook): New.
+	(call-with-break-hook): New, too. Both extracted from elsewhere.
+	(install-debugger-globally, call-with-debugger-hook): Use them.
+	(make-invoke-debugger-hook): Adapted not to call *debugger-hook*
+	on its own; it should rather decline because *debugger-hook* is
+	tried after *invoke-debugger-hook* anyway. Previously, a
+	custom *debugger-hook* (which declines itself) would have been
+	executed twice.
+
 2009-12-07  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-parse-toplevel-form): Use




From trittweiler at common-lisp.net  Thu Dec 10 22:21:09 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 10 Dec 2009 17:21:09 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NIrNl-0006oC-7j@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv26127

Modified Files:
	swank-sbcl.lisp swank-backend.lisp ChangeLog 
Log Message:
	* swank-backend.lisp (*debug-swank-backend*): New variable. If
	true, backends should not catch internal errors (e.g. during
	definition finding), and should not perform backtrace magic.
	(make-error-location): New helper.
	(find-definitions [interface]): Default to error location.

	* swank-sbcl.lisp (converting-errors-to-location): New helper
	macro. Regards new *DEBUG-SWANK-BACKEND*.
	(find-definitions [implementation]): Use it.
	(find-source-location [implementation]): Ditto.
	(functiond-spec): Ditto.
	(frame-source-location [implementation]): Ditto.
	(*debug-definition-finding*): Removed.
	(make-source-location-specification): Removed.
	(safe-function-source-location): Removed.
	(safe-source-location-for-emacs): Removed. Not needed anymore.

	(call-with-debugging-environment): Do not perform stack hinting
	depending on *DEBUG-SWANK-BACKEND*.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/10 20:51:33	1.257
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/10 22:21:09	1.258
@@ -642,9 +642,17 @@
 
 ;;;; Definitions
 
-(defvar *debug-definition-finding* nil
-  "When true don't handle errors while looking for definitions.
-This is useful when debugging the definition-finding code.")
+(defmacro converting-errors-to-location (&body body)
+  "Catches error and converts them to an error location."
+  (let ((gblock (gensym "CONVERTING-ERRORS+")))
+    `(block ,gblock
+       (handler-bind ((error
+                       #'(lambda (e)
+                            (if *debug-swank-backend*
+                                nil     ;decline
+                                (return-from ,gblock
+                                  (make-error-location e))))))
+         , at body))))
 
 (defparameter *definition-types*
   '(:variable defvar
@@ -676,14 +684,21 @@
       :def-ir1-translator
       (getf *definition-types* type)))
 
+(defun make-dspec (type name source-location)
+  (list* (definition-specifier type name)
+         name
+         (sb-introspect::definition-source-description source-location)))
 
 (defimplementation find-definitions (name)
   (loop for type in *definition-types* by #'cddr
         for locations = (sb-introspect:find-definition-sources-by-name
                          name type)
         append (loop for source-location in locations collect
-                     (make-source-location-specification type name
-                                                         source-location))))
+                       (list (make-dspec type name source-location)
+                             (converting-errors-to-location
+                               (make-definition-source-location source-location
+                                                                type
+                                                                name))))))
 
 (defimplementation find-source-location (obj)
   (flet ((general-type-of (obj)
@@ -706,26 +721,11 @@
               (with-output-to-string (s)
                 (print-unreadable-object (obj s :type t :identity t))))
              (t (princ-to-string 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 (make-dspec type name source-location)
-        (if *debug-definition-finding*
-            (make-definition-source-location source-location type name)
-            (handler-case
-                (make-definition-source-location source-location type name)
-              (error (e)
-                (list :error (format nil "Error: ~A" e)))))))
+    (converting-errors-to-location
+      (make-definition-source-location (sb-introspect:find-definition-source obj)
+                                       (general-type-of obj)
+                                       (to-string obj)))))
 
-(defun make-dspec (type name source-location)
-  (list* (definition-specifier type name)
-         name
-         (sb-introspect::definition-source-description source-location)))
 
 (defun make-definition-source-location (definition-source type name)
   (with-struct (sb-introspect::definition-source-
@@ -779,13 +779,6 @@
   (let ((location (sb-introspect:find-definition-source function)))
     (make-definition-source-location location :function name)))
 
-(defun safe-function-source-location (fun name)
-  (if *debug-definition-finding*
-      (function-source-location fun name)
-      (handler-case (function-source-location fun name)
-        (error (e)
-          (list :error (format nil "Error: ~A" e))))))
-
 (defimplementation describe-symbol-for-emacs (symbol)
   "Return a plist describing SYMBOL.
 Return NIL if the symbol is unbound."
@@ -854,12 +847,9 @@
 (defun source-location-for-xref-data (xref-data)
   (let ((name (car xref-data))
         (source-location (cdr xref-data)))
-    (list name
-          (handler-case (make-definition-source-location source-location
-                                                         'function
-                                                         name)
-            (error (e)
-              (list :error (format nil "Error: ~A" e)))))))
+    (list name (make-definition-source-location source-location
+                                                'function
+                                                name))))
 
 (defimplementation list-callers (symbol)
   (let ((fn (fdefinition symbol)))
@@ -900,7 +890,8 @@
   "Describe where the function FN was defined.
 Return a list of the form (NAME LOCATION)."
   (let ((name (sb-kernel:%fun-name fn)))
-    (list name (safe-function-source-location fn name))))
+    (list name (converting-errors-to-location
+                 (function-source-location fn name)))))
 
 ;;; macroexpansion
 
@@ -959,7 +950,9 @@
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
-  (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
+  (let* ((*sldb-stack-top* (if *debug-swank-backend*
+                               (sb-di:top-frame)
+                               (or sb-debug:*stack-top-hint* (sb-di:top-frame))))
          (sb-debug:*stack-top-hint* nil))
     (handler-bind ((sb-di:debug-condition
 		    (lambda (condition)
@@ -1128,15 +1121,10 @@
 
 ;;; source-path-file-position and friends are in swank-source-path-parser
 
-(defun safe-source-location-for-emacs (code-location)
-  (if *debug-definition-finding*
-      (code-location-source-location code-location)
-      (handler-case (code-location-source-location code-location)
-        (error (c) (list :error (format nil "~A" c))))))
-
 (defimplementation frame-source-location (index)
-  (safe-source-location-for-emacs
-   (sb-di:frame-code-location (nth-frame index))))
+  (converting-errors-to-location
+    (code-location-source-location
+     (sb-di:frame-code-location (nth-frame index)))))
 
 (defun frame-debug-vars (frame)
   "Return a vector of debug-variables in frame."
--- /project/slime/cvsroot/slime/swank-backend.lisp	2009/11/21 21:32:28	1.185
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2009/12/10 22:21:09	1.186
@@ -12,7 +12,8 @@
 
 (defpackage :swank-backend
   (:use :common-lisp)
-  (:export #:sldb-condition
+  (:export #:*debug-swank-backend*
+           #:sldb-condition
            #:compiler-condition
            #:original-condition
            #:message
@@ -32,6 +33,7 @@
            #:unbound-slot-filler
            #:declaration-arglist
            #:type-specifier-arglist
+           #:with-struct
            ;; interrupt macro for the backend
            #:*pending-slime-interrupts*
            #:check-slime-interrupts
@@ -40,8 +42,6 @@
            #:emacs-inspect
            #:label-value-line
            #:label-value-line*
-           
-           #:with-struct
            ))
 
 (defpackage :swank-mop
@@ -102,6 +102,11 @@
 
 ;;;; Metacode
 
+(defparameter *debug-swank-backend* nil
+  "If this is true, backends should not catch errors but enter the
+debugger where appropriate. Also, they should not perform backtrace
+magic but really show every frame including SWANK related ones.")
+
 (defparameter *interface-functions* '()
   "The names of all interface functions.")
 
@@ -790,6 +795,15 @@
 (defstruct (:buffer (:type list) :named (:constructor)) name)
 (defstruct (:position (:type list) :named (:constructor)) pos)
 
+(defun make-error-location (datum &rest args)
+  (cond ((typep datum 'condition)
+         `(:error ,(format nil "Error: ~A" datum)))
+        ((symbolp datum)
+         `(:error ,(format nil "Error: ~A" (apply #'make-condition datum args))))
+        (t
+         (assert (stringp datum))
+         `(:error ,(apply #'format nil datum args)))))
+
 (definterface find-definitions (name)
    "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
 
@@ -811,7 +825,9 @@
   ;; This returns one source location and not a list of locations. It's
   ;; supposed to return the location of the DEFGENERIC definition on
   ;; #'SOME-GENERIC-FUNCTION.
-  )
+  (declare (ignore object))
+  (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
+                        this implementation."))
 
 
 (definterface buffer-first-change (filename)
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/10 20:51:33	1.1929
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/10 22:21:09	1.1930
@@ -1,5 +1,27 @@
 2009-12-10  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-backend.lisp (*debug-swank-backend*): New variable. If
+	true, backends should not catch internal errors (e.g. during
+	definition finding), and should not perform backtrace magic.
+	(make-error-location): New helper.
+	(find-definitions [interface]): Default to error location.
+
+	* swank-sbcl.lisp (converting-errors-to-location): New helper
+	macro. Regards new *DEBUG-SWANK-BACKEND*.
+	(find-definitions [implementation]): Use it.
+	(find-source-location [implementation]): Ditto.
+	(functiond-spec): Ditto.
+	(frame-source-location [implementation]): Ditto.
+	(*debug-definition-finding*): Removed.
+	(make-source-location-specification): Removed.
+	(safe-function-source-location): Removed.
+	(safe-source-location-for-emacs): Removed. Not needed anymore.
+
+	(call-with-debugging-environment): Do not perform stack hinting
+	depending on *DEBUG-SWANK-BACKEND*.
+
+2009-12-10  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank-sbcl.lisp (set-break-hook): New.
 	(call-with-break-hook): New, too. Both extracted from elsewhere.
 	(install-debugger-globally, call-with-debugger-hook): Use them.




From trittweiler at common-lisp.net  Thu Dec 10 23:07:38 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 10 Dec 2009 18:07:38 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NIs6k-0001fi-TU@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv6349

Modified Files:
	swank-sbcl.lisp ChangeLog 
Log Message:
	* swank-sbcl.lisp (call-with-debugger-hook): Oops, removed the
	binding for *DEBUGGER-HOOK*. Fix that.
	(make-invoke-debugger-hook): Do nothing if hook is NIL.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/10 22:21:09	1.258
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/10 23:07:38	1.259
@@ -909,11 +909,12 @@
 ;;; feature.
 
 (defun make-invoke-debugger-hook (hook)
-  #'(sb-int:named-lambda swank-invoke-debugger-hook
-        (condition old-hook)
-      (if *debugger-hook*
-          nil           ; decline, *DEBUGGER-HOOK* will be tried next.
-          (funcall hook condition old-hook))))
+  (when hook
+    #'(sb-int:named-lambda swank-invoke-debugger-hook
+          (condition old-hook)
+        (if *debugger-hook*
+            nil         ; decline, *DEBUGGER-HOOK* will be tried next.
+            (funcall hook condition old-hook)))))
 
 (defun set-break-hook (hook)
   (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
@@ -976,7 +977,8 @@
     (invoke-restart 'sb-ext:step-out)))
 
 (defimplementation call-with-debugger-hook (hook fun)
-  (let (#+#.(swank-backend::sbcl-with-new-stepper-p)
+  (let ((*debugger-hook* hook)
+        #+#.(swank-backend::sbcl-with-new-stepper-p)
         (sb-ext:*stepper-hook*
          (lambda (condition)
            (typecase condition
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/10 22:21:09	1.1930
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/10 23:07:38	1.1931
@@ -1,3 +1,9 @@
+2009-12-11  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-sbcl.lisp (call-with-debugger-hook): Oops, removed the
+	binding for *DEBUGGER-HOOK*. Fix that.
+	(make-invoke-debugger-hook): Do nothing if hook is NIL.
+
 2009-12-10  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-backend.lisp (*debug-swank-backend*): New variable. If




From trittweiler at common-lisp.net  Thu Dec 10 23:15:42 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 10 Dec 2009 18:15:42 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NIsEY-0002gR-Qz@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv10273

Modified Files:
	swank.lisp slime.el ChangeLog 
Log Message:
	Add `M-x slime-toggle-debug-on-swank-error'.

	In "Debug on SWANK error" mode, errors which are normally caught
	to not annoy the user, will now drop into the debugger.

	Additionally, the backend won't do any backtrace magic so you'll
	see the full backtrace with all its glory details.

	SBCL only so far.

	* slime.el (slime-toggle-debug-on-swank-error): New.

	* swank.lisp (toggle-debug-on-swank-error): New slimefun.
	(debug-on-swank-error): New function. SETFable.
	(invoke-default-debugger): Use CALL-WITH-DEBUGGER-HOOK so we're
	trapped into the native debugger on SBCL (previously we weren't
	due to SB-EXT:*INVOKE-DEBUGGER-HOOK*.)

	* swank.lisp: Rename SWANK-ERROR to SWANK-PROTOCOL-ERROR.


--- /project/slime/cvsroot/slime/swank.lisp	2009/11/13 20:23:57	1.673
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/10 23:15:42	1.674
@@ -44,8 +44,9 @@
            #:*sldb-printer-bindings*
            #:*swank-pprint-bindings*
            #:*record-repl-results*
-           #:*debug-on-swank-error*
            #:*inspector-verbose*
+           ;; This is SETFable.
+           #:debug-on-swank-error
            ;; These are re-exported directly from the backend:
            #:buffer-first-change
            #:frame-source-location
@@ -330,15 +331,15 @@
 (defslimefun ping (tag)
   tag)
 
-;; A conditions to include backtrace information
-(define-condition swank-error (error) 
-  ((condition :initarg :condition :reader swank-error.condition)
-   (backtrace :initarg :backtrace :reader swank-error.backtrace))
+;; A condition to include backtrace information
+(define-condition swank-protocol-error (error) 
+  ((condition :initarg :condition :reader swank-protocol-error.condition)
+   (backtrace :initarg :backtrace :reader swank-protocol-error.backtrace))
   (:report (lambda (condition stream)
-             (princ (swank-error.condition condition) stream))))
+             (princ (swank-protocol-error.condition condition) stream))))
 
-(defun make-swank-error (condition)
-  (make-condition 'swank-error :condition condition 
+(defun make-swank-protocol-error (condition)
+  (make-condition 'swank-protocol-error :condition condition 
                   :backtrace (safe-backtrace)))
 
 (defun safe-backtrace ()
@@ -346,23 +347,28 @@
     (call-with-debugging-environment 
      (lambda () (backtrace 0 nil)))))
 
-(defvar *debug-on-swank-error* nil
-  "When non-nil invoke the system debugger on swank internal errors.
-Do not set this to T unless you want to debug swank internals.")
+(defvar *debug-on-swank-protocol-error* nil
+  "When non-nil invoke the system debugger on errors that were
+signalled during decoding/encoding the wire protocol.  Do not set this
+to T unless you want to debug swank internals.")
 
-(defmacro with-swank-error-handler ((connection) &body body)
+(defmacro with-swank-protocol-error-handler ((connection) &body body)
   (let ((var (gensym)))
   `(let ((,var ,connection))
      (handler-case 
-         (handler-bind ((swank-error 
+         (handler-bind ((swank-protocol-error 
                          (lambda (condition)
-                           (when *debug-on-swank-error*
+                           (format t "~&+++ SWANK-PROTOCOL-ERROR: ~S ~S~%"
+                                   *debug-on-swank-protocol-error*
+                                   condition)
+                           (when *debug-on-swank-protocol-error*
+                             (format t "~&+++ INVOKE-DEFAULT-DEBUGGER +++ ~S~%" condition)
                              (invoke-default-debugger condition)))))
            (progn , at body))
-       (swank-error (condition)
+       (swank-protocol-error (condition)
          (close-connection ,var
-                           (swank-error.condition condition)
-                           (swank-error.backtrace condition)))))))
+                           (swank-protocol-error.condition condition)
+                           (swank-protocol-error.backtrace condition)))))))
 
 (defmacro with-panic-handler ((connection) &body body)
   (let ((var (gensym)))
@@ -445,7 +451,7 @@
       (let ((*emacs-connection* connection)
             (*pending-slime-interrupts* '()))
         (without-slime-interrupts
-          (with-swank-error-handler (*emacs-connection*)
+          (with-swank-protocol-error-handler (*emacs-connection*)
             (with-io-redirection (*emacs-connection*)
               (call-with-debugger-hook #'swank-debugger-hook function)))))))
 
@@ -1055,11 +1061,14 @@
 (defun read-loop (connection)
   (let ((input-stream (connection.socket-io connection))
         (control-thread (connection.control-thread connection)))
-    (with-swank-error-handler (connection)
+    (with-swank-protocol-error-handler (connection)
       (loop (send control-thread (decode-message input-stream))))))
 
 (defun dispatch-loop (connection)
   (let ((*emacs-connection* connection))
+    ;; FIXME: Why do we use WITH-PANIC-HANDLER here, and why is it not
+    ;; appropriate here to use WITH-SWANK-PROTOCOL-ERROR-HANDLER?
+    ;; I think this should be documented.
     (with-panic-handler (connection)
       (loop (dispatch-event (receive))))))
 
@@ -1326,7 +1335,7 @@
               (let* ((stdin (real-input-stream *standard-input*))
                      (*standard-input* (make-repl-input-stream connection 
                                                                stdin)))
-                (with-swank-error-handler (connection)
+                (with-swank-protocol-error-handler (connection)
                   (simple-repl)))))))
     (close-connection connection nil (safe-backtrace))))
 
@@ -1706,7 +1715,7 @@
   "Read an S-expression from STREAM using the SLIME protocol."
   ;;(log-event "decode-message~%")
   (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
-    (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
+    (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
       (let ((packet (read-packet stream)))
         (handler-case (values (read-form packet) nil)
           (reader-error (c) 
@@ -1750,7 +1759,7 @@
   (send-to-emacs object))
 
 (defun encode-message (message stream)
-  (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
+  (handler-bind ((error (lambda (c) (error (make-swank-protocol-error c)))))
     (let* ((string (prin1-to-string-for-emacs message))
            (length (length string))) 
       (log-event "WRITE: ~A~%" string)
@@ -1887,6 +1896,17 @@
     (finish-output *trace-output*)
     nil))
 
+(defun debug-on-swank-error ()
+  (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
+  *debug-on-swank-protocol-error*)
+
+(defun (setf debug-on-swank-error) (new-value)
+  (setf *debug-on-swank-protocol-error* new-value)
+  (setf *debug-swank-backend* new-value))
+
+(defslimefun toggle-debug-on-swank-error ()
+  (setf (debug-on-swank-error) (not (debug-on-swank-error))))
+
 
 ;;;; Reading and printing
 
@@ -2479,8 +2499,7 @@
       (invoke-default-debugger condition))))
 
 (defun invoke-default-debugger (condition)
-  (let ((*debugger-hook* nil))
-    (invoke-debugger condition)))
+  (call-with-debugger-hook nil (lambda () (invoke-debugger condition))))
   
 (defvar *global-debugger* t
   "Non-nil means the Swank debugger hook will be installed globally.")
--- /project/slime/cvsroot/slime/slime.el	2009/12/07 05:55:37	1.1255
+++ /project/slime/cvsroot/slime/slime.el	2009/12/10 23:15:42	1.1256
@@ -1458,6 +1458,12 @@
         (assert (integerp port))
         port))))
 
+(defun slime-toggle-debug-on-swank-error ()
+  (interactive)
+  (if (slime-eval `(swank:toggle-debug-on-swank-error))
+      (message "Debug on SWANK error enabled.")
+      (message "Debug on SWANK error disabled.")))
+
 ;;; Words of encouragement
 
 (defun slime-user-first-name ()
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/10 23:07:38	1.1931
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/10 23:15:42	1.1932
@@ -1,5 +1,27 @@
 2009-12-11  Tobias C. Rittweiler <tcr at freebits.de>
 
+	Add `M-x slime-toggle-debug-on-swank-error'.
+
+	In "Debug on SWANK error" mode, errors which are normally caught
+	to not annoy the user, will now drop into the debugger.
+
+	Additionally, the backend won't do any backtrace magic so you'll
+	see the full backtrace with all its glory details.
+
+	SBCL only so far.
+
+	* slime.el (slime-toggle-debug-on-swank-error): New.
+
+	* swank.lisp (toggle-debug-on-swank-error): New slimefun.
+	(debug-on-swank-error): New function. SETFable.
+	(invoke-default-debugger): Use CALL-WITH-DEBUGGER-HOOK so we're
+	trapped into the native debugger on SBCL (previously we weren't
+	due to SB-EXT:*INVOKE-DEBUGGER-HOOK*.)
+
+	* swank.lisp: Rename SWANK-ERROR to SWANK-PROTOCOL-ERROR.
+
+2009-12-11  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank-sbcl.lisp (call-with-debugger-hook): Oops, removed the
 	binding for *DEBUGGER-HOOK*. Fix that.
 	(make-invoke-debugger-hook): Do nothing if hook is NIL.




From trittweiler at common-lisp.net  Thu Dec 10 23:17:45 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 10 Dec 2009 18:17:45 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NIsGX-0002on-Nw@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv10834

Modified Files:
	ChangeLog 
Log Message:
fix ChangeLog entry slightly


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/10 23:15:42	1.1932
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/10 23:17:45	1.1933
@@ -6,9 +6,8 @@
 	to not annoy the user, will now drop into the debugger.
 
 	Additionally, the backend won't do any backtrace magic so you'll
-	see the full backtrace with all its glory details.
-
-	SBCL only so far.
+	see the full backtrace with all its glory details. (SBCL only so
+	far.)
 
 	* slime.el (slime-toggle-debug-on-swank-error): New.
 




From trittweiler at common-lisp.net  Thu Dec 10 23:26:07 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 10 Dec 2009 18:26:07 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NIsOd-0003de-F3@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv13974/contrib

Modified Files:
	swank-arglists.lisp ChangeLog 
Log Message:
	* swank-arglists.lisp (*swank-debug-arglists*): Removed.
	(arglist-for-echo-area): Use DEBUG-ON-SWANK-ERROR instead.


--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/04 01:15:22	1.45
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/10 23:26:07	1.46
@@ -1107,15 +1107,13 @@
 ;;; %CURSOR-MARKER%)). Only the forms up to point should be
 ;;; considered.
 
-(defvar *swank-debug-arglists* nil)
-
 (defslimefun arglist-for-echo-area (raw-form &key print-right-margin print-lines)
   "Return a string representing the arglist for the deepest subform in
 RAW-FORM that does have an arglist. The highlighted parameter is
 wrapped in ===> X <===."
   (handler-bind ((serious-condition
                   #'(lambda (c)
-                      (unless *swank-debug-arglists*
+                      (unless (debug-on-swank-error)
                         (let ((*print-right-margin* print-right-margin)
                               (*print-lines* print-lines))
                           (return-from arglist-for-echo-area
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/04 01:15:22	1.296
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/10 23:26:07	1.297
@@ -1,3 +1,8 @@
+2009-12-11  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-arglists.lisp (*swank-debug-arglists*): Removed.
+	(arglist-for-echo-area): Use DEBUG-ON-SWANK-ERROR instead.
+
 2009-12-04  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-arglists.lisp (find-subform-with-arglist): Return




From sboukarev at common-lisp.net  Fri Dec 11 03:05:24 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 10 Dec 2009 22:05:24 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NIvoq-00088o-HB@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv31294/contrib

Modified Files:
	ChangeLog slime-asdf.el swank-asdf.lisp 
Log Message:
* contrib/swank-asdf.lisp (find-operation): New function for
finding asdf operations independent of readtable
case sensitivity (read Allegro Modern Mode).
(operate-on-system): Accept symbols instead of strings for
operation-name, and use the above function.

* contrib/slime-asdf.el: Replace strings with operation names
for `slime-oos' with symbols.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/10 23:26:07	1.297
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/11 03:05:24	1.298
@@ -1,3 +1,14 @@
+2009-12-11  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-asdf.lisp (find-operation): New function for
+	finding asdf operations independent of readtable
+	case sensitivity (read Allegro Modern Mode).
+	(operate-on-system): Accept symbols instead of strings for
+	operation-name, and use the above function.
+
+	* slime-asdf.el: Replace strings with operation names
+	for `slime-oos' with symbols.
+
 2009-12-11  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-arglists.lisp (*swank-debug-arglists*): Removed.
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/03 12:46:12	1.19
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/11 03:05:24	1.20
@@ -76,7 +76,7 @@
            operation (if keyword-args (format " %S" keyword-args) "")
            system)
   (slime-repl-shortcut-eval-async
-   `(swank:operate-on-system-for-emacs ,system ,operation , at keyword-args)
+   `(swank:operate-on-system-for-emacs ,system ',operation , at keyword-args)
    #'slime-compilation-finished))
 
 
@@ -88,7 +88,7 @@
 Default system name is taken from first file matching *.asd in current
 buffer's working directory"
   (interactive (list (slime-read-system-name)))
-  (slime-oos system "LOAD-OP"))
+  (slime-oos system 'load-op))
 
 (defun slime-open-system (name &optional load)
   "Open all files in an ASDF system."
@@ -172,38 +172,38 @@
 (defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
   (:handler (lambda ()
               (interactive)
-              (slime-oos (slime-read-system-name) "LOAD-OP" :force t)))
+              (slime-oos (slime-read-system-name) 'load-op :force t)))
   (:one-liner "Recompile and load an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-load-system ("load-system")
   (:handler (lambda ()
               (interactive)
-              (slime-oos (slime-read-system-name) "LOAD-OP")))
+              (slime-oos (slime-read-system-name) 'load-op)))
   (:one-liner "Compile (as needed) and load an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-test/force-system ("force-test-system")
   (:handler (lambda ()
               (interactive)
-              (slime-oos (slime-read-system-name) "TEST-OP" :force t)))
+              (slime-oos (slime-read-system-name) 'test-op :force t)))
   (:one-liner "Compile (as needed) and force test an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-test-system ("test-system")
   (:handler (lambda ()
               (interactive)
-              (slime-oos (slime-read-system-name) "TEST-OP")))
+              (slime-oos (slime-read-system-name) 'test-op)))
   (:one-liner "Compile (as needed) and test an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-compile-system ("compile-system")
   (:handler (lambda ()
               (interactive)
-              (slime-oos (slime-read-system-name) "COMPILE-OP")))
+              (slime-oos (slime-read-system-name) 'compile-op)))
   (:one-liner "Compile (but not load) an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-compile/force-system 
   ("force-compile-system")  
   (:handler (lambda ()
               (interactive)
-              (slime-oos (slime-read-system-name) "COMPILE-OP" :force t)))
+              (slime-oos (slime-read-system-name) 'compile-op :force t)))
   (:one-liner "Recompile (but not load) an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-open-system ("open-system")
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/01 08:52:20	1.17
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/11 03:05:24	1.18
@@ -13,25 +13,25 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (require :asdf))
 
+(defun find-operation (operation)
+  (or (find-symbol (symbol-name operation) :asdf)
+      (error "Couldn't find ASDF operation ~S" operation)))
+
 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
   "Compile and load SYSTEM using ASDF.
 Record compiler notes signalled as `compiler-condition's."
-   (collect-notes
-    (lambda ()
-      (apply #'operate-on-system system-name operation keywords))))
+  (collect-notes
+   (lambda ()
+     (apply #'operate-on-system system-name operation keywords))))
 
 (defun operate-on-system (system-name operation-name &rest keyword-args)
   "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
 The KEYWORD-ARGS are passed on to the operation.
 Example:
-\(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"
-  (handler-case 
+\(operate-on-system \"swank\" 'compile-op :force t)"
+  (handler-case
       (with-compilation-hooks ()
-	(let ((operation (find-symbol operation-name :asdf)))
-	  (when (null operation)
-	    (error "Couldn't find ASDF operation ~S" operation-name))
-	  (apply #'asdf:operate operation system-name keyword-args)
-	  t))
+	(apply #'asdf:operate (find-operation operation-name) system-name keyword-args))
     (asdf:compile-error () nil)))
 
 (defun asdf-central-registry ()




From sboukarev at common-lisp.net  Fri Dec 11 03:37:17 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 10 Dec 2009 22:37:17 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NIwJh-00018S-VM@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv4350

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
swank-allegro.lisp: Use new function `make-error-location'.
(find-fspec-location): Handle errors.
Patch by Tobias C. Rittweiler.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/10 23:17:45	1.1933
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/11 03:37:17	1.1934
@@ -1,3 +1,9 @@
+2009-12-11  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-allegro.lisp: Use new function `make-error-location'.
+	(find-fspec-location): Handle errors.
+	Patch by Tobias C. Rittweiler.
+
 2009-12-11  Tobias C. Rittweiler <tcr at freebits.de>
 
 	Add `M-x slime-toggle-debug-on-swank-error'.
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2009/11/02 09:20:33	1.129
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2009/12/11 03:37:17	1.130
@@ -271,7 +271,7 @@
               (list :file (namestring (truename file)))
               (list :position (1+ pos)))))
           (t
-           (list :error "No error location available.")))))
+           (make-error-location "No error location available.")))))
 
 (defun location-for-reader-error (condition)
   (let ((pos  (car (last (slot-value condition 'excl::format-arguments))))
@@ -283,7 +283,7 @@
                                      ,(- pos *temp-file-header-end-position* 1)))
             (make-location `(:file ,(namestring (truename file)))
                            `(:position ,pos)))
-        (list :error "No error location available."))))
+        (make-error-location "No error location available."))))
 
 (defun handle-undefined-functions-warning (condition)
   (let ((fargs (slot-value condition 'excl::format-arguments)))
@@ -411,14 +411,16 @@
      (list :offset (parse-integer (subseq filename (1+ pos))) 0))))
 
 (defun find-fspec-location (fspec type file top-level)
-  (etypecase file
-    (pathname
-     (find-definition-in-file fspec type file top-level))
-    ((member :top-level)
-     (list :error (format nil "Defined at toplevel: ~A"
-                          (fspec->string fspec))))
-    (string
-     (find-definition-in-buffer file))))
+  (handler-case
+      (etypecase file
+        (pathname
+           (find-definition-in-file fspec type file top-level))
+        ((member :top-level)
+           (make-error-location "Defined at toplevel: ~A" (fspec->string fspec)))
+        (string
+           (find-definition-in-buffer file)))
+    (error (e)
+      (make-error-location "Error: ~A" e))))
 
 (defun fspec->string (fspec)
   (etypecase fspec
@@ -431,37 +433,35 @@
 
 (defun fspec-definition-locations (fspec)
   (cond
-   ((and (listp fspec)
-         (eql (car fspec) :top-level-form))
-    (destructuring-bind (top-level-form file &optional position) fspec 
-      (declare (ignore top-level-form))
-      (list
-       (list (list nil fspec)
+    ((and (listp fspec)
+          (eql (car fspec) :top-level-form))
+     (destructuring-bind (top-level-form file &optional position) fspec 
+       (declare (ignore top-level-form))
+       (list fspec
              (make-location (list :buffer file) ; FIXME: should use :file
                             (list :position position)
-                            (list :align t))))))
-   ((and (listp fspec) (eq (car fspec) :internal))
-    (destructuring-bind (_internal next _n) fspec
-      (declare (ignore _internal _n))
-      (fspec-definition-locations next)))
-   (t
-    (let ((defs (excl::find-source-file fspec)))
-      (when (and (null defs)
-                 (listp fspec)
-                 (string= (car fspec) '#:method))
-        ;; If methods are defined in a defgeneric form, the source location is
-        ;; recorded for the gf but not for the methods. Therefore fall back to
-        ;; the gf as the likely place of definition.
-        (setq defs (excl::find-source-file (second fspec))))
-      (if (null defs)
-          (list
-           (list (list nil fspec)
-                 (list :error
-                       (format nil "Unknown source location for ~A" 
-                               (fspec->string fspec)))))
-        (loop for (fspec type file top-level) in defs 
-              collect (list (list type fspec)
-                            (find-fspec-location fspec type file top-level))))))))
+                            (list :align t)))))
+    ((and (listp fspec) (eq (car fspec) :internal))
+     (destructuring-bind (_internal next _n) fspec
+       (declare (ignore _internal _n))
+       (fspec-definition-locations next)))
+    (t
+     (let ((defs (excl::find-source-file fspec)))
+       (when (and (null defs)
+                  (listp fspec)
+                  (string= (car fspec) '#:method))
+         ;; If methods are defined in a defgeneric form, the source location is
+         ;; recorded for the gf but not for the methods. Therefore fall back to
+         ;; the gf as the likely place of definition.
+         (setq defs (excl::find-source-file (second fspec))))
+       (if (null defs)
+           (list
+            (list fspec
+                  (make-error-location "Unknown source location for ~A" 
+                                       (fspec->string fspec))))
+           (loop for (fspec type file top-level) in defs 
+                 collect (list (list type fspec)
+                               (find-fspec-location fspec type file top-level))))))))
 
 (defimplementation find-definitions (symbol)
   (fspec-definition-locations symbol))




From sboukarev at common-lisp.net  Fri Dec 11 05:52:20 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 11 Dec 2009 00:52:20 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NIyQO-0002hD-AZ@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv10361/contrib

Modified Files:
	ChangeLog slime-presentations.el 
Log Message:
contrib/slime-presentations.el(slime-reify-old-output): Quote
the CL expession behind presentations, so _(1 2 3)_ (representing a
presentation) is not tried to be evaluated.
(slime-copy-presentation-to-repl): Use `looking-back' for looking back.
Apply De Morgan's law to conditions.
Patch by Tobias C. Rittweiler.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/11 03:05:24	1.298
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/11 05:52:20	1.299
@@ -1,5 +1,14 @@
 2009-12-11  Stas Boukarev  <stassats at gmail.com>
 
+	* slime-presentations.el (slime-reify-old-output): Quote
+	the CL expession behind presentations, so _(1 2 3)_ (representing a
+	presentation) is not tried to be evaluated.
+	(slime-copy-presentation-to-repl): Use `looking-back' for looking back.
+	Apply De Morgan's law to conditions.
+	Patch by Tobias C. Rittweiler.
+
+2009-12-11  Stas Boukarev  <stassats at gmail.com>
+
 	* swank-asdf.lisp (find-operation): New function for
 	finding asdf operations independent of readtable
 	case sensitivity (read Allegro Modern Mode).
--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2009/11/30 14:47:28	1.25
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2009/12/11 05:52:20	1.26
@@ -415,12 +415,11 @@
     (unless (eql major-mode 'slime-repl-mode)
       (slime-switch-to-output-buffer))
     (flet ((do-insertion ()
-			 (when (not (string-match "\\s-"
-						  (buffer-substring (1- (point)) (point))))
-			   (insert " "))
-			 (insert presentation-text)
-			 (when (and (not (eolp)) (not (looking-at "\\s-")))
-			   (insert " "))))
+	     (unless (looking-back "\\s-")
+	       (insert " "))
+	     (insert presentation-text)
+	     (unless (or (eolp) (looking-at "\\s-"))
+	       (insert " "))))
       (if (>= (point) slime-repl-prompt-start-mark)
 	  (do-insertion)
 	(save-excursion
@@ -656,7 +655,7 @@
               (concat (substring str-no-props 0 pos)
                       ;; Eval in the reader so that we play nice with quote.
                       ;; -luke (19/May/2005)
-                      "#." (slime-presentation-expression presentation)
+                      "'#." (slime-presentation-expression presentation)
                       (slime-reify-old-output (substring str-props end-pos)
                                               (substring str-no-props end-pos))))))))
 




From sboukarev at common-lisp.net  Fri Dec 11 06:35:20 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 11 Dec 2009 01:35:20 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NIz60-0005IG-C7@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv20347/contrib

Modified Files:
	ChangeLog slime-fuzzy.el 
Log Message:
contrib/slime-fuzzy.el(slime-fuzzy-choices-buffer): Don't
show cursor in *Fuzzy Completions*.
Patch by Tobias C. Rittweiler.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/11 05:52:20	1.299
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/11 06:35:20	1.300
@@ -1,5 +1,11 @@
 2009-12-11  Stas Boukarev  <stassats at gmail.com>
 
+	* slime-fuzzy.el (slime-fuzzy-choices-buffer): Don't
+	show cursor in *Fuzzy Completions*.
+	Patch by Tobias C. Rittweiler.
+
+2009-12-11  Stas Boukarev  <stassats at gmail.com>
+
 	* slime-presentations.el (slime-reify-old-output): Quote
 	the CL expession behind presentations, so _(1 2 3)_ (representing a
 	presentation) is not tried to be evaluated.
--- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2009/11/19 13:37:45	1.13
+++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2009/12/11 06:35:20	1.14
@@ -366,6 +366,7 @@
         (add-hook 'window-configuration-change-hook
                   'slime-fuzzy-window-configuration-change))
       (slime-add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort)
+      (set (make-local-variable 'cursor-type) nil)
       (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
     (when slime-fuzzy-completion-in-place
       ;; switch back to the original buffer




From mkoeppe at common-lisp.net  Sat Dec 12 18:43:04 2009
From: mkoeppe at common-lisp.net (CVS User mkoeppe)
Date: Sat, 12 Dec 2009 13:43:04 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NJWvo-0005G3-QG@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv20212

Modified Files:
	slime-presentations.el 
Log Message:
(slime-reify-old-output): Revert change of 2009-12-11, which
introduced spurious quotes in non-evaluated contexts like here:


	  '(1 2 #<STANDARD-CLASS STANDARD-OBJECT> 3 4)

Presentations do not change standard quoting rules; users just need to
remember this.


--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2009/12/11 05:52:20	1.26
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2009/12/12 18:43:04	1.27
@@ -655,7 +655,7 @@
               (concat (substring str-no-props 0 pos)
                       ;; Eval in the reader so that we play nice with quote.
                       ;; -luke (19/May/2005)
-                      "'#." (slime-presentation-expression presentation)
+                      "#." (slime-presentation-expression presentation)
                       (slime-reify-old-output (substring str-props end-pos)
                                               (substring str-no-props end-pos))))))))
 




From mkoeppe at common-lisp.net  Sat Dec 12 18:43:29 2009
From: mkoeppe at common-lisp.net (CVS User mkoeppe)
Date: Sat, 12 Dec 2009 13:43:29 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NJWwD-0005Gz-HS@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv20269

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/11 06:35:20	1.300
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/12 18:43:29	1.301
@@ -1,3 +1,14 @@
+2009-12-12  Matthias Koeppe  <mkoeppe at math.ucdavis.edu>
+
+	* slime-presentations.el (slime-reify-old-output): Revert change
+	of 2009-12-11, which introduced spurious quotes in non-evaluated
+	contexts like here:
+
+	  '(1 2 #<STANDARD-CLASS STANDARD-OBJECT> 3 4)
+
+	Presentations do not change standard quoting rules; users just
+	need to remember this.
+
 2009-12-11  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-fuzzy.el (slime-fuzzy-choices-buffer): Don't




From mkoeppe at common-lisp.net  Sat Dec 12 18:58:32 2009
From: mkoeppe at common-lisp.net (CVS User mkoeppe)
Date: Sat, 12 Dec 2009 13:58:32 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NJXAm-0005gf-Lx@common-lisp.net>

Update of /project/slime/cvsroot/slime/doc
In directory cl-net:/tmp/cvs-serv21862

Modified Files:
	slime.texi 
Log Message:
(Presentations): Add an example that illustrates quoting necessary
with presentations that are lists.


--- /project/slime/cvsroot/slime/doc/slime.texi	2009/12/09 19:33:55	1.87
+++ /project/slime/cvsroot/slime/doc/slime.texi	2009/12/12 18:58:32	1.88
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2009/12/09 19:33:55 $}
+ at set UPDATED @code{$Date: 2009/12/12 18:58:32 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -2661,10 +2661,25 @@
 commands, the presentation can be copied to a new input in the REPL:
 
 @example
-CL-USER> (eql '@emph{#<STANDARD-CLASS STANDARD-CLASS>} '@emph{#<STANDARD-CLASS STANDARD-CLASS>})
+CL-USER> (eql '@emph{#<STANDARD-CLASS STANDARD-CLASS>} 
+              '@emph{#<STANDARD-CLASS STANDARD-CLASS>})
 @emph{T}
 @end example
 
+Note that standard evaluation and quoting rules still apply.  So if a
+presentation is a list, it needs to be quoted in an evaluated context to
+avoid treating it as a function call:
+
+ at example
+CL-USER> (list (find-class 'standard-class) 2 3 4)
+ at emph{(#<STANDARD-CLASS STANDARD-CLASS> 2 3 4)}
+CL-USER> @emph{(#<STANDARD-CLASS STANDARD-CLASS> 2 3 4)}
+; Funcall of #<STANDARD-CLASS STANDARD-CLASS> which is a non-function.
+; Evaluation aborted.
+CL-USER> '@emph{(#<STANDARD-CLASS STANDARD-CLASS> 2 3 4)}
+(#<STANDARD-CLASS STANDARD-CLASS> 2 3 4)
+ at end example
+
 When you copy an incomplete presentation or edit the text within a
 presentation, the presentation changes to plain text, losing the
 association with a Lisp object.  In the buffer, this is indicated by




From mkoeppe at common-lisp.net  Sat Dec 12 18:58:46 2009
From: mkoeppe at common-lisp.net (CVS User mkoeppe)
Date: Sat, 12 Dec 2009 13:58:46 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NJXB0-0005hq-Mr@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv21899

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/ChangeLog	2009/12/11 03:37:17	1.1934
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/12 18:58:46	1.1935
@@ -1,3 +1,8 @@
+2009-12-12  Matthias Koeppe  <mkoeppe at math.ucdavis.edu>
+
+	* doc/slime.texi (Presentations): Add an example that illustrates
+	quoting necessary with presentations that are lists.
+
 2009-12-11  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-allegro.lisp: Use new function `make-error-location'.




From sboukarev at common-lisp.net  Mon Dec 14 09:06:35 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 14 Dec 2009 04:06:35 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NK6t1-0002Rv-51@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv9412

Modified Files:
	ChangeLog 
Log Message:
* contrib/slime-asdf.el (slime-delete-system-fasls): New command with a
shortcut `delete-system-fasls'.

* contrib/swank-asdf.lisp (delete-system-fasls): New function.
(asdf-module-output-files): New function for finding fasls.

* doc/slime.texi (ASDF): Document new commands.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/12 18:58:46	1.1935
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/14 09:06:34	1.1936
@@ -1,3 +1,7 @@
+2009-12-14  Stas Boukarev  <stassats at gmail.com>
+
+	* doc/slime.texi (ASDF): Document new commands.
+
 2009-12-12  Matthias Koeppe  <mkoeppe at math.ucdavis.edu>
 
 	* doc/slime.texi (Presentations): Add an example that illustrates




From sboukarev at common-lisp.net  Mon Dec 14 09:06:35 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 14 Dec 2009 04:06:35 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NK6t1-0002S7-Dd@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv9412/contrib

Modified Files:
	ChangeLog slime-asdf.el swank-asdf.lisp 
Log Message:
* contrib/slime-asdf.el (slime-delete-system-fasls): New command with a
shortcut `delete-system-fasls'.

* contrib/swank-asdf.lisp (delete-system-fasls): New function.
(asdf-module-output-files): New function for finding fasls.

* doc/slime.texi (ASDF): Document new commands.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/12 18:43:29	1.301
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/14 09:06:35	1.302
@@ -1,3 +1,11 @@
+2009-12-14  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-asdf.el (slime-delete-system-fasls): New command with a
+	shortcut `delete-system-fasls'.
+
+	* swank-asdf.lisp (delete-system-fasls): New function.
+	(asdf-module-output-files): New function for finding fasls.
+
 2009-12-12  Matthias Koeppe  <mkoeppe at math.ucdavis.edu>
 
 	* slime-presentations.el (slime-reify-old-output): Revert change
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/11 03:05:24	1.20
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/14 09:06:35	1.21
@@ -166,6 +166,13 @@
   (tags-query-replace (regexp-quote from) to delimited
 		      '(slime-eval `(swank:asdf-system-files ,name))))
 
+(defun slime-delete-system-fasls (name)
+  "Delete FASLs produced by compiling a system."
+  (interactive (list (slime-read-system-name)))
+  (slime-repl-shortcut-eval-async
+   `(swank:delete-system-fasls ,name)
+   'message))
+
 
 ;;; REPL shortcuts
 
@@ -207,17 +214,17 @@
   (:one-liner "Recompile (but not load) an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-open-system ("open-system")
-  (:handler (lambda ()
-              (interactive)
-              (call-interactively 'slime-open-system)))
+  (:handler 'slime-open-system)
   (:one-liner "Open all files in an ASDF system."))
 
 (defslime-repl-shortcut slime-repl-browse-system ("browse-system")
-  (:handler (lambda ()
-              (interactive)
-              (call-interactively 'slime-browse-system)))
+  (:handler 'slime-browse-system)
   (:one-liner "Browse files in an ASDF system using Dired."))
 
+(defslime-repl-shortcut slime-repl-delete-system-fasls ("delete-system-fasls")
+  (:handler 'slime-delete-system-fasls)
+  (:one-liner "Delete FASLs of an ASDF system."))
+
 
 ;;; Initialization
 
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/11 03:05:24	1.18
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/14 09:06:35	1.19
@@ -76,6 +76,16 @@
                (asdf-module-files component))))
           (asdf:module-components module)))
 
+(defun asdf-module-output-files (module)
+  (mapcan (lambda (component)
+            (typecase component
+              (asdf:source-file
+               (asdf:output-files (make-instance 'asdf:compile-op)
+                                  component))
+              (asdf:module
+               (asdf-module-output-files component))))
+          (asdf:module-components module)))
+
 (defslimefun asdf-system-files (name)
   (let* ((system (asdf:find-system name))
          (files (mapcar #'namestring
@@ -133,4 +143,11 @@
           (return-from asdf-determine-system
             (asdf:component-name system)))))))
 
+(defslimefun delete-system-fasls (name)
+  (let ((removed-count
+         (loop for file in (asdf-module-output-files (asdf:find-system name))
+               when (probe-file file) count it
+               and do (delete-file file))))
+    (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count)))
+
 (provide :swank-asdf)




From sboukarev at common-lisp.net  Mon Dec 14 09:06:35 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 14 Dec 2009 04:06:35 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NK6t1-0002SS-Mz@common-lisp.net>

Update of /project/slime/cvsroot/slime/doc
In directory cl-net:/tmp/cvs-serv9412/doc

Modified Files:
	slime.texi 
Log Message:
* contrib/slime-asdf.el (slime-delete-system-fasls): New command with a
shortcut `delete-system-fasls'.

* contrib/swank-asdf.lisp (delete-system-fasls): New function.
(asdf-module-output-files): New function for finding fasls.

* doc/slime.texi (ASDF): Document new commands.


--- /project/slime/cvsroot/slime/doc/slime.texi	2009/12/12 18:58:32	1.88
+++ /project/slime/cvsroot/slime/doc/slime.texi	2009/12/14 09:06:35	1.89
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2009/12/12 18:58:32 $}
+ at set UPDATED @code{$Date: 2009/12/14 09:06:35 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -2541,8 +2541,15 @@
 Open all files in a system, optionally load it if LOAD is non-nil.
 @cmditem{slime-browse-system NAME}
 Browse files in a system using Dired.
+ at cmditem{slime-delete-system-fasls NAME}
+Delete FASLs produced by compiling a system.
+ at cmditem{slime-rgrep-system NAME REGEXP}
+Run @code{rgrep} on the base directory of an ASDF system.
+ at cmditem{slime-isearch-system NAME}
+Run @code{isearch-forward} on the files of an ASDF system.
+ at cmditem{slime-query-replace-system NAME FROM TO &OPTIONAL DELIMITED}
+Run @code{query-replace} on an ASDF system.
 @end table
-
 The package also installs some new REPL shortcuts (@pxref{Shortcuts}):
 
 @table @kbd
@@ -2558,6 +2565,8 @@
 Open all files in a system.
 @item browse-system
 Browse files in a system using Dired.
+ at item delete-system-fasls
+Delete FASLs produced by compiling a system.
 @end table
 
 @node Banner




From trittweiler at common-lisp.net  Mon Dec 14 15:28:46 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 14 Dec 2009 10:28:46 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NKCqs-0007wl-L5@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv30547/contrib

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
	Take recursiveness of LABELS into account for displaying local
	arglists. I.e. make the following work:

         (labels ((iseven (x)
                    ...)
                  (isodd (y)
                    (if (zerop y)
                       nil
                      (iseven <>))))) ; Point is here
	   ...)

	As we only have information to look backward, we cannot show
	arglist for ISODD within ISEVEN, though.

	* swank-arglists.lisp (extract-local-op-arglists): Handle LABELS
	specially.
	(find-subform-with-arglists): Adapted accordingly. Plus: Small
	refactoring, and fix comparasion of local ops to properly deal
	with arglist dummies.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/14 09:06:35	1.302
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/14 15:28:46	1.303
@@ -1,3 +1,25 @@
+2009-12-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Take recursiveness of LABELS into account for displaying local
+	arglists. I.e. make the following work:
+
+         (labels ((iseven (x)
+                    ...)
+                  (isodd (y)
+                    (if (zerop y)
+                       nil
+                      (iseven <>))))) ; Point is here
+	   ...)
+
+	As we only have information to look backward, we cannot show
+	arglist for ISODD within ISEVEN, though.
+
+	* swank-arglists.lisp (extract-local-op-arglists): Handle LABELS
+	specially.
+	(find-subform-with-arglists): Adapted accordingly. Plus: Small
+	refactoring, and fix comparasion of local ops to properly deal
+	with arglist dummies.
+
 2009-12-14  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-asdf.el (slime-delete-system-fasls): New command with a
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/10 23:26:07	1.46
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/14 15:28:46	1.47
@@ -1183,64 +1183,97 @@
 This function takes local function and macro definitions appearing in
 FORM into account."
   (labels 
-      ((yield (form local-ops)
+      ((yield-success (form local-ops)
          (let ((form (remove-from-tree +cursor-marker+ form)))
            (values form
-                   (let ((entry (assoc (car form) local-ops)))
+                   (let ((entry (assoc (car form) local-ops :test #'op=)))
                      (if entry
                          (decode-arglist (cdr entry))
                          (arglist-from-form form))))))
+       (yield-failure ()
+         (values nil :not-available))
        (operator-p (operator local-ops)
-         (and (symbolp operator)
-              (or (valid-operator-symbol-p operator)
-                  (assoc operator local-ops :test #'eq))))
+         (or (and (symbolp operator) (valid-operator-symbol-p operator))
+             (assoc operator local-ops :test #'op=)))
+       (op= (op1 op2)
+         (cond ((and (symbolp op1) (symbolp op2))
+                (eq op1 op2))
+               ((and (arglist-dummy-p op1) (arglist-dummy-p op2))
+                (string= (arglist-dummy.string-representation op1)
+                         (arglist-dummy.string-representation op2)))))
        (grovel-form (form local-ops)
+         "Descend FORM top-down, always taking the rightest branch,
+          until +CURSOR-MARKER+."
          (assert (listp form))
          (destructuring-bind (operator . args) form
-           (declare (ignore args))
            ;; N.b. the user's cursor is at the rightmost, deepest
            ;; subform right before +CURSOR-MARKER+.
-           (let ((last-subform (car (last form))))
+           (let ((last-subform (car (last form)))
+                 (new-ops))
              (cond
                ((eq last-subform +cursor-marker+)
                 (if (operator-p operator local-ops)
-                    (yield form local-ops)
-                    (values nil :not-available)))
+                    (yield-success form local-ops)
+                    (yield-failure)))
                ((not (operator-p operator local-ops))
                 (grovel-form last-subform local-ops))
                ;; Make sure to pick up the arglists of local
                ;; function/macro definitions.
-               ((memq operator '(cl:flet cl:labels cl:macrolet))
+               ((setq new-ops (extract-local-op-arglists operator args))
                 (multiple-value-or (grovel-form last-subform 
-                                                (nconc (extract-local-op-arglists form)
-                                                       local-ops))
-                                   (yield form local-ops)))
+                                                (nconc new-ops local-ops))
+                                   (yield-success form local-ops)))
                ;; Some typespecs clash with function names, so we make
                ;; sure to bail out early.
                ((member operator '(cl:declare cl:declaim))
-                (yield form local-ops))
+                (yield-success form local-ops))
                ;; Mostly uninteresting, hence skip.
                ((memq operator '(cl:quote cl:function))
-                (values nil :not-available))
+                (yield-failure))
                (t
                 (multiple-value-or (grovel-form last-subform local-ops)
-                                   (yield form local-ops))))))))
+                                   (yield-success form local-ops))))))))
     (if (null form)
-        (values nil :not-available)
+        (yield-failure)
         (grovel-form form '()))))
 
-(defun extract-local-op-arglists (form)
-  ;; FIXME: Take recursive scope of LABELS into account.
-  (cond ((null (cddr form)) nil)        ; `(flet ((foo (x) |'
-        ((atom (second form)) nil)      ; `(flet ,foo (|'
-        (t
-         (let* ((defs (second form))
-                (defs (remove-if-not #'(lambda (x)
-                                        ;; Well-formed FLET/LABELS def?
-                                        (and (consp x) (second x)))
-                                    defs)))
-           (loop for (name arglist . nil) in defs
-                 collect (cons name arglist))))))
+(flet ((collect-op/argl-alist (defs)
+         (setq defs (remove-if-not #'(lambda (x)
+                                       ;; Well-formed FLET/LABELS def?
+                                       (and (consp x) (second x)))
+                                   defs))
+         (loop for (name arglist . nil) in defs
+               collect (cons name arglist))))
+  (defgeneric extract-local-op-arglists (operator args)
+    (:documentation
+     "If the form `(OPERATOR , at ARGS) is a local operator binding form,
+     return a list of pairs (OP . ARGLIST) for each locally bound op.")
+    (:method (operator args)
+      (declare (ignore operator args))
+      nil)
+    ;; FLET
+    (:method ((operator (eql 'cl:flet)) args)
+      (let ((defs (first args))
+            (body (rest args)))
+        (cond ((null body) nil)         ; `(flet ((foo (x) |'
+              ((atom defs) nil)         ; `(flet ,foo (|'
+              (t (collect-op/argl-alist defs)))))
+    ;; LABELS
+    (:method ((operator (eql 'cl:labels)) args)
+      ;; Notice that we only have information to "look backward" and
+      ;; show arglists of previously occuring local functions.
+      (let ((defs (first args))
+            (body (rest args)))
+        (cond ((atom defs) nil)
+              ((not (null body))
+               (extract-local-op-arglists 'cl:flet args))
+              (t
+               (let ((def.body (cddr (car (last defs)))))
+                 (when def.body
+                   (collect-op/argl-alist defs)))))))
+    ;; MACROLET
+    (:method ((operator (eql 'cl:macrolet)) args)
+      (extract-local-op-arglists 'cl:labels args))))
 
 (defun find-immediately-containing-arglist (form)
   "Returns the arglist of the form immediately containing




From sboukarev at common-lisp.net  Tue Dec 15 17:12:42 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 15 Dec 2009 12:12:42 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NKax0-0005bS-7U@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv21537/contrib

Modified Files:
	ChangeLog slime-asdf.el swank-asdf.lisp 
Log Message:
* contrib/slime-asdf.el (slime-reload-system): New command for reloading
a system without recompiling recursively its dependencies.
REPL shortcut for it is `reload-system'.

* contrib/swank-asdf.lisp (reload-system): New function.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/14 15:28:46	1.303
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/15 17:12:41	1.304
@@ -1,3 +1,11 @@
+2009-12-15  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-asdf.el (slime-reload-system): New command for reloading
+	a system without recompiling recursively its dependencies.
+	REPL shortcut for it is `reload-system'.
+
+	* swank-asdf.lisp (reload-system): New function.
+
 2009-12-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Take recursiveness of LABELS into account for displaying local
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/14 09:06:35	1.21
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/15 17:12:41	1.22
@@ -173,6 +173,16 @@
    `(swank:delete-system-fasls ,name)
    'message))
 
+(defun slime-reload-system (system)
+  "Reload an ASDF system without reloading its dependencies."
+  (interactive (list (slime-read-system-name)))
+  (slime-save-some-lisp-buffers)
+  (slime-display-output-buffer)
+  (message "Performing ASDF LOAD-OP on system %S" system)
+  (slime-repl-shortcut-eval-async
+   `(swank:reload-system ,system)
+   #'slime-compilation-finished))
+
 
 ;;; REPL shortcuts
 
@@ -225,6 +235,10 @@
   (:handler 'slime-delete-system-fasls)
   (:one-liner "Delete FASLs of an ASDF system."))
 
+(defslime-repl-shortcut slime-repl-reload-system ("reload-system")
+  (:handler 'slime-reload-system)
+  (:one-liner "Recompile and load an ASDF system."))
+
 
 ;;; Initialization
 
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/14 09:06:35	1.19
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/15 17:12:41	1.20
@@ -31,7 +31,9 @@
 \(operate-on-system \"swank\" 'compile-op :force t)"
   (handler-case
       (with-compilation-hooks ()
-	(apply #'asdf:operate (find-operation operation-name) system-name keyword-args))
+	(apply #'asdf:operate (find-operation operation-name)
+               system-name keyword-args)
+        t)
     (asdf:compile-error () nil)))
 
 (defun asdf-central-registry ()
@@ -150,4 +152,23 @@
                and do (delete-file file))))
     (format nil "~d file~:p ~:*~[were~;was~:;were~] removed" removed-count)))
 
+(defvar *recompile-system* nil)
+
+(defmethod asdf:operation-done-p asdf:around ((operation asdf:compile-op)
+                                              component)
+  (unless (eql *recompile-system*
+               (asdf:component-system component))
+    (call-next-method)))
+
+(defslimefun reload-system (name)
+  (let* ((system (asdf:find-system name))
+         (*recompile-system* system))
+    (collect-notes
+     (lambda ()
+       (handler-case
+           (with-compilation-hooks ()
+             (asdf:oos 'asdf:load-op system)
+             t)
+         (asdf:compile-error () nil))))))
+
 (provide :swank-asdf)




From sboukarev at common-lisp.net  Tue Dec 15 17:12:42 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 15 Dec 2009 12:12:42 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NKax0-0005bl-DD@common-lisp.net>

Update of /project/slime/cvsroot/slime/doc
In directory cl-net:/tmp/cvs-serv21537/doc

Modified Files:
	slime.texi 
Log Message:
* contrib/slime-asdf.el (slime-reload-system): New command for reloading
a system without recompiling recursively its dependencies.
REPL shortcut for it is `reload-system'.

* contrib/swank-asdf.lisp (reload-system): New function.


--- /project/slime/cvsroot/slime/doc/slime.texi	2009/12/14 09:06:35	1.89
+++ /project/slime/cvsroot/slime/doc/slime.texi	2009/12/15 17:12:42	1.90
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2009/12/14 09:06:35 $}
+ at set UPDATED @code{$Date: 2009/12/15 17:12:42 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -2537,6 +2537,8 @@
 @cmditem{slime-load-system NAME}
 Compile and load an ASDF system.  The default system name is taken
 from the first file matching *.asd in the current directory.
+ at cmditem{slime-reload-system NAME}
+Recompile and load an ASDF system without recompiling its dependencies.
 @cmditem{slime-open-system NAME &optional LOAD}
 Open all files in a system, optionally load it if LOAD is non-nil.
 @cmditem{slime-browse-system NAME}
@@ -2555,6 +2557,8 @@
 @table @kbd
 @item load-system
 Compile (as needed) and load an ASDF system.
+ at item reload-system
+Recompile and load an ASDF system.
 @item compile-system
 Compile (but not load) an ASDF system.
 @item force-compile-system




From trittweiler at common-lisp.net  Tue Dec 15 20:14:38 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 15 Dec 2009 15:14:38 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NKdn4-0007AS-8P@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv27552/contrib

Modified Files:
	ChangeLog swank-asdf.lisp 
Log Message:
	* swank-asdf.lisp (map-defined-systems): Factored out.
	(list-all-systems-known-to-asdf): Use it.
	(asdf-determine-system): Use it, too.
	(reload-system): Reuse `operate-on-system-for-emacs'.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/15 17:12:41	1.304
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/15 20:14:38	1.305
@@ -1,3 +1,10 @@
+2009-12-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-asdf.lisp (map-defined-systems): Factored out.
+	(list-all-systems-known-to-asdf): Use it.
+	(asdf-determine-system): Use it, too.
+	(reload-system): Reuse `operate-on-system-for-emacs'.
+
 2009-12-15  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-asdf.el (slime-reload-system): New command for reloading
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/15 17:12:41	1.20
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/15 20:14:38	1.21
@@ -17,6 +17,10 @@
   (or (find-symbol (symbol-name operation) :asdf)
       (error "Couldn't find ASDF operation ~S" operation)))
 
+(defun map-defined-systems (fn)
+  (loop for (nil . system) being the hash-values in asdf::*defined-systems*
+        do (funcall fn system)))
+
 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
   "Compile and load SYSTEM using ASDF.
 Record compiler notes signalled as `compiler-condition's."
@@ -57,10 +61,10 @@
 
 (defslimefun list-all-systems-known-to-asdf ()
   "Returns a list of all systems ASDF knows already."
-  ;; ugh, yeah, it's unexported - but do we really expect this to
-  ;; change anytime soon?
-  (loop for name being the hash-keys of asdf::*defined-systems*
-        collect name))
+  (let ((result))
+    (map-defined-systems
+     #'(lambda (system) (push (asdf:component-name system) result)))
+    result))
 
 (defslimefun list-asdf-systems ()
   "Returns the systems in ASDF's central registry and those which ASDF
@@ -130,17 +134,18 @@
   ;; First try to grovel through all defined systems to find a system
   ;; which contains FILE.
   (when file
-    (loop with pathname      = (pathname file)
-          with pathname-name = (pathname-name pathname)
-          for (nil . system) being the hash-value of asdf::*defined-systems*
-          when (system-contains-file-p system pathname pathname-name)
-            do (return-from asdf-determine-system
-                 (asdf:component-name system))))
+    (let* ((pathname      (pathname file))
+           (pathname-name (pathname-name pathname)))
+      (map-defined-systems
+       #'(lambda (system)
+           (when (system-contains-file-p system pathname pathname-name)
+             (return-from asdf-determine-system
+               (asdf:component-name system)))))))
   ;; If we couldn't find a system by that, we now try if there's a
   ;; system that's named like BUFFER-PACKAGE-NAME.
   (let ((package (guess-buffer-package buffer-package-name)))
     (dolist (name (package-names package))
-      (let ((system (asdf:find-system (string-downcase name) nil)))
+      (let ((system (asdf:find-system (asdf::coerce-name name) nil)))
         (when system
           (return-from asdf-determine-system
             (asdf:component-name system)))))))
@@ -161,14 +166,7 @@
     (call-next-method)))
 
 (defslimefun reload-system (name)
-  (let* ((system (asdf:find-system name))
-         (*recompile-system* system))
-    (collect-notes
-     (lambda ()
-       (handler-case
-           (with-compilation-hooks ()
-             (asdf:oos 'asdf:load-op system)
-             t)
-         (asdf:compile-error () nil))))))
+  (let ((*recompile-system* (asdf:find-system name)))
+    (operate-on-system-for-emacs name 'asdf:load-op)))
 
 (provide :swank-asdf)




From trittweiler at common-lisp.net  Tue Dec 15 20:29:01 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 15 Dec 2009 15:29:01 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NKe0z-000898-Fg@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv31302/contrib

Modified Files:
	ChangeLog swank-asdf.lisp 
Log Message:
	* swank-asdf.lisp (who-depends-on): Add.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/15 20:14:38	1.305
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/15 20:29:01	1.306
@@ -1,5 +1,9 @@
 2009-12-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-asdf.lisp (who-depends-on): Add.
+
+2009-12-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank-asdf.lisp (map-defined-systems): Factored out.
 	(list-all-systems-known-to-asdf): Use it.
 	(asdf-determine-system): Use it, too.
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/15 20:14:38	1.21
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/15 20:29:01	1.22
@@ -21,6 +21,22 @@
   (loop for (nil . system) being the hash-values in asdf::*defined-systems*
         do (funcall fn system)))
 
+;;; This is probably a crude hack, see ASDF's LP #481187.
+(defun who-depends-on (system)
+  (flet ((system-dependencies (op system)
+           (mapcar #'(lambda (dep)
+                       (asdf::coerce-name (if (consp dep) (second dep) dep)))
+                   (cdr (assoc op (asdf:component-depends-on op system))))))
+    (let ((system-name (asdf::coerce-name system))
+          (result))
+      (map-defined-systems
+       #'(lambda (system)
+           (when (member system-name
+                         (system-dependencies 'asdf:load-op system)
+                         :test #'string=)
+             (push (asdf:component-name system) result))))
+      result)))
+
 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
   "Compile and load SYSTEM using ASDF.
 Record compiler notes signalled as `compiler-condition's."




From trittweiler at common-lisp.net  Tue Dec 15 21:56:55 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 15 Dec 2009 16:56:55 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NKfO3-00055z-PH@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv19560

Modified Files:
	ChangeLog swank-sbcl.lisp swank.lisp 
Log Message:
	* swank.lisp (collect-notes): Establish new abort restart ("Abort
	Compilation"); if an error is signaled in EVAL-WHEN, or during
	macroexpansion -- assuming the backend DTRT --, invoking this
	restart will result in the normal compilation failure behaviour,
	including correct reporting of the offending toplevel form.

	* swank-sbcl.lisp (handle-notification-condition): Use
	`real-condition' here.
	(handle-file-compiler-termination): As a result, not needed anymore.
	(call-with-compilation-hooks): Also signal information about
	normal errors.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/14 09:06:34	1.1936
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/15 21:56:55	1.1937
@@ -1,3 +1,17 @@
+2009-12-15  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp (collect-notes): Establish new abort restart ("Abort
+	Compilation"); if an error is signaled in EVAL-WHEN, or during
+	macroexpansion -- assuming the backend DTRT --, invoking this
+	restart will result in the normal compilation failure behaviour,
+	including correct reporting of the offending toplevel form.
+
+	* swank-sbcl.lisp (handle-notification-condition): Use
+	`real-condition' here.
+	(handle-file-compiler-termination): As a result, not needed anymore.
+	(call-with-compilation-hooks): Also signal information about
+	normal errors.
+
 2009-12-14  Stas Boukarev  <stassats at gmail.com>
 
 	* doc/slime.texi (ASDF): Document new commands.
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/10 23:07:38	1.259
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/15 21:56:55	1.260
@@ -422,7 +422,8 @@
     (when (typep condition 'warning)
       (signal condition))
     (setq *previous-compiler-condition* condition)
-    (signal-compiler-condition condition (sb-c::find-error-context nil))))
+    (signal-compiler-condition (real-condition condition)
+                               (sb-c::find-error-context nil))))
 
 (defun signal-compiler-condition (condition context)
   (signal (make-condition
@@ -431,14 +432,14 @@
            :severity (etypecase condition
                        (sb-c:compiler-error  :error)
                        (sb-ext:compiler-note :note)
+                       (error                :error)
+                       (reader-error         :read-error)
                        #+#.(swank-backend::with-symbol redefinition-warning sb-kernel)
                        (sb-kernel:redefinition-warning
                                              :redefinition)
                        (style-warning        :style-warning)
-                       (warning              :warning)
-                       (reader-error         :read-error)
-                       (error                :error))
-           :references (condition-references (real-condition condition))
+                       (warning              :warning))
+           :references (condition-references condition)
            :message (brief-compiler-message-for-emacs condition)
            :source-context (compiler-error-context context)
            :location (compiler-note-location condition context))))
@@ -543,16 +544,13 @@
       ;; N.B. Even though these handlers are called HANDLE-FOO they
       ;; actually decline, i.e. the signalling of the original
       ;; condition continues upward.
-      ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
-       (sb-c:compiler-error  #'handle-notification-condition)
-       (sb-ext:compiler-note #'handle-notification-condition)
-       (warning              #'handle-notification-condition))
+      ((sb-c:fatal-compiler-error #'handle-notification-condition)
+       (sb-c:compiler-error       #'handle-notification-condition)
+       (sb-ext:compiler-note      #'handle-notification-condition)
+       (error                     #'handle-notification-condition)
+       (warning                   #'handle-notification-condition))
     (funcall function)))
 
-(defun handle-file-compiler-termination (condition)
-  "Handle a condition that caused the file compiler to terminate."
-  (handle-notification-condition
-   (sb-int:encapsulated-condition condition)))
 
 (defvar *trap-load-time-warnings* nil)
 
--- /project/slime/cvsroot/slime/swank.lisp	2009/12/10 23:15:42	1.674
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/15 21:56:55	1.675
@@ -2802,7 +2802,12 @@
     (multiple-value-bind (successp seconds)
         (handler-bind ((compiler-condition
                         (lambda (c) (push (make-compiler-note c) notes))))
-          (measure-time-interval function))
+          (measure-time-interval
+           #'(lambda ()
+               ;; To report location of error-signaling toplevel forms
+               ;; for errors in EVAL-WHEN or during macroexpansion.
+               (with-simple-restart (abort "Abort compilation.")
+                 (funcall function)))))
       (make-compilation-result (reverse notes) (and successp t) seconds))))
 
 (defslimefun compile-file-for-emacs (filename load-p &optional options)




From trittweiler at common-lisp.net  Wed Dec 16 09:24:12 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 16 Dec 2009 04:24:12 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NKq7A-0000if-6Y@common-lisp.net>

Update of /project/slime/cvsroot/slime/doc
In directory cl-net:/tmp/cvs-serv2759/doc

Modified Files:
	slime.texi 
Log Message:
	* swank.lisp (*sldb-quit-restart*): Export. For users to customize
	what `q' does in SLDB.
	(handle-requests): Test differently for recursive invocations
	as *sldb-quit-restart* may now be globally bound due to user
	customization.
	(coerce-restart): Coerces a restart-designator to a restart.
	(throw-to-toplevel): Use it.

	* slime.texi (swank:*sldb-quit-restart*): Document it.


--- /project/slime/cvsroot/slime/doc/slime.texi	2009/12/15 17:12:42	1.90
+++ /project/slime/cvsroot/slime/doc/slime.texi	2009/12/16 09:24:11	1.91
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2009/12/15 17:12:42 $}
+ at set UPDATED @code{$Date: 2009/12/16 09:24:11 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -1396,9 +1396,11 @@
 @kbditem{a, sldb-abort}
 Invoke the @code{ABORT} restart.
 
+ at anchor{sldb-quit}
 @kbditem{q, sldb-quit}
-``Quit'' -- @code{THROW} to a tag that the top-level @SLIME{}
-request-loop catches.
+``Quit'' -- For @SLIME{} evaluation requests, invoke a restart which
+restores to a known program state. For errors in other threads, see
+ at ref{SWANK:*SLDB-QUIT-RESTART*}.
 
 @kbditem{c, sldb-continue}
 Invoke the @code{CONTINUE} restart.
@@ -1832,11 +1834,26 @@
 to handle all debugging in the Lisp image. This is for debugging
 multithreaded and callback-driven applications.
 
- at vindex SWANK:*SLDB-PRINTER-BINDINGS*
+ at anchor{SWANK:*SLDB-QUIT-RESTART*}
+ at vindex SWANK:*SLDB-QUIT-RESTART*
+ at item SWANK:*SLDB-QUIT-RESTART*
+This variable names the restart that is invoked when pressing @kbd{q}
+(@pxref{sldb-quit}) in @SLDB{}. For @SLIME{} evaluation requests this
+is @emph{unconditionally} bound to a restart that returns to a safe
+point. This variable is supposed to customize what @kbd{q} does if an
+application's thread lands into the debuggger (see
+ at code{SWANK:*GLOBAL-DEBUGGER*}).
+ at example
+(setf swank:*sldb-quit-restart* 'sb-thread:terminate-thread)
+ at end example
+
+ at vindex SWANK:*BACKTRACE-PRINTER-BINDINGS*
 @vindex SWANK:*MACROEXPAND-PRINTER-BINDINGS*
+ at vindex SWANK:*SLDB-PRINTER-BINDINGS*
 @vindex SWANK:*SWANK-PPRINT-BINDINGS*
- at item SWANK:*SLDB-PRINTER-BINDINGS*
+ at item SWANK:*BACKTRACE-PRINTER-BINDINGS*
 @itemx SWANK:*MACROEXPAND-PRINTER-BINDINGS*
+ at itemx SWANK:*SLDB-PRINTER-BINDINGS*
 @itemx SWANK:*SWANK-PPRINT-BINDINGS*
 These variables can be used to customize the printer in various
 situations.  The values of the variables are association lists of




From trittweiler at common-lisp.net  Wed Dec 16 09:24:12 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 16 Dec 2009 04:24:12 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NKq7A-0000ir-GP@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv2759

Modified Files:
	swank.lisp ChangeLog 
Log Message:
	* swank.lisp (*sldb-quit-restart*): Export. For users to customize
	what `q' does in SLDB.
	(handle-requests): Test differently for recursive invocations
	as *sldb-quit-restart* may now be globally bound due to user
	customization.
	(coerce-restart): Coerces a restart-designator to a restart.
	(throw-to-toplevel): Use it.

	* slime.texi (swank:*sldb-quit-restart*): Document it.


--- /project/slime/cvsroot/slime/swank.lisp	2009/12/15 21:56:55	1.675
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/16 09:24:12	1.676
@@ -38,6 +38,7 @@
            #:*readtable-alist*
            #:*globally-redirect-io*
            #:*global-debugger*
+           #:*sldb-quit-restart*
            #:*backtrace-printer-bindings*
            #:*default-worker-thread-bindings*
            #:*macroexpand-printer-bindings*
@@ -521,6 +522,12 @@
 (defun current-thread-id ()
   (thread-id (current-thread)))
 
+(defmacro define-special (name doc)
+  "Define a special variable NAME with doc string DOC.
+This is like defvar, but NAME will not be initialized."
+  `(progn
+    (defvar ,name)
+    (setf (documentation ',name 'variable) ,doc)))
 
 
 ;;;;; Logging
@@ -978,16 +985,19 @@
       (when socket
         (close-socket socket)))))
 
-;; The restart that will be invoked when the user calls sldb-quit.
-;; This restart will be named "abort" because many people press "a"
-;; instead of "q" in the debugger.
-(defvar *sldb-quit-restart*)
+;; By default, this restart will be named "abort" because many people
+;; press "a" instead of "q" in the debugger.
+(define-special *sldb-quit-restart*
+    "The restart that will be invoked when the user calls sldb-quit.")
 
 ;; Establish a top-level restart and execute BODY.
 ;; Execute K if the restart is invoked.
 (defmacro with-top-level-restart ((connection k) &body body)
   `(with-connection (,connection)
-     (restart-case 
+     (restart-case
+         ;; We explicitly rebind (and do not look at user's
+         ;; customization), so sldb-quit will always be our restart
+         ;; for rex requests.
          (let ((*sldb-quit-restart* (find-restart 'abort)))
            . ,body)
        (abort (&optional v)
@@ -999,9 +1009,10 @@
 (defun handle-requests (connection &optional timeout)
   "Read and process :emacs-rex requests.
 The processing is done in the extent of the toplevel restart."
-  (cond ((boundp '*sldb-quit-restart*)
+  (cond ((eq *emacs-connection* connection)
+         (assert (boundp '*sldb-quit-restart*))
          (process-requests timeout))
-        (t 
+        (t
          (tagbody
             start
             (with-top-level-restart (connection (go start))
@@ -1910,13 +1921,6 @@
 
 ;;;; Reading and printing
 
-(defmacro define-special (name doc)
-  "Define a special variable NAME with doc string DOC.
-This is like defvar, but NAME will not be initialized."
-  `(progn
-    (defvar ,name)
-    (setf (documentation ',name 'variable) ,doc)))
-
 (define-special *buffer-package*     
     "Package corresponding to slime-buffer-package.  
 
@@ -2692,12 +2696,16 @@
 (defslimefun sldb-continue ()
   (continue))
 
+(defun coerce-restart (restart-designator)
+  (when (or (typep restart-designator 'restart)
+            (typep restart-designator '(and symbol (not null))))
+    (find-restart restart-designator)))
+
 (defslimefun throw-to-toplevel ()
   "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
 If we are not evaluating an RPC then ABORT instead."
   (let ((restart (and (boundp '*sldb-quit-restart*)
-                      (typep *sldb-quit-restart* 'restart)
-                      (find-restart *sldb-quit-restart*))))
+                      (coerce-restart *sldb-quit-restart*))))
     (cond (restart (invoke-restart restart))
           (t "No toplevel restart active"))))
 
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/15 21:56:55	1.1937
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/16 09:24:12	1.1938
@@ -1,5 +1,17 @@
 2009-12-15  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (*sldb-quit-restart*): Export. For users to customize
+	what `q' does in SLDB.
+	(handle-requests): Test differently for recursive invocations
+	as *sldb-quit-restart* may now be globally bound due to user
+	customization.
+	(coerce-restart): Coerces a restart-designator to a restart.
+	(throw-to-toplevel): Use it.
+
+	* slime.texi (swank:*sldb-quit-restart*): Document it.
+
+2009-12-15  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (collect-notes): Establish new abort restart ("Abort
 	Compilation"); if an error is signaled in EVAL-WHEN, or during
 	macroexpansion -- assuming the backend DTRT --, invoking this




From sboukarev at common-lisp.net  Wed Dec 16 11:36:46 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 16 Dec 2009 06:36:46 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NKsBS-0000nG-0h@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv3028

Modified Files:
	ChangeLog swank.lisp 
Log Message:
swank.lisp(compile-file-output): Use
(make-pathname :directory dir :defaults (compile-file-pathname file))
instead of (compile-file-pathname file :output-file dir),
because the latter works differently on different implementations.
(fasl-pathname): Use the above function.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/16 09:24:12	1.1938
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/16 11:36:45	1.1939
@@ -1,3 +1,11 @@
+2009-12-16  Stas Boukarev  <stassats at gmail.com>
+
+	* swank.lisp (compile-file-output): Use
+	(make-pathname :directory dir :defaults (compile-file-pathname file))
+	instead of (compile-file-pathname file :output-file dir),
+	because the latter works differently on different implementations.
+	(fasl-pathname): Use the above function.
+
 2009-12-15  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (*sldb-quit-restart*): Export. For users to customize
--- /project/slime/cvsroot/slime/swank.lisp	2009/12/16 09:24:12	1.676
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/16 11:36:45	1.677
@@ -2765,10 +2765,10 @@
             (setq *sldb-stepping-p* t)
             (,backend-function-name))
            ((find-restart 'continue)
-         (activate-stepping frame)
-         (setq *sldb-stepping-p* t)
-         (continue))
-        (t
+            (activate-stepping frame)
+            (setq *sldb-stepping-p* t)
+            (continue))
+           (t
             (error "Not currently single-stepping, and no continue restart available.")))))
 
 (define-stepper-function sldb-step sldb-step-into)
@@ -2838,14 +2838,17 @@
 (defvar *fasl-pathname-function* nil
   "In non-nil, use this function to compute the name for fasl-files.")
 
+(defun compile-file-output (file directory)
+  (make-pathname :directory directory
+                 :defaults (compile-file-pathname file)))
+
 (defun fasl-pathname (input-file options)
   (cond (*fasl-pathname-function*
          (funcall *fasl-pathname-function* input-file options))
         ((getf options :fasl-directory)
-         (let* ((str (getf options :fasl-directory))
-                (dir (filename-to-pathname str)))
-           (assert (char= (aref str (1- (length str))) #\/))
-           (compile-file-pathname input-file :output-file dir)))
+         (let ((dir (getf options :fasl-directory)))
+           (assert (char= (aref dir (1- (length dir))) #\/))
+           (compile-file-output input-file dir)))
         (t
          (compile-file-pathname input-file))))
 




From trittweiler at common-lisp.net  Wed Dec 16 21:59:49 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 16 Dec 2009 16:59:49 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NL1uP-0003wZ-Oi@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv15140

Modified Files:
	swank-sbcl.lisp ChangeLog 
Log Message:
	* swank-sbcl.org (categorize-definition-source): New.
	(definition-source-for-emacs): Use it. Slightly
	refactored. Renamed from `make-definition-source-location'.
	(find-definitions, find-source-location)
	(source-location-for-xref-data, function-dspec): Updated
	accordingly.
	(source-file-position): Scratch last argument, not needed anymore.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/15 21:56:55	1.260
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/16 21:59:49	1.261
@@ -689,14 +689,11 @@
 
 (defimplementation find-definitions (name)
   (loop for type in *definition-types* by #'cddr
-        for locations = (sb-introspect:find-definition-sources-by-name
-                         name type)
-        append (loop for source-location in locations collect
-                       (list (make-dspec type name source-location)
-                             (converting-errors-to-location
-                               (make-definition-source-location source-location
-                                                                type
-                                                                name))))))
+        for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
+        append (loop for defsrc in defsrcs collect
+                     (list (make-dspec type name defsrc)
+                           (converting-errors-to-location
+                             (definition-source-for-emacs defsrc type name))))))
 
 (defimplementation find-source-location (obj)
   (flet ((general-type-of (obj)
@@ -708,7 +705,7 @@
              (class              :class)
              (method-combination :method-combination)
              (package            :package)
-             (condition          :condition)             
+             (condition          :condition)
              (structure-object   :structure-object)
              (standard-object    :standard-object)
              (t                  :thing)))
@@ -720,62 +717,75 @@
                 (print-unreadable-object (obj s :type t :identity t))))
              (t (princ-to-string obj)))))
     (converting-errors-to-location
-      (make-definition-source-location (sb-introspect:find-definition-source obj)
-                                       (general-type-of obj)
-                                       (to-string obj)))))
+      (let ((defsrc (sb-introspect:find-definition-source obj)))
+        (definition-source-for-emacs defsrc
+                                     (general-type-of obj)
+                                     (to-string obj))))))
 
 
-(defun make-definition-source-location (definition-source type name)
+(defun categorize-definition-source (definition-source)
+  (with-struct (sb-introspect::definition-source-
+                   pathname form-path character-offset plist)
+      definition-source
+    (when (getf plist :emacs-buffer)
+      (return-from categorize-definition-source :buffer))
+    (when (and pathname (or form-path character-offset))
+      (return-from categorize-definition-source :file))
+    :invalid))
+
+(defun definition-source-for-emacs (definition-source type name)
   (with-struct (sb-introspect::definition-source-
                    pathname form-path character-offset plist
                    file-write-date)
       definition-source
-    (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
-                              emacs-string &allow-other-keys)
-        plist
-      (cond
-        (emacs-buffer
+    (ecase (categorize-definition-source definition-source)
+      (:buffer
+       (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
+                                 emacs-string &allow-other-keys)
+           plist
          (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
            (multiple-value-bind (start end)
                (if form-path
                    (with-debootstrapping
                      (source-path-string-position form-path emacs-string))
                    (values character-offset most-positive-fixnum))
-             (make-location `(:buffer ,emacs-buffer)
-                            `(:offset ,emacs-position ,start)
-                            `(:snippet
-                              ,(subseq emacs-string
-                                       start
-                                       (min end (+ start *source-snippet-size*))))))))
-        ((not pathname)
-         `(:error ,(format nil "Source definition of ~A ~A not found"
-                           (string-downcase type) name)))
-        (t
-         (let* ((namestring (namestring (translate-logical-pathname pathname)))
-                (pos (source-file-position namestring file-write-date form-path
-                                           character-offset))
-                (snippet (source-hint-snippet namestring file-write-date pos)))
-           (make-location `(:file ,namestring)
-                          ;; /file positions/ in Common Lisp start
-                          ;; from 0, in Emacs they start from 1.
-                          `(:position ,(1+ pos))
-                          `(:snippet ,snippet))))))))
+             (make-location
+              `(:buffer ,emacs-buffer)
+              `(:offset ,emacs-position ,start)
+              `(:snippet
+                ,(subseq emacs-string
+                         start
+                         (min end (+ start *source-snippet-size*)))))))))
+      (:file
+       (let* ((namestring (namestring (translate-logical-pathname pathname)))
+              (pos (if form-path
+                       (source-file-position namestring file-write-date form-path)
+                       character-offset))
+              (snippet (source-hint-snippet namestring file-write-date pos)))
+         (make-location `(:file ,namestring)
+                        ;; /file positions/ in Common Lisp start from
+                        ;; 0, buffer positions in Emacs start from 1.
+                        `(:position ,(1+ pos))
+                        `(:snippet ,snippet))))
+      (:invalid
+       (error "DEFINITION-SOURCE of ~A ~A did not contain ~
+               meaningful information."
+              (string-downcase type) name)))))
 
-(defun source-file-position (filename write-date form-path character-offset)
+(defun source-file-position (filename write-date form-path)
   (let ((source (get-source-code filename write-date))
         (*readtable* (guess-readtable-for-filename filename)))
     (with-debootstrapping
-      (if form-path
-          (source-path-string-position form-path source)
-          (or character-offset 0)))))
+      (source-path-string-position form-path source))))
 
 (defun source-hint-snippet (filename write-date position)
   (read-snippet-from-string (get-source-code filename write-date) position))
 
 (defun function-source-location (function &optional name)
   (declare (type function function))
-  (let ((location (sb-introspect:find-definition-source function)))
-    (make-definition-source-location location :function name)))
+  (definition-source-for-emacs (sb-introspect:find-definition-source function)
+                               :function
+                               (or name (function-name function))))
 
 (defimplementation describe-symbol-for-emacs (symbol)
   "Return a plist describing SYMBOL.
@@ -843,11 +853,9 @@
   (defxref who-specializes who-specializes-directly))
 
 (defun source-location-for-xref-data (xref-data)
-  (let ((name (car xref-data))
-        (source-location (cdr xref-data)))
-    (list name (make-definition-source-location source-location
-                                                'function
-                                                name))))
+  (destructuring-bind (name . defsrc) xref-data
+    (list name (converting-errors-to-location
+                 (definition-source-for-emacs defsrc 'function name)))))
 
 (defimplementation list-callers (symbol)
   (let ((fn (fdefinition symbol)))
@@ -887,7 +895,7 @@
 (defun function-dspec (fn)
   "Describe where the function FN was defined.
 Return a list of the form (NAME LOCATION)."
-  (let ((name (sb-kernel:%fun-name fn)))
+  (let ((name (function-name fn)))
     (list name (converting-errors-to-location
                  (function-source-location fn name)))))
 
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/16 11:36:45	1.1939
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/16 21:59:49	1.1940
@@ -1,3 +1,13 @@
+2009-12-16  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-sbcl.org (categorize-definition-source): New.
+	(definition-source-for-emacs): Use it. Slightly
+	refactored. Renamed from `make-definition-source-location'.
+	(find-definitions, find-source-location)
+	(source-location-for-xref-data, function-dspec): Updated
+	accordingly.
+	(source-file-position): Scratch last argument, not needed anymore.
+
 2009-12-16  Stas Boukarev  <stassats at gmail.com>
 
 	* swank.lisp (compile-file-output): Use
@@ -6,7 +16,7 @@
 	because the latter works differently on different implementations.
 	(fasl-pathname): Use the above function.
 
-2009-12-15  Tobias C. Rittweiler <tcr at freebits.de>
+2009-12-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (*sldb-quit-restart*): Export. For users to customize
 	what `q' does in SLDB.




From trittweiler at common-lisp.net  Wed Dec 16 22:02:20 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 16 Dec 2009 17:02:20 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NL1wq-0004ml-5p@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv18396

Modified Files:
	swank-sbcl.lisp 
Log Message:
simplify newly introduced categorize-definition-source;
gosh what was I thinking?


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/16 21:59:49	1.261
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/16 22:02:20	1.262
@@ -727,11 +727,9 @@
   (with-struct (sb-introspect::definition-source-
                    pathname form-path character-offset plist)
       definition-source
-    (when (getf plist :emacs-buffer)
-      (return-from categorize-definition-source :buffer))
-    (when (and pathname (or form-path character-offset))
-      (return-from categorize-definition-source :file))
-    :invalid))
+    (cond ((getf plist :emacs-buffer) :buffer)
+          ((and pathname (or form-path character-offset)) :file)
+          (t :invalid))))
 
 (defun definition-source-for-emacs (definition-source type name)
   (with-struct (sb-introspect::definition-source-




From sboukarev at common-lisp.net  Thu Dec 17 06:25:01 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 17 Dec 2009 01:25:01 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NL9nJ-00021k-Aa@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv7782

Modified Files:
	ChangeLog swank.lisp 
Log Message:
swank.lisp(handle-requests): Comment out
(assert (boundp '*sldb-quit-restart*)) because it's not bound
on NIL communication style. It's not a real fix, but at least it
lets null communication-style work.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/16 21:59:49	1.1940
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/17 06:25:00	1.1941
@@ -1,3 +1,10 @@
+2009-12-17  Stas Boukarev  <stassats at gmail.com>
+
+	* swank.lisp (handle-requests): Comment out
+	(assert (boundp '*sldb-quit-restart*)) because it's not bound
+	on NIL communication style. It's not a real fix, but at least it
+	lets null communication-style work.
+
 2009-12-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-sbcl.org (categorize-definition-source): New.
--- /project/slime/cvsroot/slime/swank.lisp	2009/12/16 11:36:45	1.677
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/17 06:25:00	1.678
@@ -1010,7 +1010,8 @@
   "Read and process :emacs-rex requests.
 The processing is done in the extent of the toplevel restart."
   (cond ((eq *emacs-connection* connection)
-         (assert (boundp '*sldb-quit-restart*))
+         ;; *sldb-quit-restart* isn't bound here on *communication-style* NIL
+         ;; (assert (boundp '*sldb-quit-restart*))
          (process-requests timeout))
         (t
          (tagbody




From sboukarev at common-lisp.net  Thu Dec 17 09:48:20 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 17 Dec 2009 04:48:20 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NLCy4-0007ZN-1y@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv29098

Modified Files:
	swank-match.lisp 
Log Message:
swank-match.lisp: Fix formatting and style warnings.


--- /project/slime/cvsroot/slime/swank-match.lisp	2009/10/31 22:13:55	1.1
+++ /project/slime/cvsroot/slime/swank-match.lisp	2009/12/17 09:48:19	1.2
@@ -22,16 +22,14 @@
 ;;  Synopsis:
 ;;
 ;;  (select-match expression
-;;      (pattern  action+)*
-;;  )
+;;      (pattern  action+)*)
 ;;
 ;;      --- or ---
 ;;
 ;;  (select-match expression
 ;;      pattern => expression
 ;;      pattern => expression
-;;      ...
-;;  )
+;;      ...)
 ;;
 ;;  pattern ->  constant		;egs  1, #\x, #c(1.0 1.1)
 ;;          |   symbol                  ;matches anything
@@ -63,8 +61,7 @@
 ;;  .   Symbols match anything. The symbol is bound to the matched item
 ;;      for the execution of the actions.
 ;;      For example, (SELECT-MATCH '(1 2 3)
-;;                      (1 . X) => X
-;;                   )
+;;                      (1 . X) => X)
 ;;      returns (2 3) because X is bound to the cdr of the candidate.
 ;;
 ;;  .   The two pattern match (p1 = p2) can be used to name parts
@@ -97,106 +94,71 @@
   `(select-match ,expression , at patterns))
 
 (defmacro select-match (expression &rest patterns)
-    (let* ( (do-let (not (atom expression)))
-            (key    (if do-let (gensym) expression))
-            (cbody  (expand-select-patterns key patterns))
-            (cform  `(cond . ,cbody))
-          )
-
-        (if do-let
-            `(let ((,key ,expression)) ,cform)
-            cform))
-)
-
+  (let* ((do-let (not (atom expression)))
+         (key    (if do-let (gensym) expression))
+         (cbody  (expand-select-patterns key patterns))
+         (cform  `(cond . ,cbody)))
+    (if do-let
+        `(let ((,key ,expression)) ,cform)
+        cform)))
 
 (defun expand-select-patterns (key patterns)
-    (if (eq (second patterns) '=>)
-        (expand-select-patterns-style-2 key patterns)
-        (expand-select-patterns-style-1 key patterns)))
-
+  (if (eq (second patterns) '=>)
+      (expand-select-patterns-style-2 key patterns)
+      (expand-select-patterns-style-1 key patterns)))
 
 (defun expand-select-patterns-style-1 (key patterns)
-
   (if (null patterns)
-  
-    `((t (error "Case select pattern match failure on ~S" ,key)))
-
-    (let ((pattern  (caar patterns))
-          (actions  (cdar patterns))
-          (rest     (cdr patterns)) )
-
-        (let  ( (test       (compile-select-test key pattern))
-                (bindings   (compile-select-bindings key pattern actions)))
-
-            `(  ,(if bindings  `(,test (let ,bindings . ,actions))
-                               `(,test . ,actions))
-              . ,(if (eq test t)
-                    nil
-                    (expand-select-patterns-style-1 key rest)))
-        )
-    )
-))
-
-
+      `((t (error "Case select pattern match failure on ~S" ,key)))
+      (let* ((pattern  (caar patterns))
+             (actions  (cdar patterns))
+             (rest     (cdr patterns))
+             (test     (compile-select-test key pattern))
+             (bindings (compile-select-bindings key pattern actions)))
+        `(,(if bindings `(,test (let ,bindings . ,actions))
+               `(,test . ,actions))
+           . ,(unless (eq test t)
+                (expand-select-patterns-style-1 key rest))))))
 
 (defun expand-select-patterns-style-2 (key patterns)
-
-  (if (null patterns)
-  
-    `((t (error "Case select pattern match failure on ~S" ,key)))
-
-    (let ((pattern  (first patterns))
-          (arrow    (if (or (< (length patterns) 3)
-                            (not (eq (second patterns) '=>)))
-                        (error "Illegal patterns: ~S" patterns)))
-          (actions  (list (third patterns)))
-          (rest     (cdddr patterns)) )
-
-        (let  ( (test       (compile-select-test key pattern))
-                (bindings   (compile-select-bindings key pattern actions)))
-
-            `(  ,(if bindings  `(,test (let ,bindings . ,actions))
-                               `(,test . ,actions))
-              . ,(if (eq test t)
-                    nil
-                    (expand-select-patterns-style-2 key rest)))
-        )
-    )
-))
-
-
+  (cond ((null patterns)
+         `((t (error "Case select pattern match failure on ~S" ,key))))
+        (t (when (or (< (length patterns) 3)
+                     (not (eq (second patterns) '=>)))
+             (error "Illegal patterns: ~S" patterns))
+           (let* ((pattern  (first patterns))
+                  (actions  (list (third patterns)))
+                  (rest     (cdddr patterns))
+                  (test     (compile-select-test key pattern))
+                  (bindings (compile-select-bindings key pattern actions)))
+             `(,(if bindings `(,test (let ,bindings . ,actions))
+                    `(,test . ,actions))
+                . ,(unless (eq test t)
+                     (expand-select-patterns-style-2 key rest)))))))
 
 (defun compile-select-test (key pattern)
-    (let  ((tests (remove-if
-                        #'(lambda (item) (eq item t))
-                        (compile-select-tests key pattern))))
-        (cond
-            ;; note AND does this anyway, but this allows us to tell if
-            ;; the pattern will always match.
-            ((null tests)           t)
-            ((= (length tests) 1)   (car tests))
-            (t                      `(and . ,tests)))))
-
+  (let ((tests (remove t (compile-select-tests key pattern))))
+    (cond
+      ;; note AND does this anyway, but this allows us to tell if
+      ;; the pattern will always match.
+      ((null tests)         t)
+      ((= (length tests) 1) (car tests))
+      (t                    `(and . ,tests)))))
 
 (defun compile-select-tests (key pattern)
-
-  (cond   ((constantp pattern)   `((,(cond ((numberp pattern) 'eql)
-                                           ((symbolp pattern) 'eq)
-                                           (t                'equal))
-                                     ,key ,pattern)))
-
+  (cond ((constantp pattern)   `((,(cond ((numberp pattern) 'eql)
+                                         ((symbolp pattern) 'eq)
+                                         (t                'equal))
+                                   ,key ,pattern)))
         ((symbolp pattern)      '(t))
-
         ((select-double-match? pattern)
          (append
           (compile-select-tests key (first pattern))
           (compile-select-tests key (third pattern))))
-
         ((select-predicate? pattern)
          (append
           `((,(second (first pattern)) ,key))
           (compile-select-tests key (second pattern))))
-
         ((consp pattern)
          (append
           `((consp ,key))
@@ -204,88 +166,73 @@
                                                pattern))
           (compile-select-tests (!cs-cdr key) (cdr
                                                pattern))))
-
-        (t         (error "Illegal select pattern: ~S" pattern))
-        )
-  )
+        (t (error "Illegal select pattern: ~S" pattern))))
 
 
 (defun compile-select-bindings (key pattern action)
-
-  (cond   ((constantp pattern)    '())
+  (cond ((constantp pattern) '())
         ((symbolp pattern)
-         (if (select!-in-tree pattern action) `((,pattern ,key))
+         (if (select!-in-tree pattern action)
+             `((,pattern ,key))
              '()))
-
         ((select-double-match? pattern)
          (append
           (compile-select-bindings key (first pattern) action)
-          (compile-select-bindings key (third pattern)
-                                   action)))
-
+          (compile-select-bindings key (third pattern) action)))
         ((select-predicate? pattern)
-         (compile-select-bindings key (second pattern)
-                                  action))
-
+         (compile-select-bindings key (second pattern) action))
         ((consp pattern)
          (append
           (compile-select-bindings (!cs-car key) (car pattern)
                                    action)
           (compile-select-bindings (!cs-cdr key) (cdr pattern)
-                                   action)))
-        )
-  )
-
+                                   action)))))
 
 (defun select!-in-tree (atom tree)
-    (or (eq atom tree)
-        (if (consp tree)
-            (or (select!-in-tree atom (car tree))
-                (select!-in-tree atom (cdr tree))))))
+  (or (eq atom tree)
+      (if (consp tree)
+          (or (select!-in-tree atom (car tree))
+              (select!-in-tree atom (cdr tree))))))
 
 (defun select-double-match? (pattern)
-    ;;  (<pattern> = <pattern>)
-    (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
-         (null (cdddr pattern))
-         (eq (second pattern) '=)))
-
+  ;;  (<pattern> = <pattern>)
+  (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
+       (null (cdddr pattern))
+       (eq (second pattern) '=)))
 
 (defun select-predicate? (pattern)
-    ;; ((function <f>) <pattern>)
-    (and    (consp pattern)
-            (consp (cdr pattern))
-            (null (cddr pattern))
-            (consp (first pattern))
-            (consp (cdr (first pattern)))
-            (null (cddr (first pattern)))
-            (eq (caar pattern) 'function)))
-
-
-
+  ;; ((function <f>) <pattern>)
+  (and (consp pattern)
+       (consp (cdr pattern))
+       (null (cddr pattern))
+       (consp (first pattern))
+       (consp (cdr (first pattern)))
+       (null (cddr (first pattern)))
+       (eq (caar pattern) 'function)))
 
 (defun !cs-car (exp)
-    (!cs-car/cdr 'car exp '(
-            (car . caar)    (cdr . cadr)    (caar . caaar)  (cadr . caadr)
-            (cdar . cadar)  (cddr . caddr)
-            (caaar . caaaar)    (caadr . caaadr)    (cadar . caadar)
-            (caddr . caaddr)    (cdaar . cadaar)    (cdadr . cadadr)
-            (cddar . caddar)    (cdddr . cadddr))))
+  (!cs-car/cdr 'car exp
+               '((car . caar)     (cdr . cadr)    (caar . caaar) (cadr . caadr)
+                 (cdar . cadar)   (cddr . caddr)
+                 (caaar . caaaar) (caadr . caaadr) (cadar . caadar)
+                 (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
+                 (cddar . caddar) (cdddr . cadddr))))
 
 (defun !cs-cdr (exp)
-    (!cs-car/cdr 'cdr exp '(
-            (car . cdar)    (cdr . cddr)    (caar . cdaar)  (cadr . cdadr)
-            (cdar . cddar)  (cddr . cdddr)
-            (caaar . cdaaar)    (caadr . cdaadr)    (cadar . cdadar)
-            (caddr . cdaddr)    (cdaar . cddaar)    (cdadr . cddadr)
-            (cddar . cdddar)    (cdddr . cddddr))))
+  (!cs-car/cdr 'cdr exp
+               '((car . cdar)    (cdr . cddr)    (caar . cdaar)  (cadr . cdadr)
+                 (cdar . cddar)  (cddr . cdddr)
+                 (caaar . cdaaar)    (caadr . cdaadr)    (cadar . cdadar)
+                 (caddr . cdaddr)    (cdaar . cddaar)    (cdadr . cddadr)
+                 (cddar . cdddar)    (cdddr . cddddr))))
 
 (defun !cs-car/cdr (op exp table)
-    (if (and (consp exp) (= (length exp) 2))
-        (let ((replacement  (assoc (car exp) table)))
-            (if replacement
-                `(,(cdr replacement) ,(second exp))
-                `(,op ,exp)))
-        `(,op ,exp)))
+  (if (and (consp exp) (= (length exp) 2))
+      (let ((replacement  (assoc (car exp) table)))
+        (if replacement
+            `(,(cdr replacement) ,(second exp))
+            `(,op ,exp)))
+      `(,op ,exp)))
 
 ;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
 ;; (setf c2 '(select-match (car y)




From sboukarev at common-lisp.net  Thu Dec 17 09:49:19 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 17 Dec 2009 04:49:19 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NLCz1-0007ad-0l@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv29151

Modified Files:
	ChangeLog 
Log Message:
swank-match.lisp: Fix formatting and style warnings.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/17 06:25:00	1.1941
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/17 09:49:18	1.1942
@@ -1,5 +1,9 @@
 2009-12-17  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-match.lisp: Fix formatting and style warnings.
+
+2009-12-17  Stas Boukarev  <stassats at gmail.com>
+
 	* swank.lisp (handle-requests): Comment out
 	(assert (boundp '*sldb-quit-restart*)) because it's not bound
 	on NIL communication style. It's not a real fix, but at least it




From trittweiler at common-lisp.net  Thu Dec 17 10:15:18 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 17 Dec 2009 05:15:18 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NLDOA-0000dl-Tq@common-lisp.net>

Update of /project/slime/cvsroot/slime/doc
In directory cl-net:/tmp/cvs-serv1646/doc

Modified Files:
	slime.texi 
Log Message:
	* swank.lisp (with-top-level-restart): Bind local special.
	(top-level-restart-p): Check for it; this tells us if where's in
	the dynamic extent of with-top-level-restart.
	(handle-requests): Use it.


--- /project/slime/cvsroot/slime/doc/slime.texi	2009/12/16 09:24:11	1.91
+++ /project/slime/cvsroot/slime/doc/slime.texi	2009/12/17 10:15:18	1.92
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2009/12/16 09:24:11 $}
+ at set UPDATED @code{$Date: 2009/12/17 10:15:18 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -1841,7 +1841,7 @@
 (@pxref{sldb-quit}) in @SLDB{}. For @SLIME{} evaluation requests this
 is @emph{unconditionally} bound to a restart that returns to a safe
 point. This variable is supposed to customize what @kbd{q} does if an
-application's thread lands into the debuggger (see
+application's thread lands into the debugger (see
 @code{SWANK:*GLOBAL-DEBUGGER*}).
 @example
 (setf swank:*sldb-quit-restart* 'sb-thread:terminate-thread)




From trittweiler at common-lisp.net  Thu Dec 17 10:15:19 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 17 Dec 2009 05:15:19 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NLDOB-0000dx-8P@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv1646

Modified Files:
	swank.lisp ChangeLog 
Log Message:
	* swank.lisp (with-top-level-restart): Bind local special.
	(top-level-restart-p): Check for it; this tells us if where's in
	the dynamic extent of with-top-level-restart.
	(handle-requests): Use it.


--- /project/slime/cvsroot/slime/swank.lisp	2009/12/17 06:25:00	1.678
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/17 10:15:19	1.679
@@ -998,24 +998,37 @@
          ;; We explicitly rebind (and do not look at user's
          ;; customization), so sldb-quit will always be our restart
          ;; for rex requests.
-         (let ((*sldb-quit-restart* (find-restart 'abort)))
-           . ,body)
+         (let ((*sldb-quit-restart* (find-restart 'abort))
+               (*toplevel-restart-available* t))
+           (declare (special *toplevel-restart-available*))
+           , at body)
        (abort (&optional v)
          :report "Return to SLIME's top level."
          (declare (ignore v))
          (force-user-output)
          ,k))))
 
+(defun top-level-restart-p ()
+  ;; FIXME: this could probably be done better; previously this used
+  ;; *SLDB-QUIT-RESTART* but we cannot use that anymore because it's
+  ;; exported now, and might hence be bound globally.
+  ;;
+  ;; The caveat is that for slime rex requests, we do not want to use
+  ;; the global value of *sldb-quit-restart* because that might be
+  ;; bound to terminate-thread, and hence `q' in the debugger would
+  ;; kill the repl thread.
+  (boundp '*toplevel-restart-available*))
+
 (defun handle-requests (connection &optional timeout)
   "Read and process :emacs-rex requests.
 The processing is done in the extent of the toplevel restart."
-  (cond ((eq *emacs-connection* connection)
-         ;; *sldb-quit-restart* isn't bound here on *communication-style* NIL
-         ;; (assert (boundp '*sldb-quit-restart*))
+  (cond ((top-level-restart-p)
+         (assert (boundp '*sldb-quit-restart*))
+         (assert *emacs-connection*)
          (process-requests timeout))
         (t
          (tagbody
-            start
+          start
             (with-top-level-restart (connection (go start))
               (process-requests timeout))))))
 
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/17 09:49:18	1.1942
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/17 10:15:19	1.1943
@@ -1,3 +1,10 @@
+2009-12-17  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp (with-top-level-restart): Bind local special.
+	(top-level-restart-p): Check for it; this tells us if where's in
+	the dynamic extent of with-top-level-restart.
+	(handle-requests): Use it.
+
 2009-12-17  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-match.lisp: Fix formatting and style warnings.
@@ -11,7 +18,7 @@
 
 2009-12-16  Tobias C. Rittweiler <tcr at freebits.de>
 
-	* swank-sbcl.org (categorize-definition-source): New.
+	* swank-sbcl.lisp (categorize-definition-source): New.
 	(definition-source-for-emacs): Use it. Slightly
 	refactored. Renamed from `make-definition-source-location'.
 	(find-definitions, find-source-location)




From trittweiler at common-lisp.net  Thu Dec 17 10:30:32 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 17 Dec 2009 05:30:32 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NLDct-0001eF-WB@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv6334/contrib

Modified Files:
	swank-asdf.lisp slime-asdf.el ChangeLog 
Log Message:
	* slime.el (slime-edit-uses-xrefs): New variable. For contribs to
	extend.
	(slime-edit-uses): Use it.

	* swank.lisp (xref-doit): Now a generic functions. For contribs to
	extend.

	* swank-asdf.lisp (who-depends-on): Make defslimefun.
	(xref-doit [:depends-on]): New method to make :depends-on valid
	xref request.

	* slime-asdf.el (slime-who-depends-on-rpc): New.
	(slime-who-depends-on): New interactive function.
	(slime-asdf-init): Make `slime-edit-uses' perform a :depends-on
	request, and bind `C-c C-w d' to `slime-who-depends-on'.


--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/15 20:29:01	1.22
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/17 10:30:31	1.23
@@ -22,7 +22,7 @@
         do (funcall fn system)))
 
 ;;; This is probably a crude hack, see ASDF's LP #481187.
-(defun who-depends-on (system)
+(defslimefun who-depends-on (system)
   (flet ((system-dependencies (op system)
            (mapcar #'(lambda (dep)
                        (asdf::coerce-name (if (consp dep) (second dep) dep)))
@@ -37,6 +37,17 @@
              (push (asdf:component-name system) result))))
       result)))
 
+(defmethod xref-doit ((type (eql :depends-on)) thing)
+  (loop for dependency in (who-depends-on thing)
+        for asd-file = (asdf:system-definition-pathname dependency)
+        collect (list dependency
+                      (swank-backend::make-location
+                       `(:file ,(namestring asd-file))
+                       `(:position 1)
+                       `(:snippet ,(format nil "(defsystem :~A" dependency)
+                         :align t)))))
+
+
 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
   "Compile and load SYSTEM using ASDF.
 Record compiler notes signalled as `compiler-condition's."
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/15 17:12:41	1.22
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/17 10:30:31	1.23
@@ -68,6 +68,9 @@
   "Try to determine the asdf system that `filename' belongs to."
   (slime-eval `(swank:asdf-determine-system ,filename ,buffer-package)))
 
+(defun slime-who-depends-on-rpc (system)
+  (slime-eval `(swank:who-depends-on ,system)))
+
 (defun slime-oos (system operation &rest keyword-args)
   "Operate On System."
   (slime-save-some-lisp-buffers)
@@ -183,6 +186,10 @@
    `(swank:reload-system ,system)
    #'slime-compilation-finished))
 
+(defun slime-who-depends-on (system-name)
+  (interactive (list (slime-read-system-name)))
+  (slime-xref :depends-on system-name))
+
 
 ;;; REPL shortcuts
 
@@ -246,7 +253,9 @@
   (slime-eval-async '(swank:swank-require :swank-asdf)))
 
 (defun slime-asdf-init ()
-  (add-hook 'slime-connected-hook 'slime-asdf-on-connect))
+  (add-hook 'slime-connected-hook 'slime-asdf-on-connect)
+  (add-to-list 'slime-edit-uses-xrefs :depends-on t)
+  (define-key slime-who-map [?d] 'slime-who-depends-on))
 
 (defun slime-asdf-unload ()
   (remove-hook 'slime-connected-hook 'slime-asdf-on-connect))
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/15 20:29:01	1.306
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/17 10:30:31	1.307
@@ -1,3 +1,14 @@
+2009-12-17  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-asdf.lisp (who-depends-on): Make defslimefun.
+	(xref-doit [:depends-on]): New method to make :depends-on valid
+	xref request.
+
+	* slime-asdf.el (slime-who-depends-on-rpc): New.
+	(slime-who-depends-on): New interactive function.
+	(slime-asdf-init): Make `slime-edit-uses' perform a :depends-on
+	request, and bind `C-c C-w d' to `slime-who-depends-on'.
+
 2009-12-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-asdf.lisp (who-depends-on): Add.




From trittweiler at common-lisp.net  Thu Dec 17 10:30:32 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 17 Dec 2009 05:30:32 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NLDcu-0001eb-B9@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv6334

Modified Files:
	swank.lisp slime.el ChangeLog 
Log Message:
	* slime.el (slime-edit-uses-xrefs): New variable. For contribs to
	extend.
	(slime-edit-uses): Use it.

	* swank.lisp (xref-doit): Now a generic functions. For contribs to
	extend.

	* swank-asdf.lisp (who-depends-on): Make defslimefun.
	(xref-doit [:depends-on]): New method to make :depends-on valid
	xref request.

	* slime-asdf.el (slime-who-depends-on-rpc): New.
	(slime-who-depends-on): New interactive function.
	(slime-asdf-init): Make `slime-edit-uses' perform a :depends-on
	request, and bind `C-c C-w d' to `slime-who-depends-on'.


--- /project/slime/cvsroot/slime/swank.lisp	2009/12/17 10:15:19	1.679
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/17 10:30:32	1.680
@@ -3291,17 +3291,27 @@
     (unless error
       (mapcar #'xref>elisp (find-definitions sexp)))))
 
-(defun xref-doit (type symbol)
-  (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))))
+(defgeneric xref-doit (type thing)
+  (:method ((type (eql :calls)) thing)
+    (who-calls thing))
+  (:method ((type (eql :calls-who)) thing)
+    (calls-who thing))
+  (:method ((type (eql :references)) thing)
+    (who-references thing))
+  (:method ((type (eql :binds)) thing)
+    (who-binds thing))
+  (:method ((type (eql :sets)) thing)
+    (who-sets thing))
+  (:method ((type (eql :macroexpands)) thing)
+    (who-macroexpands thing))
+  (:method ((type (eql :specializes)) thing)
+    (who-specializes thing))
+  (:method ((type (eql :callers)) thing)
+    (list-callers thing))
+  (:method ((type (eql :callees)) thing)
+    (list-callees thing))
+  (:method (type thing)
+    :not-implemented))
 
 (defslimefun xref (type name)
   (multiple-value-bind (sexp error) (ignore-errors (from-string name))
--- /project/slime/cvsroot/slime/slime.el	2009/12/10 23:15:42	1.1256
+++ /project/slime/cvsroot/slime/slime.el	2009/12/17 10:30:32	1.1257
@@ -2604,6 +2604,7 @@
   (interactive)
   (slime-compile-file t))
 
+;;; FIXME: This should become a DEFCUSTOM
 (defvar slime-compile-file-options '()
   "Plist of additional options that C-c C-k should pass to Lisp.
 Currently only :fasl-directory is supported.")
@@ -3871,17 +3872,18 @@
            (slime-show-xrefs file-alist 'definition name
                              (slime-current-package))))))
 
+(defvar slime-edit-uses-xrefs 
+  '(:calls :macroexpands :binds :references :sets :specializes))
+
 ;;; FIXME. TODO: Would be nice to group the symbols (in each
 ;;;              type-group) by their home-package.
 (defun slime-edit-uses (symbol)
   "Lookup all the uses of SYMBOL."
   (interactive (list (slime-read-symbol-name "Edit Uses of: ")))
-  (slime-xrefs '(:calls :macroexpands
-                 :binds :references :sets
-                 :specializes) 
+  (slime-xrefs slime-edit-uses-xrefs
                symbol
                #'(lambda (xrefs type symbol package snapshot)
-                   (cond 
+                   (cond
                      ((null xrefs)
                       (message "No xref information found for %s." symbol))
                      ((and (slime-length= xrefs 1)          ; one group
@@ -3891,7 +3893,7 @@
                         (slime-pop-to-location loc)))
                      (t
                       (slime-push-definition-stack)
-                      (slime-show-xref-buffer xrefs type symbol 
+                      (slime-show-xref-buffer xrefs type symbol
                                               package snapshot))))))
 
 (defun slime-analyze-xrefs (xrefs)
@@ -5022,7 +5024,7 @@
                              :complained)))))))
 
 (defun slime-aggregate-compilation-results (results)
-  `(:complilation-result
+  `(:compilation-result
     ,(reduce #'append (mapcar #'slime-compilation-result.notes results))
     ,(every #'slime-compilation-result.successp results)
     ,(reduce #'+ (mapcar #'slime-compilation-result.duration results))))
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/17 10:15:19	1.1943
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/17 10:30:32	1.1944
@@ -1,7 +1,16 @@
 2009-12-17  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* slime.el (slime-edit-uses-xrefs): New variable. For contribs to
+	extend.
+	(slime-edit-uses): Use it.
+
+	* swank.lisp (xref-doit): Now a generic functions. For contribs to
+	extend.
+
+2009-12-17  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (with-top-level-restart): Bind local special.
-	(top-level-restart-p): Check for it; this tells us if where's in
+	(top-level-restart-p): Check for it; this tells us if we're in
 	the dynamic extent of with-top-level-restart.
 	(handle-requests): Use it.
 




From trittweiler at common-lisp.net  Fri Dec 18 19:47:55 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 18 Dec 2009 14:47:55 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NLinr-0005d8-NF@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv21639/contrib

Modified Files:
	swank-asdf.lisp slime-asdf.el ChangeLog 
Log Message:
	Add 'M-x slime-query-replace-system-and-dependencies' which is
	like `slime-query-replace-system' but also runs query-replace on
	all files of systems _depending on_ the user-queried system.

	* slime-asdf.el (slime-read-query-replace-args): Factored out from
	`slime-query-replace-system'.
	(slime-query-replace-system): Use it.
	(slime-query-replace-system-and-dependencies): Add.

	* swank-asdf.lisp (who-depends-on):
	`asdf:system-definition-pathname' may return NIL, guard against
	that.


--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/17 10:30:31	1.23
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/18 19:47:55	1.24
@@ -40,12 +40,13 @@
 (defmethod xref-doit ((type (eql :depends-on)) thing)
   (loop for dependency in (who-depends-on thing)
         for asd-file = (asdf:system-definition-pathname dependency)
-        collect (list dependency
-                      (swank-backend::make-location
-                       `(:file ,(namestring asd-file))
-                       `(:position 1)
-                       `(:snippet ,(format nil "(defsystem :~A" dependency)
-                         :align t)))))
+        when asd-file
+          collect (list dependency
+                        (swank-backend::make-location
+                         `(:file ,(namestring asd-file))
+                         `(:position 1)
+                         `(:snippet ,(format nil "(defsystem :~A" dependency)
+                           :align t)))))
 
 
 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/17 10:30:31	1.23
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/18 19:47:55	1.24
@@ -155,19 +155,43 @@
       (interactive)
       (error "This command is only supported on GNU Emacs >23.1.x.")))
 
+(defun slime-read-query-replace-args (format-string &rest format-args)
+  (let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook))
+         (minibuffer-local-map slime-minibuffer-map)
+         (common (query-replace-read-args (apply #'format format-string
+                                                 format-args)
+                                          t t)))
+    (list (nth 0 common) (nth 1 common) (nth 2 common))))
+
 (defun slime-query-replace-system (name from to &optional delimited)
   "Run `query-replace' on an ASDF system."
-  (interactive 
-   (let* ((minibuffer-setup-hook (slime-minibuffer-setup-hook))
-	  (minibuffer-local-map slime-minibuffer-map)
-	  (system (slime-read-system-name nil nil t))
-          (common (query-replace-read-args 
-                   (format "Query replace throughout `%s'" system) t t)))
-     (list system (nth 0 common) (nth 1 common) (nth 2 common))))
-  ;; `tags-query-replace' actually uses `query-replace-regexp'
-  ;; internally.
-  (tags-query-replace (regexp-quote from) to delimited
-		      '(slime-eval `(swank:asdf-system-files ,name))))
+  (interactive (let ((system (slime-read-system-name nil nil t)))
+                 (cons system (slime-read-query-replace-args
+                               "Query replace throughout `%s'" system))))
+  (condition-case c
+      ;; `tags-query-replace' actually uses `query-replace-regexp'
+      ;; internally.
+      (tags-query-replace (regexp-quote from) to delimited
+                          '(slime-eval `(swank:asdf-system-files ,name)))
+    (error
+     ;; Kludge: `tags-query-replace' does not actually return but
+     ;; signals an unnamed error with the below error
+     ;; message. (<=23.1.2, at least.)
+     (unless (string-equal (error-message-string c) "All files processed")
+       (signal (car c) (cdr c)))        ; resignal
+     t)))
+
+(defun slime-query-replace-system-and-dependencies
+    (name from to &optional delimited)
+  "Run `query-replace' on an ASDF system."
+  (interactive (let ((system (slime-read-system-name nil nil t)))
+                 (cons system (slime-read-query-replace-args
+                               "Query replace throughout `%s'+dependencies"
+                               system))))
+  (slime-query-replace-system name from to delimited)
+  (dolist (dep (slime-who-depends-on-rpc name))
+    (when (y-or-n-p (format "Descend into system `%s'? " dep))
+      (slime-query-replace-system dep from to delimited))))
 
 (defun slime-delete-system-fasls (name)
   "Delete FASLs produced by compiling a system."
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/17 10:30:31	1.307
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/18 19:47:55	1.308
@@ -1,3 +1,18 @@
+2009-12-18  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Add 'M-x slime-query-replace-system-and-dependencies' which is
+	like `slime-query-replace-system' but also runs query-replace on
+	all files of systems _depending on_ the user-queried system.
+
+	* slime-asdf.el (slime-read-query-replace-args): Factored out from
+	`slime-query-replace-system'.
+	(slime-query-replace-system): Use it.
+	(slime-query-replace-system-and-dependencies): Add.
+
+	* swank-asdf.lisp (who-depends-on):
+	`asdf:system-definition-pathname' may return NIL, guard against
+	that.
+
 2009-12-17  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-asdf.lisp (who-depends-on): Make defslimefun.




From trittweiler at common-lisp.net  Sat Dec 19 10:11:28 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 19 Dec 2009 05:11:28 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NLwHY-0003ky-7B@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv14440/contrib

Modified Files:
	slime-asdf.el ChangeLog 
Log Message:
	* slime-asdf.el (slime-query-replace-system-and-dependents):
	Renamed from `slime-query-replace-system-and-dependencies' because
	that's what it actually does.


--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/18 19:47:55	1.24
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2009/12/19 10:11:27	1.25
@@ -181,9 +181,10 @@
        (signal (car c) (cdr c)))        ; resignal
      t)))
 
-(defun slime-query-replace-system-and-dependencies
+(defun slime-query-replace-system-and-dependents
     (name from to &optional delimited)
-  "Run `query-replace' on an ASDF system."
+  "Run `query-replace' on an ASDF system and all the systems
+depending on it."
   (interactive (let ((system (slime-read-system-name nil nil t)))
                  (cons system (slime-read-query-replace-args
                                "Query replace throughout `%s'+dependencies"
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/18 19:47:55	1.308
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/19 10:11:28	1.309
@@ -1,3 +1,9 @@
+2009-12-19  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-asdf.el (slime-query-replace-system-and-dependents):
+	Renamed from `slime-query-replace-system-and-dependencies' because
+	that's what it actually does.
+
 2009-12-18  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Add 'M-x slime-query-replace-system-and-dependencies' which is




From sboukarev at common-lisp.net  Sat Dec 19 14:56:07 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 19 Dec 2009 09:56:07 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NM0j1-00017z-29@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv4318

Modified Files:
	ChangeLog swank-abcl.lisp swank-backend.lisp swank-ecl.lisp 
	swank-sbcl.lisp 
Log Message:
* contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with some
implementations doesn't have AROUND method combination, so guard
against its usage. This will prevent swank:reload-system from working,
but it will let load swank-asdf.
Reported by Mark Evenson.

* swank-backend.lisp (defpackage): export with-symbol and
replace its fully qualified usage everywhere.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/17 10:30:32	1.1944
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/19 14:56:06	1.1945
@@ -1,3 +1,8 @@
+2009-12-19  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-backend.lisp (defpackage): export with-symbol and
+	replace its fully qualified usage everywhere.
+
 2009-12-17  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-edit-uses-xrefs): New variable. For contribs to
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2009/11/26 07:06:50	1.77
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2009/12/19 14:56:06	1.78
@@ -17,15 +17,14 @@
 ;;; The introduction of SYS::*INVOKE-DEBUGGER-HOOK* obliterates the
 ;;; need for redefining BREAK. The following should thus be removed at
 ;;; some point in the future.
-#-#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
+#-#.(swank-backend:with-symbol '*invoke-debugger-hook* 'sys)
 (defun sys::break (&optional (format-control "BREAK called") 
                    &rest format-arguments)
   (let ((sys::*saved-backtrace* 
-         #+#.(swank-backend::with-symbol 'backtrace 'sys) 
+         #+#.(swank-backend:with-symbol 'backtrace 'sys) 
          (sys:backtrace)
-         #-#.(swank-backend::with-symbol 'backtrace 'sys)
-         (ext:backtrace-as-list)
-         ))
+         #-#.(swank-backend:with-symbol 'backtrace 'sys)
+         (ext:backtrace-as-list)))
     (with-simple-restart (continue "Return from BREAK.")
       (invoke-debugger
        (sys::%make-condition 'simple-condition
@@ -300,13 +299,13 @@
 
 (defimplementation call-with-debugger-hook (hook fun)
   (let ((*debugger-hook* hook)
-        #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
+        #+#.(swank-backend:with-symbol '*invoke-debugger-hook* 'sys)
         (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
     (funcall fun)))
 
 (defimplementation install-debugger-globally (function)
   (setq *debugger-hook* function)
-  #+#.(swank-backend::with-symbol '*invoke-debugger-hook* 'sys)
+  #+#.(swank-backend:with-symbol '*invoke-debugger-hook* 'sys)
   (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
 
 (defvar *sldb-topframe*)
@@ -314,11 +313,11 @@
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
          (*sldb-topframe* 
-          #+#.(swank-backend::with-symbol 'backtrace 'sys)
+          #+#.(swank-backend:with-symbol 'backtrace 'sys)
           (second (member magic-token (sys:backtrace)
                           :key #'(lambda (frame) 
                                    (first (sys:frame-to-list frame)))))
-          #-#.(swank-backend::with-symbol 'backtrace 'sys)
+          #-#.(swank-backend:with-symbol 'backtrace 'sys)
           (second (member magic-token (ext:backtrace-as-list)
                           :key #'(lambda (frame) 
                                    (first frame))))
@@ -328,9 +327,9 @@
 (defun backtrace (start end)
   "A backtrace without initial SWANK frames."
   (let ((backtrace 
-         #+#.(swank-backend::with-symbol 'backtrace 'sys)
+         #+#.(swank-backend:with-symbol 'backtrace 'sys)
          (sys:backtrace)
-         #-#.(swank-backend::with-symbol 'backtrace 'sys)
+         #-#.(swank-backend:with-symbol 'backtrace 'sys)
          (ext:backtrace-as-list)
          ))
     (subseq (or (member *sldb-topframe* backtrace) backtrace)
@@ -345,9 +344,9 @@
 
 (defimplementation print-frame (frame stream)
   (write-string
-   #+#.(swank-backend::with-symbol 'backtrace 'sys)
+   #+#.(swank-backend:with-symbol 'backtrace 'sys)
    (sys:frame-to-string frame)
-   #-#.(swank-backend::with-symbol 'backtrace 'sys)
+   #-#.(swank-backend:with-symbol 'backtrace 'sys)
    (string-trim '(#\space #\newline) (prin1-to-string frame))
    stream))
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2009/12/10 22:21:09	1.186
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2009/12/19 14:56:06	1.187
@@ -42,7 +42,7 @@
            #:emacs-inspect
            #:label-value-line
            #:label-value-line*
-           ))
+           #:with-symbol))
 
 (defpackage :swank-mop
   (:use)
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2009/11/13 19:55:04	1.49
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2009/12/19 14:56:06	1.50
@@ -305,13 +305,13 @@
      (declare (ignore position))
      (if file (is-swank-source-p file)))))
 
-#+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
+#+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
 (defmacro find-ihs-top (x)
   (if (< ext:+ecl-version-number+ 90601)
       `(si::ihs-top ,x)
       '(si::ihs-top)))
 
-#-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
+#-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
 (defmacro find-ihs-top (x) 
   `(si::ihs-top ,x))
 
@@ -379,11 +379,11 @@
   (let ((functions '())
         (blocks '())
         (variables '()))
-    #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
+    #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
     #.(if (< ext:+ecl-version-number+ 90601)
         '(setf frame (second frame))
         '(setf frame (si::decode-ihs-env (second frame))))
-    #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
+    #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
     '(setf frame (second frame))
     (dolist (record frame)
       (let* ((record0 (car record))
@@ -493,11 +493,11 @@
               `(:snippet
                 ,(with-open-file (s file)
 
-                                 #+#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
+                                 #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
                                  (if (< ext:+ecl-version-number+ 90601)
                                      (skip-toplevel-forms pos s)
                                      (file-position s pos))
-                                 #-#.(swank-backend::with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
+                                 #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
                                  (skip-toplevel-forms pos s)
                                  (skip-comments-and-whitespace s)
                                  (read-snippet s))))))))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/16 22:02:20	1.262
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/12/19 14:56:06	1.263
@@ -372,11 +372,11 @@
 
 ;;; Utilities
 
-#+#.(swank-backend::with-symbol 'function-lambda-list 'sb-introspect)
+#+#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
 (defimplementation arglist (fname)
   (sb-introspect:function-lambda-list fname))
 
-#-#.(swank-backend::with-symbol 'function-lambda-list 'sb-introspect)
+#-#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
 (defimplementation arglist (fname)
   (sb-introspect:function-arglist fname))
 
@@ -396,7 +396,7 @@
                                   flags :key #'ensure-list))
           (call-next-method)))))
 
-#+#.(swank-backend::with-symbol 'deftype-lambda-list 'sb-introspect)
+#+#.(swank-backend:with-symbol 'deftype-lambda-list 'sb-introspect)
 (defmethod type-specifier-arglist :around (typespec-operator)
   (multiple-value-bind (arglist foundp)
       (sb-introspect:deftype-lambda-list typespec-operator)
@@ -434,7 +434,7 @@
                        (sb-ext:compiler-note :note)
                        (error                :error)
                        (reader-error         :read-error)
-                       #+#.(swank-backend::with-symbol redefinition-warning sb-kernel)
+                       #+#.(swank-backend:with-symbol redefinition-warning sb-kernel)
                        (sb-kernel:redefinition-warning
                                              :redefinition)
                        (style-warning        :style-warning)
@@ -594,13 +594,13 @@
 
 (defun get-compiler-policy (default-policy)
   (declare (ignorable default-policy))
-  #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
+  #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
   (remove-duplicates (append default-policy (sb-ext:restrict-compiler-policy))
                      :key #'car))
 
 (defun set-compiler-policy (policy)
   (declare (ignorable policy))
-  #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
+  #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
    (loop for (qual . value) in policy
          do (sb-ext:restrict-compiler-policy qual value)))
 
@@ -847,7 +847,7 @@
   (defxref who-sets)
   (defxref who-references)
   (defxref who-macroexpands)
-  #+#.(swank-backend::with-symbol 'who-specializes-directly 'sb-introspect)
+  #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
   (defxref who-specializes who-specializes-directly))
 
 (defun source-location-for-xref-data (xref-data)
@@ -1027,11 +1027,11 @@
          (plist (sb-c::debug-source-plist dsource)))
     (if (getf plist :emacs-buffer)
         (emacs-buffer-source-location code-location plist)
-        #+#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
+        #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
         (ecase (sb-di:debug-source-from dsource)
           (:file (file-source-location code-location))
           (:lisp (lisp-source-location code-location)))
-        #-#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
+        #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
         (if (sb-di:debug-source-namestring dsource)
             (file-source-location code-location)
             (lisp-source-location code-location)))))
@@ -1087,10 +1087,10 @@
                          `(:snippet ,snippet)))))))
 
 (defun code-location-debug-source-name (code-location)
-  (namestring (truename (#+#.(swank-backend::with-symbol
+  (namestring (truename (#+#.(swank-backend:with-symbol
                               'debug-source-name 'sb-di)
                              sb-c::debug-source-name
-                             #-#.(swank-backend::with-symbol
+                             #-#.(swank-backend:with-symbol
                                   'debug-source-name 'sb-di)
                              sb-c::debug-source-namestring
                          (sb-di::code-location-debug-source code-location)))))




From sboukarev at common-lisp.net  Sat Dec 19 14:56:07 2009
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 19 Dec 2009 09:56:07 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NM0j1-00018V-BY@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv4318/contrib

Modified Files:
	ChangeLog swank-asdf.lisp 
Log Message:
* contrib/swank-asdf.lisp (asdf:operation-done-p): ASDF included with some
implementations doesn't have AROUND method combination, so guard
against its usage. This will prevent swank:reload-system from working,
but it will let load swank-asdf.
Reported by Mark Evenson.

* swank-backend.lisp (defpackage): export with-symbol and
replace its fully qualified usage everywhere.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/19 10:11:28	1.309
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/19 14:56:07	1.310
@@ -1,3 +1,11 @@
+2009-12-19  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-asdf.lisp (asdf:operation-done-p): ASDF included with some
+	implementations doesn't have AROUND method combination, so guard
+	against its usage. This will prevent swank:reload-system from working,
+	but it will let load swank-asdf.
+	Reported by Mark Evenson.
+
 2009-12-19  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-asdf.el (slime-query-replace-system-and-dependents):
--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/18 19:47:55	1.24
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2009/12/19 14:56:07	1.25
@@ -187,6 +187,7 @@
 
 (defvar *recompile-system* nil)
 
+#+#.(swank-backend:with-symbol 'around 'asdf)
 (defmethod asdf:operation-done-p asdf:around ((operation asdf:compile-op)
                                               component)
   (unless (eql *recompile-system*




From trittweiler at common-lisp.net  Mon Dec 21 13:31:55 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 21 Dec 2009 08:31:55 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NMiMd-0002tE-HK@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv11096

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-at-list-p): Deleted.
	(slime-at-expression-p): Moved to slime-package-fu.
	(slime-forward-blanks): Deleted. Use `(skip-chars-forward
	"[:space:]")' instead.
	(slime-forward-any-comment): Deleted.
	(slime-reader-conditionals-regexp): Make a constant so it's
	inlined.
	(slime-unknown-feature-expression): Make it an error.

	* slime-package-fu.el (slime-at-expression-p): Moved from
	slime.el.
	(slime-goto-next-export-clause): Replace `slime-forward-blanks'.

	* slime-parse.el (slime-parse-sexp-at-point)
	(slime-parse-extended-operator-name): Replace
	`slime-forward-blanks'.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/19 14:56:06	1.1945
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/21 13:31:55	1.1946
@@ -1,3 +1,14 @@
+2009-12-21  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (slime-at-list-p): Deleted.
+	(slime-at-expression-p): Moved to slime-package-fu.
+	(slime-forward-blanks): Deleted. Use `(skip-chars-forward
+	"[:space:]")' instead.
+	(slime-forward-any-comment): Deleted.
+	(slime-reader-conditionals-regexp): Make a constant so it's
+	inlined.
+	(slime-unknown-feature-expression): Make it an error.
+
 2009-12-19  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-backend.lisp (defpackage): export with-symbol and
--- /project/slime/cvsroot/slime/slime.el	2009/12/17 10:30:32	1.1257
+++ /project/slime/cvsroot/slime/slime.el	2009/12/21 13:31:55	1.1258
@@ -4356,18 +4356,6 @@
           (t 
            name))))
 
-(defun slime-at-list-p (&optional skip-blanks)
-  (save-excursion
-    (when skip-blanks 
-      (slime-forward-blanks))
-    (ignore-errors 
-      (= (point) (progn (down-list 1) (backward-up-list 1) (point))))))
-
-(defun slime-at-expression-p (pattern &optional skip-blanks)
-  (when (slime-at-list-p skip-blanks)
-    (save-excursion
-      (down-list 1)
-      (slime-in-expression-p pattern))))
 
 (defun slime-in-expression-p (pattern)
   "A helper function to determine the current context.
@@ -8315,29 +8303,7 @@
     (slime-forward-cruft)
     (forward-sexp)))
 
-(defun slime-forward-cruft ()
-  "Move forward over whitespace, comments, reader conditionals."
-  (while (slime-point-moves-p (slime-forward-blanks)
-                              (slime-forward-any-comment)
-                              (slime-forward-reader-conditional))))
-
-(defun slime-forward-blanks ()
-  "Move forward over all whitespace and newlines at point."
-  (ignore-errors
-    (while (slime-point-moves-p
-             (skip-syntax-forward " ")
-             ;; newlines aren't in lisp-mode's whitespace syntax class
-             (when (eolp) (forward-char))))))
-
-(defun slime-forward-any-comment ()
-  "Skip the whole comment at point, or the comment where point is
-within. This includes nested comments (#| ... |#)."
-  (forward-comment (buffer-size)) ; We may be exactly in front of a semicolon.
-  (when-let (comment-start (nth 8 (slime-current-parser-state)))
-    (goto-char comment-start)
-    (forward-comment (buffer-size))))
-
-(defvar slime-reader-conditionals-regexp
+(defconst slime-reader-conditionals-regexp
   ;; #!+, #!- are SBCL specific reader-conditional syntax.
   ;; We need this for the source files of SBCL itself.
   (regexp-opt '("#+" "#-" "#!+" "#!-")))
@@ -8347,11 +8313,21 @@
   (when (looking-at slime-reader-conditionals-regexp)
     (goto-char (match-end 0))
     (let* ((plus-conditional-p (eq (char-before) ?+))
-           (result (slime-eval-feature-expression (read (current-buffer)))))
+           (result (slime-eval-feature-expression 
+                    (condition-case e
+                        (read (current-buffer))
+                      (invalid-read-syntax 
+                       (signal 'slime-unknown-feature-expression (cdr e)))))))
       (unless (if plus-conditional-p result (not result))
         ;; skip this sexp
         (slime-forward-sexp)))))
 
+(defun slime-forward-cruft ()
+  "Move forward over whitespace, comments, reader conditionals."
+  (while (slime-point-moves-p (skip-chars-forward "[:space:]")
+                              (forward-comment (buffer-size))
+                              (inline (slime-forward-reader-conditional)))))
+
 (defun slime-keywordify (symbol)
   "Make a keyword out of the symbol SYMBOL."
   (let ((name (downcase (symbol-name symbol))))
@@ -8364,7 +8340,8 @@
 
 (put 'slime-unknown-feature-expression
      'error-conditions '(slime-unknown-feature-expression 
-                         slime-incorrect-feature-expression))
+                         slime-incorrect-feature-expression
+                         error))
 
 ;; FIXME: let it crash
 ;; FIXME: the length=1 constraint is bogus
@@ -8943,7 +8920,7 @@
           slime-eval-feature-expression
           slime-forward-sexp
           slime-forward-cruft
-          slime-forward-any-comment
+          slime-forward-reader-conditional
           )))
 
 (provide 'slime)




From trittweiler at common-lisp.net  Mon Dec 21 13:31:56 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 21 Dec 2009 08:31:56 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NMiMe-0002tV-7r@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv11096/contrib

Modified Files:
	ChangeLog slime-package-fu.el slime-parse.el 
Log Message:
	* slime.el (slime-at-list-p): Deleted.
	(slime-at-expression-p): Moved to slime-package-fu.
	(slime-forward-blanks): Deleted. Use `(skip-chars-forward
	"[:space:]")' instead.
	(slime-forward-any-comment): Deleted.
	(slime-reader-conditionals-regexp): Make a constant so it's
	inlined.
	(slime-unknown-feature-expression): Make it an error.

	* slime-package-fu.el (slime-at-expression-p): Moved from
	slime.el.
	(slime-goto-next-export-clause): Replace `slime-forward-blanks'.

	* slime-parse.el (slime-parse-sexp-at-point)
	(slime-parse-extended-operator-name): Replace
	`slime-forward-blanks'.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/19 14:56:07	1.310
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 13:31:56	1.311
@@ -1,3 +1,13 @@
+2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-package-fu.el (slime-at-expression-p): Moved from
+	slime.el.
+	(slime-goto-next-export-clause): Replace `slime-forward-blanks'.
+
+	* slime-parse.el (slime-parse-sexp-at-point)
+	(slime-parse-extended-operator-name): Replace
+	`slime-forward-blanks'.
+
 2009-12-19  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-asdf.lisp (asdf:operation-done-p): ASDF included with some
--- /project/slime/cvsroot/slime/contrib/slime-package-fu.el	2009/11/07 02:04:56	1.6
+++ /project/slime/cvsroot/slime/contrib/slime-package-fu.el	2009/12/21 13:31:56	1.7
@@ -78,6 +78,15 @@
 		 (slime-find-package-definition-regexp package))))
 	(error "Couldn't find source definition of package: %s" package))))
 
+(defun slime-at-expression-p (pattern)
+  (when (ignore-errors
+          ;; at a list?
+          (= (point) (progn (down-list 1)
+                            (backward-up-list 1)
+                            (point))))
+    (save-excursion
+      (down-list 1)
+      (slime-in-expression-p pattern))))
 
 (defun slime-goto-next-export-clause ()
   ;; Assumes we're inside the beginning of a DEFPACKAGE form.
@@ -85,7 +94,7 @@
     (save-excursion
       (block nil
 	(while (ignore-errors (slime-forward-sexp) t)
-	  (slime-forward-blanks)
+	  (skip-chars-forward "[:space:]")
 	  (when (slime-at-expression-p '(:export *))
 	    (setq point (point))
 	    (return)))))
--- /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/11/24 13:17:00	1.29
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/21 13:31:56	1.30
@@ -11,7 +11,7 @@
   (slime-make-form-spec-from-string
    (concat (slime-incomplete-sexp-at-point) ")")))
 
-(defun slime-parse-sexp-at-point (&optional n skip-blanks-p)
+(defun slime-parse-sexp-at-point (&optional n)
   "Returns the sexps at point as a list of strings, otherwise nil.
 \(If there are not as many sexps as N, a list with < N sexps is
 returned.\) 
@@ -19,8 +19,6 @@
 "
   (interactive "p") (or n (setq n 1))
   (save-excursion
-    (when skip-blanks-p ; e.g. `( foo bat)' where point is after ?\(.
-      (slime-forward-blanks))
     (let ((result nil))
       (dotimes (i n)
         ;; Is there an additional sexp in front of us?
@@ -29,7 +27,7 @@
             (return)))
         (push (slime-sexp-at-point) result)
         ;; Skip current sexp
-        (ignore-errors (forward-sexp) (slime-forward-blanks)))
+        (ignore-errors (forward-sexp) (skip-chars-forward "[:space:]")))
       (nreverse result))))
 
 (defun slime-has-symbol-syntax-p (string)
@@ -63,7 +61,7 @@
                          entry)))
         (ignore-errors
           (forward-char (1+ (length current-op)))
-          (slime-forward-blanks))
+          (skip-chars-forward "[:space:]"))
         (when parser
           (multiple-value-setq (forms indices points)
             ;; We pass the fully qualified name (`current-op'), so it's the




From trittweiler at common-lisp.net  Mon Dec 21 14:18:46 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 21 Dec 2009 09:18:46 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NMj5y-00079N-Fx@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv27484/contrib

Modified Files:
	ChangeLog slime-parse.el 
Log Message:
	* slime-parse.el (slime-parse-form-upto-point): Rewritten to make
	it more performant.
	(slime-parse-form-until): New helper.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 13:31:56	1.311
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 14:18:46	1.312
@@ -1,5 +1,11 @@
 2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-parse.el (slime-parse-form-upto-point): Rewritten to make
+	it more performant.
+	(slime-parse-form-until): New helper.
+
+2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-package-fu.el (slime-at-expression-p): Moved from
 	slime.el.
 	(slime-goto-next-export-clause): Replace `slime-forward-blanks'.
--- /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/21 13:31:56	1.30
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/21 14:18:46	1.31
@@ -326,6 +326,58 @@
      (nreverse arg-indices)
      (nreverse points))))
 
+(defun slime-parse-form-until (limit form-suffix)
+  "Parses form from point to `limit'."
+  ;; For performance reasons, this function does not use recursion.
+  (let ((todo (list (point))) ; stack of positions
+        (sexps)               ; stack of expressions
+        (cursexp)
+        (curpos)
+        (depth 1))            ; This function must be called from the
+                              ; start of the sexp to be parsed.
+    (while (and (setq curpos (pop todo))
+                (progn
+                  (goto-char curpos)
+                  ;; (Here we also move over suppressed
+                  ;; reader-conditionalized code! Important so CL-side
+                  ;; of autodoc won't see that garbage.)
+                  (ignore-errors (slime-forward-cruft))
+                  (< (point) limit)))
+      (setq cursexp (pop sexps))
+      (cond
+        ;; End of an sexp?
+        ((or (looking-at "\\s)") (eolp))
+         (decf depth)
+         (push (nreverse cursexp) (car sexps)))
+        ;; Start of a new sexp?
+        ((looking-at "\\s'?\\s(")
+         (let ((subpt (match-end 0)))
+           (ignore-errors
+             (forward-sexp)
+             ;; (In case of error, we're at an incomplete sexp, and
+             ;; nothing's left todo after it.)
+             (push (point) todo))
+           (push cursexp sexps)
+           (push subpt todo)            ; to descend into new sexp
+           (push nil sexps)
+           (incf depth)))
+        ;; In mid of an sexp..
+        (t
+         (let ((pt1 (point))
+               (pt2 (condition-case e
+                        (progn (forward-sexp) (point))
+                      (scan-error
+                       (fourth e)))))   ; end of sexp
+           (push (buffer-substring-no-properties pt1 pt2) cursexp)
+           (push pt2 todo)
+           (push cursexp sexps)))))
+    (when sexps
+      (setf (car sexps) (nreconc form-suffix (car sexps)))
+      (while (> depth 1)
+        (push (nreverse (pop sexps)) (car sexps))
+        (decf depth))
+      (nreverse (car sexps)))))
+
 (defun slime-compare-char-syntax (get-char-fn syntax &optional unescaped)
   "Returns t if the character that `get-char-fn' yields has
 characer syntax of `syntax'. If `unescaped' is true, it's ensured
@@ -342,13 +394,11 @@
 (defconst slime-cursor-marker 'swank::%cursor-marker%)
 
 (defun slime-parse-form-upto-point (&optional max-levels)
-  ;; We assert this, because `slime-incomplete-form-at-point' blows up
-  ;; inside a comment.
-  (assert (not (slime-inside-string-or-comment-p)))
   (save-restriction
-    ;; Don't parse more than 15000 characters before point, so we
-    ;; don't spend too much time.
-    (narrow-to-region (max (point-min) (- (point) 15000)) (point-max))
+    ;; Don't parse more than 500 lines before point, so we don't spend
+    ;; too much time. NB. Make sure to go to beginning of line, and
+    ;; not possibly anywhere inside comments or strings.
+    (narrow-to-region (line-beginning-position -500) (point-max))
     (save-excursion
       (let ((suffix (list slime-cursor-marker)))
         (cond ((slime-compare-char-syntax #'char-after "(" t)
@@ -364,27 +414,15 @@
               ((slime-compare-char-syntax #'char-before "(" t)
                ;; We're directly after an opening parenthesis, so we
                ;; have to make sure that something comes before
-               ;; %CURSOR-MARKER%..
+               ;; %CURSOR-MARKER%.
                (push "" suffix))
               (t
                ;; We're at a symbol, so make sure we get the whole symbol.
                (slime-end-of-symbol)))
-        (let ((result-form '())
-              (levels (or max-levels 5)))
-          (condition-case nil
-              ;; We unroll the first iteration of the loop because
-              ;; `suffix' must be merged into the first form rather
-              ;; than onto.
-              (let ((form (slime-incomplete-form-at-point)))
-                (setq result-form (nconc form suffix))
-                (up-list -1)
-                (dotimes (i (1- levels))
-                  (let ((next (slime-incomplete-form-at-point)))
-                    (setq result-form (nconc next (list result-form))))
-                  (up-list -1)))
-            (scan-error nil)) ; At head of toplevel form.
-          result-form)))))
-
+        (let ((pt (point)))
+          (ignore-errors (up-list (if max-levels (- max-levels) -5)))
+          (ignore-errors (down-list))
+          (slime-parse-form-until pt suffix))))))
 
 (defun slime-ensure-list (thing)
   (if (listp thing) thing (list thing)))
@@ -460,7 +498,11 @@
       ("(defun foo (x y*HERE*"        ("defun" "foo" ("x" "y" swank::%cursor-marker%)))
       ("(apply 'foo*HERE*"            ("apply" "'foo" swank::%cursor-marker%))
       ("(apply #'foo*HERE*"           ("apply" "#'foo" swank::%cursor-marker%))
-      ("(declare ((vector bit *HERE*" ("declare" (("vector" "bit" "" swank::%cursor-marker%)))))
+      ("(declare ((vector bit *HERE*" ("declare" (("vector" "bit" "" swank::%cursor-marker%))))
+      ("(with-open-file (*HERE*"      ("with-open-file" ("" swank::%cursor-marker%)))
+      ("(((*HERE*"                    ((("" swank::%cursor-marker%))))
+      ("(defun #| foo #| *HERE*"      ("defun" "" swank::%cursor-marker%))
+      ("(defun #-(and) (bar) f*HERE*" ("defun" "f" swank::%cursor-marker%)))
   (slime-check-top-level)
   (with-temp-buffer
     (lisp-mode)




From trittweiler at common-lisp.net  Mon Dec 21 16:03:41 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 21 Dec 2009 11:03:41 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NMkjV-0005TI-Gx@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv21032/contrib

Modified Files:
	ChangeLog slime-autodoc.el slime-c-p-c.el 
	slime-enclosing-context.el slime-fancy.el slime-parse.el 
	slime-sbcl-exts.el swank-arglists.lisp 
Log Message:
	Today's cleanup day.

	* slime-parse.el (slime-incomplete-form-at-point)
	(slime-parse-sexp-at-point)
	(slime-has-symbol-syntax-p)
	(slime-incomplete-sexp-at-point)
	(slime-parse-extended-operator-name)
	(slime-extended-operator-name-parser-alist)
	(slime-make-extended-operator-parser/look-ahead)
	(slime-parse-extended-operator/proclaim)
	(slime-parse-extended-operator/declare)
	(slime-parse-extended-operator/check-type)
	(slime-parse-extended-operator/the)
	(slime-nesting-until-point)
	(slime-make-form-spec-from-string)
	(slime-enclosing-form-specs)
	(slime-ensure-list)
	(slime-beginning-of-string)
	(slime-check-enclosing-form-specs)
	(enclosing-form-specs.1 [test]): Deleted. The new arglist code made
	all this superfluous.

	* slime-autodoc.el (slime-autodoc-accuracy-depth): New defcustom.
	(slime-retrieve-arglist): Return :not-available if appropriate.
	(slime-arglist): Use `slime-retrieve-arglist'. Delete reference to
	undefined variable.
	(slime-autodoc-thing-at-point): Deleted, not needed anymore.
	(slime-autodoc-hook): Deleted.
	(slime-autodoc-worthwhile-p): Deleted.
	(slime-make-autodoc-rpc-form): Simplified.
	(slime-compute-autodoc-internal): Merged with `slime-compute-autodoc'.
	(slime-compute-autodoc): Removed usage of old
	infrastructure. Simplified.

	* swank-arglists.lisp (print-decoded-arglist): Print ((:foo bar)
	quux) &key parameters correctly.
	(variable-desc-for-echo-area): Return :not-available, not nil.

	* slime-c-p-c.el (slime-complete-symbol*-fancy-bit): Adapted for
	new return value of `slime-retrieve-arglist'.

	* slime-fancy.el: Disable `slime-mdot-fu' contrib because that has
	to be adapted to new infrastructure.

	* slime-sbcl-exts.el (slime-enable-autodoc-for-sb-assem:inst):
	Deleted. Used old infrastructure.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 14:18:46	1.312
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 16:03:41	1.313
@@ -1,5 +1,54 @@
 2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	Today's cleanup day.
+
+	* slime-parse.el (slime-incomplete-form-at-point)
+	(slime-parse-sexp-at-point)
+	(slime-has-symbol-syntax-p)
+	(slime-incomplete-sexp-at-point)
+	(slime-parse-extended-operator-name)
+	(slime-extended-operator-name-parser-alist)
+	(slime-make-extended-operator-parser/look-ahead)
+	(slime-parse-extended-operator/proclaim)
+	(slime-parse-extended-operator/declare)
+	(slime-parse-extended-operator/check-type)
+	(slime-parse-extended-operator/the)
+	(slime-nesting-until-point)
+	(slime-make-form-spec-from-string)
+	(slime-enclosing-form-specs)
+	(slime-ensure-list)
+	(slime-beginning-of-string)
+	(slime-check-enclosing-form-specs)
+	(enclosing-form-specs.1 [test]): Deleted. The new arglist code made
+	all this superfluous.
+
+	* slime-autodoc.el (slime-autodoc-accuracy-depth): New defcustom.
+	(slime-retrieve-arglist): Return :not-available if appropriate.
+	(slime-arglist): Use `slime-retrieve-arglist'. Delete reference to
+	undefined variable.
+	(slime-autodoc-thing-at-point): Deleted, not needed anymore.
+	(slime-autodoc-hook): Deleted.
+	(slime-autodoc-worthwhile-p): Deleted.
+	(slime-make-autodoc-rpc-form): Simplified.
+	(slime-compute-autodoc-internal): Merged with `slime-compute-autodoc'.
+	(slime-compute-autodoc): Removed usage of old
+	infrastructure. Simplified.
+
+	* swank-arglists.lisp (print-decoded-arglist): Print ((:foo bar)
+	quux) &key parameters correctly.
+	(variable-desc-for-echo-area): Return :not-available, not nil.
+
+	* slime-c-p-c.el (slime-complete-symbol*-fancy-bit): Adapted for
+	new return value of `slime-retrieve-arglist'.
+
+	* slime-fancy.el: Disable `slime-mdot-fu' contrib because that has
+	to be adapted to new infrastructure.
+
+	* slime-sbcl-exts.el (slime-enable-autodoc-for-sb-assem:inst):
+	Deleted. Used old infrastructure.
+
+2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-parse.el (slime-parse-form-upto-point): Rewritten to make
 	it more performant.
 	(slime-parse-form-until): New helper.
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/11/06 19:08:39	1.24
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/12/21 16:03:41	1.25
@@ -36,57 +36,48 @@
   :type 'number
   :group 'slime-ui)
 
+(defcustom slime-autodoc-accuracy-depth 10
+  "Number of paren levels that autodoc takes into account for
+  context-sensitive arglist display (local functions. etc)")
+
 
 
 (defun slime-arglist (name)
   "Show the argument list for NAME."
   (interactive (list (slime-read-symbol-name "Arglist of: " t)))
-  (let ((arglist (slime-eval `(swank:arglist-for-echo-area 
-                               '(,name ,slime-cursor-marker)))))
+  (let ((arglist (slime-retrieve-arglist name)))
     (if (eq arglist :not-available)
-        (and errorp (error "Arglist not available"))
+        (error "Arglist not available")
         (message "%s" (slime-fontify-string arglist)))))
 
 (defun slime-retrieve-arglist (name)
-  (let* ((name (etypecase name
+  (let ((name (etypecase name
                  (string name)
-                 (symbol (symbol-name name))))
-         (arglist 
-          (slime-eval `(swank:arglist-for-echo-area 
-                        '(,name ,slime-cursor-marker)))))
-    (if (eq arglist :not-available)
-        nil
-        arglist)))
+                 (symbol (symbol-name name)))))
+    (slime-eval `(swank:arglist-for-echo-area '(,name ,slime-cursor-marker)))))
 
 
 ;;;; Autodocs (automatic context-sensitive help)
 
-(defun slime-autodoc-thing-at-point ()
-  "Not used; for debugging purposes."
-  (multiple-value-bind (operators arg-indices points)
-	    (slime-enclosing-form-specs)
-    (slime-make-autodoc-rpc-form operators arg-indices points)))
-
-;; TODO: get rid of args
-(defun slime-make-autodoc-rpc-form (operators arg-indices points)
+(defun slime-make-autodoc-rpc-form ()
   "Return a cache key and a swank form."
-  (unless (slime-inside-string-or-comment-p)
-    (let ((global (slime-autodoc-global-at-point)))
-      (if global
-          (values (slime-qualify-cl-symbol-name global)
-                  `(swank:variable-desc-for-echo-area ,global))
-          (let ((buffer-form (slime-parse-form-upto-point 10)))
-            (values buffer-form
-                    (multiple-value-bind (width height)
-                        (slime-autodoc-message-dimensions)
-                      `(swank:arglist-for-echo-area ',buffer-form
-                        :print-right-margin ,width
-                        :print-lines ,height))))))))
+  (let ((global (slime-autodoc-global-at-point)))
+    (if global
+        (values (slime-qualify-cl-symbol-name global)
+                `(swank:variable-desc-for-echo-area ,global))
+        (let* ((levels slime-autodoc-accuracy-depth)
+               (buffer-form (slime-parse-form-upto-point levels)))
+          (values buffer-form
+                  (multiple-value-bind (width height)
+                      (slime-autodoc-message-dimensions)
+                    `(swank:arglist-for-echo-area ',buffer-form
+                                                  :print-right-margin ,width
+                                                  :print-lines ,height)))))))
 
 (defun slime-autodoc-global-at-point ()
   "Return the global variable name at point, if any."
   (when-let (name (slime-symbol-at-point))
-    (if (slime-global-variable-name-p name) name)))
+    (and (slime-global-variable-name-p name) name)))
 
 (defcustom slime-global-variable-name-regexp "^\\(.*:\\)?\\([*+]\\).+\\2$"
   "Regexp used to check if a symbol name is a global variable.
@@ -189,49 +180,33 @@
 
 ;;;; slime-autodoc-mode
 
-(defvar slime-autodoc-hook '()
-  "If autodoc is enabled, this hook is run periodically in the
-background everytime a new autodoc is computed. The hook is
-applied to the result of `slime-enclosing-form-specs'.")
-
-(defun slime-autodoc-worthwhile-p (ops)
-  ;; Prevent an RPC call for when the user solely typed in an opening
-  ;; parenthesis.
-  (and (not (null ops))
-       (or (not (null (first ops)))
-	   (slime-length> ops 1))))
 
-(defun slime-compute-autodoc-internal ()
+(defun slime-compute-autodoc ()
   "Returns the cached arglist information as string, or nil.
 If it's not in the cache, the cache will be updated asynchronously."
-  (multiple-value-bind (ops arg-indices points)
-      (slime-enclosing-form-specs)
-    (when (slime-autodoc-worthwhile-p ops)
-      (run-hook-with-args 'slime-autodoc-hook ops arg-indices points)
-      (multiple-value-bind (cache-key retrieve-form)
-	  (slime-make-autodoc-rpc-form ops arg-indices points)
-	(let ((cached (slime-get-cached-autodoc cache-key)))
-	  (if cached
-	      cached
-            ;; If nothing is in the cache, we first decline, and fetch
-            ;; the arglist information asynchronously.
-            (prog1 nil
-              (slime-eval-async retrieve-form
-                (lexical-let ((cache-key cache-key)) 
-                  (lambda (doc)
-                    (let ((doc (if (or (null doc)
-				       (eq doc :not-available))
-				   ""
-				   (slime-format-autodoc doc))))
-                      ;; Now that we've got our information, get it to
-                      ;; the user ASAP.
-                      (eldoc-message doc)
-                      (slime-store-into-autodoc-cache cache-key doc))))))))))))
-
-(defun slime-compute-autodoc ()
   (save-excursion
+    ;; Save match data just in case. This is automatically run in
+    ;; background, so it'd be rather disastrous if it touched match
+    ;; data.
     (save-match-data
-      (slime-compute-autodoc-internal))))
+      (unless (slime-inside-string-or-comment-p)
+        (multiple-value-bind (cache-key retrieve-form) (slime-make-autodoc-rpc-form)
+          (let ((cached (slime-get-cached-autodoc cache-key)))
+            (if cached
+                cached
+                ;; If nothing is in the cache, we first decline, and fetch
+                ;; the arglist information asynchronously.
+                (prog1 nil
+                  (slime-eval-async retrieve-form
+                    (lexical-let ((cache-key cache-key)) 
+                      (lambda (doc)
+                        (let ((doc (if (eq doc :not-available)
+                                       ""
+                                       (slime-format-autodoc doc))))
+                          ;; Now that we've got our information, get it to
+                          ;; the user ASAP.
+                          (eldoc-message doc)
+                          (slime-store-into-autodoc-cache cache-key doc)))))))))))))
 
 (make-variable-buffer-local (defvar slime-autodoc-mode nil))
 
@@ -290,7 +265,7 @@
   (slime-test-expect (format "Autodoc in `%s' (at %d) is as expected" 
                              (buffer-string) (point)) 
                      arglist
-                     (slime-eval (second (slime-autodoc-thing-at-point)))
+                     (slime-eval (second (slime-make-autodoc-rpc-form)))
                      'equal))
 
 (def-slime-test autodoc.1
--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/11/06 19:08:39	1.15
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/21 16:03:41	1.16
@@ -85,7 +85,7 @@
   "Do fancy tricks after completing a symbol.
 \(Insert a space or close-paren based on arglist information.)"
   (let ((arglist (slime-retrieve-arglist (slime-symbol-at-point))))
-    (when arglist
+    (unless (eq arglist :not-available)
       (let ((args
              ;; Don't intern these symbols
              (let ((obarray (make-vector 10 0)))
--- /project/slime/cvsroot/slime/contrib/slime-enclosing-context.el	2009/03/09 22:40:21	1.6
+++ /project/slime/cvsroot/slime/contrib/slime-enclosing-context.el	2009/12/21 16:03:41	1.7
@@ -5,6 +5,9 @@
 ;; License: GNU GPL (same license as Emacs)
 ;;
 
+;;; TODO: with the removal of `slime-enclosing-form-specs' this
+;;; contrib won't work anymore.
+
 (require 'slime-parse)
 
 (defvar slime-variable-binding-ops-alist
--- /project/slime/cvsroot/slime/contrib/slime-fancy.el	2009/08/15 08:35:00	1.9
+++ /project/slime/cvsroot/slime/contrib/slime-fancy.el	2009/12/21 16:03:41	1.10
@@ -74,9 +74,11 @@
 (require 'slime-references)
 (slime-references-init)
 
+;;; Disabled -- after the removal of `slime-enclosing-form-specs',
+;;; this contrib has to be adapted.
 ;; Makes M-. work on local definitions, too.
-(require 'slime-mdot-fu)
-(slime-mdot-fu-init)
+;; (require 'slime-mdot-fu)
+;; (slime-mdot-fu-init)
 
 ;; Add/Remove a symbol at point from the relevant DEFPACKAGE form
 ;; via C-c x.
--- /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/21 14:18:46	1.31
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/21 16:03:41	1.32
@@ -7,325 +7,6 @@
 ;; License: GNU GPL (same license as Emacs)
 ;;
 
-(defun slime-incomplete-form-at-point ()
-  (slime-make-form-spec-from-string
-   (concat (slime-incomplete-sexp-at-point) ")")))
-
-(defun slime-parse-sexp-at-point (&optional n)
-  "Returns the sexps at point as a list of strings, otherwise nil.
-\(If there are not as many sexps as N, a list with < N sexps is
-returned.\) 
-If SKIP-BLANKS-P is true, leading whitespaces &c are skipped.
-"
-  (interactive "p") (or n (setq n 1))
-  (save-excursion
-    (let ((result nil))
-      (dotimes (i n)
-        ;; Is there an additional sexp in front of us?
-        (save-excursion
-          (unless (slime-point-moves-p (ignore-errors (forward-sexp)))
-            (return)))
-        (push (slime-sexp-at-point) result)
-        ;; Skip current sexp
-        (ignore-errors (forward-sexp) (skip-chars-forward "[:space:]")))
-      (nreverse result))))
-
-(defun slime-has-symbol-syntax-p (string)
-  (if (and string (not (zerop (length string))))
-      (member (char-syntax (aref string 0)) 
-	      '(?w ?_ ?\' ?\\))))
-
-(defun slime-incomplete-sexp-at-point (&optional n)
-  (interactive "p") (or n (setq n 1))
-  (buffer-substring-no-properties 
-   (save-excursion (backward-up-list n) (point))
-   (point)))
-
-
-(defun slime-parse-extended-operator-name (user-point forms indices points)
-  "Assume that point is directly at the operator that should be parsed.
-USER-POINT is the value of `point' where the user was looking at.
-OPS, INDICES and POINTS are updated to reflect the new values after
-parsing, and are then returned back as multiple values."
-  ;; OPS, INDICES and POINTS are like the finally returned values of
-  ;; SLIME-ENCLOSING-FORM-SPECS except that they're in reversed order,
-  ;; i.e. the leftmost operator comes first.
-  (save-excursion
-    (ignore-errors
-      (let* ((current-op (first (first forms)))
-             (op-name (upcase (slime-cl-symbol-name current-op)))
-             (assoc (assoc op-name slime-extended-operator-name-parser-alist))
-             (entry (cdr assoc))
-             (parser (if (and entry (listp entry)) 
-                         (apply (first entry) (rest entry))
-                         entry)))
-        (ignore-errors
-          (forward-char (1+ (length current-op)))
-          (skip-chars-forward "[:space:]"))
-        (when parser
-          (multiple-value-setq (forms indices points)
-            ;; We pass the fully qualified name (`current-op'), so it's the
-            ;; fully qualified name that will be sent to SWANK.
-            (funcall parser current-op user-point forms indices points))))))
-  (values forms indices points))
-
-
-(defvar slime-extended-operator-name-parser-alist
-  '(("MAKE-INSTANCE"  . (slime-make-extended-operator-parser/look-ahead 1))
-    ("MAKE-CONDITION" . (slime-make-extended-operator-parser/look-ahead 1))
-    ("ERROR"          . (slime-make-extended-operator-parser/look-ahead 1))
-    ("SIGNAL"         . (slime-make-extended-operator-parser/look-ahead 1))
-    ("WARN"           . (slime-make-extended-operator-parser/look-ahead 1))
-    ("CERROR"         . (slime-make-extended-operator-parser/look-ahead 2))
-    ("CHANGE-CLASS"   . (slime-make-extended-operator-parser/look-ahead 2))
-    ("DEFMETHOD"      . (slime-make-extended-operator-parser/look-ahead 1))
-    ("DEFINE-COMPILER-MACRO" . (slime-make-extended-operator-parser/look-ahead 1))
-    ("APPLY"          . (slime-make-extended-operator-parser/look-ahead 1))
-    ("DECLARE"        . slime-parse-extended-operator/declare)
-    ("DECLAIM"        . slime-parse-extended-operator/declare)
-    ("PROCLAIM"       . slime-parse-extended-operator/proclaim)
-    ("CHECK-TYPE"     . slime-parse-extended-operator/check-type)
-    ("TYPEP"          . slime-parse-extended-operator/check-type)
-    ("THE"            . slime-parse-extended-operator/the)))
-
-
-(defun slime-make-extended-operator-parser/look-ahead (steps)
-  "Returns a parser that parses the current operator at point
-plus (at most) STEPS-many additional sexps on the right side of
-the operator."
-  (lexical-let ((n steps))
-    #'(lambda (name user-point current-forms current-indices current-points)
-        (let ((old-forms (rest current-forms))
-              (arg-idx   (first current-indices)))
-          (when (and (not (zerop arg-idx)) ; point is at CAR of form?
-                     (not (= (point)       ; point is at end of form?
-                             (save-excursion
-                               (ignore-errors (slime-end-of-list))
-                               (point)))))
-            (let* ((args (slime-parse-sexp-at-point n))
-                   (arg-specs (mapcar #'slime-make-form-spec-from-string args)))
-              (setq current-forms (cons `(,name , at arg-specs) old-forms))))
-          (values current-forms current-indices current-points)))))
-
-;;; FIXME: We display "(proclaim (optimize ...))" instead of the
-;;; correct "(proclaim '(optimize ...))".
-(defun slime-parse-extended-operator/proclaim (&rest args)
-  (when (looking-at "['`]")
-    (forward-char)
-    (apply #'slime-parse-extended-operator/declare args)))
-
-(defun slime-parse-extended-operator/declare
-    (name user-point current-forms current-indices current-points)
-  (when (looking-at "(")
-    (goto-char user-point)
-    (slime-end-of-symbol)
-    ;; Head of CURRENT-FORMS is "declare" (or similiar) at this
-    ;; point, but we're interested in what comes next.
-    (let* ((decl-indices (rest current-indices))
-           (decl-points  (rest current-points))
-           (decl-pos     (1- (first decl-points)))
-           (nesting      (slime-nesting-until-point decl-pos))
-           (declspec-str (concat (slime-incomplete-sexp-at-point nesting)
-                                 (make-string nesting ?\)))))
-      (save-match-data ; `(declare ((foo ...))' or `(declare (type (foo ...)))' ?
-        (if (or (eql 0 (string-match "\\s-*(\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$"
-                                     declspec-str))
-                (eql 0 (string-match "\\s-*(type\\s-*\\((\\(\\sw\\|\\s_\\|\\s-\\)*)\\))$"
-                                     declspec-str)))
-            (let* ((typespec-str (match-string 1 declspec-str))
-                   (typespec (slime-make-form-spec-from-string typespec-str)))
-              (setq current-forms   (list `(:type-specifier ,typespec)))
-              (setq current-indices (list (second decl-indices)))
-              (setq current-points  (list (second decl-points))))
-            (let ((declspec (slime-make-form-spec-from-string declspec-str)))
-              (setq current-forms   (list `(,name) `(:declaration ,declspec)))
-              (setq current-indices (list (first current-indices)
-                                          (first decl-indices)))
-              (setq current-points  (list (first current-points)
-                                          (first decl-points))))))))
-  (values current-forms current-indices current-points))
-
-(defun slime-parse-extended-operator/check-type
-    (name user-point current-forms current-indices current-points)
-  (let ((arg-idx        (first current-indices))
-        (typespec       (second current-forms))
-        (typespec-start (second current-points)))
-    (when (and (eql 2 arg-index)
-               typespec                   ; `(check-type ... (foo |' ?
-               (if (equalp name "typep")  ; `(typep ... '(foo |' ?
-                   (progn (goto-char (- typespec-start 2))
-                          (looking-at "['`]"))
-                   t))
-        ;; compound types VALUES and FUNCTION are not allowed in TYPEP
-        ;; (and consequently CHECK-TYPE.)
-        (unless (member (first typespec) '("values" "function"))
-          (setq current-forms   `((:type-specifier ,typespec)))
-          (setq current-indices (rest current-indices))
-          (setq current-points  (rest current-points))))
-    (values current-forms current-indices current-points)))
-
-(defun slime-parse-extended-operator/the
-    (name user-point current-forms current-indices current-points)
-  (let ((arg-idx  (first current-indices))
-        (typespec (second current-forms)))
-    (if (and (eql 1 arg-idx) typespec)  ; `(the (foo |' ?
-        (values `((:type-specifier ,typespec))
-                (rest current-indices)
-                (rest current-points))
-        (values current-forms current-indices current-points))))
-
-
-
-(defun slime-nesting-until-point (target-point)
-  "Returns the nesting level between current point and TARGET-POINT.
-If TARGET-POINT could not be reached, 0 is returned. (As a result
-TARGET-POINT should always be placed just before a `?\('.)"
-  (save-excursion
-    (let ((nesting 0))
-      (while (> (point) target-point)
-        (backward-up-list)
-        (incf nesting))
-      (if (= (point) target-point)
-          nesting
-          0))))
-
-(defun slime-make-form-spec-from-string (string &optional strip-operator-p)
-  "Example: \"(foo (bar 1 (baz :quux)) 'toto)\" 
-
-            => (\"foo\" (\"bar\" \"1\" (\"baz\" \":quux\")) \"'toto\")"
-  (cond ((slime-length= string 0) "")                    ; ""
-	((equal string "()") '())                        ; "()"
-	((eql (char-syntax (aref string 0)) ?\') string) ; "'(foo)", "#(foo)" &c
-	((not (eql (aref string 0) ?\()) string)         ; "foo"
-	(t                                               ; "(op arg1 arg2 ...)"
-         (with-current-buffer (get-buffer-create " *slime-make-form-spec-buffer*")
-           ;; Do NEVER ever try to activate `lisp-mode' here with
-           ;; `slime-use-autodoc-mode' enabled, as this function is used
-           ;; to compute the current autodoc itself.
-           (set-syntax-table lisp-mode-syntax-table)
-           (erase-buffer)
-           (insert string)
-           (goto-char (1+ (point-min)))
-           (let ((subsexps)
-                 (end))
-             (while (condition-case nil 
-                        (slime-point-moves-p (slime-forward-sexp))
-                      (scan-error nil)  ; can't move any further
-                      (error t))        ; unknown feature expression etc.
-               ;; We first move back for (FOO)'BAR where point is at
-               ;; the quote character.
-               (setq end (point))               
-               (push (buffer-substring-no-properties 
-                      (save-excursion (backward-sexp) (point)) 
-                      end) 
-                     subsexps))
-             (mapcar #'(lambda (s)
-                         (assert (not (equal s string)))      
-                         (slime-make-form-spec-from-string s))
-                     (nreverse subsexps)))))))
-
-;;; TODO: With the rewrite of autodoc, this function like pretty much
-;;; everything else in this file, is obsolete.
-
-(defun slime-enclosing-form-specs (&optional max-levels)
-  "Return the list of ``raw form specs'' of all the forms 
-containing point from right to left.
-
-As a secondary value, return a list of indices: Each index tells
-for each corresponding form spec in what argument position the
-user's point is.
-
-As tertiary value, return the positions of the operators that are
-contained in the returned form specs. 
-
-When MAX-LEVELS is non-nil, go up at most this many levels of
-parens.
-
-\(See SWANK::PARSE-FORM-SPEC for more information about what
-exactly constitutes a ``raw form specs'')
-
-Examples:
-
-  A return value like the following
-
-    (values  ((\"quux\") (\"bar\") (\"foo\")) (3 2 1) (p1 p2 p3))
-
-  can be interpreted as follows:
-
-    The user point is located in the 3rd argument position of a
-    form with the operator name \"quux\" (which starts at P1.)
-   
-    This form is located in the 2nd argument position of a form
-    with the operator name \"bar\" (which starts at P2.)
-
-    This form again is in the 1st argument position of a form
-    with the operator name \"foo\" (which itself begins at P3.)
-
-  For instance, the corresponding buffer content could have looked
-  like `(foo (bar arg1 (quux 1 2 |' where `|' denotes point.
-"
-  (let ((level 1)
-        (parse-sexp-lookup-properties nil)
-        (initial-point (point))
-        (result '()) (arg-indices '()) (points '())) 
-    ;; The expensive lookup of syntax-class text properties is only
-    ;; used for interactive balancing of #<...> in presentations; we
-    ;; do not need them in navigating through the nested lists.
-    ;; This speeds up this function significantly.
-    (ignore-errors
-      (save-excursion
-        ;; Make sure we get the whole thing at point.
-        (if (not (slime-inside-string-p))
-            (slime-end-of-symbol)
-          (slime-beginning-of-string)
-          (forward-sexp))
-        (save-restriction
-          ;; Don't parse more than 20000 characters before point, so we don't spend
-          ;; too much time.
-          (narrow-to-region (max (point-min) (- (point) 20000)) (point-max))
-          (narrow-to-region (save-excursion (beginning-of-defun) (point))
-                            (min (1+ (point)) (point-max)))
-          (while (or (not max-levels)
-                     (<= level max-levels))
-            (let ((arg-index 0))
-              ;; Move to the beginning of the current sexp if not already there.
-              (if (or (and (char-after)
-                           (member (char-syntax (char-after)) '(?\( ?')))
-                      (member (char-syntax (char-before)) '(?\  ?>)))
-                  (incf arg-index))
-              (ignore-errors (backward-sexp 1))
-              (while (and (< arg-index 64)
-                          (ignore-errors (backward-sexp 1) 
-                                         (> (point) (point-min))))
-                (incf arg-index))
-              (backward-up-list 1)
-              (when (member (char-syntax (char-after)) '(?\( ?')) 
-                (incf level)
-                (forward-char 1)
-                (let ((name (slime-symbol-at-point)))
-                  (cond
-                    (name
-                     (save-restriction
-                       (widen) ; to allow looking-ahead/back in extended parsing.
-                       (multiple-value-bind (new-result new-indices new-points)
-                           (slime-parse-extended-operator-name 
-                            initial-point
-                            (cons `(,name) result) ; minimal form spec
-                            (cons arg-index arg-indices)
-                            (cons (point) points))
-                         (setq result new-result)
-                         (setq arg-indices new-indices)
-                         (setq points new-points))))
-                    (t
-                     (push nil result)
-                     (push arg-index arg-indices)
-                     (push (point) points))))
-                (backward-up-list 1)))))))
-    (values 
-     (nreverse result)
-     (nreverse arg-indices)
-     (nreverse points))))
-
 (defun slime-parse-form-until (limit form-suffix)
   "Parses form from point to `limit'."
   ;; For performance reasons, this function does not use recursion.
@@ -424,59 +105,9 @@
           (ignore-errors (down-list))
           (slime-parse-form-until pt suffix))))))
 
-(defun slime-ensure-list (thing)
-  (if (listp thing) thing (list thing)))
-
-(defun slime-beginning-of-string ()
-  (let* ((parser-state (slime-current-parser-state))
-	 (inside-string-p  (nth 3 parser-state))
-	 (string-start-pos (nth 8 parser-state)))
-    (if inside-string-p
-        (goto-char string-start-pos)
-        (error "We're not within a string"))))
-
 
 ;;;; Test cases
 
-(defun slime-check-enclosing-form-specs (wished-form-specs)
-  (slime-test-expect 
-   (format "Enclosing form specs correct in `%s' (at %d)" (buffer-string) (point))
-   wished-form-specs
-   (first (slime-enclosing-form-specs))))
-
-(def-slime-test enclosing-form-specs.1
-    (buffer-sexpr wished-form-specs)
-    "Check that we correctly determine enclosing forms."
-    '(("(defun *HERE*"                  (("defun")))
-      ("(defun foo *HERE*"              (("defun")))
-      ("(defun foo (x y) *HERE*"        (("defun")))
-      ("(defmethod *HERE*"              (("defmethod")))
-      ("(defmethod foo *HERE*"          (("defmethod" "foo")))
-      ("(cerror foo *HERE*"             (("cerror" "foo")))
-      ("(cerror foo bar *HERE*"         (("cerror" "foo" "bar")))
-      ("(make-instance foo *HERE*"      (("make-instance" "foo")))
-      ("(apply 'foo *HERE*"             (("apply" "'foo")))
-      ("(apply #'foo *HERE*"            (("apply" "#'foo")))
-      ("(declare *HERE*"                (("declare")))
-      ("(declare (optimize *HERE*"      ((:declaration ("optimize")) ("declare")))
-      ("(declare (string *HERE*"        ((:declaration ("string")) ("declare")))
-      ("(declare ((vector *HERE*"       ((:type-specifier ("vector"))))
-      ("(declare ((vector bit *HERE*"   ((:type-specifier ("vector" "bit"))))
-      ("(proclaim '(optimize *HERE*"    ((:declaration ("optimize")) ("proclaim")))
-      ("(the (string *HERE*"            ((:type-specifier ("string"))))
-      ("(check-type foo (string *HERE*" ((:type-specifier ("string"))))
-      ("(typep foo '(string *HERE*"     ((:type-specifier ("string")))))
-  (slime-check-top-level)
-  (with-temp-buffer
-    (lisp-mode)
-    (insert buffer-sexpr)
-    (search-backward "*HERE*")
-    (delete-region (match-beginning 0) (match-end 0))
-    (slime-check-enclosing-form-specs wished-form-specs)
-    (insert ")") (backward-char)
-    (slime-check-enclosing-form-specs wished-form-specs)      
-    ))
-
 (defun slime-check-buffer-form (result-form)
   (slime-test-expect 
    (format "Buffer form correct in `%s' (at %d)" (buffer-string) (point))
@@ -518,7 +149,7 @@
 
 (let ((byte-compile-warnings '()))
   (mapc #'byte-compile
-        '(slime-make-form-spec-from-string
-          slime-parse-form-upto-point
+        '(slime-parse-form-upto-point
+          slime-parse-form-until
           slime-compare-char-syntax
           )))
\ No newline at end of file
--- /project/slime/cvsroot/slime/contrib/slime-sbcl-exts.el	2009/10/30 23:06:26	1.3
+++ /project/slime/cvsroot/slime/contrib/slime-sbcl-exts.el	2009/12/21 16:03:41	1.4
@@ -5,7 +5,6 @@
 ;; License: GNU GPL (same license as Emacs)
 ;;
 
-(require 'slime-autodoc)
 (require 'slime-references)
 
 (defun slime-sbcl-bug-at-point ()
@@ -31,12 +30,7 @@
   (browse-url (format "http://bugs.launchpad.net/sbcl/+bug/%s" 
                       (substring bug 1))))
 
-(defun slime-enable-autodoc-for-sb-assem:inst ()
-  (push '("INST" . (slime-make-extended-operator-parser/look-ahead 1))
-        slime-extended-operator-name-parser-alist))
-
-(defun slime-sbcl-exts-init ()
-  (slime-enable-autodoc-for-sb-assem:inst))
+(defun slime-sbcl-exts-init ())
 
 (slime-require :swank-sbcl-exts)
 
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/14 15:28:46	1.47
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/21 16:03:41	1.48
@@ -298,7 +298,7 @@
                    (print-arglist-recursively arg :index keyword))
                  (with-highlighting (:index keyword)
                    (cond ((and init (keywordp keyword))
-                          (format t "~:@<~A ~S~@:>" arg init))
+                          (format t "~:@<~A ~S~@:>" keyword init))
                          (init
                           (format t "~:@<(~S ..) ~S~@:>" keyword init))
                          ((not (keywordp keyword))
@@ -1084,7 +1084,8 @@
 		(*print-readably* nil))
 	    (call/truncated-output-to-string
 	     75 (lambda (s)
-		  (format s "~A => ~S" sym (symbol-value sym)))))))))
+		  (format s "~A => ~S" sym (symbol-value sym)))))
+          :not-available))))
 
 ;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at
 ;;; user's point in Emacs. A RAW-FORM looks like




From trittweiler at common-lisp.net  Mon Dec 21 16:23:02 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 21 Dec 2009 11:23:02 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NMl2E-0006xs-MQ@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv26771/contrib

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
	* swank-arglists.lisp (completions-for-keyword): Return nil
	instead of :not-available because the function is supposed to
	return a list of available completions.

	Adapted from patch by Ariel Badichi.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 16:03:41	1.313
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 16:23:02	1.314
@@ -1,5 +1,13 @@
 2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-arglists.lisp (completions-for-keyword): Return nil
+	instead of :not-available because the function is supposed to
+	return a list of available completions.
+
+	Adapted from patch by Ariel Badichi.
+
+2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Today's cleanup day.
 
 	* slime-parse.el (slime-incomplete-form-at-point)
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/21 16:03:41	1.48
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/21 16:23:02	1.49
@@ -1151,27 +1151,28 @@
   "Return a list of possible completions for KEYWORD-STRING relative
 to the context provided by RAW-FORM."
   (with-buffer-syntax ()
-    (with-available-arglist (arglist)
-        (find-immediately-containing-arglist (parse-raw-form raw-form))
-      ;; It would be possible to complete keywords only if we are in
-      ;; a keyword position, but it is not clear if we want that.
-      (let* ((keywords
-              (append (mapcar #'keyword-arg.keyword
-                              (arglist.keyword-args arglist))
-                      (remove-if-not #'keywordp (arglist.any-args arglist))))
-             (keyword-name
-              (tokenize-symbol keyword-string))
-             (matching-keywords
-              (find-matching-symbols-in-list
-               keyword-name keywords (make-compound-prefix-matcher #\-)))
-             (converter (completion-output-symbol-converter keyword-string))
-             (strings
-              (mapcar converter
-                      (mapcar #'symbol-name matching-keywords)))
-             (completion-set
-              (format-completion-set strings nil "")))
-        (list completion-set
-              (longest-compound-prefix completion-set))))))
+    (let ((arglist (find-immediately-containing-arglist
+                    (parse-raw-form raw-form))))
+      (when (arglist-available-p arglist)
+        ;; It would be possible to complete keywords only if we are in
+        ;; a keyword position, but it is not clear if we want that.
+        (let* ((keywords
+                (append (mapcar #'keyword-arg.keyword
+                                (arglist.keyword-args arglist))
+                        (remove-if-not #'keywordp (arglist.any-args arglist))))
+               (keyword-name
+                (tokenize-symbol keyword-string))
+               (matching-keywords
+                (find-matching-symbols-in-list
+                 keyword-name keywords (make-compound-prefix-matcher #\-)))
+               (converter (completion-output-symbol-converter keyword-string))
+               (strings
+                (mapcar converter
+                        (mapcar #'symbol-name matching-keywords)))
+               (completion-set
+                (format-completion-set strings nil "")))
+          (list completion-set
+                (longest-compound-prefix completion-set)))))))
 
 (defparameter +cursor-marker+ '%cursor-marker%)
 




From heller at common-lisp.net  Tue Dec 22 09:31:15 2009
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 22 Dec 2009 04:31:15 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NN15H-0006Vr-Da@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv25008

Modified Files:
	ChangeLog swank.lisp swank-backend.lisp swank-cmucl.lisp 
Log Message:
Commands to save&restore image files without disconnecting.

* slime-snapshot.el: New file.
* swank-snapshot.lisp: New file.

Some new backend functions used for loading image files.

* swank-backend.lisp (socket-fd, make-fd-stream, dup, exec-image)
(command-line-args): New functions.
* swank-cmucl.lisp: Impemented.
* swank-cmucl.lisp (reset-sigio-handlers): New function.
(save-image): Fix quoting bug.

* swank.lisp (clear-event-history): New functoin.
(interactive-eval, eval-region): Don't use FRESH-LINE.


--- /project/slime/cvsroot/slime/ChangeLog	2009/12/21 13:31:55	1.1946
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/22 09:31:15	1.1947
@@ -1,3 +1,16 @@
+2009-12-22  Helmut Eller  <heller at common-lisp.net>
+
+	Some new backend functions used for loading image files.
+
+	* swank-backend.lisp (socket-fd, make-fd-stream, dup, exec-image)
+	(command-line-args): New functions.
+	* swank-cmucl.lisp: Impemented.
+	* swank-cmucl.lisp (reset-sigio-handlers): New function.
+	(save-image): Fix quoting bug.
+
+	* swank.lisp (clear-event-history): New functoin.
+	(interactive-eval, eval-region): Don't use FRESH-LINE.
+
 2009-12-21  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-at-list-p): Deleted.
--- /project/slime/cvsroot/slime/swank.lisp	2009/12/17 10:30:32	1.680
+++ /project/slime/cvsroot/slime/swank.lisp	2009/12/22 09:31:15	1.681
@@ -585,6 +585,10 @@
         (idx *event-history-index*))
     (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
 
+(defun clear-event-history ()
+  (fill *event-history* nil)
+  (setq *event-history-index* 0))
+
 (defun dump-event-history (stream)
   (dolist (e (event-history-to-list))
     (dump-event e stream)))
@@ -766,8 +770,8 @@
                                     (coding-system *coding-system*))
   "Start the server and write the listen port number to PORT-FILE.
 This is the entry point for Emacs."
-  (setup-server 0 (lambda (port) 
-                    (announce-server-port port-file port))
+  (setup-server 0
+                (lambda (port) (announce-server-port port-file port))
                 style dont-close 
                 (find-external-format-or-lose coding-system)))
 
@@ -1367,17 +1371,16 @@
 (defun simple-repl ()
   (loop
    (with-simple-restart (abort "Abort")
-     (format t "~&~a> " (package-string-for-prompt *package*))
+     (format t "~a> " (package-string-for-prompt *package*))
      (force-output)
      (let ((form (read)))
-       (fresh-line)
        (let ((- form)
              (values (multiple-value-list (eval form))))
          (setq *** **  ** *  * (car values)
                /// //  // /  / values
                +++ ++  ++ +  + form)
-         (cond ((null values) (format t "~&; No values"))
-               (t (mapc (lambda (v) (format t "~&~s" v)) values))))))))
+         (cond ((null values) (format t "; No values~&"))
+               (t (mapc (lambda (v) (format t "~s~&" v)) values))))))))
 
 (defun make-repl-input-stream (connection stdin)
   (make-input-stream
@@ -2195,7 +2198,6 @@
   (with-buffer-syntax ()
     (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
       (let ((values (multiple-value-list (eval (from-string string)))))
-        (fresh-line)
         (finish-output)
         (format-values-for-echo-area values)))))
 
@@ -2217,7 +2219,6 @@
       (loop
        (let ((form (read stream nil stream)))
          (when (eq form stream)
-           (fresh-line)
            (finish-output)
            (return (values values -)))
          (setq - form)
--- /project/slime/cvsroot/slime/swank-backend.lisp	2009/12/19 14:56:06	1.187
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2009/12/22 09:31:15	1.188
@@ -335,6 +335,28 @@
   "Return a short name for the Lisp implementation."
   (lisp-implementation-type))
 
+(definterface socket-fd (socket-stream)
+  "Return the file descriptor for SOCKET-STREAM.")
+
+(definterface make-fd-stream (fd external-format)
+  "Create a character stream for the file descriptor FD.")
+
+(definterface dup (fd)
+  "Duplicate a file descriptor.
+If the syscall fails, signal a condition.
+See dup(2).")
+
+(definterface exec-image (image-file args)
+  "Replace the current process with a new process image.
+The new image is created by loading the previously dumped
+core file IMAGE-FILE.
+ARGS is a list of strings passed as arguments to
+the new image.
+This is thin wrapper around exec(3).")
+
+(definterface command-line-args ()
+  "Return a list of strings as passed by the OS.")
+
 
 ;; pathnames are sooo useless
 
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2009/11/03 18:22:58	1.215
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2009/12/22 09:31:15	1.216
@@ -107,7 +107,7 @@
 
 ;;;;; Sockets
 
-(defun socket-fd (socket)
+(defimplementation socket-fd (socket)
   "Return the filedescriptor for the socket represented by SOCKET."
   (etypecase socket
     (fixnum socket)
@@ -137,6 +137,27 @@
                       #+unicode :external-format 
                       #+unicode external-format))
 
+(defimplementation make-fd-stream (fd external-format)
+  (make-socket-io-stream fd :full external-format))
+
+(defimplementation dup (fd)
+  (multiple-value-bind (clone error) (unix:unix-dup fd)
+    (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error)))
+    clone))
+
+(defimplementation command-line-args ()
+  ext:*command-line-strings*)
+
+(defimplementation exec-image (image-file args)
+  (multiple-value-bind (ok error)
+      (unix:unix-execve (car (command-line-args))
+			(list* (car (command-line-args)) 
+                               "-core" image-file
+                               "-noinit"
+                               args))
+    (error "~a" (unix:get-unix-error-msg error))
+    ok))
+
 ;;;;; Signal-driven I/O
 
 (defimplementation install-sigint-handler (function)
@@ -149,6 +170,10 @@
 All functions are called on SIGIO, and the key is used for removing
 specific functions.")
 
+(defun reset-sigio-handlers () (setq *sigio-handlers* '()))
+;; All file handlers are invalid afer reload.
+(pushnew 'reset-sigio-handlers ext:*after-save-initializations*)
+
 (defun set-sigio-handler ()
   (sys:enable-interrupt :sigio (lambda (signal code scp)
                                  (sigio-handler signal code scp))))
@@ -2366,10 +2391,10 @@
   (multiple-value-bind (pid error) (unix:unix-fork)
     (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error)))
     (cond ((= pid 0)
-           (let ((args `(,filename 
-                         ,@(if restart-function
-                               `((:init-function ,restart-function))))))
-             (apply #'ext:save-lisp args)))
+           (apply #'ext:save-lisp
+                  filename 
+                  (if restart-function
+                      `(:init-function ,restart-function))))
           (t 
            (let ((status (waitpid pid)))
              (destructuring-bind (&key exited? status &allow-other-keys) status




From heller at common-lisp.net  Tue Dec 22 09:31:15 2009
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 22 Dec 2009 04:31:15 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NN15H-0006WE-Nw@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv25008/contrib

Modified Files:
	ChangeLog 
Added Files:
	slime-snapshot.el swank-snapshot.lisp 
Log Message:
Commands to save&restore image files without disconnecting.

* slime-snapshot.el: New file.
* swank-snapshot.lisp: New file.

Some new backend functions used for loading image files.

* swank-backend.lisp (socket-fd, make-fd-stream, dup, exec-image)
(command-line-args): New functions.
* swank-cmucl.lisp: Impemented.
* swank-cmucl.lisp (reset-sigio-handlers): New function.
(save-image): Fix quoting bug.

* swank.lisp (clear-event-history): New functoin.
(interactive-eval, eval-region): Don't use FRESH-LINE.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/21 16:23:02	1.314
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/22 09:31:15	1.315
@@ -1,3 +1,10 @@
+2009-12-22  Helmut Eller  <heller at common-lisp.net>
+
+	Commands to save&restore image files without disconnecting.
+
+	* slime-snapshot.el: New file.
+	* swank-snapshot.lisp: New file.
+
 2009-12-21  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-arglists.lisp (completions-for-keyword): Return nil

--- /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2009/12/22 09:31:15	NONE
+++ /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2009/12/22 09:31:15	1.1
;; slime-snapshot.el --- Save&restore memory images without disconnecting

(slime-require :swank-snapshot)

(defun slime-snapshot (filename)
  "Save a memory image to the file FILENAME."
  (interactive (list (read-file-name "Image file: ")))
  (slime-eval-with-transcript 
   `(swank-snapshot:save-snapshot ,(expand-file-name filename))))

(defun slime-restore (filename)
  "Restore a memory image stored in file FILENAME."
  (interactive (list (read-file-name "Image file: ")))
  ;; bypass event dispatcher because we don't expect a reply. FIXME.
  (slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot 
				,(expand-file-name filename))
			       nil t nil)
		  (slime-connection)))
--- /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2009/12/22 09:31:15	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2009/12/22 09:31:15	1.1

(defpackage swank-snapshot
  (:use cl)
  (:export restore-snapshot save-snapshot)
  (:import-from swank defslimefun))
(in-package swank-snapshot)

(defslimefun save-snapshot (image-file)
  (swank-backend:save-image image-file 
			    (let ((c swank::*emacs-connection*))
			      (lambda () (resurrect c))))
  t)

(defslimefun restore-snapshot (image-file)
  (let* ((conn swank::*emacs-connection*)
	 (stream (swank::connection.socket-io conn))
	 (clone (swank-backend:dup (swank-backend:socket-fd stream)))
	 (style (swank::connection.communication-style conn))
	 (args (list "--swank-fd" (format nil "~d" clone)
		     "--swank-style" (format nil "~s" style))))
    (swank::close-connection conn nil nil)
    (swank-backend:exec-image image-file args)))

(in-package :swank)

(defun swank-snapshot::resurrect (old-connection)
  (setq *log-output* nil)
  (init-log-output)
  (clear-event-history)
  (setq *connections* (delete old-connection *connections*))
  (format *error-output* "args: ~s~%" (command-line-args))
  (let* ((fd (read-command-line-arg "--swank-fd"))
	 (style (read-command-line-arg "--swank-style")))
    (format *error-output* "fd=~s style=~s~%" fd style)
    (let ((connection (create-connection (make-fd-stream fd :default) style)))
      (run-hook *new-connection-hook* connection)
      (push connection *connections*)
      (serve-requests connection)
      (simple-repl))))

(defun read-command-line-arg (name)
  (let* ((args (command-line-args))
	 (pos (position name args :test #'equal)))
    (read-from-string (elt args (1+ pos)))))

(in-package :swank-snapshot)



From trittweiler at common-lisp.net  Wed Dec 23 08:34:18 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 23 Dec 2009 03:34:18 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NNMfi-0004in-Fb@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv18130

Modified Files:
	slime-c-p-c.el slime-autodoc.el ChangeLog 
Log Message:
	* slime-autodoc.el (autodoc.1 [test]): Add a test case involving
	DEFMETHOD.

	* slime-c-p-c.el (complete-form [test]): New test. Fails for the
	moment.

	Reported by Matthias Koeppe.


--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/21 16:03:41	1.16
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/23 08:34:17	1.17
@@ -206,4 +206,36 @@
   (let ((completions (slime-completions prefix)))
     (slime-test-expect "Completion set" expected-completions completions)))
 
+(def-slime-test complete-form
+    (buffer-sexpr wished-completion)
+    ""
+    '(("(defmethod swank::arglist-dispatch *HERE*"
+       "(defmethod swank::arglist-dispatch (operator arguments) body...)"))
+  (slime-check-top-level)
+  (with-temp-buffer
+    (setq slime-buffer-package "COMMON-LISP-USER")
+    (lisp-mode)
+    (insert buffer-sexpr)
+    (search-backward "*HERE*")
+    (delete-region (match-beginning 0) (match-end 0))
+    (slime-complete-form)
+    (slime-check-completed-form buffer-sexpr wished-completion)
+
+    ;; Now the same but with trailing `)' for paredit users...
+    (erase-buffer)
+    (insert buffer-sexpr)
+    (search-backward "*HERE*")
+    (delete-region (match-beginning 0) (match-end 0))
+    (insert ")") (backward-char)
+    (slime-complete-form)
+    (slime-check-completed-form (concat buffer-sexpr ")") wished-completion)
+    ))
+
+(defun slime-check-completed-form (buffer-sexpr wished-completion)
+  (slime-test-expect (format "Completed form for `%s' is as expected"
+                              buffer-sexpr)
+                     wished-completion
+                     (buffer-string)
+                     'equal))
+
 (provide 'slime-c-p-c)
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/12/21 16:03:41	1.25
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/12/23 08:34:17	1.26
@@ -279,6 +279,8 @@
       ("(swank::symbol-status foo *HERE*" 
        "(symbol-status symbol &optional ===> (package (symbol-package symbol)) <===)")
 
+      ("(defmethod swank::arglist-dispatch (*HERE*"
+       "(defmethod arglist-dispatch (===> operator <=== arguments) &body body)")
       ("(apply 'swank::eval-for-emacs*HERE*"
        "(apply 'eval-for-emacs &optional form buffer-package id &rest args)")
 
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/22 09:31:15	1.315
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/23 08:34:17	1.316
@@ -1,3 +1,13 @@
+2009-12-23  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-autodoc.el (autodoc.1 [test]): Add a test case involving
+	DEFMETHOD.
+
+	* slime-c-p-c.el (complete-form [test]): New test. Fails for the
+	moment.
+
+	Reported by Matthias Koeppe.
+
 2009-12-22  Helmut Eller  <heller at common-lisp.net>
 
 	Commands to save&restore image files without disconnecting.




From trittweiler at common-lisp.net  Wed Dec 23 08:52:01 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 23 Dec 2009 03:52:01 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NNMwr-00066J-36@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv23419/contrib

Modified Files:
	slime-c-p-c.el ChangeLog 
Log Message:
	* slime.el (complete-symbol [test]): Fix test case.

	* slime-c-p-c.el (complete-symbol* [test]): Fix test case.


--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/23 08:34:17	1.17
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/23 08:52:00	1.18
@@ -199,6 +199,7 @@
       ("swank::compile-file" (("swank::compile-file" 
                                "swank::compile-file-for-emacs"
                                "swank::compile-file-if-needed"
+                               "swank::compile-file-output"
                                "swank::compile-file-pathname")
                               "swank::compile-file"))
       ("cl:m-v-l" (("cl:multiple-value-list" "cl:multiple-values-limit") "cl:multiple-value"))
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/23 08:34:17	1.316
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/23 08:52:01	1.317
@@ -1,5 +1,9 @@
 2009-12-23  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-c-p-c.el (complete-symbol* [test]): Fix test case.
+
+2009-12-23  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-autodoc.el (autodoc.1 [test]): Add a test case involving
 	DEFMETHOD.
 




From trittweiler at common-lisp.net  Wed Dec 23 08:52:01 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 23 Dec 2009 03:52:01 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NNMwr-00066a-Fr@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv23419

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el (complete-symbol [test]): Fix test case.

	* slime-c-p-c.el (complete-symbol* [test]): Fix test case.


--- /project/slime/cvsroot/slime/slime.el	2009/12/21 13:31:55	1.1258
+++ /project/slime/cvsroot/slime/slime.el	2009/12/23 08:52:01	1.1259
@@ -2216,7 +2216,9 @@
   ;; slime-autodoc.)  If this ever happens again, returning the
   ;; following will make debugging much easier:
   :slime-eval-async)
-  
+
+(put 'slime-eval-async 'lisp-indent-function 1)
+
 ;;; These functions can be handy too:
 
 (defun slime-connected-p ()
@@ -7634,6 +7636,7 @@
       ("swank::compile-file" (("swank::compile-file" 
                                "swank::compile-file-for-emacs"
                                "swank::compile-file-if-needed"
+                               "swank::compile-file-output"
                                "swank::compile-file-pathname")
                               "swank::compile-file"))
       ("cl:m-v-l" (nil "")))
--- /project/slime/cvsroot/slime/ChangeLog	2009/12/22 09:31:15	1.1947
+++ /project/slime/cvsroot/slime/ChangeLog	2009/12/23 08:52:01	1.1948
@@ -1,3 +1,7 @@
+2009-12-23  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (complete-symbol [test]): Fix test case.
+
 2009-12-22  Helmut Eller  <heller at common-lisp.net>
 
 	Some new backend functions used for loading image files.




From trittweiler at common-lisp.net  Wed Dec 23 08:55:41 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 23 Dec 2009 03:55:41 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NNN0P-0006Ap-5f@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv23721/contrib

Modified Files:
	slime-parse.el ChangeLog 
Log Message:
	* slime-parse.el (form-up-to-point.1 [test]): Fix test case.


--- /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/21 16:03:41	1.32
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/23 08:55:40	1.33
@@ -115,14 +115,12 @@
    (slime-parse-form-upto-point 10)))
 
 (def-slime-test form-up-to-point.1
-    (buffer-sexpr result-form)
+    (buffer-sexpr result-form &optional skip-trailing-test-p)
     ""
     '(("(char= #\\(*HERE*"            ("char=" "#\\(" swank::%cursor-marker%))
       ("(char= #\\( *HERE*"           ("char=" "#\\(" "" swank::%cursor-marker%))
       ("(char= #\\) *HERE*"           ("char=" "#\\)" "" swank::%cursor-marker%))
-                                      ;; The #\) here is an accident of 
-                                      ;; the implementation.
-      ("(char= #\\*HERE*"             ("char=" "#\\)" swank::%cursor-marker%))
+      ("(char= #\\*HERE*"             ("char=" "#\\" swank::%cursor-marker%) t)
       ("(defun*HERE*"                 ("defun" swank::%cursor-marker%))
       ("(defun foo*HERE*"             ("defun" "foo" swank::%cursor-marker%))
       ("(defun foo (x y)*HERE*"       ("defun" "foo" ("x" "y") swank::%cursor-marker%))
@@ -141,8 +139,9 @@
     (search-backward "*HERE*")
     (delete-region (match-beginning 0) (match-end 0))
     (slime-check-buffer-form result-form)
-    (insert ")") (backward-char)
-    (slime-check-buffer-form result-form)      
+    (unless skip-trailing-test-p
+      (insert ")") (backward-char)
+      (slime-check-buffer-form result-form))
     ))
 
 (provide 'slime-parse)
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/23 08:52:01	1.317
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/23 08:55:41	1.318
@@ -1,5 +1,9 @@
 2009-12-23  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-parse.el (form-up-to-point.1 [test]): Fix test case.
+
+2009-12-23  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-c-p-c.el (complete-symbol* [test]): Fix test case.
 
 2009-12-23  Tobias C. Rittweiler  <tcr at freebits.de>




From trittweiler at common-lisp.net  Fri Dec 25 11:04:00 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 25 Dec 2009 06:04:00 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NO7xg-0005RM-H2@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv20907/contrib

Modified Files:
	ChangeLog slime-c-p-c.el swank-arglists.lisp 
Log Message:
	* swank-arglists.lisp (delete-given-args): Make sure to properly
	delete provided-args.

	* slime-c-p-c.el (complete-form [test]): Extend. Succeeds now.



--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/23 08:55:41	1.318
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/25 11:04:00	1.319
@@ -1,3 +1,10 @@
+2009-12-25  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-arglists.lisp (delete-given-args): Make sure to properly
+	delete provided-args.
+
+	* slime-c-p-c.el (complete-form [test]): Extend. Succeeds now.
+
 2009-12-23  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-parse.el (form-up-to-point.1 [test]): Fix test case.
--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/23 08:52:00	1.18
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/25 11:04:00	1.19
@@ -208,13 +208,21 @@
     (slime-test-expect "Completion set" expected-completions completions)))
 
 (def-slime-test complete-form
-    (buffer-sexpr wished-completion)
+    (buffer-sexpr wished-completion &optional skip-trailing-test-p)
     ""
-    '(("(defmethod swank::arglist-dispatch *HERE*"
-       "(defmethod swank::arglist-dispatch (operator arguments) body...)"))
+    '(("(defmethod arglist-dispatch *HERE*"
+       "(defmethod arglist-dispatch (operator arguments) body...)")
+      ("(with-struct *HERE*"
+       "(with-struct (conc-name names...) obj body...)")
+      ("(with-struct *HERE*"
+       "(with-struct (conc-name names...) obj body...)")
+      ("(with-struct (*HERE*"
+       "(with-struct (conc-name names...)" t)
+      ("(with-struct (foo. bar baz *HERE*"
+       "(with-struct (foo. bar baz names...)" t))
   (slime-check-top-level)
   (with-temp-buffer
-    (setq slime-buffer-package "COMMON-LISP-USER")
+    (setq slime-buffer-package "SWANK")
     (lisp-mode)
     (insert buffer-sexpr)
     (search-backward "*HERE*")
@@ -223,13 +231,14 @@
     (slime-check-completed-form buffer-sexpr wished-completion)
 
     ;; Now the same but with trailing `)' for paredit users...
-    (erase-buffer)
-    (insert buffer-sexpr)
-    (search-backward "*HERE*")
-    (delete-region (match-beginning 0) (match-end 0))
-    (insert ")") (backward-char)
-    (slime-complete-form)
-    (slime-check-completed-form (concat buffer-sexpr ")") wished-completion)
+    (unless skip-trailing-test-p
+      (erase-buffer)
+      (insert buffer-sexpr)
+      (search-backward "*HERE*")
+      (delete-region (match-beginning 0) (match-end 0))
+      (insert ")") (backward-char)
+      (slime-complete-form)
+      (slime-check-completed-form (concat buffer-sexpr ")") wished-completion))
     ))
 
 (defun slime-check-completed-form (buffer-sexpr wished-completion)
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/21 16:23:02	1.49
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/25 11:04:00	1.50
@@ -354,6 +354,7 @@
              (pprint-newline :fill)))
       (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
         (do-decoded-arglist decoded-arglist
+          (&provided ())  ; do nothing; provided args are in the buffer already.
           (&required (arg)
             (space) (print-arg-or-pattern arg))
           (&optional (arg)
@@ -935,6 +936,9 @@
 		    (return-from do-decoded-arglist)
 		    (pop ,list))))
     (do-decoded-arglist decoded-arglist
+      (&provided ()
+       (assert (eq (pop-or-return args)
+                   (pop (arglist.provided-args decoded-arglist)))))
       (&required ()
        (pop-or-return args)
        (pop (arglist.required-args decoded-arglist)))




From trittweiler at common-lisp.net  Tue Dec 29 12:48:32 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 29 Dec 2009 07:48:32 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NPbV2-0001o9-5m@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv6950/contrib

Modified Files:
	slime-parse.el ChangeLog 
Log Message:
	* slime-parse.el (slime-parse-form-until): Properly deal with #'
	prefix.
	(form-up-to-point.1 [test]): Extend.


--- /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/23 08:55:40	1.33
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/12/29 12:48:31	1.34
@@ -31,7 +31,7 @@
          (decf depth)
          (push (nreverse cursexp) (car sexps)))
         ;; Start of a new sexp?
-        ((looking-at "\\s'?\\s(")
+        ((looking-at "\\s'*\\s(")
          (let ((subpt (match-end 0)))
            (ignore-errors
              (forward-sexp)
@@ -117,21 +117,24 @@
 (def-slime-test form-up-to-point.1
     (buffer-sexpr result-form &optional skip-trailing-test-p)
     ""
-    '(("(char= #\\(*HERE*"            ("char=" "#\\(" swank::%cursor-marker%))
-      ("(char= #\\( *HERE*"           ("char=" "#\\(" "" swank::%cursor-marker%))
-      ("(char= #\\) *HERE*"           ("char=" "#\\)" "" swank::%cursor-marker%))
-      ("(char= #\\*HERE*"             ("char=" "#\\" swank::%cursor-marker%) t)
-      ("(defun*HERE*"                 ("defun" swank::%cursor-marker%))
-      ("(defun foo*HERE*"             ("defun" "foo" swank::%cursor-marker%))
-      ("(defun foo (x y)*HERE*"       ("defun" "foo" ("x" "y") swank::%cursor-marker%))
-      ("(defun foo (x y*HERE*"        ("defun" "foo" ("x" "y" swank::%cursor-marker%)))
-      ("(apply 'foo*HERE*"            ("apply" "'foo" swank::%cursor-marker%))
-      ("(apply #'foo*HERE*"           ("apply" "#'foo" swank::%cursor-marker%))
-      ("(declare ((vector bit *HERE*" ("declare" (("vector" "bit" "" swank::%cursor-marker%))))
-      ("(with-open-file (*HERE*"      ("with-open-file" ("" swank::%cursor-marker%)))
-      ("(((*HERE*"                    ((("" swank::%cursor-marker%))))
-      ("(defun #| foo #| *HERE*"      ("defun" "" swank::%cursor-marker%))
-      ("(defun #-(and) (bar) f*HERE*" ("defun" "f" swank::%cursor-marker%)))
+    '(("(char= #\\(*HERE*"               ("char=" "#\\(" swank::%cursor-marker%))
+      ("(char= #\\( *HERE*"              ("char=" "#\\(" "" swank::%cursor-marker%))
+      ("(char= #\\) *HERE*"              ("char=" "#\\)" "" swank::%cursor-marker%))
+      ("(char= #\\*HERE*"                ("char=" "#\\" swank::%cursor-marker%) t)
+      ("(defun*HERE*"                    ("defun" swank::%cursor-marker%))
+      ("(defun foo*HERE*"                ("defun" "foo" swank::%cursor-marker%))
+      ("(defun foo (x y)*HERE*"          ("defun" "foo" ("x" "y") swank::%cursor-marker%))
+      ("(defun foo (x y*HERE*"           ("defun" "foo" ("x" "y" swank::%cursor-marker%)))
+      ("(apply 'foo*HERE*"               ("apply" "'foo" swank::%cursor-marker%))
+      ("(apply #'foo*HERE*"              ("apply" "#'foo" swank::%cursor-marker%))
+      ("(declare ((vector bit *HERE*"    ("declare" (("vector" "bit" "" swank::%cursor-marker%))))
+      ("(with-open-file (*HERE*"         ("with-open-file" ("" swank::%cursor-marker%)))
+      ("(((*HERE*"                       ((("" swank::%cursor-marker%))))
+      ("(defun #| foo #| *HERE*"         ("defun" "" swank::%cursor-marker%))
+      ("(defun #-(and) (bar) f*HERE*"    ("defun" "f" swank::%cursor-marker%))
+      ("(remove-if #'(lambda (x)*HERE*"  ("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
+      ("`(remove-if ,(lambda (x)*HERE*"  ("remove-if" ("lambda" ("x") swank::%cursor-marker%)))
+      ("`(remove-if ,@(lambda (x)*HERE*" ("remove-if" ("lambda" ("x") swank::%cursor-marker%))))
   (slime-check-top-level)
   (with-temp-buffer
     (lisp-mode)
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/25 11:04:00	1.319
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 12:48:31	1.320
@@ -1,3 +1,9 @@
+2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-parse.el (slime-parse-form-until): Properly deal with #'
+	prefix.
+	(form-up-to-point.1 [test]): Extend.
+
 2009-12-25  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-arglists.lisp (delete-given-args): Make sure to properly




From trittweiler at common-lisp.net  Tue Dec 29 19:01:37 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 29 Dec 2009 14:01:37 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NPhK5-0008TH-7O@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv32564/contrib

Modified Files:
	swank-arglists.lisp ChangeLog 
Log Message:
	Some cleanup of arglist code.

	* swank-arglists.lisp (remove-from-tree-if): Deleted.
	(remove-from-tree): Deleted.
	(maybecall): Deleted.
	(arglist-path-to-parameter): Deleted.
	(arglist-path-to-nested-arglist): Deleted.
	(last-arg): Deleted.
	(compute-arglist-index): Deleted.

	(form-path-to-arglist-path): New.
	(arglist-index): New.
	(extract-cursor-marker): New.
	(find-subform-with-arglist): Adapted.
	(find-immediately-containing-arglist): Adapted.
	(arglist-for-echo-area): Adapted.


--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/25 11:04:00	1.50
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/29 19:01:37	1.51
@@ -38,21 +38,6 @@
 (defun memq (item list)
   (member item list :test #'eq))
 
-(defun remove-from-tree-if (predicate tree)
-  (cond ((atom tree) tree)
-        ((funcall predicate (car tree))
-         (remove-from-tree-if predicate (cdr tree)))
-        (t
-         (cons (remove-from-tree-if predicate (car tree)) 
-               (remove-from-tree-if predicate (cdr tree))))))
-
-(defun remove-from-tree (item tree)
-  (remove-from-tree-if #'(lambda (x) (eql x item)) tree))
-
-(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."
@@ -1124,16 +1109,16 @@
                           (return-from arglist-for-echo-area
                             (format nil "Arglist Error: \"~A\"" c)))))))
       (with-buffer-syntax ()
-        (multiple-value-bind (form arglist)
+        (multiple-value-bind (form arglist obj-at-cursor form-path)
             (find-subform-with-arglist (parse-raw-form raw-form))
+          (declare (ignore obj-at-cursor))
           (with-available-arglist (arglist) arglist
-            (destructuring-bind (operator . args) form
-              (decoded-arglist-to-string
-               arglist
-               :print-right-margin print-right-margin
-               :print-lines print-lines
-               :operator operator
-               :highlight (arglist-path-to-parameter arglist args))))))))
+            (decoded-arglist-to-string
+             arglist
+             :print-right-margin print-right-margin
+             :print-lines print-lines
+             :operator (car form)
+             :highlight (form-path-to-arglist-path form-path form arglist)))))))
 
 (defslimefun complete-form (raw-form)
   "Read FORM-STRING in the current buffer package, then complete it
@@ -1146,7 +1131,7 @@
         (find-immediately-containing-arglist (parse-raw-form raw-form))
       (with-available-arglist (arglist) arglist
         (decoded-arglist-to-template-string
-         (delete-given-args arglist 
+         (delete-given-args arglist
                             (remove-if #'empty-arg-p provided-args
                                        :from-end t :count 1))
          :prefix "" :suffix "")))))
@@ -1181,21 +1166,29 @@
 (defparameter +cursor-marker+ '%cursor-marker%)
 
 (defun find-subform-with-arglist (form)
-  "Returns two values: the appropriate subform of FORM which is close
-to the +CURSOR-MARKER+ and whose operator is valid and has an
-arglist. Second value is the arglist. The +CURSOR-MARKER+ is removed
-from the subform returned.
-
-This function takes local function and macro definitions appearing in
-FORM into account."
-  (labels 
+  "Returns four values:
+
+     The appropriate subform of `form' which is closest to the
+     +CURSOR-MARKER+ and whose operator is valid and has an
+     arglist. The +CURSOR-MARKER+ is removed from that subform.
+
+     Second value is the arglist. Local function and macro definitions
+     appearing in `form' into account.
+
+     Third value is the object in front of +CURSOR-MARKER+.
+
+     Fourth value is a form path to that object."
+  (labels
       ((yield-success (form local-ops)
-         (let ((form (remove-from-tree +cursor-marker+ form)))
+         (multiple-value-bind (form obj-at-cursor form-path)
+             (extract-cursor-marker form)
            (values form
                    (let ((entry (assoc (car form) local-ops :test #'op=)))
                      (if entry
                          (decode-arglist (cdr entry))
-                         (arglist-from-form form))))))
+                         (arglist-from-form form)))
+                   obj-at-cursor
+                   form-path)))
        (yield-failure ()
          (values nil :not-available))
        (operator-p (operator local-ops)
@@ -1243,110 +1236,149 @@
         (yield-failure)
         (grovel-form form '()))))
 
-(flet ((collect-op/argl-alist (defs)
-         (setq defs (remove-if-not #'(lambda (x)
-                                       ;; Well-formed FLET/LABELS def?
-                                       (and (consp x) (second x)))
-                                   defs))
-         (loop for (name arglist . nil) in defs
-               collect (cons name arglist))))
-  (defgeneric extract-local-op-arglists (operator args)
-    (:documentation
-     "If the form `(OPERATOR , at ARGS) is a local operator binding form,
+(defun extract-cursor-marker (form)
+  "Returns three values: normalized `form' without +CURSOR-MARKER+,
+the object in front of +CURSOR-MARKER+, and a form path to that
+object."
+  (labels ((grovel (form last path)
+             (let ((result-form))
+               (loop for (car . cdr) on form do
+                     (cond ((eql car +cursor-marker+)
+                            (decf (first path))
+                            (return-from grovel
+                              (values (nreconc result-form cdr)
+                                      last
+                                      (nreverse path))))
+                           (t
+                            (multiple-value-bind (new-car new-last new-path)
+                                (grovel car last (cons 0 path))
+                              (when path
+                                (return-from grovel
+                                  (values (nreconc
+                                           (cons new-car result-form) cdr)
+                                          new-last
+                                          new-path))))
+                            (push car result-form)
+                            (setq last car)
+                            (incf (first path))))
+                     finally
+                       (return (values (nreverse result-form) nil))))))
+    (grovel form nil (list 0))))
+
+(defgeneric extract-local-op-arglists (operator args)
+  (:documentation
+   "If the form `(OPERATOR , at ARGS) is a local operator binding form,
      return a list of pairs (OP . ARGLIST) for each locally bound op.")
-    (:method (operator args)
-      (declare (ignore operator args))
-      nil)
-    ;; FLET
-    (:method ((operator (eql 'cl:flet)) args)
-      (let ((defs (first args))
-            (body (rest args)))
-        (cond ((null body) nil)         ; `(flet ((foo (x) |'
-              ((atom defs) nil)         ; `(flet ,foo (|'
-              (t (collect-op/argl-alist defs)))))
-    ;; LABELS
-    (:method ((operator (eql 'cl:labels)) args)
-      ;; Notice that we only have information to "look backward" and
-      ;; show arglists of previously occuring local functions.
-      (let ((defs (first args))
-            (body (rest args)))
-        (cond ((atom defs) nil)
-              ((not (null body))
-               (extract-local-op-arglists 'cl:flet args))
-              (t
-               (let ((def.body (cddr (car (last defs)))))
-                 (when def.body
-                   (collect-op/argl-alist defs)))))))
-    ;; MACROLET
-    (:method ((operator (eql 'cl:macrolet)) args)
-      (extract-local-op-arglists 'cl:labels args))))
+  (:method (operator args)
+    (declare (ignore operator args))
+    nil)
+  ;; FLET
+  (:method ((operator (eql 'cl:flet)) args)
+    (let ((defs (first args))
+          (body (rest args)))
+      (cond ((null body) nil)           ; `(flet ((foo (x) |'
+            ((atom defs) nil)           ; `(flet ,foo (|'
+            (t (%collect-op/argl-alist defs)))))
+  ;; LABELS
+  (:method ((operator (eql 'cl:labels)) args)
+    ;; Notice that we only have information to "look backward" and
+    ;; show arglists of previously occuring local functions.
+    (let ((defs (first args))
+          (body (rest args)))
+      (cond ((atom defs) nil)
+            ((not (null body))
+             (extract-local-op-arglists 'cl:flet args))
+            (t
+             (let ((def.body (cddr (car (last defs)))))
+               (when def.body
+                 (%collect-op/argl-alist defs)))))))
+  ;; MACROLET
+  (:method ((operator (eql 'cl:macrolet)) args)
+    (extract-local-op-arglists 'cl:labels args)))
+
+(defun %collect-op/argl-alist (defs)
+  (setq defs (remove-if-not #'(lambda (x)
+                                ;; Well-formed FLET/LABELS def?
+                                (and (consp x) (second x)))
+                            defs))
+  (loop for (name arglist . nil) in defs
+        collect (cons name arglist)))
 
 (defun find-immediately-containing-arglist (form)
-  "Returns the arglist of the form immediately containing
-+CURSOR-MARKER+ in form. Notice, however, as +CURSOR-MARKER+ may be in
-a nested arglist \(e.g. `(WITH-OPEN-FILE (|'\), the appropriate parent
-form may in fact be considered."
-  (multiple-value-bind (form arglist) (find-subform-with-arglist form)
-    (if (eql arglist :not-available)
-        (values :not-available nil)
-        (let ((provided-args (cdr form)))
-          (multiple-value-bind (last-arg last-provd-arg)
-              (last-arg arglist provided-args)
-            (cond
-              ;; Are we stuck in a nested arglist?
-              ((and (arglist-p last-arg) (listp last-provd-arg))
-               (let* ((path (arglist-path-to-nested-arglist arglist provided-args))
-                      (argl (apply #'arglist-ref arglist path))
-                      (args (apply #'provided-arguments-ref
-                                   provided-args arglist path)))
-                 (values argl args)))
-              ;; We aren't in a nested arglist, so we couldn't
-              ;; actually find any arglist for the form that the
-              ;; cursor is immediately contained in.
-              ((consp last-provd-arg)
-               (values :not-available nil))
-              (t
-               (values arglist provided-args))))))))
-
-(defun arglist-path-to-parameter (arglist provided-args)
-  "Returns a path to the arglist parameter that the last argument in
-PROVIDED-ARGS would take up on application."
-  (let* ((path (arglist-path-to-nested-arglist arglist provided-args))
-         (argl (apply #'arglist-ref arglist path))
-         (provided-arg (apply #'provided-arguments-ref provided-args arglist path)))
-    (nconc path (list (compute-arglist-index argl provided-arg)))))
-
-(defun arglist-path-to-nested-arglist (arglist provided-args)
-  "Returns a path to the (nested) arglist that still contains the last
-argument in PROVIDED-ARGS."
-  (multiple-value-bind (last-arg last-provd-arg idx)
-      (last-arg arglist provided-args)
-    (if (and (arglist-p last-arg) (listp last-provd-arg))
-        (cons idx (arglist-path-to-nested-arglist last-arg last-provd-arg))
-        nil)))
-
-(defun last-arg (arglist provided-args)
-  (let ((idx (compute-arglist-index arglist provided-args)))
-    (when idx
-      (values (arglist-ref arglist idx)
-              (provided-arguments-ref provided-args arglist idx)
-              idx))))
-
-(defun compute-arglist-index (arglist provided-args)
-  "Returns the index of ARGLIST pertaining to the last argument in
-PROVIDED-ARGUMENTS."
-  (let ((arg-index (1- (length provided-args)))
-        (positional-args# (positional-args-number arglist)))
+  "Returns the arglist of the subform _immediately_ containing
++CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may
+be in a nested arglist \(e.g. `(WITH-OPEN-FILE (<here>'\), and the
+arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be
+returned in that case."
+  (flet ((try (form-path form arglist)
+           (let* ((arglist-path (form-path-to-arglist-path form-path
+                                                           form
+                                                           arglist))
+                  (argl (apply #'arglist-ref
+                               arglist
+                               arglist-path))
+                  (args (apply #'provided-arguments-ref
+                               (cdr form)
+                               arglist
+                               arglist-path)))
+             (when (and (arglist-p argl) (listp args))
+               (values argl args)))))
+    (multiple-value-bind (form arglist obj form-path)
+        (find-subform-with-arglist form)
+      (declare (ignore obj))
+      (with-available-arglist (arglist) arglist
+        ;; First try the form the cursor is in (in case of a normal
+        ;; form), then try the surrounding form (in case of a nested
+        ;; macro form).
+        (multiple-value-or (try form-path form arglist)
+                           (try (butlast form-path) form arglist)
+                           :not-available)))))
+
+(defun form-path-to-arglist-path (form-path form arglist)
+  "Convert a form path to an arglist path consisting of arglist
+indices."
+  (labels ((convert (path args arglist)
+             (if (null path)
+                 nil
+                 (let* ((idx      (car path))
+                        (idx*     (arglist-index idx args arglist))
+                        (arglist* (arglist-ref arglist idx*))
+                        (args*    (provided-arguments-ref args arglist idx*)))
+                   ;; The FORM-PATH may be more detailed than ARGLIST;
+                   ;; consider (defun foo (x y) ...), a form path may
+                   ;; point into the function's lambda-list, but the
+                   ;; arglist of DEFUN won't contain as much information.
+                   (if (arglist-p arglist*)
+                       (cons idx* (convert (cdr path) args* arglist*))
+                       (list idx*))))))
+    (convert
+     ;; FORM contains irrelevant operator. Adjust FORM-PATH.
+     (cond ((null form-path) nil)
+           ((equal form-path '(0)) nil)
+           (t
+            (destructuring-bind (car . cdr) form-path
+              (cons (1- car) cdr))))
+     (cdr form)
+     arglist)))
+
+(defun arglist-index (provided-argument-index provided-arguments arglist)
+  "Return the arglist index into `arglist' for the parameter belonging
+to the argument (NTH `provided-argument-index' `provided-arguments')."
+  (let ((positional-args# (positional-args-number arglist))
+        (arg-index provided-argument-index))
     (cond
-      ((< arg-index 0) nil)
-      ((< arg-index positional-args#) arg-index)        ; required + optional
-      ((not (arglist.key-p arglist))  positional-args#) ; rest + body
-      (t                                                ; key
+      ((< arg-index positional-args#)        ; required + optional
+       arg-index)
+      ((not (arglist.key-p arglist))         ; rest + body
+       (assert (arglist.rest arglist))
+       positional-args#) 
+      (t                                     ; key
        ;; Find last provided &key parameter
-       (let ((provided-keys (subseq provided-args positional-args#)))
-         (loop for (key nil . rest) on provided-keys by #'cddr
-               when (null rest) 
-                 return (and (symbolp key) key)))))))
+       (let* ((argument      (nth arg-index provided-arguments))
+              (provided-keys (subseq provided-arguments positional-args#)))
+         (loop for (key value) on provided-keys by #'cddr
+               when (eq value argument) 
+                 return key))))))
 
 (defun arglist-ref (arglist &rest indices)
   "Returns the parameter in ARGLIST along the INDICIES path. Numbers
@@ -1380,10 +1412,12 @@
 (defun provided-arguments-ref (provided-args arglist &rest indices)
   "Returns the argument in PROVIDED-ARGUMENT along the INDICES path
 relative to ARGLIST."
+  (check-type arglist arglist)
   (flet ((ref (provided-args arglist index)
            (if (numberp index)
                (nth index provided-args)
-               (let ((provided-keys (subseq provided-args (positional-args-number arglist))))
+               (let ((provided-keys (subseq provided-args
+                                            (positional-args-number arglist))))
                  (loop for (key value) on provided-keys
                        when (eq key index)
                          return value)))))
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 12:48:31	1.320
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 19:01:37	1.321
@@ -1,5 +1,24 @@
 2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	Some cleanup of arglist code.
+
+	* swank-arglists.lisp (remove-from-tree-if): Deleted.
+	(remove-from-tree): Deleted.
+	(maybecall): Deleted.
+	(arglist-path-to-parameter): Deleted.
+	(arglist-path-to-nested-arglist): Deleted.
+	(last-arg): Deleted.
+	(compute-arglist-index): Deleted.
+
+	(form-path-to-arglist-path): New.
+	(arglist-index): New.
+	(extract-cursor-marker): New.
+	(find-subform-with-arglist): Adapted.
+	(find-immediately-containing-arglist): Adapted.
+	(arglist-for-echo-area): Adapted.
+
+2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-parse.el (slime-parse-form-until): Properly deal with #'
 	prefix.
 	(form-up-to-point.1 [test]): Extend.




From trittweiler at common-lisp.net  Tue Dec 29 19:29:31 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 29 Dec 2009 14:29:31 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NPhl5-0001LY-36@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv5176/contrib

Modified Files:
	swank-arglists.lisp slime-autodoc.el ChangeLog 
Log Message:
	More cleanup.

	The RP swank:arglist-for-echo-area is now called swank:autodoc.

	* swank-arglists.lisp (autodoc): Renamed from
	arglist-for-echo-area.
	(variable-desc-for-echo-area): Deleted. Above function subsumes
	this functionality now.
	(print-variable-to-string): Extracted from
	variable-desc-for-echo-area.

	* slime-autodoc.el (slime-retrieve-arglist): Change RPC.
	(slime-make-autodoc-rpc-form): Ditto.
	(slime-autodoc-cache-type): Deleted.
	(slime-autodoc-cache): Deleted.
	(slime-autodoc-last-buffer-form): Replacement.
	(slime-autodoc-last-autodoc): Replacement.
	(slime-get-cached-autodoc): Adapted accordingly.
	(slime-store-into-autodoc-cache): Adapted accordingly.
	(slime-compute-autodoc): Simplified slightly.
	(autodoc.1 [test]): Extended.


--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/29 19:01:37	1.51
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/29 19:29:30	1.52
@@ -1060,21 +1060,7 @@
        (setf (arglist.provided-args arglist) (list type-specifier))
        arglist))))
 
-
 ;;; Slimefuns
-  
-(defslimefun variable-desc-for-echo-area (variable-name)
-  "Return a short description of VARIABLE-NAME, or NIL."
-  (with-buffer-syntax ()
-    (let ((sym (parse-symbol variable-name)))
-      (if (and sym (boundp sym))
-          (let ((*print-pretty* t) (*print-level* 4)
-                (*print-length* 10) (*print-lines* 1)
-		(*print-readably* nil))
-	    (call/truncated-output-to-string
-	     75 (lambda (s)
-		  (format s "~A => ~S" sym (symbol-value sym)))))
-          :not-available))))
 
 ;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at
 ;;; user's point in Emacs. A RAW-FORM looks like
@@ -1097,7 +1083,7 @@
 ;;; %CURSOR-MARKER%)). Only the forms up to point should be
 ;;; considered.
 
-(defslimefun arglist-for-echo-area (raw-form &key print-right-margin print-lines)
+(defslimefun autodoc (raw-form &key print-right-margin print-lines)
   "Return a string representing the arglist for the deepest subform in
 RAW-FORM that does have an arglist. The highlighted parameter is
 wrapped in ===> X <===."
@@ -1106,19 +1092,35 @@
                       (unless (debug-on-swank-error)
                         (let ((*print-right-margin* print-right-margin)
                               (*print-lines* print-lines))
-                          (return-from arglist-for-echo-area
+                          (return-from autodoc
                             (format nil "Arglist Error: \"~A\"" c)))))))
       (with-buffer-syntax ()
         (multiple-value-bind (form arglist obj-at-cursor form-path)
             (find-subform-with-arglist (parse-raw-form raw-form))
-          (declare (ignore obj-at-cursor))
-          (with-available-arglist (arglist) arglist
-            (decoded-arglist-to-string
-             arglist
-             :print-right-margin print-right-margin
-             :print-lines print-lines
-             :operator (car form)
-             :highlight (form-path-to-arglist-path form-path form arglist)))))))
+          (cond ((and obj-at-cursor
+                      (symbolp obj-at-cursor)
+                      (boundp obj-at-cursor))
+                 (print-variable-to-string obj-at-cursor))
+                (t
+                 (with-available-arglist (arglist) arglist
+                   (decoded-arglist-to-string
+                    arglist
+                    :print-right-margin print-right-margin
+                    :print-lines print-lines
+                    :operator (car form)
+                    :highlight (form-path-to-arglist-path form-path
+                                                          form
+                                                          arglist)))))))))
+
+(defun print-variable-to-string (symbol)
+  "Return a short description of VARIABLE-NAME, or NIL."
+  (let ((*print-pretty* t) (*print-level* 4)
+        (*print-length* 10) (*print-lines* 1)
+        (*print-readably* nil))
+    (call/truncated-output-to-string
+     75 (lambda (s)
+          (format s "~A => ~S" symbol (symbol-value symbol))))))
+
 
 (defslimefun complete-form (raw-form)
   "Read FORM-STRING in the current buffer package, then complete it
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/12/23 08:34:17	1.26
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/12/29 19:29:31	1.27
@@ -21,7 +21,6 @@
 	  "slime-autodoc doesn't work with XEmacs"))
 
 (require 'slime-parse)
-(require 'slime-enclosing-context)
 
 (defcustom slime-use-autodoc-mode t
   "When non-nil always enable slime-autodoc-mode in slime-mode.")
@@ -54,25 +53,21 @@
   (let ((name (etypecase name
                  (string name)
                  (symbol (symbol-name name)))))
-    (slime-eval `(swank:arglist-for-echo-area '(,name ,slime-cursor-marker)))))
+    (slime-eval `(swank:autodoc '(,name ,slime-cursor-marker)))))
 
 
 ;;;; Autodocs (automatic context-sensitive help)
 
 (defun slime-make-autodoc-rpc-form ()
   "Return a cache key and a swank form."
-  (let ((global (slime-autodoc-global-at-point)))
-    (if global
-        (values (slime-qualify-cl-symbol-name global)
-                `(swank:variable-desc-for-echo-area ,global))
-        (let* ((levels slime-autodoc-accuracy-depth)
-               (buffer-form (slime-parse-form-upto-point levels)))
-          (values buffer-form
-                  (multiple-value-bind (width height)
-                      (slime-autodoc-message-dimensions)
-                    `(swank:arglist-for-echo-area ',buffer-form
-                                                  :print-right-margin ,width
-                                                  :print-lines ,height)))))))
+  (let* ((levels slime-autodoc-accuracy-depth)
+         (buffer-form (slime-parse-form-upto-point levels)))
+    (values buffer-form
+            (multiple-value-bind (width height)
+                (slime-autodoc-message-dimensions)
+              `(swank:autodoc ',buffer-form
+                              :print-right-margin ,width
+                              :print-lines ,height)))))
 
 (defun slime-autodoc-global-at-point ()
   "Return the global variable name at point, if any."
@@ -112,41 +107,19 @@
 
 ;;;; Autodoc cache
 
-(defvar slime-autodoc-cache-type 'last
-  "*Cache policy for automatically fetched documentation.
-Possible values are:
- nil  - none.
- last - cache only the most recently-looked-at symbol's documentation.
-        The values are stored in the variable `slime-autodoc-cache'.
-
-More caching means fewer calls to the Lisp process, but at the risk of
-using outdated information.")
-
-(defvar slime-autodoc-cache nil
-  "Cache variable for when `slime-autodoc-cache-type' is 'last'.
-The value is (SYMBOL-NAME . DOCUMENTATION).")
-
-(defun slime-get-cached-autodoc (symbol-name)
-  "Return the cached autodoc documentation for SYMBOL-NAME, or nil."
-  (ecase slime-autodoc-cache-type
-    ((nil) nil)
-    ((last)
-     (when (equal (car slime-autodoc-cache) symbol-name)
-       (cdr slime-autodoc-cache)))
-    ((all)
-     (when-let (symbol (intern-soft symbol-name))
-       (get symbol 'slime-autodoc-cache)))))
+(defvar slime-autodoc-last-buffer-form nil)
+(defvar slime-autodoc-last-autodoc nil)
 
-(defun slime-store-into-autodoc-cache (symbol-name documentation)
+(defun slime-get-cached-autodoc (buffer-form)
+  "Return the cached autodoc documentation for `buffer-form', or nil."
+  (when (equal buffer-form slime-autodoc-last-buffer-form)
+    slime-autodoc-last-autodoc))
+
+(defun slime-store-into-autodoc-cache (buffer-form autodoc)
   "Update the autodoc cache for SYMBOL with DOCUMENTATION.
 Return DOCUMENTATION."
-  (ecase slime-autodoc-cache-type
-    ((nil) nil)
-    ((last)
-     (setq slime-autodoc-cache (cons symbol-name documentation)))
-    ((all)
-     (put (intern symbol-name) 'slime-autodoc-cache documentation)))
-  documentation)
+  (setq slime-autodoc-last-buffer-form buffer-form)
+  (setq slime-autodoc-last-autodoc autodoc))
 
 
 ;;;; Formatting autodoc
@@ -190,23 +163,22 @@
     ;; data.
     (save-match-data
       (unless (slime-inside-string-or-comment-p)
-        (multiple-value-bind (cache-key retrieve-form) (slime-make-autodoc-rpc-form)
+        (multiple-value-bind (cache-key retrieve-form) 
+            (slime-make-autodoc-rpc-form)
           (let ((cached (slime-get-cached-autodoc cache-key)))
             (if cached
                 cached
                 ;; If nothing is in the cache, we first decline, and fetch
                 ;; the arglist information asynchronously.
-                (prog1 nil
-                  (slime-eval-async retrieve-form
-                    (lexical-let ((cache-key cache-key)) 
-                      (lambda (doc)
-                        (let ((doc (if (eq doc :not-available)
-                                       ""
-                                       (slime-format-autodoc doc))))
-                          ;; Now that we've got our information, get it to
-                          ;; the user ASAP.
-                          (eldoc-message doc)
-                          (slime-store-into-autodoc-cache cache-key doc)))))))))))))
+                (slime-eval-async retrieve-form
+                  (lexical-let ((cache-key cache-key))
+                    (lambda (doc)
+                      (unless (eq doc :not-available) 
+                        (setq doc (slime-format-autodoc doc))
+                        ;; Now that we've got our information,
+                        ;; get it to the user ASAP.
+                        (eldoc-message doc)
+                        (slime-store-into-autodoc-cache cache-key doc))))))))))))
 
 (make-variable-buffer-local (defvar slime-autodoc-mode nil))
 
@@ -269,13 +241,21 @@
                      'equal))
 
 (def-slime-test autodoc.1
-    (buffer-sexpr wished-arglist)
+    (buffer-sexpr wished-arglist &optional skip-trailing-test-p)
     ""
     '(("(swank::emacs-connected*HERE*"    "(emacs-connected)")
       ("(swank::create-socket*HERE*"      "(create-socket host port)")
       ("(swank::create-socket *HERE*"     "(create-socket ===> host <=== port)")
       ("(swank::create-socket foo *HERE*" "(create-socket host ===> port <===)")
 
+      ("#'(lambda () (swank::create-socket*HERE*" "(create-socket host port)")
+      ("`(lambda () ,(swank::create-socket*HERE*" "(create-socket host port)")
+
+      ("(remove-if #'(lambda () (swank::create-socket*HERE*"
+       "(create-socket host port)")
+      ("`(remove-if #'(lambda () ,@(swank::create-socket*HERE*"
+       "(create-socket host port)")
+
       ("(swank::symbol-status foo *HERE*" 
        "(symbol-status symbol &optional ===> (package (symbol-package symbol)) <===)")
 
@@ -291,7 +271,16 @@
        "(apply 'eval-for-emacs &optional form ===> buffer-package <=== id &rest args)")
 
       ("(apply #'swank::eval-for-emacs foo *HERE*"
-       "(apply #'eval-for-emacs &optional form ===> buffer-package <=== id &rest args)"))
+       "(apply #'eval-for-emacs &optional form ===> buffer-package <=== id &rest args)")
+
+      ("(swank::with-retry-restart (:msg *HERE*"
+       "(with-retry-restart (&key ===> (msg \"Retry.\") <===) &body body)")
+      ("(swank::start-server \"/tmp/foo\" :coding-system *HERE*"
+       "(start-server port-file &key (style swank:*communication-style*) (dont-close swank:*dont-close*) ===> (coding-system swank::*coding-system*) <===)")
+
+      ("(swank::with-struct *HERE*(foo. x y) *struct* body1)"
+       "(with-struct (conc-name &rest names) obj &body body)"
+       t))
   (slime-check-top-level)
   (with-temp-buffer
     (setq slime-buffer-package "COMMON-LISP-USER")
@@ -300,8 +289,9 @@
     (search-backward "*HERE*")
     (delete-region (match-beginning 0) (match-end 0))
     (slime-check-autodoc-at-point wished-arglist)
-    (insert ")") (backward-char)
-    (slime-check-autodoc-at-point wished-arglist)
+    (unless skip-trailing-test-p
+      (insert ")") (backward-char)
+      (slime-check-autodoc-at-point wished-arglist))
     ))
 
 (provide 'slime-autodoc)
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 19:01:37	1.321
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 19:29:31	1.322
@@ -1,5 +1,29 @@
 2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	More cleanup.
+
+	The RP swank:arglist-for-echo-area is now called swank:autodoc.
+
+	* swank-arglists.lisp (autodoc): Renamed from
+	arglist-for-echo-area.
+	(variable-desc-for-echo-area): Deleted. Above function subsumes
+	this functionality now.
+	(print-variable-to-string): Extracted from
+	variable-desc-for-echo-area.
+
+	* slime-autodoc.el (slime-retrieve-arglist): Change RPC.
+	(slime-make-autodoc-rpc-form): Ditto.
+	(slime-autodoc-cache-type): Deleted.
+	(slime-autodoc-cache): Deleted.
+	(slime-autodoc-last-buffer-form): Replacement.
+	(slime-autodoc-last-autodoc): Replacement.
+	(slime-get-cached-autodoc): Adapted accordingly.
+	(slime-store-into-autodoc-cache): Adapted accordingly.
+	(slime-compute-autodoc): Simplified slightly.
+	(autodoc.1 [test]): Extended.
+
+2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Some cleanup of arglist code.
 
 	* swank-arglists.lisp (remove-from-tree-if): Deleted.




From trittweiler at common-lisp.net  Tue Dec 29 19:41:05 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 29 Dec 2009 14:41:05 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NPhwH-0002c8-Ib@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv10049/contrib

Modified Files:
	slime-autodoc.el ChangeLog 
Log Message:
	* slime-autodoc.el (slime-compute-autodoc): Revert last change.
	We must return nil to decline.


--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/12/29 19:29:31	1.27
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/12/29 19:41:05	1.28
@@ -168,17 +168,19 @@
           (let ((cached (slime-get-cached-autodoc cache-key)))
             (if cached
                 cached
-                ;; If nothing is in the cache, we first decline, and fetch
-                ;; the arglist information asynchronously.
-                (slime-eval-async retrieve-form
-                  (lexical-let ((cache-key cache-key))
-                    (lambda (doc)
-                      (unless (eq doc :not-available) 
-                        (setq doc (slime-format-autodoc doc))
-                        ;; Now that we've got our information,
-                        ;; get it to the user ASAP.
-                        (eldoc-message doc)
-                        (slime-store-into-autodoc-cache cache-key doc))))))))))))
+                ;; If nothing is in the cache, we first decline (by
+                ;; returning nil), and fetch the arglist information
+                ;; asynchronously.
+                (prog1 nil
+                  (slime-eval-async retrieve-form
+                    (lexical-let ((cache-key cache-key))
+                      (lambda (doc)
+                        (unless (eq doc :not-available) 
+                          (setq doc (slime-format-autodoc doc))
+                          ;; Now that we've got our information,
+                          ;; get it to the user ASAP.
+                          (eldoc-message doc)
+                          (slime-store-into-autodoc-cache cache-key doc)))))))))))))
 
 (make-variable-buffer-local (defvar slime-autodoc-mode nil))
 
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 19:29:31	1.322
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 19:41:05	1.323
@@ -1,5 +1,10 @@
 2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-autodoc.el (slime-compute-autodoc): Revert last change.
+	We must return nil to decline.
+
+2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	More cleanup.
 
 	The RP swank:arglist-for-echo-area is now called swank:autodoc.




From trittweiler at common-lisp.net  Wed Dec 30 10:25:04 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 30 Dec 2009 05:25:04 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NPvjk-00037v-O1@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv12018/contrib

Modified Files:
	swank-arglists.lisp ChangeLog 
Log Message:
	* swank-arglists.lisp (extract-cursor-marker): Fix typo.
	(autodoc): Do not try to display variable content for T and NIL.
	(interesting-variable-p): New helper.


--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/29 19:29:30	1.52
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/12/30 10:25:04	1.53
@@ -68,6 +68,11 @@
        (fboundp form)
        t))
 
+(defun interesting-variable-p (symbol)
+  (and symbol
+       (symbolp symbol)
+       (boundp symbol)
+       (not (memq symbol '(cl:t cl:nil)))))
 
 (defmacro multiple-value-or (&rest forms)
   (if (null forms)
@@ -1097,9 +1102,7 @@
       (with-buffer-syntax ()
         (multiple-value-bind (form arglist obj-at-cursor form-path)
             (find-subform-with-arglist (parse-raw-form raw-form))
-          (cond ((and obj-at-cursor
-                      (symbolp obj-at-cursor)
-                      (boundp obj-at-cursor))
+          (cond ((interesting-variable-p obj-at-cursor)
                  (print-variable-to-string obj-at-cursor))
                 (t
                  (with-available-arglist (arglist) arglist
@@ -1254,7 +1257,7 @@
                            (t
                             (multiple-value-bind (new-car new-last new-path)
                                 (grovel car last (cons 0 path))
-                              (when path
+                              (when new-path
                                 (return-from grovel
                                   (values (nreconc
                                            (cons new-car result-form) cdr)
@@ -1264,7 +1267,8 @@
                             (setq last car)
                             (incf (first path))))
                      finally
-                       (return (values (nreverse result-form) nil))))))
+                       (return-from grovel
+                         (values (nreverse result-form) nil nil))))))
     (grovel form nil (list 0))))
 
 (defgeneric extract-local-op-arglists (operator args)
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/29 19:41:05	1.323
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/30 10:25:04	1.324
@@ -1,3 +1,9 @@
+2009-12-30  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-arglists.lisp (extract-cursor-marker): Fix typo.
+	(autodoc): Do not try to display variable content for T and NIL.
+	(interesting-variable-p): New helper.
+
 2009-12-29  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-autodoc.el (slime-compute-autodoc): Revert last change.




From trittweiler at common-lisp.net  Wed Dec 30 10:30:14 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 30 Dec 2009 05:30:14 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NPvok-0003TU-69@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv13353/contrib

Modified Files:
	slime-c-p-c.el ChangeLog 
Log Message:
	* slime-c-p-c.el (complete-form [test]): Set
	`slime-buffer-package' after changing to lisp-mode because
	changing major-mode kills buffer-local variables.


--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/25 11:04:00	1.19
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/30 10:30:13	1.20
@@ -222,8 +222,8 @@
        "(with-struct (foo. bar baz names...)" t))
   (slime-check-top-level)
   (with-temp-buffer
-    (setq slime-buffer-package "SWANK")
     (lisp-mode)
+    (setq slime-buffer-package "SWANK")
     (insert buffer-sexpr)
     (search-backward "*HERE*")
     (delete-region (match-beginning 0) (match-end 0))
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/30 10:25:04	1.324
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/12/30 10:30:13	1.325
@@ -1,5 +1,11 @@
 2009-12-30  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-c-p-c.el (complete-form [test]): Set
+	`slime-buffer-package' after changing to lisp-mode because
+	changing major-mode kills buffer-local variables.
+
+2009-12-30  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank-arglists.lisp (extract-cursor-marker): Fix typo.
 	(autodoc): Do not try to display variable content for T and NIL.
 	(interesting-variable-p): New helper.