From sboukarev at common-lisp.net  Sat Aug  4 22:35:13 2012
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 04 Aug 2012 15:35:13 -0700
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1SxmwD-0005qP-K3@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory tiger.common-lisp.net:/tmp/cvs-serv22438/contrib

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
* swank-arglists.lisp (test-print-arglist): bind
*print-right-margin* to 1000 instead of NIL, because the default
value on ABCL is less than the length of the tested arglist.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2012/05/23 20:55:43	1.548
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2012/08/04 22:35:13	1.549
@@ -1,3 +1,9 @@
+2012-08-04  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-arglists.lisp (test-print-arglist): bind
+	*print-right-margin* to 1000 instead of NIL, because the default
+	value on ABCL is less than the length of the tested arglist.
+
 2012-05-23  Christophe Rhodes  <csr21 at cantab.net>
 
 	* swank-media.lisp: add provide.
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2012/03/19 14:27:04	1.73
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2012/08/04 22:35:13	1.74
@@ -118,7 +118,7 @@
 ;;;
 ;;;     For example, a) let us describe the situations of EVAL-WHEN as
 ;;;
-;;;       (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body)
+;;;     (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body)
 ;;;
 ;;;     and b) let us describe the optimization qualifiers that are valid
 ;;;     in the declaration specifier `OPTIMIZE':
@@ -152,14 +152,16 @@
 	     (loop for clause in clauses
 		   for lambda-list-keyword = (first clause)
 		   for clause-parameter    = (second clause)
-		   doing (cond ((eq clause-parameter :initially)
-				(setf (gethash lambda-list-keyword initial) clause))
-			       ((eq clause-parameter :finally)
-				(setf (gethash lambda-list-keyword final) clause))
-			       (t
-				(setf (gethash lambda-list-keyword main) clause)))
+		   do
+                   (case clause-parameter
+                     (:initially
+                      (setf (gethash lambda-list-keyword initial) clause))
+                     (:finally
+                      (setf (gethash lambda-list-keyword final) clause))
+                     (t
+                      (setf (gethash lambda-list-keyword main) clause)))
 		   finally
-		(return (values initial main final)))))
+                   (return (values initial main final)))))
 	 (generate-main-clause (clause arglist)
 	   (destructure-case clause
              ((&provided (&optional arg) . body)
@@ -178,16 +180,21 @@
 	      (let ((optarg (gensym "OPTIONAL-ARG+")))
 		`(dolist (,optarg (arglist.optional-args ,arglist))
 		   (declare (ignorable ,optarg))
-		   (let (,@(when arg  `((,arg (optional-arg.arg-name ,optarg))))
-			 ,@(when init `((,init (optional-arg.default-arg ,optarg)))))
+		   (let (,@(when arg
+                             `((,arg (optional-arg.arg-name ,optarg))))
+			 ,@(when init
+                             `((,init (optional-arg.default-arg ,optarg)))))
 		     , at body))))
 	     ((&key (&optional keyword arg init) . body)
 	      (let ((keyarg (gensym "KEY-ARG+")))
 		`(dolist (,keyarg (arglist.keyword-args ,arglist))
 		   (declare (ignorable ,keyarg))
-		   (let (,@(when keyword `((,keyword (keyword-arg.keyword ,keyarg))))
-			 ,@(when arg     `((,arg (keyword-arg.arg-name ,keyarg))))
-			 ,@(when init    `((,init (keyword-arg.default-arg ,keyarg)))))
+		   (let (,@(when keyword
+                             `((,keyword (keyword-arg.keyword ,keyarg))))
+			 ,@(when arg
+                             `((,arg (keyword-arg.arg-name ,keyarg))))
+			 ,@(when init
+                             `((,init (keyword-arg.default-arg ,keyarg)))))
 		     , at body))))
 	     ((&rest (&optional arg body-p) . body)
 	      `(when (arglist.rest ,arglist)
@@ -205,10 +212,12 @@
 	  (parse-clauses clauses)
 	`(let ((,arglist ,decoded-arglist))
 	   (block do-decoded-arglist
-	     ,@(loop for keyword in '(&provided &required &optional &rest &key &any)
+	     ,@(loop for keyword in '(&provided &required
+                                      &optional &rest &key &any)
 		     append (cddr (gethash keyword initially-clauses))
 		     collect (let ((clause (gethash keyword main-clauses)))
-			       (when clause (generate-main-clause clause arglist)))
+			       (when clause
+                                 (generate-main-clause clause arglist)))
 		     append (cddr (gethash keyword finally-clauses)))))))))
 
 ;;;; Arglist Printing
@@ -327,12 +336,13 @@
                (symbol        (if (keywordp arg) (prin1 arg) (princ arg)))
                (string        (princ arg))
                (list          (princ arg))
-               (arglist-dummy (princ (arglist-dummy.string-representation arg)))
+               (arglist-dummy (princ
+                               (arglist-dummy.string-representation arg)))
                (arglist       (print-decoded-arglist-as-template arg)))
              (pprint-newline :fill)))
       (pprint-logical-block (nil nil :prefix prefix :suffix suffix)
         (do-decoded-arglist decoded-arglist
-          (&provided ())  ; do nothing; provided args are in the buffer already.
+          (&provided ()) ; do nothing; provided args are in the buffer already.
           (&required (arg)
             (space) (print-arg-or-pattern arg))
           (&optional (arg)
@@ -427,7 +437,8 @@
                              (decode-required-arg (cadar arg))
                              (cadr arg)))
           ((consp arg)
-           (make-keyword-arg (intern-as-keyword (car arg)) (car arg) (cadr arg)))
+           (make-keyword-arg (intern-as-keyword (car arg))
+                             (car arg) (cadr arg)))
           (t
            (error "Bad keyword item of formal argument list")))))
 
@@ -575,13 +586,16 @@
     finally (return result)))
 
 (defun encode-arglist (decoded-arglist)
-  (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
+  (append (mapcar #'encode-required-arg
+                  (arglist.required-args decoded-arglist))
           (when (arglist.optional-args decoded-arglist)
             '(&optional))
-          (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
+          (mapcar #'encode-optional-arg
+                  (arglist.optional-args decoded-arglist))
           (when (arglist.key-p decoded-arglist)
             '(&key))
-          (mapcar #'encode-keyword-arg (arglist.keyword-args decoded-arglist))
+          (mapcar #'encode-keyword-arg
+                  (arglist.keyword-args decoded-arglist))
           (when (arglist.allow-other-keys-p decoded-arglist)
             '(&allow-other-keys))
           (when (arglist.any-args decoded-arglist)
@@ -751,12 +765,14 @@
                #'allocate-instance (list class))
             (multiple-value-bind (initialize-instance-keywords ii-aokp)
                 (ignore-errors
-                  (applicable-methods-keywords
-                   #'initialize-instance (list (swank-mop:class-prototype class))))
+                 (applicable-methods-keywords
+                  #'initialize-instance
+                  (list (swank-mop:class-prototype class))))
               (multiple-value-bind (shared-initialize-keywords si-aokp)
                   (ignore-errors
-                    (applicable-methods-keywords
-                     #'shared-initialize (list (swank-mop:class-prototype class) t)))
+                   (applicable-methods-keywords
+                    #'shared-initialize
+                    (list (swank-mop:class-prototype class) t)))
                 (values (append slot-init-keywords
                                 allocate-instance-keywords
                                 initialize-instance-keywords
@@ -776,7 +792,8 @@
           (multiple-value-bind (shared-initialize-keywords si-aokp)
               (ignore-errors
                 (applicable-methods-keywords
-                 #'shared-initialize (list (swank-mop:class-prototype class) t)))
+                 #'shared-initialize
+                 (list (swank-mop:class-prototype class) t)))
             ;; FIXME: much as it would be nice to include the
             ;; applicable keywords from
             ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see
@@ -831,7 +848,8 @@
                 (cons (car args) determiners))
         (call-next-method))))
 
-(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords allow-other-keys-p)
+(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords
+                                             allow-other-keys-p)
   "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P."
   (when keywords
     (setf (arglist.key-p decoded-arglist) t)
@@ -872,8 +890,8 @@
                                                 (cons operator-form
                                                       argument-forms))))
 
-(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'with-open-file))
-                                             argument-forms)
+(defmethod compute-enriched-decoded-arglist
+    ((operator-form (eql 'with-open-file)) argument-forms)
   (declare (ignore argument-forms))
   (multiple-value-bind (decoded-arglist determining-args)
       (call-next-method)
@@ -898,24 +916,25 @@
                  (compute-enriched-decoded-arglist function-name
                                                    (cdr argument-forms))))
             (return-from compute-enriched-decoded-arglist
-              (values (make-arglist :required-args
-                                    (list 'function)
-                                    :optional-args
-                                    (append
-                                     (mapcar #'(lambda (arg)
-                                                 (make-optional-arg arg nil))
-                                             (arglist.required-args function-arglist))
-                                     (arglist.optional-args function-arglist))
-                                    :key-p
-                                    (arglist.key-p function-arglist)
-                                    :keyword-args
-                                    (arglist.keyword-args function-arglist)
-                                    :rest
-                                    'args
-                                    :allow-other-keys-p
-                                    (arglist.allow-other-keys-p function-arglist))
-                      (list function-name-form)
-                      t)))))))
+              (values
+               (make-arglist :required-args
+                             (list 'function)
+                             :optional-args
+                             (append
+                              (mapcar #'(lambda (arg)
+                                          (make-optional-arg arg nil))
+                                      (arglist.required-args function-arglist))
+                              (arglist.optional-args function-arglist))
+                             :key-p
+                             (arglist.key-p function-arglist)
+                             :keyword-args
+                             (arglist.keyword-args function-arglist)
+                             :rest
+                             'args
+                             :allow-other-keys-p
+                             (arglist.allow-other-keys-p function-arglist))
+               (list function-name-form)
+               t)))))))
   (call-next-method))
 
 (defmethod compute-enriched-decoded-arglist
@@ -1423,10 +1442,12 @@
 represent key parameters."
   (flet ((ref-positional-arg (arglist index)
            (check-type index (integer 0 *))
-           (with-struct (arglist. provided-args required-args optional-args rest) 
+           (with-struct (arglist. provided-args required-args
+                                  optional-args rest) 
                arglist
              (loop for args in (list provided-args required-args 
-                                     (mapcar #'optional-arg.arg-name optional-args))
+                                     (mapcar #'optional-arg.arg-name
+                                             optional-args))
                    for args# = (length args)
                    if (< index args#)
                      return (nth index args)
@@ -1529,7 +1550,9 @@
 (defun test-print-arglist ()
   (flet ((test (arglist string)
            (let* ((*package* (find-package :swank))
-                  (actual  (decoded-arglist-to-string (decode-arglist arglist))))
+                  (actual (decoded-arglist-to-string
+                           (decode-arglist arglist)
+                           :print-right-margin 1000)))
              (unless (string= actual string)
                (warn "Test failed: ~S => ~S~%  Expected: ~S"
                      arglist actual string)))))
@@ -1540,11 +1563,11 @@
     (test '(x &aux y z) "(x)")
     (test '(x &environment env y) "(x y)")
     (test '(&key ((function f))) "(&key ((function ..)))")
-    (test '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)
-	  "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)")
+    (test
+     '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)
+     "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)")
     (test '(declare (optimize &any (speed 1) (safety 1)))
-	  "(declare (optimize &any (speed 1) (safety 1)))")
-    ))
+	  "(declare (optimize &any (speed 1) (safety 1)))")))
 
 (defun test-arglist-ref ()
   (macrolet ((soft-assert (form)
@@ -1555,9 +1578,12 @@
       (soft-assert (eq (arglist-ref sample :k 0) 'y))
       (soft-assert (eq (arglist-ref sample :k 1) 'z))
 
-      (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0)    'a))
-      (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0) 'b))
-      (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1) 'c)))))
+      (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0)
+                       'a))
+      (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0)
+                       'b))
+      (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1)
+                       'c)))))
 
 (test-print-arglist)
 (test-arglist-ref)




From sboukarev at common-lisp.net  Sat Aug  4 23:32:37 2012
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 04 Aug 2012 16:32:37 -0700
Subject: [slime-cvs] CVS slime
Message-ID: <E1Sxnpl-0006JX-Ql@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv24228

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (call-with-debugging-environment): Use
sb-debug::resolve-stack-top-hint instead of just
sb-debug:*stack-top-hint*, because now it can contain things other
than just frames.


--- /project/slime/cvsroot/slime/ChangeLog	2012/07/13 13:52:45	1.2345
+++ /project/slime/cvsroot/slime/ChangeLog	2012/08/04 23:32:37	1.2346
@@ -1,3 +1,10 @@
+2012-08-04  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-sbcl.lisp (call-with-debugging-environment): Use
+	sb-debug::resolve-stack-top-hint instead of just
+	sb-debug:*stack-top-hint*, because now it can contain things other
+	than just frames.
+
 2012-07-13  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el: Don't compile functions that are now in other files.
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/05/12 06:34:47	1.322
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/08/04 23:32:37	1.323
@@ -1069,16 +1069,19 @@
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
-  (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))
+  (let ((*sldb-stack-top*
+          (if (and (not *debug-swank-backend*)
+                   sb-debug:*stack-top-hint*)
+              #+#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
+              (sb-debug::resolve-stack-top-hint)
+              #-#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
+              sb-debug:*stack-top-hint*
+              (sb-di:top-frame)))
+        (sb-debug:*stack-top-hint* nil))
     (handler-bind ((sb-di:debug-condition
-		    (lambda (condition)
-                      (signal (make-condition
-                               'sldb-condition
-                               :original-condition condition)))))
+                     (lambda (condition)
+                       (signal 'sldb-condition
+                               :original-condition condition))))
       (funcall debugger-loop-fn))))
 
 #+#.(swank-backend::sbcl-with-new-stepper-p)




From sboukarev at common-lisp.net  Sat Aug  4 23:48:19 2012
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 04 Aug 2012 16:48:19 -0700
Subject: [slime-cvs] CVS slime
Message-ID: <E1Sxo4x-0000SW-QV@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv1503

Modified Files:
	ChangeLog swank-abcl.lisp swank-allegro.lisp swank-ccl.lisp 
	swank-clisp.lisp swank-cmucl.lisp swank-corman.lisp 
	swank-ecl.lisp swank-rpc.lisp swank-sbcl.lisp swank-scl.lisp 
	swank.lisp 
Log Message:
* clean up: (signal (make-condition ...)) => (signal ...)


--- /project/slime/cvsroot/slime/ChangeLog	2012/08/04 23:32:37	1.2346
+++ /project/slime/cvsroot/slime/ChangeLog	2012/08/04 23:48:19	1.2347
@@ -4,6 +4,7 @@
 	sb-debug::resolve-stack-top-hint instead of just
 	sb-debug:*stack-top-hint*, because now it can contain things other
 	than just frames.
+	* clean up: (signal (make-condition ...)) => (signal ...)
 
 2012-07-13  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2012/04/07 10:23:38	1.91
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2012/08/04 23:48:19	1.92
@@ -414,24 +414,23 @@
     ;; filter condition signaled more than once.
     (unless (member condition *abcl-signaled-conditions*) 
       (push condition *abcl-signaled-conditions*) 
-      (signal (make-condition
-               'compiler-condition
-               :original-condition condition
-               :severity :warning
-               :message (format nil "~A" condition)
-               :location (cond (*buffer-name*
-                                (make-location 
-                                 (list :buffer *buffer-name*)
-                                 (list :offset *buffer-start-position* 0)))
-                               (loc
-                                (destructuring-bind (file . pos) loc
-                                  (make-location
-                                   (list :file (namestring (truename file)))
-                                   (list :position (1+ pos)))))
-                               (t  
-                                (make-location
-                                 (list :file (namestring *compile-filename*))
-                                 (list :position 1)))))))))
+      (signal 'compiler-condition
+              :original-condition condition
+              :severity :warning
+              :message (format nil "~A" condition)
+              :location (cond (*buffer-name*
+                               (make-location 
+                                (list :buffer *buffer-name*)
+                                (list :offset *buffer-start-position* 0)))
+                              (loc
+                               (destructuring-bind (file . pos) loc
+                                 (make-location
+                                  (list :file (namestring (truename file)))
+                                  (list :position (1+ pos)))))
+                              (t  
+                               (make-location
+                                (list :file (namestring *compile-filename*))
+                                (list :position 1))))))))
 
 (defimplementation swank-compile-file (input-file output-file
                                        load-p external-format
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2012/05/06 16:16:02	1.153
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2012/08/04 23:48:19	1.154
@@ -341,7 +341,7 @@
   `(satisfies redefinition-p))
 
 (defun signal-compiler-condition (&rest args)
-  (signal (apply #'make-condition 'compiler-condition args)))
+  (apply #'signal 'compiler-condition args))
 
 (defun handle-compiler-warning (condition)
   (declare (optimize (debug 3) (speed 0) (space 0)))
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2012/03/26 15:09:57	1.27
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2012/08/04 23:48:19	1.28
@@ -158,16 +158,15 @@
 
 (defun handle-compiler-warning (condition)
   "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."
-  (signal (make-condition
-           'compiler-condition
-           :original-condition condition
-           :message (compiler-warning-short-message condition)
-           :source-context nil
-           :severity (compiler-warning-severity condition)
-           :location (source-note-to-source-location 
-                      (ccl:compiler-warning-source-note condition)
-                      (lambda () "Unknown source")
-                      (ccl:compiler-warning-function-name condition)))))
+  (signal 'compiler-condition
+          :original-condition condition
+          :message (compiler-warning-short-message condition)
+          :source-context nil
+          :severity (compiler-warning-severity condition)
+          :location (source-note-to-source-location 
+                     (ccl:compiler-warning-source-note condition)
+                     (lambda () "Unknown source")
+                     (ccl:compiler-warning-function-name condition))))
 
 (defgeneric compiler-warning-severity (condition))
 (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2012/04/07 10:23:38	1.101
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2012/08/04 23:48:19	1.102
@@ -627,10 +627,10 @@
            (list :error "No error location available")))))
 
 (defun signal-compiler-warning (cstring args severity orig-fn)
-  (signal (make-condition 'compiler-condition
-                          :severity severity
-                          :message (apply #'format nil cstring args)
-                          :location (compiler-note-location)))
+  (signal 'compiler-condition
+          :severity severity
+          :message (apply #'format nil cstring args)
+          :location (compiler-note-location))
   (apply orig-fn cstring args))
 
 (defun c-warn (cstring &rest args)
@@ -641,13 +641,13 @@
     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
 
 (defun c-error (&rest args)
-  (signal (make-condition 'compiler-condition
-                          :severity :error
-                          :message (apply #'format nil
-                                          (if (= (length args) 3)
-                                              (cdr args)
-                                              args))
-                          :location (compiler-note-location)))
+  (signal 'compiler-condition
+          :severity :error
+          :message (apply #'format nil
+                          (if (= (length args) 3)
+                              (cdr args)
+                              args))
+          :location (compiler-note-location))
   (apply *orig-c-error* args))
 
 (defimplementation call-with-compilation-hooks (function)
@@ -659,11 +659,11 @@
 
 (defun handle-notification-condition (condition)
   "Handle a condition caused by a compiler warning."
-  (signal (make-condition 'compiler-condition
-                          :original-condition condition
-                          :severity :warning
-                          :message (princ-to-string condition)
-                          :location (compiler-note-location))))
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity :warning
+          :message (princ-to-string condition)
+          :location (compiler-note-location)))
 
 (defimplementation swank-compile-file (input-file output-file
                                        load-p external-format
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2012/04/07 09:35:42	1.243
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2012/08/04 23:48:19	1.244
@@ -373,7 +373,7 @@
         (cond ((zerop (length string))
                (return-from sis/in
                  (if eof-errorp
-                     (error (make-condition 'end-of-file :stream stream))
+                     (error 'end-of-file :stream stream)
                      eof-value)))
               (t
                (setf buffer string)
@@ -475,15 +475,14 @@
       (signal-compiler-condition condition context))))
 
 (defun signal-compiler-condition (condition context)
-  (signal (make-condition
-           'compiler-condition
-           :original-condition condition
-           :severity (severity-for-emacs condition)
-           :message (compiler-condition-message condition)
-           :source-context (compiler-error-context context)
-           :location (if (read-error-p condition)
-                         (read-error-location condition)
-                         (compiler-note-location context)))))
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity (severity-for-emacs condition)
+          :message (compiler-condition-message condition)
+          :source-context (compiler-error-context context)
+          :location (if (read-error-p condition)
+                        (read-error-location condition)
+                        (compiler-note-location context))))
 
 (defun severity-for-emacs (condition)
   "Return the severity of CONDITION."
@@ -1586,9 +1585,8 @@
          (kernel:*current-level* 0))
     (handler-bind ((di::unhandled-condition
 		    (lambda (condition)
-                      (error (make-condition
-                              'sldb-condition
-                              :original-condition condition)))))
+                      (error 'sldb-condition
+                             :original-condition condition))))
       (unwind-protect
            (progn
              #+(or)(sys:scrub-control-stack)
--- /project/slime/cvsroot/slime/swank-corman.lisp	2012/04/07 10:23:38	1.27
+++ /project/slime/cvsroot/slime/swank-corman.lisp	2012/08/04 23:48:19	1.28
@@ -347,22 +347,21 @@
 ;; FIXME
 (defimplementation call-with-compilation-hooks (FN)
   (handler-bind ((error (lambda (c)
-                          (signal (make-condition
-                                   'compiler-condition
-                                   :original-condition c
-                                   :severity :warning
-                                   :message (format nil "~A" c)
-                                   :location
-                                   (cond (*buffer-name*
-                                          (make-location
-                                           (list :buffer *buffer-name*)
-                                           (list :offset *buffer-position* 0)))
-                                         (*compile-filename*
-                                          (make-location
-                                           (list :file *compile-filename*)
-                                           (list :position 1)))
-                                         (t
-                                          (list :error "No location"))))))))
+                          (signal 'compiler-condition
+                                  :original-condition c
+                                  :severity :warning
+                                  :message (format nil "~A" c)
+                                  :location
+                                  (cond (*buffer-name*
+                                         (make-location
+                                          (list :buffer *buffer-name*)
+                                          (list :offset *buffer-position* 0)))
+                                        (*compile-filename*
+                                         (make-location
+                                          (list :file *compile-filename*)
+                                          (list :position 1)))
+                                        (t
+                                         (list :error "No location")))))))
     (funcall fn)))
 
 (defimplementation swank-compile-file (input-file output-file 
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2012/06/19 19:46:53	1.76
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2012/08/04 23:48:19	1.77
@@ -221,7 +221,7 @@
 (defvar *buffer-start-position*)
 
 (defun signal-compiler-condition (&rest args)
-  (signal (apply #'make-condition 'compiler-condition args)))
+  (apply #'signal 'compiler-condition args))
 
 #-ecl-bytecmp
 (defun handle-compiler-message (condition)
--- /project/slime/cvsroot/slime/swank-rpc.lisp	2012/05/06 08:51:26	1.13
+++ /project/slime/cvsroot/slime/swank-rpc.lisp	2012/08/04 23:48:19	1.14
@@ -32,17 +32,17 @@
   (let ((packet (read-packet stream)))
     (handler-case (values (read-form packet package))
       (reader-error (c)
-        (error (make-condition 'swank-reader-error 
-                               :packet packet :cause c))))))
+        (error 'swank-reader-error 
+               :packet packet :cause c)))))
 
 (defun read-packet (stream)
   (let* ((length (parse-header stream))
          (octets (read-chunk stream length)))
     (handler-case (swank-backend:utf8-to-string octets)
       (error (c) 
-        (error (make-condition 'swank-reader-error 
-                               :packet (asciify octets)
-                               :cause c))))))
+        (error 'swank-reader-error 
+               :packet (asciify octets)
+               :cause c)))))
 
 (defun asciify (packet)
   (with-output-to-string (*standard-output*)
@@ -62,7 +62,7 @@
     (cond ((= count length)
            buffer)
           ((zerop count)
-           (error (make-condition 'end-of-file :stream stream)))
+           (error 'end-of-file :stream stream))
           (t
            (error "Short read: length=~D  count=~D" length count)))))
 
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/08/04 23:32:37	1.323
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/08/04 23:48:19	1.324
@@ -463,24 +463,23 @@
                                (sb-c::find-error-context nil))))
 
 (defun signal-compiler-condition (condition context)
-  (signal (make-condition
-           'compiler-condition
-           :original-condition condition
-           :severity (etypecase condition
-                       (sb-ext:compiler-note :note)
-                       (sb-c:compiler-error  :error)
-                       (reader-error         :read-error)
-                       (error                :error)
-                       #+#.(swank-backend:with-symbol redefinition-warning 
-                             sb-kernel)
-                       (sb-kernel:redefinition-warning
-                                             :redefinition)
-                       (style-warning        :style-warning)
-                       (warning              :warning))
-           :references (condition-references condition)
-           :message (brief-compiler-message-for-emacs condition)
-           :source-context (compiler-error-context context)
-           :location (compiler-note-location condition context))))
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity (etypecase condition
+                      (sb-ext:compiler-note :note)
+                      (sb-c:compiler-error  :error)
+                      (reader-error         :read-error)
+                      (error                :error)
+                      #+#.(swank-backend:with-symbol redefinition-warning 
+                            sb-kernel)
+                      (sb-kernel:redefinition-warning
+                       :redefinition)
+                      (style-warning        :style-warning)
+                      (warning              :warning))
+          :references (condition-references condition)
+          :message (brief-compiler-message-for-emacs condition)
+          :source-context (compiler-error-context context)
+          :location (compiler-note-location condition context)))
 
 (defun real-condition (condition)
   "Return the encapsulated condition or CONDITION itself."
--- /project/slime/cvsroot/slime/swank-scl.lisp	2012/04/24 11:08:13	1.41
+++ /project/slime/cvsroot/slime/swank-scl.lisp	2012/08/04 23:48:19	1.42
@@ -498,15 +498,14 @@
       (signal-compiler-condition condition context))))
 
 (defun signal-compiler-condition (condition context)
-  (signal (make-condition
-           'compiler-condition
-           :original-condition condition
-           :severity (severity-for-emacs condition)
-           :message (brief-compiler-message-for-emacs condition)
-           :source-context (compiler-error-context context)
-           :location (if (read-error-p condition)
-                         (read-error-location condition)
-                         (compiler-note-location context)))))
+  (signal 'compiler-condition
+          :original-condition condition
+          :severity (severity-for-emacs condition)
+          :message (brief-compiler-message-for-emacs condition)
+          :source-context (compiler-error-context context)
+          :location (if (read-error-p condition)
+                        (read-error-location condition)
+                        (compiler-note-location context))))
 
 (defun severity-for-emacs (condition)
   "Return the severity of 'condition."
@@ -1354,9 +1353,8 @@
          (kernel:*current-level* 0))
     (handler-bind ((di::unhandled-condition
 		    (lambda (condition)
-                      (error (make-condition
-                              'sldb-condition
-                              :original-condition condition)))))
+                      (error 'sldb-condition
+                             :original-condition condition))))
       (funcall debugger-loop-fn))))
 
 (defun frame-down (frame)
--- /project/slime/cvsroot/slime/swank.lisp	2012/05/06 08:51:26	1.790
+++ /project/slime/cvsroot/slime/swank.lisp	2012/08/04 23:48:19	1.791
@@ -291,8 +291,8 @@
   (:report (lambda (c s) (princ (swank-error.condition c) s)))
   (:documentation "Condition which carries a backtrace."))
 
