[slime-cvs] CVS slime/contrib

[CVS User sboukarev]

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

Modified Files:
	ChangeLog slime-autodoc.el swank-arglists.lisp 
Log Message:
* swank-arglists.lisp (arglist-dispatch): Handle method qualifiers.
(print-arg): Renamed from princ-arg.
(prin1-arg): Removed.
* slime-autodoc.el (autodoc.1): Add test-case for method qualifiers.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/30 02:07:10	1.361
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/04/03 10:33:53	1.362
@@ -1,3 +1,10 @@
+2010-04-03  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-arglists.lisp (arglist-dispatch): Handle method qualifiers.
+	(print-arg): Renamed from princ-arg.
+	(prin1-arg): Removed.
+	* slime-autodoc.el (autodoc.1): Add test-case for method qualifiers
+
 2010-03-30  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-arglists.lisp (*arglist-show-packages*): New
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/03/23 20:24:16	1.38
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/04/03 10:33:53	1.39
@@ -289,6 +289,8 @@
       ;; Test context-sensitive autodoc (DEFMETHOD)
       ("(defmethod swank::arglist-dispatch (*HERE*"
        "(defmethod arglist-dispatch (===> operator <=== arguments) &body body)")
+      ("(defmethod swank::arglist-dispatch :before (*HERE*"
+       "(defmethod arglist-dispatch :before (===> operator <=== arguments) &body body)")
 
       ;; Test context-sensitive autodoc (APPLY)
       ("(apply 'swank::eval-for-emacs*HERE*"
@@ -302,9 +304,9 @@
 
       ;; Test context-sensitive autodoc (ERROR, CERROR)
       ("(error 'simple-condition*HERE*"
-       "(error 'simple-condition &rest arguments &key format-arguments format-control)")
+       "(error 'simple-condition &rest arguments &key :format-arguments :format-control)")
       ("(cerror \"Foo\" 'simple-condition*HERE*"
-       "(cerror \"Foo\" 'simple-condition &rest arguments &key format-arguments format-control)")
+       "(cerror \"Foo\" 'simple-condition &rest arguments &key :format-arguments :format-control)")
       
       ;; Test &KEY and nested arglists
       ("(swank::with-retry-restart (:msg *HERE*"
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/30 02:07:10	1.61
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/04/03 10:33:53	1.62
@@ -251,19 +251,19 @@
     (let ((index 0))
       (pprint-logical-block (nil nil :prefix "(" :suffix ")")
         (when operator
-          (princ-arg operator)
+          (print-arg operator)
           (pprint-indent :current 1))   ; 1 due to possibly added space
         (do-decoded-arglist (remove-given-args arglist provided-args)
           (&provided (arg)
              (space)
-             (princ-arg arg)
+             (print-arg arg)
              (incf index))
           (&required (arg)
              (space)
              (if (arglist-p arg)
                  (print-arglist-recursively arg :index index)
                  (with-highlighting (:index index)
-                   (princ-arg arg)))
+                   (print-arg arg)))
              (incf index))
           (&optional :initially
              (when (arglist.optional-args arglist)
@@ -275,7 +275,7 @@
                  (print-arglist-recursively arg :index index)
                  (with-highlighting (:index index)
                    (if (null init-value)
-                       (princ-arg arg)
+                       (print-arg arg)
                        (format t "~:@<~A ~S~@:>" arg init-value))))
              (incf index))
           (&key :initially
@@ -296,7 +296,7 @@
                          ((not (keywordp keyword))
                           (format t "~:@<(~S ..)~@:>" keyword))
                          (t
-                          (princ-arg keyword))))))
+                          (print-arg keyword))))))
           (&key :finally
              (when (arglist.allow-other-keys-p arglist)
                (space)
@@ -315,20 +315,17 @@
              (if (arglist-p args)
                  (print-arglist-recursively args :index index)
                  (with-highlighting (:index index)
-                   (princ-arg args))))
+                   (print-arg args))))
           ;; FIXME: add &UNKNOWN-JUNK?
           )))))
 
-
-(defun princ-arg (arg)
-  (princ (if (arglist-dummy-p arg)
-             (arglist-dummy.string-representation arg)
-             arg)))
-
-(defun prin1-arg (arg)
-  (if (arglist-dummy-p arg)
-      (princ (arglist-dummy.string-representation arg))
-      (prin1 arg)))
+(defun print-arg (arg)
+  (let ((arg (if (arglist-dummy-p arg)
+                 (arglist-dummy.string-representation arg)
+                 arg)))
+    (if (keywordp arg)
+        (prin1 arg)
+        (princ arg))))
 
 (defun print-decoded-arglist-as-template (decoded-arglist &key
                                           (prefix "(") (suffix ")"))
@@ -986,14 +983,17 @@
 
 (defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments)
   (match (cons operator arguments)
-    (('defmethod (#'valid-function-name-p gf-name) . _)
+    (('defmethod (#'valid-function-name-p gf-name) . rest)
      (let ((gf (fdefinition gf-name)))
        (when (typep gf 'generic-function)
          (with-available-arglist (arglist) (decode-arglist (arglist gf))
-           (return-from arglist-dispatch
-             (make-arglist :provided-args (list gf-name)
-                           :required-args (list arglist)
-                           :rest "body" :body-p t))))))
+           (let ((qualifiers (loop for x in rest
+                                   until (or (listp x) (empty-arg-p x))
+                                   collect x)))
+             (return-from arglist-dispatch
+               (make-arglist :provided-args (cons gf-name qualifiers)
+                             :required-args (list arglist)
+                             :rest "body" :body-p t)))))))
     (_)) ; Fall through
   (call-next-method))