-(defun make-swank-error (condition &optional (backtrace (safe-backtrace)))
-  (make-condition 'swank-error :condition condition :backtrace backtrace))
+(defun signal-swank-error (condition &optional (backtrace (safe-backtrace)))
+  (error 'swank-error :condition condition :backtrace backtrace))
 
 (defvar *debug-on-swank-protocol-error* nil
   "When non-nil invoke the system debugger on errors that were
@@ -879,7 +879,7 @@
   "Read an S-expression from STREAM using the SLIME protocol."
   (log-event "decode-message~%")
   (without-slime-interrupts
-    (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
+    (handler-bind ((error #'signal-swank-error))
       (handler-case (read-message stream *swank-io-package*)
         (swank-reader-error (c) 
           `(:reader-error ,(swank-reader-error.packet c)
@@ -889,7 +889,7 @@
   "Write an S-expression to STREAM using the SLIME protocol."
   (log-event "encode-message~%")
   (without-slime-interrupts
-    (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
+    (handler-bind ((error #'signal-swank-error))
       (write-message message *swank-io-package* stream))))
 
 




From sboukarev at common-lisp.net  Mon Aug 13 20:50:34 2012
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 13 Aug 2012 13:50:34 -0700
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1T11as-0001VA-A2@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory tiger.common-lisp.net:/tmp/cvs-serv5745

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
* swank-arglists.lisp (extra-keywords/slots): Check for
slot-definition-initfunction being present before calling
slot-definition-initform.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2012/08/04 22:35:13	1.549
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2012/08/13 20:50:34	1.550
@@ -1,3 +1,9 @@
+2012-08-13  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-arglists.lisp (extra-keywords/slots): Check for
+	slot-definition-initfunction being present before calling
+	slot-definition-initform.
+
 2012-08-04  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-arglists.lisp (test-print-arglist): bind
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2012/08/04 22:35:13	1.74
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2012/08/13 20:50:34	1.75
@@ -743,13 +743,14 @@
           (values (swank-mop:class-slots class) nil)
           (values (swank-mop:class-direct-slots class) t))
     (let ((slot-init-keywords
-           (loop for slot in slots append
-                 (mapcar (lambda (initarg)
-                           (make-keyword-arg
-                            initarg
-                            (swank-mop:slot-definition-name slot)
-                            (swank-mop:slot-definition-initform slot)))
-                         (swank-mop:slot-definition-initargs slot)))))
+            (loop for slot in slots append
+                  (mapcar (lambda (initarg)
+                            (make-keyword-arg
+                             initarg
+                             (swank-mop:slot-definition-name slot)
+                             (and (swank-mop:slot-definition-initfunction slot)
+                                  (swank-mop:slot-definition-initform slot))))
+                          (swank-mop:slot-definition-initargs slot)))))
       (values slot-init-keywords allow-other-keys-p))))
 
 (defun extra-keywords/make-instance (operator &rest args)




From sboukarev at common-lisp.net  Sat Aug 18 16:34:06 2012
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 18 Aug 2012 09:34:06 -0700
Subject: [slime-cvs] CVS slime
Message-ID: <E1T2lyQ-00084V-HA@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv31003

Modified Files:
	ChangeLog swank-abcl.lisp 
Log Message:
* swank-abcl.lisp (find-definitions): Call ext:resolve before
finding definitions, for the symbol may be not autoloaded yet.


--- /project/slime/cvsroot/slime/ChangeLog	2012/08/04 23:48:19	1.2347
+++ /project/slime/cvsroot/slime/ChangeLog	2012/08/18 16:34:06	1.2348
@@ -1,3 +1,8 @@
+2012-08-18  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-abcl.lisp (find-definitions): Call ext:resolve before
+	finding definitions, for the symbol may be not autoloaded yet.
+
 2012-08-04  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-sbcl.lisp (call-with-debugging-environment): Use
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2012/08/04 23:48:19	1.92
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2012/08/18 16:34:06	1.93
@@ -594,6 +594,7 @@
                  if (try dir) return it)))))
 
 (defimplementation find-definitions (symbol)
+  (ext:resolve symbol)
   (let ((srcloc (source-location symbol)))
     (and srcloc `((,symbol ,srcloc)))))