From trittweiler at common-lisp.net  Fri May  1 18:09:43 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 01 May 2009 14:09:43 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1LzxB9-0004hO-70@common-lisp.net>

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

Modified Files:
	ChangeLog slime-parse.el 
Log Message:
	* slime-parse.el (slime-parse-extended-operator/check-type):
	Forgot to delete debugging code.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/04/30 12:38:02	1.202
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/01 18:09:43	1.203
@@ -1,6 +1,11 @@
+2009-05-01  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-parse.el (slime-parse-extended-operator/check-type):
+	Forgot to delete debugging code.
+
 2009-04-30  Tobias C. Rittweiler  <tcr at freebits.de>
 
-	* slime.el (slime-parse-extended-operator/check-type): New.
+	* slime-parse.el (slime-parse-extended-operator/check-type): New.
 	(slime-parse-extended-operator/the): New.
 	(slime-extended-operator-name-parser-alist): Add entries for
 	CHECK-TYPE, TYPEP, and THE.
--- /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/04/30 12:38:02	1.21
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el	2009/05/01 18:09:43	1.22
@@ -171,7 +171,6 @@
 
 (defun slime-parse-extended-operator/check-type
     (name user-point current-forms current-indices current-points)
- (tcr:debugmsg "%S %S %S %S %S" name user-point current-forms current-indices current-points)
   (let ((arg-idx        (first current-indices))
         (typespec       (second current-forms))
         (typespec-start (second current-points)))




From trittweiler at common-lisp.net  Fri May  1 20:24:03 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 01 May 2009 16:24:03 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1LzzH9-0001he-AV@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-line-number-at-pos): Replaced with
	`line-number-at-pos', and add that to the portability layer.
	(display-warning): Add to the portability layer.
	(slime-display-warning): New.

	* slime.el: Implement a guard against infinite loops during
	fontification. We detect and prevent those. If we detect one, we
	emit a big warning to the user.

	(slime-font-lock-region): New variable.
	(slime-font-lock-region-changed-p): New helper.
	(slime-extend-region-warn-infinite-loop): New helper.
	(slime-compute-region-for-font-lock): Extracted from
	`slime-extend-region-for-font-lock'.
	(slime-extend-region-for-font-lock): Use it; add the guard.


--- /project/slime/cvsroot/slime/ChangeLog	2009/04/30 12:50:25	1.1734
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/01 20:24:03	1.1735
@@ -1,3 +1,21 @@
+2009-05-01  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-line-number-at-pos): Replaced with
+	`line-number-at-pos', and add that to the portability layer.
+	(display-warning): Add to the portability layer.
+	(slime-display-warning): New.
+
+	* slime.el: Implement a guard against infinite loops during
+	fontification. We detect and prevent those. If we detect one, we
+	emit a big warning to the user.
+
+	(slime-font-lock-region): New variable.
+	(slime-font-lock-region-changed-p): New helper.
+	(slime-extend-region-warn-infinite-loop): New helper.
+	(slime-compute-region-for-font-lock): Extracted from
+	`slime-extend-region-for-font-lock'.
+	(slime-extend-region-for-font-lock): Use it; add the guard.
+
 2009-04-30  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-abcl.lisp: Really commit Vodonosov's patch from
--- /project/slime/cvsroot/slime/slime.el	2009/04/29 22:05:16	1.1157
+++ /project/slime/cvsroot/slime/slime.el	2009/05/01 20:24:03	1.1158
@@ -733,6 +733,9 @@
 Single-line messages use the echo area."
   (apply slime-message-function format args))
 
+(defun slime-display-warning (message &rest args)
+  (display-warning 'slime (apply #'format message args)))
+
 (when (or (featurep 'xemacs))
   (setq slime-message-function 'slime-format-display-message))
 
@@ -2913,7 +2916,7 @@
                (save-excursion
                  (slime-goto-source-location location)
                  (list (or (buffer-file-name) (buffer-name))
-                       (slime-line-number-at-pos)
+                       (line-number-at-pos)
                        (1+ (current-column)))))
            (format "%s:%d:%d: " (or filename "") line col)))
         (t "")))
@@ -6328,7 +6331,7 @@
   ;; narrowed the buffer.
   (save-restriction
     (widen)
-    (cons (slime-line-number-at-pos)
+    (cons (line-number-at-pos)
           (current-column))))
 
 (defun slime-inspector-operate-on-point ()
@@ -6668,6 +6671,8 @@
 
 ;;;; Font Lock
 
+;;; Specially fontify forms suppressed by a reader conditional.
+
 (defcustom slime-highlight-suppressed-forms t
   "Display forms disabled by reader conditionals as comments."
   :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
@@ -6737,29 +6742,70 @@
             (list (point) end)
             (list start   end))))))
 
+(make-variable-buffer-local
+ (defvar slime-font-lock-region (cons -1 -1)
+   "These are the values of `font-lock-beg' and `font-lock-end' of
+the last font-lock extend-region phase."))
+
+(defun slime-font-lock-region-changed-p (font-lock-beg font-lock-end)
+  "Did `font-lock-beg', `font-lock-end' change since last extending phase?"
+  (destructuring-bind (old-beg . old-end) slime-font-lock-region
+     (or (/= old-beg font-lock-beg) 
+         (/= old-end font-lock-end))))
+
 ;;; We'll push this onto `font-lock-extend-region-functions'. In past,
 ;;; we didn't do so which made our reader-conditional font-lock magic
 ;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
 ;;; worked quite non-deterministic in general.)
 ;;;
 ;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
+;;;
+;;; We make sure that `font-lock-beg' and `font-lock-end' always point
+;;; to the beginning or end of a toplevel form. So we never miss a
+;;; reader-conditional, or point in mid of one.
 (defun slime-extend-region-for-font-lock ()
-  ;; We make sure that `font-lock-beg' and `font-lock-end' always
-  ;; point to the beginning or end of a defun. So we never miss a
-  ;; reader-conditional, or point in mid of one.
+  (when (and slime-highlight-suppressed-forms (slime-connected-p))
+    (when (slime-font-lock-region-changed-p font-lock-beg font-lock-end)
+      ;; We're in a new extending phase, so reinitialize the values.
+      (setq slime-font-lock-region (cons -1 -1)))
+    (let (changedp)
+      (multiple-value-setq (changedp font-lock-beg font-lock-end)
+        (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
+      (when changedp
+        ;; Guard against infinite loops:
+        (when (not (slime-font-lock-region-changed-p font-lock-beg font-lock-end))
+          (slime-extend-region-warn-infinite-loop)
+          (setq changedp nil))
+        ;; Update values. (N.B. cannot be done prior.)
+        (setq slime-font-lock-region (cons font-lock-beg font-lock-end)))
+      changedp)))
+
+(defun slime-compute-region-for-font-lock (beg end)
   (let ((changedp nil))
-    (goto-char font-lock-beg)
+    (goto-char beg)
     (when (plusp (nth 0 (slime-current-parser-state)))
       ;; N.B. take initial reader-conditional into account, otherwise
       ;; fontification wouldn't know the whole function definition may
       ;; be suppressed. 
-      (setq font-lock-beg (first (slime-region-for-extended-tlf-at-point)))
+      (setq beg (first (slime-region-for-extended-tlf-at-point)))
       (setq changedp t))
-    (goto-char font-lock-end)
+    (goto-char end)
     (when (plusp (nth 0 (slime-current-parser-state)))
-      (setq font-lock-end (second (slime-region-for-tlf-at-point)))
+      (setq end (second (slime-region-for-tlf-at-point)))
       (setq changedp t))
-    changedp))
+    (values changedp beg end)))
+
+(defun slime-extend-region-warn-infinite-loop ()
+  (slime-display-warning
+   "%S:%d:%d (pt=%d).
+Prevented infinite loop during fontification. This is a bug in Slime itself.
+Please report this to the mailinglist slime-devel at common-lisp.net and include
+your Emacs version, the guilty Lisp source file, and the header of this 
+message."
+   (buffer-name)
+   (line-number-at-pos)
+   (current-column)
+   (point)))
 
 ;;; FIXME: This is supposed to be the value for
 ;;; `font-lock-mark-block-function' (so M-o M-o will DTRT), but I
@@ -8493,12 +8539,6 @@
 (put 'slime-DEFMACRO-if-undefined 'lisp-indent-function 2)
 (put 'slime-indulge-pretty-colors 'slime-DEFMACRO-if-undefined t)
 
-(defmacro slime-defmacro-if-undefined (name &rest rest)
-  `(unless (fboundp ',name)
-     (defmacro ,name , at rest)))
-
-(put 'slime-defmacro-if-undefined 'lisp-indent-function 2)
-
 
 (defvar slime-accept-process-output-supports-floats 
   (ignore-errors (accept-process-output nil 0.0) t))
@@ -8540,12 +8580,13 @@
       (apply #'run-mode-hooks hooks)
     (apply #'run-hooks hooks)))
 
-(defun slime-line-number-at-pos ()
-  (cond ((fboundp 'line-number-at-pos)
-         (line-number-at-pos))  ; Emacs 22
-        ((fboundp 'line-number)
-         (line-number))         ; XEmacs
-        (t (1+ (count-lines 1 (point-at-bol))))))
+(if (featurep 'xemacs)
+  (slime-DEFUN-if-undefined line-number-at-pos (&optional pos)
+     (line-number pos))
+  (slime-DEFUN-if-undefined line-number-at-pos (&optional pos)
+     (save-excursion
+       (when pos (goto-char pos))
+       (1+ (count-lines 1 (point-at-bol))))))
 
 (defun slime-local-variable-p (var &optional buffer)
   (local-variable-p var (or buffer (current-buffer)))) ; XEmacs
@@ -8644,7 +8685,7 @@
       (if (eq (aref newstr i) fromchar)
 	  (aset newstr i tochar)))
     newstr))
-
+                          
 (slime-DEFUN-if-undefined count-screen-lines 
   (&optional beg end count-final-newline window)
   (unless beg
@@ -8772,6 +8813,11 @@
 (slime-DEFUN-if-undefined set-process-coding-system 
     (process &optional decoding encoding))
 
+(slime-DEFUN-if-undefined display-warning  
+                          (type message &optional level buffer-name)
+  (slime-display-message (apply #'format (concat "Warning (%s): " message) type args)
+                         "*Warnings*"))
+
 (unless (boundp 'temporary-file-directory)
   (defvar temporary-file-directory
     (file-name-as-directory




From trittweiler at common-lisp.net  Sat May  2 09:11:09 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 02 May 2009 05:11:09 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M0BFV-0005x8-Bc@common-lisp.net>

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

Modified Files:
	slime-autodoc.el ChangeLog 
Log Message:
	* slime-autodoc.el (slime-fontify-string): Deactivate autodoc
	itself in the temporary help buffer. And deactivate slime's
	font-lock magic.


--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/03/09 22:40:21	1.15
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2009/05/02 09:11:08	1.16
@@ -180,8 +180,10 @@
   "Fontify STRING as `font-lock-mode' does in Lisp mode."
   (with-current-buffer (get-buffer-create " *slime-fontify*")
     (erase-buffer)
-    (if (not (eq major-mode 'lisp-mode))
-        (lisp-mode))
+    (unless (eq major-mode 'lisp-mode)
+      (lisp-mode)
+      (slime-autodoc-mode -1)
+      (set (make-local-variable 'slime-highlight-suppressed-forms) nil))
     (insert string)
     (let ((font-lock-verbose nil))
       (font-lock-fontify-buffer))
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/01 18:09:43	1.203
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/02 09:11:09	1.204
@@ -1,3 +1,9 @@
+2009-05-02  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-autodoc.el (slime-fontify-string): Deactivate autodoc
+	itself in the temporary help buffer. And deactivate slime's
+	font-lock magic.
+
 2009-05-01  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-parse.el (slime-parse-extended-operator/check-type):




From trittweiler at common-lisp.net  Fri May  8 16:14:10 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 08 May 2009 12:14:10 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M2SiA-0008Ff-RL@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	#+#.foo confused the recent fontification changes. Fix that.

	* slime.el (slime-search-suppressed-forms-internal): New. Split
	from `slime-search-suppressed-forms'.
	(slime-search-suppressed-forms): Catch `invalid-read-syntax'
	errors.


--- /project/slime/cvsroot/slime/slime.el	2009/05/01 20:24:03	1.1158
+++ /project/slime/cvsroot/slime/slime.el	2009/05/08 16:14:10	1.1159
@@ -6686,35 +6686,56 @@
   "Face for compiler notes while selected."
   :group 'slime-mode-faces)
 
+(defun slime-search-suppressed-forms-internal (limit)
+  (let* ((start (- (point) 2))
+         (char (char-before))
+         (e (read (current-buffer)))
+         (val (slime-eval-feature-conditional e)))
+    (when (<= (point) limit)
+      (if (or (and (eq char ?+) (not val))
+              (and (eq char ?-) val))
+          (progn
+            (forward-sexp) (backward-sexp)
+            (slime-forward-sexp)
+            ;; There was an `ignore-errors' form around all this
+            ;; because the following assertion was triggered
+            ;; regularly (resulting in the "non-deterministic"
+            ;; behaviour mentioned in the comment further below.)
+            ;; With extending the region properly, this assertion
+            ;; would truly mean a bug now.
+            (assert (<= (point) limit))
+            (let ((md (match-data)))
+              (fill md nil)
+              (setf (first md) start)
+              (setf (second md) (point))
+              (set-match-data md)
+              t))
+          (slime-search-suppressed-forms-internal limit)))))
+
 (defun slime-search-suppressed-forms (limit)
   "Find reader conditionalized forms where the test is false."
   (when (and slime-highlight-suppressed-forms
              (slime-connected-p)
              (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t))
-    (let* ((start (- (point) 2))
-           (char (char-before))
-           (e (read (current-buffer)))
-           (val (slime-eval-feature-conditional e)))
-      (when (<= (point) limit)
-        (if (or (and (eq char ?+) (not val))
-                (and (eq char ?-) val))
-            (progn
-              (forward-sexp) (backward-sexp)
-              (slime-forward-sexp)
-              ;; There was an `ignore-errors' form around all this
-              ;; because the following assertion was triggered
-              ;; regularly (resulting in the "non-deterministic"
-              ;; behaviour mentioned in the comment further below.)
-              ;; With extending the region properly, this assertion
-              ;; would truly mean a bug now.
-              (assert (<= (point) limit))
-              (let ((md (match-data)))
-                (fill md nil)
-                (setf (first md) start)
-                (setf (second md) (point))
-                (set-match-data md)
-                t))
-            (slime-search-suppressed-forms limit))))))
+    (condition-case condition
+        (slime-search-suppressed-forms-internal limit)
+      (invalid-read-syntax nil)         ; ignore e.g. #+#.foo
+      (error 
+       (slime-display-warning
+        "%S:%d:%d (pt=%d).
+Caught error during fontification while searching for forms that
+are suppressed by reader-conditionals. The error was: %S.
+
+This is a bug in Slime itself. Please report this to the
+mailinglist slime-devel at common-lisp.net and include your Emacs
+version, the guilty Lisp source file, and the header of this
+message.
+"
+        (buffer-name)
+        (line-number-at-pos)
+        (current-column)
+        (point)
+        condition)))))
 
 (defun slime-region-for-extended-tlf-at-point ()
   "Like `slime-region-for-tlf-at-point' except we take
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/01 20:24:03	1.1735
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/08 16:14:10	1.1736
@@ -1,3 +1,12 @@
+2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	#+#.foo confused the recent fontification changes. Fix that.
+
+	* slime.el (slime-search-suppressed-forms-internal): New. Split
+	from `slime-search-suppressed-forms'.
+	(slime-search-suppressed-forms): Catch `invalid-read-syntax'
+	errors.
+
 2009-05-01  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-line-number-at-pos): Replaced with




From trittweiler at common-lisp.net  Fri May  8 17:56:06 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 08 May 2009 13:56:06 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M2UIo-0003Nt-TA@common-lisp.net>

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

Modified Files:
	swank.lisp ChangeLog 
Log Message:
	* swank.lisp (read-from-minibuffer-in-emacs): New.
	([struct] istate): Add METADATA-PLIST slot.
	(ensure-istate-metadata): New. To attach arbitrary metadata to an
	inspector page.
	(inspect-object): Adapted so methods on EMACS-INSPECT can look at
	*ISTATE*.


--- /project/slime/cvsroot/slime/swank.lisp	2009/03/27 20:49:49	1.640
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/08 17:56:06	1.641
@@ -1868,6 +1868,13 @@
 	       ((:ok value) value)
 	       ((:abort) (abort))))))))
 
+;;; FIXME: This should not use EVAL-IN-EMACS but get its own events.
+(defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
+  (eval-in-emacs
+   `(condition-case c
+        (slime-read-from-minibuffer ,prompt ,initial-value)
+      (quit nil))))
+
 (defvar *swank-wire-protocol-version* nil
   "The version of the swank/slime communication protocol.")
 
@@ -3212,6 +3219,7 @@
   (verbose *inspector-verbose*)
   (parts (make-array 10 :adjustable t :fill-pointer 0))
   (actions (make-array 10 :adjustable t :fill-pointer 0))
+  metadata-plist
   content
   next previous)
 
@@ -3228,15 +3236,22 @@
       (reset-inspector)
       (inspect-object (eval (read-from-string string))))))
 
+(defun ensure-istate-metadata (o indicator default)
+  (with-struct (istate. object metadata-plist) *istate*
+    (assert (eq object o))
+    (let ((data (getf metadata-plist indicator default)))
+      (setf (getf metadata-plist indicator) data)
+      data)))
+
 (defun inspect-object (o)
-  (let ((previous *istate*)
-        (content (emacs-inspect/printer-bindings o)))
-    (unless (find o *inspector-history*)
-      (vector-push-extend o *inspector-history*))
-    (setq *istate* (make-inspector-state :object o :previous previous 
-                                         :content content))
-    (if previous (setf (istate.next previous) *istate*))
-    (istate>elisp *istate*)))
+  ;; Set *ISTATE* first so EMACS-INSPECT can possibly look at it.
+  (setq *istate* (make-inspector-state :object o :previous *istate*))
+  (setf (istate.content *istate*) (emacs-inspect/printer-bindings o))
+  (unless (find o *inspector-history*)
+    (vector-push-extend o *inspector-history*))
+  (let ((previous (istate.previous *istate*)))
+    (if previous (setf (istate.next previous) *istate*)))
+  (istate>elisp *istate*))
 
 (defun emacs-inspect/printer-bindings (object)
   (let ((*print-lines* 1) (*print-right-margin* 75)
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/08 16:14:10	1.1736
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/08 17:56:06	1.1737
@@ -1,5 +1,14 @@
 2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank.lisp (read-from-minibuffer-in-emacs): New.
+	([struct] istate): Add METADATA-PLIST slot.
+	(ensure-istate-metadata): New. To attach arbitrary metadata to an
+	inspector page.
+	(inspect-object): Adapted so methods on EMACS-INSPECT can look at
+	*ISTATE*.
+
+2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	#+#.foo confused the recent fontification changes. Fix that.
 
 	* slime.el (slime-search-suppressed-forms-internal): New. Split




From trittweiler at common-lisp.net  Fri May  8 18:00:49 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 08 May 2009 14:00:49 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M2UNN-0003yG-60@common-lisp.net>

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

Modified Files:
	swank-fancy-inspector.lisp ChangeLog 
Log Message:
	The inspector page for standard-objects does not append
	"[set value]" and "[make unbound]" buttons after each entry
	anymore. Instead we use a checklist.

	* swank-fancy-inspector.lisp ([struct] inspector-checklist): New.
	(make-checklist-button): New.
	(do-checklist): New.
	(slot-value-for-inspector): Previously `inspect-slot-for-emacs'.
	(query-and-set-slot): New.
	(all-slots-for-inspector): Adapted for changes described above.


--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2009/03/07 19:10:06	1.19
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2009/05/08 18:00:49	1.20
@@ -162,66 +162,98 @@
 		     maxlen
 		     (length doc))))
 
-(defgeneric inspect-slot-for-emacs (class object slot)
-  (:method (class object slot)
-           (let ((slot-name (swank-mop:slot-definition-name slot))
-                 (boundp (swank-mop:slot-boundp-using-class class object slot)))
-             `(,@(if boundp
-                     `((:value ,(swank-mop:slot-value-using-class class object slot)))
-                     `("#<unbound>"))
-               " "
-               (:action "[set value]"
-                ,(lambda () (with-simple-restart
-                                (abort "Abort setting slot ~S" slot-name)
-                              (let ((value-string (eval-in-emacs
-                                                   `(condition-case c
-                                                     (slime-read-from-minibuffer
-                                                      ,(format nil "Set slot ~S to (evaluated) : " slot-name))
-                                                     (quit nil)))))
-                                (when (and value-string
-                                           (not (string= value-string "")))
-                                  (setf (swank-mop:slot-value-using-class class object slot)
-                                        (eval (read-from-string value-string))))))))
-               ,@(when boundp
-                   `(" " (:action "[make unbound]"
-                          ,(lambda () (swank-mop:slot-makunbound-using-class class object slot)))))))))
+(defstruct (inspector-checklist (:conc-name checklist.)
+                                 (:constructor %make-checklist (buttons)))
+  (buttons nil :type (or null simple-vector)))
+
+(defun make-checklist (n)
+  (%make-checklist (make-array n :initial-element nil)))
+
+(defun make-checklist-button (i checklist)
+  (let ((buttons (checklist.buttons checklist)))
+    `(:action ,(if (svref buttons i)
+                   "[X]"
+                   "[ ]")
+              ,#'(lambda ()
+                   (setf (svref buttons i) (not (svref buttons i))))
+              :refreshp t)))
+
+(defmacro do-checklist ((idx checklist) &body body)
+  "Iterate over all set buttons in CHECKLIST."
+  (let ((buttons (gensym "buttons")))
+    `(let ((,buttons (checklist.buttons ,checklist)))
+       (dotimes (,idx (length ,buttons))
+          (when (svref ,buttons ,idx)
+            , at body)))))
 
 (defgeneric all-slots-for-inspector (object)
   (:method ((object standard-object))
-    (append '("--------------------" (:newline)
-              "All Slots:" (:newline))
-            (let* ((class (class-of object))
-                   (direct-slots (swank-mop:class-direct-slots class))
-                   (effective-slots (sort (copy-seq (swank-mop:class-slots class))
-                                          #'string< :key #'swank-mop:slot-definition-name))
-                   (slot-presentations (loop for effective-slot :in effective-slots
-                                             collect (inspect-slot-for-emacs
-                                                      class object effective-slot)))
-                   (longest-slot-name-length
-                    (loop for slot :in effective-slots
-                          maximize (length (symbol-name
-                                            (swank-mop:slot-definition-name slot))))))
+    (let* ((class (class-of object))
+           (direct-slots (swank-mop:class-direct-slots class))
+           (effective-slots (sort (copy-seq (swank-mop:class-slots class))
+                                  #'string< :key #'swank-mop:slot-definition-name))
+           (longest-slot-name-length
+            (loop for slot :in effective-slots
+                  maximize (length (symbol-name
+                                    (swank-mop:slot-definition-name slot)))))
+           (checklist
+            (ensure-istate-metadata object :checklist
+                                    (make-checklist (length effective-slots)))))
+      (append '("--------------------" (:newline)
+                "All Slots:" (:newline))
               (loop
-                  for effective-slot :in effective-slots
-                  for slot-presentation :in slot-presentations
-                  for direct-slot = (find (swank-mop:slot-definition-name effective-slot)
-                                          direct-slots :key #'swank-mop:slot-definition-name)
-                  for slot-name = (inspector-princ
-                                   (swank-mop:slot-definition-name effective-slot))
-                  for padding-length = (- longest-slot-name-length
-                                          (length (symbol-name
-                                                   (swank-mop:slot-definition-name
-                                                    effective-slot))))
-                  collect `(:value ,(if direct-slot
-                                        (list direct-slot effective-slot)
-                                        effective-slot)
-                            ,slot-name)
-                  collect (make-array padding-length
-                                      :element-type 'character
-                                      :initial-element #\Space)
-                  collect " = "
-                  append slot-presentation
-                  collect '(:newline))))))
+                for effective-slot :in effective-slots
+                for direct-slot    = (find (swank-mop:slot-definition-name effective-slot)
+                                           direct-slots :key #'swank-mop:slot-definition-name)
+                for slot-name      = (inspector-princ
+                                      (swank-mop:slot-definition-name effective-slot))
+                for padding-length = (- longest-slot-name-length
+                                        (length (symbol-name
+                                                 (swank-mop:slot-definition-name
+                                                  effective-slot))))
+                for i from 0
+                collect (make-checklist-button i checklist)
+                collect "  "
+                collect `(:value ,(if direct-slot
+                                      (list direct-slot effective-slot)
+                                      effective-slot)
+                                 ,slot-name)
+                collect (make-string padding-length :initial-element #\Space)
+                collect " = "
+                collect (slot-value-for-inspector class object effective-slot)
+                collect '(:newline))
+              `((:newline)
+                (:action "[set value]"
+                         ,(lambda ()
+                            (do-checklist (idx checklist)
+                              (query-and-set-slot class object (nth idx effective-slots))))
+                         :refreshp t)
+                "  "
+                (:action "[make unbound]"
+                         ,(lambda ()
+                            (do-checklist (idx checklist)
+                              (swank-mop:slot-makunbound-using-class
+                               class object (nth idx effective-slots))))
+                         :refreshp t)
+                )))))
+
+(defgeneric slot-value-for-inspector (class object slot)
+  (:method (class object slot)
+    (let ((boundp (swank-mop:slot-boundp-using-class class object slot)))
+      (if boundp
+          `(:value ,(swank-mop:slot-value-using-class class object slot))
+          "#<unbound>"))))
+
+(defun query-and-set-slot (class object slot)
+  (let* ((slot-name (swank-mop:slot-definition-name slot))
+         (value-string (read-from-minibuffer-in-emacs
+                        (format nil "Set slot ~S to (evaluated) : "
+                                slot-name))))
+    (when (and value-string (not (string= value-string "")))
+      (with-simple-restart (abort "Abort setting slot ~S" slot-name)
+        (setf (swank-mop:slot-value-using-class class object slot)
+              (eval (read-from-string value-string)))))))
+
 
 (defmethod emacs-inspect ((gf standard-generic-function)) 
   (flet ((lv (label value) (label-value-line label value)))
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/02 09:11:09	1.204
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/08 18:00:49	1.205
@@ -1,3 +1,16 @@
+2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	The inspector page for standard-objects does not append
+	"[set value]" and "[make unbound]" buttons after each entry
+	anymore. Instead we use a checklist.
+
+	* swank-fancy-inspector.lisp ([struct] inspector-checklist): New.
+	(make-checklist-button): New.
+	(do-checklist): New.
+	(slot-value-for-inspector): Previously `inspect-slot-for-emacs'.
+	(query-and-set-slot): New.
+	(all-slots-for-inspector): Adapted for changes described above.
+
 2009-05-02  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-autodoc.el (slime-fontify-string): Deactivate autodoc




From trittweiler at common-lisp.net  Fri May  8 18:11:14 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 08 May 2009 14:11:14 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M2UXS-00045P-EQ@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el (slime-search-suppressed-forms-internal): Not properly
	factored out by earlier changeset.


--- /project/slime/cvsroot/slime/slime.el	2009/05/08 16:14:10	1.1159
+++ /project/slime/cvsroot/slime/slime.el	2009/05/08 18:11:14	1.1160
@@ -6687,36 +6687,36 @@
   :group 'slime-mode-faces)
 
 (defun slime-search-suppressed-forms-internal (limit)
-  (let* ((start (- (point) 2))
-         (char (char-before))
-         (e (read (current-buffer)))
-         (val (slime-eval-feature-conditional e)))
-    (when (<= (point) limit)
-      (if (or (and (eq char ?+) (not val))
-              (and (eq char ?-) val))
-          (progn
-            (forward-sexp) (backward-sexp)
-            (slime-forward-sexp)
-            ;; There was an `ignore-errors' form around all this
-            ;; because the following assertion was triggered
-            ;; regularly (resulting in the "non-deterministic"
-            ;; behaviour mentioned in the comment further below.)
-            ;; With extending the region properly, this assertion
-            ;; would truly mean a bug now.
-            (assert (<= (point) limit))
-            (let ((md (match-data)))
-              (fill md nil)
-              (setf (first md) start)
-              (setf (second md) (point))
-              (set-match-data md)
-              t))
-          (slime-search-suppressed-forms-internal limit)))))
+  (when (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t)
+    (let* ((start (- (point) 2))
+           (char (char-before))
+           (e (read (current-buffer)))
+           (val (slime-eval-feature-conditional e)))
+      (when (<= (point) limit)
+        (if (or (and (eq char ?+) (not val))
+                (and (eq char ?-) val))
+            (progn
+              (forward-sexp) (backward-sexp)
+              (slime-forward-sexp)
+              ;; There was an `ignore-errors' form around all this
+              ;; because the following assertion was triggered
+              ;; regularly (resulting in the "non-deterministic"
+              ;; behaviour mentioned in the comment further below.)
+              ;; With extending the region properly, this assertion
+              ;; would truly mean a bug now.
+              (assert (<= (point) limit))
+              (let ((md (match-data)))
+                (fill md nil)
+                (setf (first md) start)
+                (setf (second md) (point))
+                (set-match-data md)
+                t))
+            (slime-search-suppressed-forms-internal limit))))))
 
 (defun slime-search-suppressed-forms (limit)
   "Find reader conditionalized forms where the test is false."
   (when (and slime-highlight-suppressed-forms
-             (slime-connected-p)
-             (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t))
+             (slime-connected-p))
     (condition-case condition
         (slime-search-suppressed-forms-internal limit)
       (invalid-read-syntax nil)         ; ignore e.g. #+#.foo
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/08 17:56:06	1.1737
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/08 18:11:14	1.1738
@@ -1,5 +1,10 @@
 2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-search-suppressed-forms-internal): Not properly
+	factored out by earlier changeset.
+
+2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank.lisp (read-from-minibuffer-in-emacs): New.
 	([struct] istate): Add METADATA-PLIST slot.
 	(ensure-istate-metadata): New. To attach arbitrary metadata to an




From trittweiler at common-lisp.net  Sat May  9 19:26:00 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 09 May 2009 15:26:00 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M2sBM-00083l-GV@common-lisp.net>

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

Modified Files:
	swank-source-file-cache.lisp swank-sbcl.lisp ChangeLog 
Log Message:
	* swank-source-file-cache.lisp (read-snippet-from-string): New.

	* swank-sbcl.lisp (source-hint-snippet): Use it.
	(emacs-buffer-source-location): Use it, too.
	(string-path-snippet): Ditto. Additionally: Make sure the returned
	string is truncated by *SOURCE-SNIPPET-SIZE*.


--- /project/slime/cvsroot/slime/swank-source-file-cache.lisp	2008/04/24 01:24:14	1.9
+++ /project/slime/cvsroot/slime/swank-source-file-cache.lisp	2009/05/09 19:26:00	1.10
@@ -98,9 +98,13 @@
 If POSITION is given, set the STREAM's file position first."
   (when position
     (file-position stream position))
-  #+SBCL (skip-comments-and-whitespace stream)
+  #+sbcl (skip-comments-and-whitespace stream)
   (read-upto-n-chars stream *source-snippet-size*))
 
+(defun read-snippet-from-string (string &optional position)
+  (with-input-from-string (s string)
+    (read-snippet s position)))
+
 (defun skip-comments-and-whitespace (stream)
   (case (peek-char nil stream)
     ((#\Space #\Tab #\Newline #\Linefeed #\Page)
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/04/29 22:29:18	1.240
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2009/05/09 19:26:00	1.241
@@ -697,7 +697,8 @@
                           `(:snippet ,snippet))))))))
 
 (defun string-path-snippet (string form-path position)
-  (if form-path
+  (if (null form-path)
+      (read-snippet-from-string string)
       ;; If we have a form-path, use it to derive a more accurate
       ;; snippet, so that we can point to the individual form rather
       ;; than just the toplevel form.
@@ -705,8 +706,7 @@
           (let ((*read-suppress* t))
             (read-from-string string nil nil :start position))
         (declare (ignore data))
-        (subseq string position end))
-      string))    
+        (subseq string position (min end *source-snippet-size*)))))    
     
 (defun source-file-position (filename write-date form-path character-offset)
   (let ((source (get-source-code filename write-date))
@@ -717,9 +717,7 @@
           (or character-offset 0)))))
 
 (defun source-hint-snippet (filename write-date position)
-  (let ((source (get-source-code filename write-date)))
-    (with-input-from-string (s source)
-      (read-snippet s position))))
+  (read-snippet-from-string (get-source-code filename write-date) position))
 
 (defun function-source-location (function &optional name)
   (declare (type function function))
@@ -1003,8 +1001,7 @@
                                 &allow-other-keys)
           plist
         (let* ((pos (string-source-position code-location emacs-string))
-               (snipped (with-input-from-string (s emacs-string)
-                          (read-snippet s pos))))
+               (snipped (read-snippet-from-string emacs-string pos)))
           (make-location `(:buffer ,emacs-buffer)
                          `(:offset ,emacs-position ,pos)
                          `(:snippet ,snipped))))
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/08 18:11:14	1.1738
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/09 19:26:00	1.1739
@@ -1,3 +1,12 @@
+2009-05-09  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-source-file-cache.lisp (read-snippet-from-string): New.
+
+	* swank-sbcl.lisp (source-hint-snippet): Use it.
+	(emacs-buffer-source-location): Use it, too.
+	(string-path-snippet): Ditto. Additionally: Make sure the returned
+	string is truncated by *SOURCE-SNIPPET-SIZE*.
+
 2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-search-suppressed-forms-internal): Not properly




From trittweiler at common-lisp.net  Sun May 10 10:11:18 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 10 May 2009 06:11:18 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3606-0001nf-QJ@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	Font-lock magic barfed on #+(test).

	* slime.el (slime-eval-feature-conditional): Renamed to
	`slime-eval-feature-expression'.
	(slime-unknown-feature-expression): New error symbol.
	(slime-eval-feature-expression): Signal it.
	(slime-search-suppressed-forms): Catch it.
	(slime-compute-region-for-font-lock): Guard against unbalanced
	parentheses.
	(slime-initialize-lisp-buffer-for-test-suite): New helper.
	([test] font-lock-magic): New test case.

	Reported by Kalyanov Dmitry.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/09 19:26:00	1.1739
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/10 10:11:18	1.1740
@@ -1,3 +1,19 @@
+2009-05-10  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Font-lock magic barfed on #+(test).
+
+	* slime.el (slime-eval-feature-conditional): Renamed to
+	`slime-eval-feature-expression'.
+	(slime-unknown-feature-expression): New error symbol.
+	(slime-eval-feature-expression): Signal it.
+	(slime-search-suppressed-forms): Catch it.
+	(slime-compute-region-for-font-lock): Guard against unbalanced
+	parentheses.
+	(slime-initialize-lisp-buffer-for-test-suite): New helper.
+	([test] font-lock-magic): New test case.
+
+	Reported by Kalyanov Dmitry.
+
 2009-05-09  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-source-file-cache.lisp (read-snippet-from-string): New.
--- /project/slime/cvsroot/slime/slime.el	2009/05/08 18:11:14	1.1160
+++ /project/slime/cvsroot/slime/slime.el	2009/05/10 10:11:18	1.1161
@@ -6691,7 +6691,7 @@
     (let* ((start (- (point) 2))
            (char (char-before))
            (e (read (current-buffer)))
-           (val (slime-eval-feature-conditional e)))
+           (val (slime-eval-feature-expression e)))
       (when (<= (point) limit)
         (if (or (and (eq char ?+) (not val))
                 (and (eq char ?-) val))
@@ -6719,7 +6719,9 @@
              (slime-connected-p))
     (condition-case condition
         (slime-search-suppressed-forms-internal limit)
-      (invalid-read-syntax nil)         ; ignore e.g. #+#.foo
+      (end-of-file                      nil) ; e.g. #+(
+      (invalid-read-syntax              nil) ; e.g. #+#.foo
+      (slime-unknown-feature-expression nil) ; e.g. #+(foo)
       (error 
        (slime-display-warning
         "%S:%d:%d (pt=%d).
@@ -6748,12 +6750,12 @@
       (save-match-data 
         (search-backward-regexp slime-reader-conditionals-regexp
                                 ;; We restrict the search to the
-                                ;; beginning of the /next/ defun.
+                                ;; beginning of the /previous/ defun.
                                 (save-excursion 
                                   (beginning-of-defun) (point))
                                 t)
         ;; We actually need to restrict the search to the end of the
-        ;; next defun, but we can't easily determine that end.
+        ;; previous defun, but we can't easily determine that end.
         ;; (`forward-sexp' after the `beginning-of-defun' won't work for
         ;; a conditionalized form at the top of a file.)
         ;;
@@ -6801,20 +6803,23 @@
         (setq slime-font-lock-region (cons font-lock-beg font-lock-end)))
       changedp)))
 
-(defun slime-compute-region-for-font-lock (beg end)
-  (let ((changedp nil))
-    (goto-char beg)
-    (when (plusp (nth 0 (slime-current-parser-state)))
-      ;; N.B. take initial reader-conditional into account, otherwise
-      ;; fontification wouldn't know the whole function definition may
-      ;; be suppressed. 
-      (setq beg (first (slime-region-for-extended-tlf-at-point)))
-      (setq changedp t))
-    (goto-char end)
-    (when (plusp (nth 0 (slime-current-parser-state)))
-      (setq end (second (slime-region-for-tlf-at-point)))
-      (setq changedp t))
-    (values changedp beg end)))
+(defun slime-compute-region-for-font-lock (orig-beg orig-end)
+  (condition-case nil
+      (let ((changedp nil) (beg orig-beg) (end (orig-end)))
+        (goto-char beg)
+        (when (plusp (nth 0 (slime-current-parser-state)))
+          ;; N.B. take initial reader-conditional into account, otherwise
+          ;; fontification wouldn't know the whole function definition may
+          ;; be suppressed. 
+          (setq beg (first (slime-region-for-extended-tlf-at-point)))
+          (setq changedp t))
+        (goto-char end)
+        (when (plusp (nth 0 (slime-current-parser-state)))
+          (setq end (second (slime-region-for-tlf-at-point)))
+          (setq changedp t))
+        (values changedp beg end))
+    (error   ; unbalanced parentheses: cannot determine beginning/end of tlf.
+     (values nil orig-beg orig-end))))
 
 (defun slime-extend-region-warn-infinite-loop ()
   (slime-display-warning
@@ -7514,6 +7519,75 @@
     (erase-buffer)
     ))
 
+(defun* slime-initialize-lisp-buffer-for-test-suite 
+    (&key (font-lock-magic t) (autodoc t))
+  (let ((hook lisp-mode-hook))
+    (unwind-protect
+         (progn 
+           (set (make-local-variable 'slime-highlight-suppressed-forms)
+                font-lock-magic)
+           (setq lisp-mode-hook nil)
+           (lisp-mode)
+           (slime-mode 1)
+           (when (boundp 'slime-autodoc-mode)
+             (if autodoc
+                 (slime-autodoc-mode 1)
+                 (slime-autodoc-mode -1))))
+      (setq lisp-mode-hook hook))))
+
+(def-slime-test font-lock-magic (buffer-content)
+    "foo"
+    '(("(defun *NO* (x y) (+ x y))")
+      ("(defun *NO*")
+      ("\(
+\(defun *NO*")
+      ("\)
+\(defun *NO*
+    \(
+\)")
+      ("#+#.foo
+\(defun *NO* (x y) (+ x y))")
+      ("#+#.foo
+\(defun *NO* (x ")
+      ("#+(
+\(defun *NO* (x ")
+      ("#+(test)
+\(defun *NO* (x ")
+
+      ("(eval-when (...)
+\(defun *NO* (x ")
+
+      ("(eval-when (...)
+#+(and)
+\(defun *NO* (x ")
+
+      ("#-(and) (defun *YES* (x y) (+ x y))")
+      ("
+#-(and) (defun *YES* (x y) (+ x y))
+#+(and) (defun *NO* (x y) (+ x y))")
+
+      ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))")
+
+      )
+  (slime-check-top-level)
+  (with-temp-buffer
+    (insert buffer-content)
+    (slime-initialize-lisp-buffer-for-test-suite
+     :autodoc t :font-lock-magic t)
+    ;; Can't use `font-lock-fontify-buffer' because for the case when
+    ;; `jit-lock-mode' is enabled. Jit-lock-mode fontifies only on
+    ;; actual display.
+    (font-lock-default-fontify-buffer)
+    (when (search-backward "*NO*" nil t)
+      (slime-test-expect "Not suppressed by reader conditional?"
+                         'font-lock-function-name-face
+                         (get-text-property (point) 'face)))
+    (goto-char (point-max))
+    (when (search-backward "*YES*" nil t)
+      (slime-test-expect "Suppressed by reader conditional?"
+                         'slime-reader-conditional-face
+                         (get-text-property (point) 'face)))))
+
 (def-slime-test narrowing ()
     "Check that narrowing is properly sustained."
     '()
@@ -8305,7 +8379,7 @@
   (when (looking-at slime-reader-conditionals-regexp)
     (goto-char (match-end 0))
     (let* ((plus-conditional-p (eq (char-before) ?+))
-           (result (slime-eval-feature-conditional (read (current-buffer)))))
+           (result (slime-eval-feature-expression (read (current-buffer)))))
       (unless (if plus-conditional-p result (not result))
         ;; skip this sexp
         (slime-forward-sexp)))))
@@ -8317,16 +8391,21 @@
                 name 
               (concat ":" name)))))
 
-(defun slime-eval-feature-conditional (e)
+(put 'slime-unknown-feature-expression
+     'error-conditions '(slime-unknown-feature-expression error))
+
+(defun slime-eval-feature-expression (e)
   "Interpret a reader conditional expression."
   (if (symbolp e)
       (memq (slime-keywordify e) (slime-lisp-features))
-    (funcall (ecase (slime-keywordify (car e))
-               (:and #'every)
-               (:or #'some)
-               (:not (lambda (f l) (not (apply f l)))))
-             #'slime-eval-feature-conditional
-             (cdr e))))
+      (funcall (let ((head (slime-keywordify (car e))))
+                 (case head
+                   (:and #'every)
+                   (:or #'some)
+                   (:not (lambda (f l) (not (apply f l))))
+                   (t (signal 'slime-unknown-feature-expression head))))
+               #'slime-eval-feature-expression
+               (cdr e))))
 
 ;;;;; Extracting Lisp forms from the buffer or user
 
@@ -8940,7 +9019,7 @@
           slime-region-for-tlf-at-point
           slime-region-for-extended-tlf-at-point
           slime-extend-region-for-font-lock
-          slime-search-suppressed-forms
+;          slime-search-suppressed-forms
           )))
 
 (provide 'slime)




From trittweiler at common-lisp.net  Sun May 10 10:13:17 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 10 May 2009 06:13:17 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3621-0001xM-MG@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
byte compile slime-search-suppressed-forms;
forgot that I commented it out.


--- /project/slime/cvsroot/slime/slime.el	2009/05/10 10:11:18	1.1161
+++ /project/slime/cvsroot/slime/slime.el	2009/05/10 10:13:17	1.1162
@@ -9019,7 +9019,7 @@
           slime-region-for-tlf-at-point
           slime-region-for-extended-tlf-at-point
           slime-extend-region-for-font-lock
-;          slime-search-suppressed-forms
+          slime-search-suppressed-forms
           )))
 
 (provide 'slime)




From trittweiler at common-lisp.net  Sun May 10 12:52:48 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 10 May 2009 08:52:48 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M38WO-0002hr-Is@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-compute-region-for-font-lock): Fix typo.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/10 10:11:18	1.1740
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/10 12:52:48	1.1741
@@ -1,5 +1,9 @@
 2009-05-10  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-compute-region-for-font-lock): Fix typo.
+
+2009-05-10  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Font-lock magic barfed on #+(test).
 
 	* slime.el (slime-eval-feature-conditional): Renamed to
--- /project/slime/cvsroot/slime/slime.el	2009/05/10 10:13:17	1.1162
+++ /project/slime/cvsroot/slime/slime.el	2009/05/10 12:52:48	1.1163
@@ -6805,7 +6805,9 @@
 
 (defun slime-compute-region-for-font-lock (orig-beg orig-end)
   (condition-case nil
-      (let ((changedp nil) (beg orig-beg) (end (orig-end)))
+      (let ((changedp nil)
+            (beg orig-beg)
+            (end orig-end))
         (goto-char beg)
         (when (plusp (nth 0 (slime-current-parser-state)))
           ;; N.B. take initial reader-conditional into account, otherwise




From heller at common-lisp.net  Sun May 10 17:18:03 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 10 May 2009 13:18:03 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3Cf5-0005CH-Cl@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el ([test] font-lock-magic): Add some hard cases.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/10 12:52:48	1.1741
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/10 17:18:02	1.1742
@@ -1,3 +1,7 @@
+2009-05-10  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el ([test] font-lock-magic): Add some hard cases.
+
 2009-05-10  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-compute-region-for-font-lock): Fix typo.
--- /project/slime/cvsroot/slime/slime.el	2009/05/10 12:52:48	1.1163
+++ /project/slime/cvsroot/slime/slime.el	2009/05/10 17:18:03	1.1164
@@ -7569,7 +7569,8 @@
 #+(and) (defun *NO* (x y) (+ x y))")
 
       ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))")
-
+      ("#| #+(or) |# *NO*")
+      ("#| #+(or) x |# *NO*")
       )
   (slime-check-top-level)
   (with-temp-buffer




From trittweiler at common-lisp.net  Mon May 11 08:03:40 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 11 May 2009 04:03:40 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3QU8-0007lm-Bx@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	(slime-eval-feature-expression): Guard for more erroneous
	input (due to refontification while user's typing.)


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/10 17:18:02	1.1742
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/11 08:03:39	1.1743
@@ -1,3 +1,8 @@
+2009-05-11  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	(slime-eval-feature-expression): Guard for more erroneous
+	input (due to refontification while user's typing.)
+
 2009-05-10  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el ([test] font-lock-magic): Add some hard cases.
--- /project/slime/cvsroot/slime/slime.el	2009/05/10 17:18:03	1.1164
+++ /project/slime/cvsroot/slime/slime.el	2009/05/11 08:03:39	1.1165
@@ -8399,16 +8399,18 @@
 
 (defun slime-eval-feature-expression (e)
   "Interpret a reader conditional expression."
-  (if (symbolp e)
-      (memq (slime-keywordify e) (slime-lisp-features))
-      (funcall (let ((head (slime-keywordify (car e))))
-                 (case head
-                   (:and #'every)
-                   (:or #'some)
-                   (:not (lambda (f l) (not (apply f l))))
-                   (t (signal 'slime-unknown-feature-expression head))))
-               #'slime-eval-feature-expression
-               (cdr e))))
+  (cond ((symbolp e)
+         (memq (slime-keywordify e) (slime-lisp-features)))
+        ((and (consp e) (symbolp (car e)))
+         (funcall (let ((head (slime-keywordify (car e))))
+                    (case head
+                      (:and #'every)
+                      (:or #'some)
+                      (:not (lambda (f l) (not (apply f l))))
+                      (t (signal 'slime-unknown-feature-expression head))))
+                  #'slime-eval-feature-expression
+                  (cdr e)))
+        (t (signal 'slime-unknown-feature-expression e))))
 
 ;;;;; Extracting Lisp forms from the buffer or user
 




From trittweiler at common-lisp.net  Tue May 12 17:24:49 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 12 May 2009 13:24:49 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3vij-0004wz-Vd@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el (slime-display-warning): Add `warning' as warning type.
	(slime-show-note-counts): If compilation failed, fontify the
	message in red to be more visibly apparant.


--- /project/slime/cvsroot/slime/slime.el	2009/05/11 08:03:39	1.1165
+++ /project/slime/cvsroot/slime/slime.el	2009/05/12 17:24:49	1.1166
@@ -734,7 +734,7 @@
   (apply slime-message-function format args))
 
 (defun slime-display-warning (message &rest args)
-  (display-warning 'slime (apply #'format message args)))
+  (display-warning '(slime warning) (apply #'format message args)))
 
 (when (or (featurep 'xemacs))
   (setq slime-message-function 'slime-format-display-message))
@@ -2727,8 +2727,11 @@
         (:warning             (incf nwarnings))
         (:style-warning       (incf nstyle-warnings))
         (:note                (incf nnotes))))
-    (message "Compilation %s:%s%s%s%s%s"
-             (if successp "finished" "failed")
+    (message "%s:%s%s%s%s%s"
+             (if successp 
+                 "Compilation finished" 
+                 (slime-add-face '(:foreground "Red")
+                   "Compilation failed"))
              (slime-note-count-string "error" nerrors)
              (slime-note-count-string "warning" nwarnings)
              (slime-note-count-string "style-warning" nstyle-warnings t)
@@ -5205,6 +5208,8 @@
   (add-text-properties 0 (length string) (list 'face face) string)
   string)
 
+(put 'slime-add-face 'lisp-indent-function 1)
+
 
 ;;;;; sldb-mode
 
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/11 08:03:39	1.1743
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/12 17:24:49	1.1744
@@ -1,3 +1,9 @@
+2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-display-warning): Add `warning' as warning type.
+	(slime-show-note-counts): If compilation failed, fontify the
+	message in red to be more visibly apparant.
+
 2009-05-11  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	(slime-eval-feature-expression): Guard for more erroneous




From trittweiler at common-lisp.net  Tue May 12 17:26:48 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 12 May 2009 13:26:48 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3vke-0004z2-71@common-lisp.net>

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

Modified Files:
	swank-allegro.lisp ChangeLog 
Log Message:
	* swank-allegro.lisp (find-topframe): Hide SWANK related cruft
	from showing up in backtraces in SLDB.


--- /project/slime/cvsroot/slime/swank-allegro.lisp	2009/01/10 12:25:16	1.124
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2009/05/12 17:26:48	1.125
@@ -143,10 +143,15 @@
   `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
 
 (defun find-topframe ()
-  (let ((skip-frames 3))
-    (do ((f (excl::int-newest-frame) (next-frame f))
-         (i 0 (1+ i)))
-        ((= i skip-frames) f))))
+  (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
+                              (find-package :swank)))
+        (top-frame (excl::int-newest-frame)))
+    (loop for frame = top-frame then (next-frame frame)
+          for name  = (debugger:frame-name frame)
+          for i from 0
+          when (eq name magic-symbol)
+            return (next-frame frame)
+          until (= i 10) finally (return top-frame))))
 
 (defun next-frame (frame)
   (let ((next (excl::int-next-older-frame frame)))
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/12 17:24:49	1.1744
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/12 17:26:48	1.1745
@@ -1,5 +1,10 @@
 2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-allegro.lisp (find-topframe): Hide SWANK related cruft
+	from showing up in backtraces in SLDB.
+
+2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (slime-display-warning): Add `warning' as warning type.
 	(slime-show-note-counts): If compilation failed, fontify the
 	message in red to be more visibly apparant.




From trittweiler at common-lisp.net  Tue May 12 17:37:13 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 12 May 2009 13:37:13 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3vuj-00057u-Ro@common-lisp.net>

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

Modified Files:
	swank-allegro.lisp ChangeLog 
Log Message:
	Highlight reader-errors in the source buffers on Allegro.

	* swank-allegro.lisp (*temp-file-header-end-position*): New
	variable.
	(call-with-compilation-hooks): Handle reader errors.
	(handle-compiler-warning): Adapt it accordingly.
	(location-for-reader-error): New.
	(compile-from-temp-file): Now takes a header argument explicitly
	so we can hold of the actual offset of the string we want to
	compile. This is needed to translate back file-positions reported
	in reader-errors.
	(swank-compile-string, swank-compile-file): Adapted accordingly.


--- /project/slime/cvsroot/slime/swank-allegro.lisp	2009/05/12 17:26:48	1.125
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2009/05/12 17:37:13	1.126
@@ -231,6 +231,7 @@
 (defvar *buffer-start-position*)
 (defvar *buffer-string*)
 (defvar *compile-filename* nil)
+(defvar *temp-file-header-end-position* nil)
 
 (defun compiler-note-p (object)
   (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
@@ -246,7 +247,7 @@
 
 (defun handle-compiler-warning (condition)
   (declare (optimize (debug 3) (speed 0) (space 0)))
-  (cond ((and (not *buffer-name*) 
+   (cond ((and (not *buffer-name*) 
               (compiler-undefined-functions-called-warning-p condition))
          (handle-undefined-functions-warning condition))
         (t
@@ -254,9 +255,12 @@
           :original-condition condition
           :severity (etypecase condition
                       (warning :warning)
-                      (compiler-note :note))
+                      (compiler-note :note)
+                      (reader-error :read-error))
           :message (format nil "~A" condition)
-          :location (location-for-warning condition)))))
+          :location (if (typep condition 'reader-error) 
+                        (location-for-reader-error condition)
+                        (location-for-warning condition))))))
 
 (defun location-for-warning (condition)
   (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
@@ -272,6 +276,18 @@
           (t
            (list :error "No error location available.")))))
 
+(defun location-for-reader-error (condition)
+  (let ((pos  (car (last (slot-value condition 'excl::format-arguments))))
+        (file (pathname (stream-error-stream condition))))
+    (if (integerp pos)
+        (if *buffer-name*
+            (make-location `(:buffer ,*buffer-name*)
+                           `(:offset ,*buffer-start-position*
+                                     ,(- pos *temp-file-header-end-position* 1)))
+            (make-location `(:file ,(namestring (truename file)))
+                           `(:position ,pos)))
+        (list :error "No error location available."))))
+
 (defun handle-undefined-functions-warning (condition)
   (let ((fargs (slot-value condition 'excl::format-arguments)))
     (loop for (fname . pos-file) in (car fargs) do
@@ -283,22 +299,23 @@
                                   fname)
                  :location (make-location (list :file file)
                                           (list :position (1+ pos))))))))
-
 (defimplementation call-with-compilation-hooks (function)
-  (handler-bind ((warning #'handle-compiler-warning)
-                 ;;(compiler-note #'handle-compiler-warning)
-                 )
+  (handler-bind ((warning       #'handle-compiler-warning)
+                 (compiler-note #'handle-compiler-warning)
+                 (reader-error  #'handle-compiler-warning))
     (funcall function)))
 
 (defimplementation swank-compile-file (input-file output-file 
                                        load-p external-format)
-  (with-compilation-hooks ()
-    (let ((*buffer-name* nil)
-          (*compile-filename* input-file))
-      (compile-file *compile-filename* 
-                    :output-file output-file
-                    :load-after-compile load-p
-                    :external-format external-format))))
+  (handler-case
+      (with-compilation-hooks ()
+        (let ((*buffer-name* nil)
+              (*compile-filename* input-file))
+          (compile-file *compile-filename* 
+                        :output-file output-file
+                        :load-after-compile load-p
+                        :external-format external-format)))
+    (reader-error () (values nil nil t))))
 
 (defun call-with-temp-file (fn)
   (let ((tmpname (system:make-temp-file-name)))
@@ -307,13 +324,15 @@
            (funcall fn file tmpname))
       (delete-file tmpname))))
 
-(defun compile-from-temp-file (string)
+(defun compile-from-temp-file (header string)
   (call-with-temp-file 
    (lambda (stream filename)
+     (write-string header stream)
+     (let ((*temp-file-header-end-position* (file-position stream)))
        (write-string string stream)
        (finish-output stream)
        (multiple-value-bind (binary-filename warnings? failure?)
-         (excl:without-redefinition-warnings
+           (excl:without-redefinition-warnings
              ;; Suppress Allegro's redefinition warnings; they are
              ;; pointless when we are compiling via a temporary
              ;; file.
@@ -321,7 +340,32 @@
          (declare (ignore warnings?))
          (when binary-filename
            (delete-file binary-filename))
-         (not failure?)))))
+         (not failure?))))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+                                         policy)
+  (declare (ignore policy))
+  (handler-case 
+      (with-compilation-hooks ()
+        (let ((*buffer-name* buffer)
+              (*buffer-start-position* position)
+              (*buffer-string* string)
+              (*default-pathname-defaults*
+               (if filename 
+                   (merge-pathnames (pathname filename))
+                   *default-pathname-defaults*)))
+          ;; We store the source buffer in excl::*source-pathname* as a
+          ;; string of the form <buffername>;<start-offset>.  Quite ugly
+          ;; encoding, but the fasl file is corrupted if we use some
+          ;; other datatype.
+          (compile-from-temp-file
+           (format nil "~S~%~S~%" 
+                   `(in-package ,(package-name *package*))
+                   `(eval-when (:compile-toplevel :load-toplevel)
+                      (setq excl::*source-pathname*
+                            ',(format nil "~A;~D" buffer position))))
+           string)))
+    (reader-error () (values nil nil t))))
 
 (defimplementation swank-compile-string (string &key buffer position filename
                                          policy)
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/12 17:26:48	1.1745
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/12 17:37:13	1.1746
@@ -1,5 +1,20 @@
 2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	Highlight reader-errors in the source buffers on Allegro.
+
+	* swank-allegro.lisp (*temp-file-header-end-position*): New
+	variable.
+	(call-with-compilation-hooks): Handle reader errors.
+	(handle-compiler-warning): Adapt it accordingly.
+	(location-for-reader-error): New.
+	(compile-from-temp-file): Now takes a header argument explicitly
+	so we can hold of the actual offset of the string we want to
+	compile. This is needed to translate back file-positions reported
+	in reader-errors.
+	(swank-compile-string, swank-compile-file): Adapted accordingly.
+
+2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank-allegro.lisp (find-topframe): Hide SWANK related cruft
 	from showing up in backtraces in SLDB.
 




From trittweiler at common-lisp.net  Tue May 12 18:36:04 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 12 May 2009 14:36:04 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M3wpg-0007lk-AK@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	Make font-lock-magic test case pass.

	* slime.el (slime-bug): New function.
	(slime-search-suppressed-forms): Use it.
	(slime-extend-region-warn-infinite-loop): Ditto.
	(slime-search-suppressed-forms-internal): Check whether we're
	inside a comment, or a string.
	([test] font-lock-magic): Add another case.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/12 17:37:13	1.1746
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/12 18:36:04	1.1747
@@ -1,5 +1,16 @@
 2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	Make font-lock-magic test case pass.
+
+	* slime.el (slime-bug): New function.
+	(slime-search-suppressed-forms): Use it.
+	(slime-extend-region-warn-infinite-loop): Ditto.
+	(slime-search-suppressed-forms-internal): Check whether we're
+	inside a comment, or a string.
+	([test] font-lock-magic): Add another case.
+
+2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Highlight reader-errors in the source buffers on Allegro.
 
 	* swank-allegro.lisp (*temp-file-header-end-position*): New
--- /project/slime/cvsroot/slime/slime.el	2009/05/12 17:24:49	1.1166
+++ /project/slime/cvsroot/slime/slime.el	2009/05/12 18:36:04	1.1167
@@ -795,6 +795,27 @@
                            (or (position ?\n string) most-positive-fixnum)
                            (1- (frame-width)))))
 
+(defun slime-bug (message &rest args)
+  (slime-display-warning 
+"%S:%d:%d (pt=%d).
+%s
+
+This is a bug in Slime itself. Please report this to the
+mailinglist slime-devel at common-lisp.net and include your Emacs
+version, the guilty Lisp source file, the header of this
+message, and the following backtrace.
+
+Backtrace:
+%s
+--------------------------------------------------------------
+"
+        (buffer-name)
+        (line-number-at-pos)
+        (current-column)
+        (point)
+        (apply #'format message args)
+        (with-output-to-string (backtrace))))
+
 ;; Interface
 (defun slime-set-truncate-lines ()
   "Apply `slime-truncate-lines' to the current buffer."
@@ -833,6 +854,12 @@
 
 (put 'slime-propertize-region 'lisp-indent-function 1)
 
+(defun slime-add-face (face string)
+  (add-text-properties 0 (length string) (list 'face face) string)
+  string)
+
+(put 'slime-add-face 'lisp-indent-function 1)
+
 ;; Interface
 (defsubst slime-insert-propertized (props &rest args)
   "Insert all ARGS and then add text-PROPS to the inserted text."
@@ -5204,12 +5231,6 @@
 
 (put 'in-sldb-face 'lisp-indent-function 1)
 
-(defun slime-add-face (face string)
-  (add-text-properties 0 (length string) (list 'face face) string)
-  string)
-
-(put 'slime-add-face 'lisp-indent-function 1)
-
 
 ;;;;; sldb-mode
 
@@ -6693,30 +6714,34 @@
 
 (defun slime-search-suppressed-forms-internal (limit)
   (when (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t)
-    (let* ((start (- (point) 2))
-           (char (char-before))
-           (e (read (current-buffer)))
-           (val (slime-eval-feature-expression e)))
-      (when (<= (point) limit)
-        (if (or (and (eq char ?+) (not val))
-                (and (eq char ?-) val))
-            (progn
-              (forward-sexp) (backward-sexp)
-              (slime-forward-sexp)
-              ;; There was an `ignore-errors' form around all this
-              ;; because the following assertion was triggered
-              ;; regularly (resulting in the "non-deterministic"
-              ;; behaviour mentioned in the comment further below.)
-              ;; With extending the region properly, this assertion
-              ;; would truly mean a bug now.
-              (assert (<= (point) limit))
-              (let ((md (match-data)))
-                (fill md nil)
-                (setf (first md) start)
-                (setf (second md) (point))
-                (set-match-data md)
-                t))
-            (slime-search-suppressed-forms-internal limit))))))
+    (if (let ((state (slime-current-parser-state)))
+          (or (nth 3 state)             ; inside string?
+              (nth 4 state)))           ; inside comment?
+        (slime-search-suppressed-forms-internal limit)
+      (let* ((start (- (point) 2))
+             (char (char-before))
+             (e (read (current-buffer)))
+             (val (slime-eval-feature-expression e)))
+        (when (<= (point) limit)
+          (if (or (and (eq char ?+) (not val))
+                  (and (eq char ?-) val))
+              (progn
+                (forward-sexp) (backward-sexp)
+                (slime-forward-sexp)
+                ;; There was an `ignore-errors' form around all this
+                ;; because the following assertion was triggered
+                ;; regularly (resulting in the "non-deterministic"
+                ;; behaviour mentioned in the comment further below.)
+                ;; With extending the region properly, this assertion
+                ;; would truly mean a bug now.
+                (assert (<= (point) limit))
+                (let ((md (match-data)))
+                  (fill md nil)
+                  (setf (first md) start)
+                  (setf (second md) (point))
+                  (set-match-data md)
+                  t))
+              (slime-search-suppressed-forms-internal limit)))))))
 
 (defun slime-search-suppressed-forms (limit)
   "Find reader conditionalized forms where the test is false."
@@ -6727,21 +6752,10 @@
       (end-of-file                      nil) ; e.g. #+(
       (invalid-read-syntax              nil) ; e.g. #+#.foo
       (slime-unknown-feature-expression nil) ; e.g. #+(foo)
+      (scan-error                       nil) ; e.g. #| #+(or) #|
       (error 
-       (slime-display-warning
-        "%S:%d:%d (pt=%d).
-Caught error during fontification while searching for forms that
-are suppressed by reader-conditionals. The error was: %S.
-
-This is a bug in Slime itself. Please report this to the
-mailinglist slime-devel at common-lisp.net and include your Emacs
-version, the guilty Lisp source file, and the header of this
-message.
-"
-        (buffer-name)
-        (line-number-at-pos)
-        (current-column)
-        (point)
+       (slime-bug "Caught error during fontification while searching for forms that
+are suppressed by reader-conditionals. The error was: %S."
         condition)))))
 
 (defun slime-region-for-extended-tlf-at-point ()
@@ -6829,16 +6843,11 @@
      (values nil orig-beg orig-end))))
 
 (defun slime-extend-region-warn-infinite-loop ()
-  (slime-display-warning
-   "%S:%d:%d (pt=%d).
-Prevented infinite loop during fontification. This is a bug in Slime itself.
+  (slime-bug
+   "Prevented infinite loop during fontification. This is a bug in Slime itself.
 Please report this to the mailinglist slime-devel at common-lisp.net and include
 your Emacs version, the guilty Lisp source file, and the header of this 
-message."
-   (buffer-name)
-   (line-number-at-pos)
-   (current-column)
-   (point)))
+message."))
 
 ;;; FIXME: This is supposed to be the value for
 ;;; `font-lock-mark-block-function' (so M-o M-o will DTRT), but I
@@ -7576,6 +7585,7 @@
       ("#+(and) (defun *NO* (x y) #-(and) (+ *YES* y))")
       ("#| #+(or) |# *NO*")
       ("#| #+(or) x |# *NO*")
+      ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*")
       )
   (slime-check-top-level)
   (with-temp-buffer
@@ -7588,8 +7598,9 @@
     (font-lock-default-fontify-buffer)
     (when (search-backward "*NO*" nil t)
       (slime-test-expect "Not suppressed by reader conditional?"
-                         'font-lock-function-name-face
-                         (get-text-property (point) 'face)))
+                         'slime-reader-conditional-face
+                         (get-text-property (point) 'face)
+                         #'(lambda (x y) (not (eq x y)))))
     (goto-char (point-max))
     (when (search-backward "*YES*" nil t)
       (slime-test-expect "Suppressed by reader conditional?"




From trittweiler at common-lisp.net  Wed May 13 18:51:27 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 13 May 2009 14:51:27 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M4JY7-0004VH-6y@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-search-suppressed-forms): On errors, we have to
	continue the search, otherwise there's a chance that we miss
	reader conditionals in the current font-lock region.
	(slime-search-backward-reader-conditional): New. Extracted from
	`slime-region-for-extended-tlf-at-point'.
	(slime-region-for-extended-tlf-at-point): Use it.
	(slime-font-lock-region): Removed.
	(slime-font-lock-region-changed-p): Removed.
	(slime-extend-region-for-font-lock): Simplified.
	(slime-compute-region-for-font-lock): Make sure that we never
	return a flag indicating change when there was in fact no
	change. This should make the explicit guard against infinite loop
	superfluous.
	(slime-extend-region-warn-infinite-loop): Removed.
	([test] font-lock-magic): More cases.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/12 18:36:04	1.1747
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/13 18:51:26	1.1748
@@ -1,5 +1,23 @@
 2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-search-suppressed-forms): On errors, we have to
+	continue the search, otherwise there's a chance that we miss
+	reader conditionals in the current font-lock region.
+	(slime-search-backward-reader-conditional): New. Extracted from
+	`slime-region-for-extended-tlf-at-point'.
+	(slime-region-for-extended-tlf-at-point): Use it.
+	(slime-font-lock-region): Removed.
+	(slime-font-lock-region-changed-p): Removed.
+	(slime-extend-region-for-font-lock): Simplified.
+	(slime-compute-region-for-font-lock): Make sure that we never
+	return a flag indicating change when there was in fact no
+	change. This should make the explicit guard against infinite loop
+	superfluous.
+	(slime-extend-region-warn-infinite-loop): Removed.
+	([test] font-lock-magic): More cases.
+
+2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Make font-lock-magic test case pass.
 
 	* slime.el (slime-bug): New function.
--- /project/slime/cvsroot/slime/slime.el	2009/05/12 18:36:04	1.1167
+++ /project/slime/cvsroot/slime/slime.el	2009/05/13 18:51:26	1.1168
@@ -6746,16 +6746,25 @@
 (defun slime-search-suppressed-forms (limit)
   "Find reader conditionalized forms where the test is false."
   (when (and slime-highlight-suppressed-forms
-             (slime-connected-p))
+             (slime-connected-p)
+             (<= (point) limit))
     (condition-case condition
         (slime-search-suppressed-forms-internal limit)
-      (end-of-file                      nil) ; e.g. #+(
-      (invalid-read-syntax              nil) ; e.g. #+#.foo
-      (slime-unknown-feature-expression nil) ; e.g. #+(foo)
-      (scan-error                       nil) ; e.g. #| #+(or) #|
+      (end-of-file                      ; e.g. #+(
+       nil) 
+      ;; We found a reader conditional we couldn't process for some
+      ;; reason; however, there may still be other reader conditionals
+      ;; before `limit'.
+      (invalid-read-syntax              ; e.g. #+#.foo
+       (slime-search-suppressed-forms limit))
+      (scan-error                       ; e.g. #| #+(or) #|
+       (slime-search-suppressed-forms limit)) 
+      (slime-unknown-feature-expression ; e.g. #+(foo)
+       (slime-search-suppressed-forms limit)) 
       (error 
-       (slime-bug "Caught error during fontification while searching for forms that
-are suppressed by reader-conditionals. The error was: %S."
+       (slime-bug 
+        (concat "Caught error during fontification while searching for forms\n"
+                "that are suppressed by reader-conditionals. The error was: %S.")
         condition)))))
 
 (defun slime-region-for-extended-tlf-at-point ()
@@ -6766,34 +6775,29 @@
       (goto-char start)
       ;; At this point we want to watch out for a possibly preceding
       ;; reader conditional..
-      (save-match-data 
-        (search-backward-regexp slime-reader-conditionals-regexp
-                                ;; We restrict the search to the
-                                ;; beginning of the /previous/ defun.
-                                (save-excursion 
-                                  (beginning-of-defun) (point))
-                                t)
-        ;; We actually need to restrict the search to the end of the
-        ;; previous defun, but we can't easily determine that end.
-        ;; (`forward-sexp' after the `beginning-of-defun' won't work for
-        ;; a conditionalized form at the top of a file.)
-        ;;
-        ;; As a result, we may be slipped into another defun here, so we
-        ;; have to check against that:
-        (if (zerop (nth 0 (slime-current-parser-state)))
-            (list (point) end)
-            (list start   end))))))
-
-(make-variable-buffer-local
- (defvar slime-font-lock-region (cons -1 -1)
-   "These are the values of `font-lock-beg' and `font-lock-end' of
-the last font-lock extend-region phase."))
-
-(defun slime-font-lock-region-changed-p (font-lock-beg font-lock-end)
-  "Did `font-lock-beg', `font-lock-end' change since last extending phase?"
-  (destructuring-bind (old-beg . old-end) slime-font-lock-region
-     (or (/= old-beg font-lock-beg) 
-         (/= old-end font-lock-end))))
+      (let ((point (slime-search-backward-reader-conditional)))
+        (if point
+            (list point end)
+            (list start end))))))
+
+(defun slime-search-backward-reader-conditional ()
+  (save-excursion
+    (save-match-data 
+      (and (search-backward-regexp slime-reader-conditionals-regexp
+                                   ;; We restrict the search to the
+                                   ;; beginning of the /previous/ defun.
+                                   (save-excursion 
+                                     (beginning-of-defun) (point))
+                                   t)
+           ;; We actually need to restrict the search to the end of the
+           ;; previous defun, but we can't easily determine that end.
+           ;; (`forward-sexp' after the `beginning-of-defun' won't work for
+           ;; a conditionalized form at the top of a file.)
+           ;;
+           ;; As a result, we may be slipped into another defun here, so we
+           ;; have to check against that:
+           (zerop (nth 0 (slime-current-parser-state)))
+           (point)))))
 
 ;;; We'll push this onto `font-lock-extend-region-functions'. In past,
 ;;; we didn't do so which made our reader-conditional font-lock magic
@@ -6807,48 +6811,32 @@
 ;;; reader-conditional, or point in mid of one.
 (defun slime-extend-region-for-font-lock ()
   (when (and slime-highlight-suppressed-forms (slime-connected-p))
-    (when (slime-font-lock-region-changed-p font-lock-beg font-lock-end)
-      ;; We're in a new extending phase, so reinitialize the values.
-      (setq slime-font-lock-region (cons -1 -1)))
     (let (changedp)
       (multiple-value-setq (changedp font-lock-beg font-lock-end)
         (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
-      (when changedp
-        ;; Guard against infinite loops:
-        (when (not (slime-font-lock-region-changed-p font-lock-beg font-lock-end))
-          (slime-extend-region-warn-infinite-loop)
-          (setq changedp nil))
-        ;; Update values. (N.B. cannot be done prior.)
-        (setq slime-font-lock-region (cons font-lock-beg font-lock-end)))
       changedp)))
 
 (defun slime-compute-region-for-font-lock (orig-beg orig-end)
   (condition-case nil
-      (let ((changedp nil)
-            (beg orig-beg)
+      (let ((beg orig-beg)
             (end orig-end))
         (goto-char beg)
-        (when (plusp (nth 0 (slime-current-parser-state)))
-          ;; N.B. take initial reader-conditional into account, otherwise
-          ;; fontification wouldn't know the whole function definition may
-          ;; be suppressed. 
-          (setq beg (first (slime-region-for-extended-tlf-at-point)))
-          (setq changedp t))
+        ;; N.B. take preceding reader-conditional into account (even
+        ;; when we're at the toplevel!), otherwise fontification
+        ;; wouldn't know the whole function definition may be
+        ;; suppressed.
+        (cond ((plusp (nth 0 (slime-current-parser-state)))
+               (setq beg (first (slime-region-for-extended-tlf-at-point))))
+              ((setq beg (or (search-backward-reader-conditional)
+                             orig-beg))))
         (goto-char end)
-        (when (plusp (nth 0 (slime-current-parser-state)))
-          (setq end (second (slime-region-for-tlf-at-point)))
-          (setq changedp t))
-        (values changedp beg end))
+        (when (or (plusp (nth 0 (slime-current-parser-state)))
+                  (search-backward-reader-conditional))
+          (setq end (second (slime-region-for-tlf-at-point))))
+        (values (or (/= beg orig-beg) (/= end orig-end)) beg end))
     (error   ; unbalanced parentheses: cannot determine beginning/end of tlf.
      (values nil orig-beg orig-end))))
 
-(defun slime-extend-region-warn-infinite-loop ()
-  (slime-bug
-   "Prevented infinite loop during fontification. This is a bug in Slime itself.
-Please report this to the mailinglist slime-devel at common-lisp.net and include
-your Emacs version, the guilty Lisp source file, and the header of this 
-message."))
-
 ;;; FIXME: This is supposed to be the value for
 ;;; `font-lock-mark-block-function' (so M-o M-o will DTRT), but I
 ;;; couldn't so far figure out how to customize that variable.
@@ -7586,6 +7574,19 @@
       ("#| #+(or) |# *NO*")
       ("#| #+(or) x |# *NO*")
       ("*NO* \"#| *NO* #+(or) x |# *NO*\" *NO*")
+      ("#+#.foo (defun foo (bar))
+#-(and) *YES* *NO* bar
+")
+      ("#+(foo) (defun foo (bar))
+#-(and) *YES* *NO* bar")
+      ("#| #+(or) |# *NO* foo
+#-(and) *YES* *NO*")
+      ("#- (and)
+\(*YES*)
+\(*NO*)
+#-(and)
+\(*YES*)
+\(*NO*)")
       )
   (slime-check-top-level)
   (with-temp-buffer
@@ -9040,6 +9041,7 @@
           slime-region-for-tlf-at-point
           slime-region-for-extended-tlf-at-point
           slime-extend-region-for-font-lock
+          slime-search-backward-reader-conditional
           slime-search-suppressed-forms
           )))
 




From trittweiler at common-lisp.net  Thu May 14 13:57:11 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 14 May 2009 09:57:11 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M4bQt-0005w0-6d@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-compute-region-for-font-lock): Fix typo.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/13 18:51:26	1.1748
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/14 13:57:10	1.1749
@@ -1,4 +1,8 @@
-2009-05-12  Tobias C. Rittweiler  <tcr at freebits.de>
+2009-05-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-compute-region-for-font-lock): Fix typo.
+
+2009-05-13  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-search-suppressed-forms): On errors, we have to
 	continue the search, otherwise there's a chance that we miss
--- /project/slime/cvsroot/slime/slime.el	2009/05/13 18:51:26	1.1168
+++ /project/slime/cvsroot/slime/slime.el	2009/05/14 13:57:10	1.1169
@@ -809,12 +809,12 @@
 %s
 --------------------------------------------------------------
 "
-        (buffer-name)
-        (line-number-at-pos)
-        (current-column)
-        (point)
-        (apply #'format message args)
-        (with-output-to-string (backtrace))))
+   (buffer-name)
+   (line-number-at-pos)
+   (current-column)
+   (point)
+   (apply #'format message args)
+   (with-output-to-string (backtrace))))
 
 ;; Interface
 (defun slime-set-truncate-lines ()
@@ -6781,6 +6781,7 @@
             (list start end))))))
 
 (defun slime-search-backward-reader-conditional ()
+  "Search for a directly preceding reader conditional."
   (save-excursion
     (save-match-data 
       (and (search-backward-regexp slime-reader-conditionals-regexp
@@ -6825,13 +6826,13 @@
         ;; when we're at the toplevel!), otherwise fontification
         ;; wouldn't know the whole function definition may be
         ;; suppressed.
-        (cond ((plusp (nth 0 (slime-current-parser-state)))
-               (setq beg (first (slime-region-for-extended-tlf-at-point))))
-              ((setq beg (or (search-backward-reader-conditional)
-                             orig-beg))))
+        (if (plusp (nth 0 (slime-current-parser-state)))
+            (setq beg (first (slime-region-for-extended-tlf-at-point)))
+            (setq beg (or (slime-search-backward-reader-conditional)
+                          orig-beg)))
         (goto-char end)
         (when (or (plusp (nth 0 (slime-current-parser-state)))
-                  (search-backward-reader-conditional))
+                  (slime-search-backward-reader-conditional))
           (setq end (second (slime-region-for-tlf-at-point))))
         (values (or (/= beg orig-beg) (/= end orig-end)) beg end))
     (error   ; unbalanced parentheses: cannot determine beginning/end of tlf.




From trittweiler at common-lisp.net  Thu May 14 14:41:47 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 14 May 2009 10:41:47 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M4c83-0000ER-IE@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-region-for-tlf-at-point): Use
	`(end-of-defun) (backward-sexp)' rather than
	`(end-of-defun) (beginning-of-defun' to go to the start of the
	current defun. The latter would fail on "() (a\nb\nc)".


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/14 13:57:10	1.1749
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/14 14:41:47	1.1750
@@ -1,5 +1,12 @@
 2009-05-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-region-for-tlf-at-point): Use
+	`(end-of-defun) (backward-sexp)' rather than
+	`(end-of-defun) (beginning-of-defun' to go to the start of the
+	current defun. The latter would fail on "() (a\nb\nc)".
+
+2009-05-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (slime-compute-region-for-font-lock): Fix typo.
 
 2009-05-13  Tobias C. Rittweiler  <tcr at freebits.de>
--- /project/slime/cvsroot/slime/slime.el	2009/05/14 13:57:10	1.1169
+++ /project/slime/cvsroot/slime/slime.el	2009/05/14 14:41:47	1.1170
@@ -6835,7 +6835,7 @@
                   (slime-search-backward-reader-conditional))
           (setq end (second (slime-region-for-tlf-at-point))))
         (values (or (/= beg orig-beg) (/= end orig-end)) beg end))
-    (error   ; unbalanced parentheses: cannot determine beginning/end of tlf.
+    (error ; unbalanced parentheses: cannot determine beginning/end of tlf.
      (values nil orig-beg orig-end))))
 
 ;;; FIXME: This is supposed to be the value for
@@ -7541,7 +7541,9 @@
       (setq lisp-mode-hook hook))))
 
 (def-slime-test font-lock-magic (buffer-content)
-    "foo"
+    "Some testing for the font-lock-magic. *YES* should be
+    highlighted as a suppressed form, *NO* should not."
+
     '(("(defun *NO* (x y) (+ x y))")
       ("(defun *NO*")
       ("\(
@@ -8458,7 +8460,7 @@
     (save-match-data
       ;; Position us at the beginning of the current defun.
       (end-of-defun) 
-      (beginning-of-defun)
+      (backward-sexp)
       (while (not (zerop (nth 0 (slime-current-parser-state))))
         ;; We go upwards, not downwards, to hopefully give the parser
         ;; state enough context to be accurate.




From trittweiler at common-lisp.net  Thu May 14 18:13:22 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 14 May 2009 14:13:22 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M4fQo-0000Zq-6t@common-lisp.net>

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

Modified Files:
	ChangeLog swank-fancy-inspector.lisp 
Log Message:
	Optionally sort slots displayed for STANDARD-OBJECTS not
	alphabetically, but by inheritance. That is group the slots
	according to the class they're direct slots of.

	* swank-fancy-inspector.lisp ([struct] inspector-checklist): New
	slot `count'.
	(make-checklist-button): Adapted accordingly.
	(reinitialize-checklist): New.
	(box, ref, (setf ref)): New.
	(all-slots-for-inspector): Add button to group slots by
	inheritance rather than alphabetically. Adapted accordingly.
	(list-all-slots-by-inheritance): New. Does the bulk work.
	(make-slot-listing): Factored out from `all-slots-for-inspector'.
	(slot-home-class-using-class): New helper.
	(stable-sort-by-inheritance): Also new.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/08 18:00:49	1.205
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/14 18:13:21	1.206
@@ -1,3 +1,21 @@
+2009-05-14  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Optionally sort slots displayed for STANDARD-OBJECTS not
+	alphabetically, but by inheritance. That is group the slots
+	according to the class they're direct slots of.
+
+	* swank-fancy-inspector.lisp ([struct] inspector-checklist): New
+	slot `count'.
+	(make-checklist-button): Adapted accordingly.
+	(reinitialize-checklist): New.
+	(box, ref, (setf ref)): New.
+	(all-slots-for-inspector): Add button to group slots by
+	inheritance rather than alphabetically. Adapted accordingly.
+	(list-all-slots-by-inheritance): New. Does the bulk work.
+	(make-slot-listing): Factored out from `all-slots-for-inspector'.
+	(slot-home-class-using-class): New helper.
+	(stable-sort-by-inheritance): Also new.
+
 2009-05-08  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	The inspector page for standard-objects does not append
--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2009/05/08 18:00:49	1.20
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2009/05/14 18:13:21	1.21
@@ -164,13 +164,22 @@
 
 (defstruct (inspector-checklist (:conc-name checklist.)
                                  (:constructor %make-checklist (buttons)))
-  (buttons nil :type (or null simple-vector)))
+  (buttons nil :type (or null simple-vector))
+  (count   0))
 
 (defun make-checklist (n)
   (%make-checklist (make-array n :initial-element nil)))
 
-(defun make-checklist-button (i checklist)
-  (let ((buttons (checklist.buttons checklist)))
+(defun reinitialize-checklist (checklist)
+  ;; Along this counter the buttons are created, so we have to
+  ;; initialize it to 0 everytime the inspector page is redisplayed.
+  (setf (checklist.count checklist) 0)
+  checklist)
+
+(defun make-checklist-button (checklist)
+  (let ((buttons (checklist.buttons checklist))
+        (i (checklist.count checklist)))
+    (incf (checklist.count checklist))
     `(:action ,(if (svref buttons i)
                    "[X]"
                    "[ ]")
@@ -186,10 +195,18 @@
           (when (svref ,buttons ,idx)
             , at body)))))
 
+(defun box (thing) (cons :box thing))
+(defun ref (box)
+  (assert (eq (car box) :box))
+  (cdr box))
+(defun (setf ref) (value box)
+  (assert (eq (car box) :box))
+  (setf (cdr box) value))
+
 (defgeneric all-slots-for-inspector (object)
   (:method ((object standard-object))
-    (let* ((class (class-of object))
-           (direct-slots (swank-mop:class-direct-slots class))
+    (let* ((class           (class-of object))
+           (direct-slots    (swank-mop:class-direct-slots class))
            (effective-slots (sort (copy-seq (swank-mop:class-slots class))
                                   #'string< :key #'swank-mop:slot-definition-name))
            (longest-slot-name-length
@@ -197,45 +214,111 @@
                   maximize (length (symbol-name
                                     (swank-mop:slot-definition-name slot)))))
            (checklist
-            (ensure-istate-metadata object :checklist
-                                    (make-checklist (length effective-slots)))))
-      (append '("--------------------" (:newline)
-                "All Slots:" (:newline))
-              (loop
-                for effective-slot :in effective-slots
-                for direct-slot    = (find (swank-mop:slot-definition-name effective-slot)
-                                           direct-slots :key #'swank-mop:slot-definition-name)
-                for slot-name      = (inspector-princ
-                                      (swank-mop:slot-definition-name effective-slot))
-                for padding-length = (- longest-slot-name-length
-                                        (length (symbol-name
-                                                 (swank-mop:slot-definition-name
-                                                  effective-slot))))
-                for i from 0
-                collect (make-checklist-button i checklist)
-                collect "  "
-                collect `(:value ,(if direct-slot
-                                      (list direct-slot effective-slot)
-                                      effective-slot)
-                                 ,slot-name)
-                collect (make-string padding-length :initial-element #\Space)
-                collect " = "
-                collect (slot-value-for-inspector class object effective-slot)
-                collect '(:newline))
+            (reinitialize-checklist
+             (ensure-istate-metadata object :checklist
+                                       (make-checklist (length effective-slots)))))
+           (grouping-kind
+            ;; We box the value so we can re-set it.
+            (ensure-istate-metadata object :grouping-kind (box :alphabetically)))
+           (effective-slots
+            ;; We need this rebinding because the this list must be in
+            ;; the same order as they checklist buttons are created.
+            (ecase (ref grouping-kind)
+              (:alphabetically effective-slots)
+              (:inheritance    (stable-sort-by-inheritance effective-slots class)))))
+      `("--------------------"
+        (:newline)
+        "  "
+        (:action ,(case (ref grouping-kind)
+                    (:alphabetically "[group slots by inheritance]")
+                    (:inheritance    "[group slots alphabetically]"))
+                 ,(lambda ()
+                    ;; We have to do this as the order of slots will
+                    ;; be sorted differently.
+                    (fill (checklist.buttons checklist) nil)
+                    (case (ref grouping-kind)
+                      (:alphabetically (setf (ref grouping-kind) :inheritance))
+                      (:inheritance    (setf (ref grouping-kind) :alphabetically))))
+                 :refreshp t)
+        (:newline)
+        ,@ (case (ref grouping-kind)
+             (:alphabetically
               `((:newline)
-                (:action "[set value]"
-                         ,(lambda ()
-                            (do-checklist (idx checklist)
-                              (query-and-set-slot class object (nth idx effective-slots))))
-                         :refreshp t)
-                "  "
-                (:action "[make unbound]"
-                         ,(lambda ()
-                            (do-checklist (idx checklist)
-                              (swank-mop:slot-makunbound-using-class
-                               class object (nth idx effective-slots))))
-                         :refreshp t)
-                )))))
+                "All Slots:"
+                (:newline)
+                ,@(make-slot-listing checklist object class
+                                     effective-slots direct-slots
+                                     longest-slot-name-length)))
+             (:inheritance
+              (list-all-slots-by-inheritance checklist object class
+                                             effective-slots direct-slots
+                                             longest-slot-name-length)))
+        (:newline)
+        (:action "[set value]"
+                 ,(lambda ()
+                    (do-checklist (idx checklist)
+                      (query-and-set-slot class object (nth idx effective-slots))))
+                 :refreshp t)
+        "  "
+        (:action "[make unbound]"
+                 ,(lambda ()
+                    (do-checklist (idx checklist)
+                      (swank-mop:slot-makunbound-using-class
+                       class object (nth idx effective-slots))))
+                 :refreshp t)
+        (:newline)
+        ))))
+
+(defun list-all-slots-by-inheritance (checklist object class effective-slots direct-slots
+                                      longest-slot-name-length)
+  (flet ((slot-home-class (slot)
+           (slot-home-class-using-class slot class)))
+    (let ((current-slots '()))
+      (append
+       (loop for slot in effective-slots
+             for previous-home-class = (slot-home-class slot) then home-class
+             for home-class = previous-home-class then (slot-home-class slot)
+             if (eq home-class previous-home-class)
+               do (push slot current-slots)
+             else
+               collect '(:newline)
+               and collect (format nil "~A:" (class-name previous-home-class))
+               and collect '(:newline)
+               and append (make-slot-listing checklist object class
+                                             (nreverse current-slots) direct-slots
+                                             longest-slot-name-length)
+               and do (setf current-slots (list slot)))
+       (and current-slots
+            `((:newline)
+              ,(format nil "~A:"
+                       (class-name (slot-home-class-using-class
+                                    (car current-slots) class)))
+              (:newline)
+              ,@(make-slot-listing checklist object class
+                                   (nreverse current-slots) direct-slots
+                                   longest-slot-name-length)))))))
+
+(defun make-slot-listing (checklist object class effective-slots direct-slots
+                          longest-slot-name-length)
+  (flet ((padding-for (slot-name)
+           (make-string (- longest-slot-name-length (length slot-name))
+                        :initial-element #\Space)))
+    (loop
+      for effective-slot :in effective-slots
+      for direct-slot = (find (swank-mop:slot-definition-name effective-slot)
+                              direct-slots :key #'swank-mop:slot-definition-name)
+      for slot-name   = (inspector-princ
+                         (swank-mop:slot-definition-name effective-slot))
+      collect (make-checklist-button checklist)
+      collect "  "
+      collect `(:value ,(if direct-slot
+                            (list direct-slot effective-slot)
+                            effective-slot)
+                       ,slot-name)
+      collect (padding-for slot-name)
+      collect " = "
+      collect (slot-value-for-inspector class object effective-slot)
+      collect '(:newline))))
 
 (defgeneric slot-value-for-inspector (class object slot)
   (:method (class object slot)
@@ -244,6 +327,18 @@
           `(:value ,(swank-mop:slot-value-using-class class object slot))
           "#<unbound>"))))
 
+(defun slot-home-class-using-class (slot class)
+  (let ((slot-name (swank-mop:slot-definition-name slot)))
+    (loop for class in (reverse (swank-mop:class-precedence-list class))
+          thereis (and (member slot-name (swank-mop:class-direct-slots class)
+                               :key #'swank-mop:slot-definition-name :test #'eq)
+                       class))))
+
+(defun stable-sort-by-inheritance (slots class)
+  (stable-sort slots #'string< 
+               :key #'(lambda (s)
+                        (class-name (slot-home-class-using-class s class)))))
+
 (defun query-and-set-slot (class object slot)
   (let* ((slot-name (swank-mop:slot-definition-name slot))
          (value-string (read-from-minibuffer-in-emacs




From trittweiler at common-lisp.net  Fri May 15 18:18:27 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 15 May 2009 14:18:27 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M51zH-0005EY-Tn@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	Rewrote some parts of the font-lock-magic in face of its fragility
	over the last days. Hopefully it'll be better now.

	* slime.el (slime-region-for-tlf-at-point): Removed. Not needed
	anymore.
	(slime-region-for-extended-tlf-at-point): Removed.
	(slime-search-backward-reader-conditional): Removed.
	(slime-search-directly-preceding-reader-conditional):
	New. Similiar to the above.
	(slime-extend-region-for-font-lock): Display bug message when
	error is caught.
	(slime-compute-region-for-font-lock): Rewritten.
	([test] font-lock-magic): Another test case.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/14 14:41:47	1.1750
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/15 18:18:27	1.1751
@@ -1,3 +1,19 @@
+2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Rewrote some parts of the font-lock-magic in face of its fragility
+	over the last days. Hopefully it'll be better now.
+
+	* slime.el (slime-region-for-tlf-at-point): Removed. Not needed
+	anymore.
+	(slime-region-for-extended-tlf-at-point): Removed.
+	(slime-search-backward-reader-conditional): Removed.
+	(slime-search-directly-preceding-reader-conditional):
+	New. Similiar to the above.
+	(slime-extend-region-for-font-lock): Display bug message when
+	error is caught.
+	(slime-compute-region-for-font-lock): Rewritten.
+	([test] font-lock-magic): Another test case.
+
 2009-05-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-region-for-tlf-at-point): Use
--- /project/slime/cvsroot/slime/slime.el	2009/05/14 14:41:47	1.1170
+++ /project/slime/cvsroot/slime/slime.el	2009/05/15 18:18:27	1.1171
@@ -6767,38 +6767,35 @@
                 "that are suppressed by reader-conditionals. The error was: %S.")
         condition)))))
 
-(defun slime-region-for-extended-tlf-at-point ()
-  "Like `slime-region-for-tlf-at-point' except we take
-preceding reader conditionals into account."
-  (destructuring-bind (start end) (slime-region-for-tlf-at-point)
-    (save-excursion
-      (goto-char start)
-      ;; At this point we want to watch out for a possibly preceding
-      ;; reader conditional..
-      (let ((point (slime-search-backward-reader-conditional)))
-        (if point
-            (list point end)
-            (list start end))))))
 
-(defun slime-search-backward-reader-conditional ()
-  "Search for a directly preceding reader conditional."
-  (save-excursion
-    (save-match-data 
-      (and (search-backward-regexp slime-reader-conditionals-regexp
-                                   ;; We restrict the search to the
-                                   ;; beginning of the /previous/ defun.
-                                   (save-excursion 
-                                     (beginning-of-defun) (point))
-                                   t)
-           ;; We actually need to restrict the search to the end of the
-           ;; previous defun, but we can't easily determine that end.
-           ;; (`forward-sexp' after the `beginning-of-defun' won't work for
-           ;; a conditionalized form at the top of a file.)
-           ;;
-           ;; As a result, we may be slipped into another defun here, so we
-           ;; have to check against that:
-           (zerop (nth 0 (slime-current-parser-state)))
-           (point)))))
+(defun slime-search-directly-preceding-reader-conditional ()
+  "Search for a directly preceding reader conditional. Return its
+position, or nil."
+  ;;; We search for a preceding reader conditional. Then we check that
+  ;;; between the reader conditional and the point where we started is
+  ;;; no other intervening sexp, and we check that the reader
+  ;;; conditional is at the same nesting level.
+  (let ((orig-pt (point)))
+    (multiple-value-bind (reader-conditional-pt parser-state)
+        (save-excursion
+          (when-let (pt (search-backward-regexp slime-reader-conditionals-regexp
+                                                ;; We restrict the search to the
+                                                ;; beginning of the /previous/ defun.
+                                                (save-match-data
+                                                  (save-excursion
+                                                    (beginning-of-defun) (point)))
+                                                t))
+            (values pt (parse-partial-sexp (progn (goto-char (+ pt 2))
+                                                  (forward-sexp) ; skip feature expr.
+                                                  (point))
+                                           orig-pt))))
+      (let ((paren-depth  (nth 0 parser-state))
+            (last-sexp-pt (nth 2 parser-state)))
+        (if (and paren-depth (not (plusp paren-depth)) ; no opening parenthesis in between?
+                 (not last-sexp-pt))                   ; no complete sexp in between?
+            reader-conditional-pt
+            nil)))))
+
 
 ;;; We'll push this onto `font-lock-extend-region-functions'. In past,
 ;;; we didn't do so which made our reader-conditional font-lock magic
@@ -6812,46 +6809,38 @@
 ;;; reader-conditional, or point in mid of one.
 (defun slime-extend-region-for-font-lock ()
   (when (and slime-highlight-suppressed-forms (slime-connected-p))
-    (let (changedp)
-      (multiple-value-setq (changedp font-lock-beg font-lock-end)
-        (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
-      changedp)))
+    (condition-case c
+        (let (changedp)
+          (multiple-value-setq (changedp font-lock-beg font-lock-end)
+            (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
+          changedp)
+      (error 
+       (slime-bug 
+        (concat "Caught error when trying to extend the region for fontification.\n"
+                "The error was: %S\n"
+                "Further: font-lock-beg=%d, font-lock-end=%d.")
+        c font-lock-beg font-lock-end)))))
 
 (defun slime-compute-region-for-font-lock (orig-beg orig-end)
-  (condition-case nil
-      (let ((beg orig-beg)
-            (end orig-end))
-        (goto-char beg)
-        ;; N.B. take preceding reader-conditional into account (even
-        ;; when we're at the toplevel!), otherwise fontification
-        ;; wouldn't know the whole function definition may be
-        ;; suppressed.
-        (if (plusp (nth 0 (slime-current-parser-state)))
-            (setq beg (first (slime-region-for-extended-tlf-at-point)))
-            (setq beg (or (slime-search-backward-reader-conditional)
-                          orig-beg)))
-        (goto-char end)
-        (when (or (plusp (nth 0 (slime-current-parser-state)))
-                  (slime-search-backward-reader-conditional))
-          (setq end (second (slime-region-for-tlf-at-point))))
-        (values (or (/= beg orig-beg) (/= end orig-end)) beg end))
-    (error ; unbalanced parentheses: cannot determine beginning/end of tlf.
-     (values nil orig-beg orig-end))))
-
-;;; FIXME: This is supposed to be the value for
-;;; `font-lock-mark-block-function' (so M-o M-o will DTRT), but I
-;;; couldn't so far figure out how to customize that variable.
-;;; (N.B. `font-lock-defaults' may (in fact does) contain an explicit
-;;; binding of that variable.)
-(defun slime-mark-defun-for-font-lock ()
-  "Almost `mark-defun' but this function sets point to a possibly
-preceding reader-conditional so slime's reader-conditional aware
-font-lock magic has a chance to run."
-  (destructuring-bind (start end) 
-      (slime-region-for-extended-tlf-at-point)
-    (goto-char end)
-    (push-mark)
-    (goto-char start)))
+  (interactive)
+  (flet ((beginning-of-tlf ()
+           (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
+                    (goto-char upper-pt)))))
+    (let ((beg orig-beg)
+          (end orig-end))
+      (goto-char beg)
+      (beginning-of-tlf)
+      (assert (not (plusp (nth 0 (slime-current-parser-state)))))
+      (setq beg (or (slime-search-directly-preceding-reader-conditional)
+                    (point)))
+      (goto-char end)
+      (when (search-backward-regexp slime-reader-conditionals-regexp beg t)
+        ;; Nested reader conditionals, yuck!
+        (while (when-let (pt (slime-search-directly-preceding-reader-conditional))
+                 (goto-char pt)))
+        (ignore-errors (slime-forward-reader-conditional))
+        (setq end (max end (point))))
+      (values (or (/= beg orig-beg) (/= end orig-end)) beg end))))
 
 
 (defun slime-activate-font-lock-magic ()
@@ -7546,6 +7535,7 @@
 
     '(("(defun *NO* (x y) (+ x y))")
       ("(defun *NO*")
+      ("*NO*) #-(and) (*YES*) (*NO* *NO*")
       ("\(
 \(defun *NO*")
       ("\)
@@ -7590,6 +7580,19 @@
 #-(and)
 \(*YES*)
 \(*NO*)")
+      ("#+nil (foo)
+
+#-(and)
+#+nil (
+       asdf *YES* a
+            fsdfad)
+
+\( asdf *YES*
+
+       )
+\(*NO*)
+
+")
       )
   (slime-check-top-level)
   (with-temp-buffer
@@ -8448,27 +8451,6 @@
         (beginning-of-defun)
         (list (point) end)))))
 
-;;; This may coincide with `slime-region-for-defun-at-point' but this
-;;; function really tries to find out the toplevel form not just a
-;;; form that begins at the 0th column. It's not guaranteed to work
-;;; reliably, though, as it relies on Emacs' parser state which is
-;;; context-sensitive. Works quite good when the buffer is processed
-;;; from top to bottom (e.g. during fontification.)
-(defun slime-region-for-tlf-at-point ()
-  "Return the start and end position of the toplevel form at point."
-  (save-excursion
-    (save-match-data
-      ;; Position us at the beginning of the current defun.
-      (end-of-defun) 
-      (backward-sexp)
-      (while (not (zerop (nth 0 (slime-current-parser-state))))
-        ;; We go upwards, not downwards, to hopefully give the parser
-        ;; state enough context to be accurate.
-        (beginning-of-defun))
-      (let ((start (point)))
-        (end-of-defun)
-        (list start (point))))))
-
 (defun slime-exit-vertical-bars ()
   "Move out from within vertical bars (|foo|) to the leading bar."
   (let* ((parser-state (slime-current-parser-state))
@@ -9041,10 +9023,8 @@
           slime-forward-sexp
           slime-forward-cruft
           slime-forward-any-comment
-          slime-region-for-tlf-at-point
-          slime-region-for-extended-tlf-at-point
           slime-extend-region-for-font-lock
-          slime-search-backward-reader-conditional
+          slime-search-directly-preceding-reader-conditional
           slime-search-suppressed-forms
           )))
 




From trittweiler at common-lisp.net  Fri May 15 18:33:51 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 15 May 2009 14:33:51 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M52EB-0005xN-4i@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	Move font-lock-magic into contrib/slime-fontifying-fu.el.

	* slime.el (slime-highlight-suppressed-forms),
	(slime-reader-conditional-face),
	(slime-search-suppressed-forms-internal),
	(slime-search-suppressed-forms),
	(slime-search-directly-preceding-reader-conditional),
	(slime-extend-region-for-font-lock),
	(slime-compute-region-for-font-lock),
	(slime-activate-font-lock-magic): Moved.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/15 18:18:27	1.1751
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/15 18:33:50	1.1752
@@ -1,5 +1,18 @@
 2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	Move font-lock-magic into contrib/slime-fontifying-fu.el.
+
+	* slime.el (slime-highlight-suppressed-forms),
+	(slime-reader-conditional-face),
+	(slime-search-suppressed-forms-internal),
+	(slime-search-suppressed-forms),
+	(slime-search-directly-preceding-reader-conditional),
+	(slime-extend-region-for-font-lock),
+	(slime-compute-region-for-font-lock),
+	(slime-activate-font-lock-magic): Moved.
+
+2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Rewrote some parts of the font-lock-magic in face of its fragility
 	over the last days. Hopefully it'll be better now.
 
--- /project/slime/cvsroot/slime/slime.el	2009/05/15 18:18:27	1.1171
+++ /project/slime/cvsroot/slime/slime.el	2009/05/15 18:33:51	1.1172
@@ -6695,176 +6695,6 @@
         finally (error "Can't find unshown buffer in %S" mode)))
 
 
-;;;; Font Lock
-
-;;; Specially fontify forms suppressed by a reader conditional.
-
-(defcustom slime-highlight-suppressed-forms t
-  "Display forms disabled by reader conditionals as comments."
-  :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
-  :group 'slime-mode)
-
-(defface slime-reader-conditional-face
-  (if (slime-face-inheritance-possible-p)
-    '((t (:inherit font-lock-comment-face)))
-  '((((background light)) (:foreground "DimGray" :bold t))
-    (((background dark)) (:foreground "LightGray" :bold t))))
-  "Face for compiler notes while selected."
-  :group 'slime-mode-faces)
-
-(defun slime-search-suppressed-forms-internal (limit)
-  (when (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t)
-    (if (let ((state (slime-current-parser-state)))
-          (or (nth 3 state)             ; inside string?
-              (nth 4 state)))           ; inside comment?
-        (slime-search-suppressed-forms-internal limit)
-      (let* ((start (- (point) 2))
-             (char (char-before))
-             (e (read (current-buffer)))
-             (val (slime-eval-feature-expression e)))
-        (when (<= (point) limit)
-          (if (or (and (eq char ?+) (not val))
-                  (and (eq char ?-) val))
-              (progn
-                (forward-sexp) (backward-sexp)
-                (slime-forward-sexp)
-                ;; There was an `ignore-errors' form around all this
-                ;; because the following assertion was triggered
-                ;; regularly (resulting in the "non-deterministic"
-                ;; behaviour mentioned in the comment further below.)
-                ;; With extending the region properly, this assertion
-                ;; would truly mean a bug now.
-                (assert (<= (point) limit))
-                (let ((md (match-data)))
-                  (fill md nil)
-                  (setf (first md) start)
-                  (setf (second md) (point))
-                  (set-match-data md)
-                  t))
-              (slime-search-suppressed-forms-internal limit)))))))
-
-(defun slime-search-suppressed-forms (limit)
-  "Find reader conditionalized forms where the test is false."
-  (when (and slime-highlight-suppressed-forms
-             (slime-connected-p)
-             (<= (point) limit))
-    (condition-case condition
-        (slime-search-suppressed-forms-internal limit)
-      (end-of-file                      ; e.g. #+(
-       nil) 
-      ;; We found a reader conditional we couldn't process for some
-      ;; reason; however, there may still be other reader conditionals
-      ;; before `limit'.
-      (invalid-read-syntax              ; e.g. #+#.foo
-       (slime-search-suppressed-forms limit))
-      (scan-error                       ; e.g. #| #+(or) #|
-       (slime-search-suppressed-forms limit)) 
-      (slime-unknown-feature-expression ; e.g. #+(foo)
-       (slime-search-suppressed-forms limit)) 
-      (error 
-       (slime-bug 
-        (concat "Caught error during fontification while searching for forms\n"
-                "that are suppressed by reader-conditionals. The error was: %S.")
-        condition)))))
-
-
-(defun slime-search-directly-preceding-reader-conditional ()
-  "Search for a directly preceding reader conditional. Return its
-position, or nil."
-  ;;; We search for a preceding reader conditional. Then we check that
-  ;;; between the reader conditional and the point where we started is
-  ;;; no other intervening sexp, and we check that the reader
-  ;;; conditional is at the same nesting level.
-  (let ((orig-pt (point)))
-    (multiple-value-bind (reader-conditional-pt parser-state)
-        (save-excursion
-          (when-let (pt (search-backward-regexp slime-reader-conditionals-regexp
-                                                ;; We restrict the search to the
-                                                ;; beginning of the /previous/ defun.
-                                                (save-match-data
-                                                  (save-excursion
-                                                    (beginning-of-defun) (point)))
-                                                t))
-            (values pt (parse-partial-sexp (progn (goto-char (+ pt 2))
-                                                  (forward-sexp) ; skip feature expr.
-                                                  (point))
-                                           orig-pt))))
-      (let ((paren-depth  (nth 0 parser-state))
-            (last-sexp-pt (nth 2 parser-state)))
-        (if (and paren-depth (not (plusp paren-depth)) ; no opening parenthesis in between?
-                 (not last-sexp-pt))                   ; no complete sexp in between?
-            reader-conditional-pt
-            nil)))))
-
-
-;;; We'll push this onto `font-lock-extend-region-functions'. In past,
-;;; we didn't do so which made our reader-conditional font-lock magic
-;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
-;;; worked quite non-deterministic in general.)
-;;;
-;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
-;;;
-;;; We make sure that `font-lock-beg' and `font-lock-end' always point
-;;; to the beginning or end of a toplevel form. So we never miss a
-;;; reader-conditional, or point in mid of one.
-(defun slime-extend-region-for-font-lock ()
-  (when (and slime-highlight-suppressed-forms (slime-connected-p))
-    (condition-case c
-        (let (changedp)
-          (multiple-value-setq (changedp font-lock-beg font-lock-end)
-            (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
-          changedp)
-      (error 
-       (slime-bug 
-        (concat "Caught error when trying to extend the region for fontification.\n"
-                "The error was: %S\n"
-                "Further: font-lock-beg=%d, font-lock-end=%d.")
-        c font-lock-beg font-lock-end)))))
-
-(defun slime-compute-region-for-font-lock (orig-beg orig-end)
-  (interactive)
-  (flet ((beginning-of-tlf ()
-           (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
-                    (goto-char upper-pt)))))
-    (let ((beg orig-beg)
-          (end orig-end))
-      (goto-char beg)
-      (beginning-of-tlf)
-      (assert (not (plusp (nth 0 (slime-current-parser-state)))))
-      (setq beg (or (slime-search-directly-preceding-reader-conditional)
-                    (point)))
-      (goto-char end)
-      (when (search-backward-regexp slime-reader-conditionals-regexp beg t)
-        ;; Nested reader conditionals, yuck!
-        (while (when-let (pt (slime-search-directly-preceding-reader-conditional))
-                 (goto-char pt)))
-        (ignore-errors (slime-forward-reader-conditional))
-        (setq end (max end (point))))
-      (values (or (/= beg orig-beg) (/= end orig-end)) beg end))))
-
-
-(defun slime-activate-font-lock-magic ()
-  (if (featurep 'xemacs)
-      (let ((pattern `((slime-search-suppressed-forms
-                        (0 slime-reader-conditional-face t)))))
-        (dolist (sym '(lisp-font-lock-keywords
-                       lisp-font-lock-keywords-1
-                       lisp-font-lock-keywords-2))
-          (set sym (append (symbol-value sym) pattern))))
-    (font-lock-add-keywords
-     'lisp-mode
-     `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t)))
-
-    (add-hook 'lisp-mode-hook 
-              #'(lambda () 
-                  (add-hook 'font-lock-extend-region-functions
-                            'slime-extend-region-for-font-lock t t)))
-    ))
-
-(when slime-highlight-suppressed-forms
-  (slime-activate-font-lock-magic))
-
-
 ;;;; Indentation
 
 (defun slime-update-indentation ()




From trittweiler at common-lisp.net  Fri May 15 18:37:10 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 15 May 2009 14:37:10 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M52HO-00060J-Im@common-lisp.net>

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

Modified Files:
	ChangeLog slime-fontifying-fu.el 
Log Message:
	Moved font-lock-magic from slime.el to slime-fontifying-fu.el.

	N.B. slime-fontifying-fu is automatically loaded by
	slime-fancy. I.e. if you use slime-fancy, font-lock-magic will be
	enabled for just like before.

	* slime-fontifying-fu.el (slime-highlight-suppressed-forms),
	(slime-reader-conditional-face),
	(slime-search-suppressed-forms-internal),
	(slime-search-suppressed-forms),
	(slime-search-directly-preceding-reader-conditional),
	(slime-extend-region-for-font-lock),
	(slime-compute-region-for-font-lock),
	(slime-activate-font-lock-magic): Moved here.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/14 18:13:21	1.206
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/15 18:37:10	1.207
@@ -1,3 +1,20 @@
+2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Moved font-lock-magic from slime.el to slime-fontifying-fu.el.
+
+	N.B. slime-fontifying-fu is automatically loaded by
+	slime-fancy. I.e. if you use slime-fancy, font-lock-magic will be
+	enabled for just like before.
+
+	* slime-fontifying-fu.el (slime-highlight-suppressed-forms),
+	(slime-reader-conditional-face),
+	(slime-search-suppressed-forms-internal),
+	(slime-search-suppressed-forms),
+	(slime-search-directly-preceding-reader-conditional),
+	(slime-extend-region-for-font-lock),
+	(slime-compute-region-for-font-lock),
+	(slime-activate-font-lock-magic): Moved here.
+
 2009-05-14  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Optionally sort slots displayed for STANDARD-OBJECTS not
--- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2008/08/20 21:46:09	1.1
+++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/15 18:37:10	1.2
@@ -6,19 +6,189 @@
 ;;
 
 
-;; Fontify WITH-FOO and DO-FOO like standard macros; fontify
-;; CHECK-FOO like CHECK-TYPE.
+;;; Fontify WITH-FOO and DO-FOO like standard macros.
+;;; Fontify CHECK-FOO like CHECK-TYPE.
 (defvar slime-additional-font-lock-keywords
  '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) 
    ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face)
    ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face)))
 
+
+;;;; Specially fontify forms suppressed by a reader conditional.
+
+(defcustom slime-highlight-suppressed-forms t
+  "Display forms disabled by reader conditionals as comments."
+  :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil))
+  :group 'slime-mode)
+
+(defface slime-reader-conditional-face
+  (if (slime-face-inheritance-possible-p)
+    '((t (:inherit font-lock-comment-face)))
+  '((((background light)) (:foreground "DimGray" :bold t))
+    (((background dark)) (:foreground "LightGray" :bold t))))
+  "Face for compiler notes while selected."
+  :group 'slime-mode-faces)
+
+(defun slime-search-suppressed-forms-internal (limit)
+  (when (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t)
+    (if (let ((state (slime-current-parser-state)))
+          (or (nth 3 state)             ; inside string?
+              (nth 4 state)))           ; inside comment?
+        (slime-search-suppressed-forms-internal limit)
+      (let* ((start (- (point) 2))
+             (char (char-before))
+             (e (read (current-buffer)))
+             (val (slime-eval-feature-expression e)))
+        (when (<= (point) limit)
+          (if (or (and (eq char ?+) (not val))
+                  (and (eq char ?-) val))
+              (progn
+                (forward-sexp) (backward-sexp)
+                (slime-forward-sexp)
+                ;; There was an `ignore-errors' form around all this
+                ;; because the following assertion was triggered
+                ;; regularly (resulting in the "non-deterministic"
+                ;; behaviour mentioned in the comment further below.)
+                ;; With extending the region properly, this assertion
+                ;; would truly mean a bug now.
+                (assert (<= (point) limit))
+                (let ((md (match-data)))
+                  (fill md nil)
+                  (setf (first md) start)
+                  (setf (second md) (point))
+                  (set-match-data md)
+                  t))
+              (slime-search-suppressed-forms-internal limit)))))))
+
+(defun slime-search-suppressed-forms (limit)
+  "Find reader conditionalized forms where the test is false."
+  (when (and slime-highlight-suppressed-forms
+             (slime-connected-p)
+             (<= (point) limit))
+    (condition-case condition
+        (slime-search-suppressed-forms-internal limit)
+      (end-of-file                      ; e.g. #+(
+       nil) 
+      ;; We found a reader conditional we couldn't process for some
+      ;; reason; however, there may still be other reader conditionals
+      ;; before `limit'.
+      (invalid-read-syntax              ; e.g. #+#.foo
+       (slime-search-suppressed-forms limit))
+      (scan-error                       ; e.g. #| #+(or) #|
+       (slime-search-suppressed-forms limit)) 
+      (slime-unknown-feature-expression ; e.g. #+(foo)
+       (slime-search-suppressed-forms limit)) 
+      (error 
+       (slime-bug 
+        (concat "Caught error during fontification while searching for forms\n"
+                "that are suppressed by reader-conditionals. The error was: %S.")
+        condition)))))
+
+
+(defun slime-search-directly-preceding-reader-conditional ()
+  "Search for a directly preceding reader conditional. Return its
+position, or nil."
+  ;;; We search for a preceding reader conditional. Then we check that
+  ;;; between the reader conditional and the point where we started is
+  ;;; no other intervening sexp, and we check that the reader
+  ;;; conditional is at the same nesting level.
+  (let ((orig-pt (point)))
+    (multiple-value-bind (reader-conditional-pt parser-state)
+        (save-excursion
+          (when-let (pt (search-backward-regexp slime-reader-conditionals-regexp
+                                                ;; We restrict the search to the
+                                                ;; beginning of the /previous/ defun.
+                                                (save-match-data
+                                                  (save-excursion
+                                                    (beginning-of-defun) (point)))
+                                                t))
+            (values pt (parse-partial-sexp (progn (goto-char (+ pt 2))
+                                                  (forward-sexp) ; skip feature expr.
+                                                  (point))
+                                           orig-pt))))
+      (let ((paren-depth  (nth 0 parser-state))
+            (last-sexp-pt (nth 2 parser-state)))
+        (if (and paren-depth (not (plusp paren-depth)) ; no opening parenthesis in between?
+                 (not last-sexp-pt))                   ; no complete sexp in between?
+            reader-conditional-pt
+            nil)))))
+
+
+;;; We'll push this onto `font-lock-extend-region-functions'. In past,
+;;; we didn't do so which made our reader-conditional font-lock magic
+;;; pretty unreliable (it wouldn't highlight all suppressed forms, and
+;;; worked quite non-deterministic in general.)
+;;;
+;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs.
+;;;
+;;; We make sure that `font-lock-beg' and `font-lock-end' always point
+;;; to the beginning or end of a toplevel form. So we never miss a
+;;; reader-conditional, or point in mid of one.
+(defun slime-extend-region-for-font-lock ()
+  (when (and slime-highlight-suppressed-forms (slime-connected-p))
+    (condition-case c
+        (let (changedp)
+          (multiple-value-setq (changedp font-lock-beg font-lock-end)
+            (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
+          changedp)
+      (error 
+       (slime-bug 
+        (concat "Caught error when trying to extend the region for fontification.\n"
+                "The error was: %S\n"
+                "Further: font-lock-beg=%d, font-lock-end=%d.")
+        c font-lock-beg font-lock-end)))))
+
+(defun slime-compute-region-for-font-lock (orig-beg orig-end)
+  (flet ((beginning-of-tlf ()
+           (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
+                    (goto-char upper-pt)))))
+    (let ((beg orig-beg)
+          (end orig-end))
+      (goto-char beg)
+      (beginning-of-tlf)
+      (assert (not (plusp (nth 0 (slime-current-parser-state)))))
+      (setq beg (or (slime-search-directly-preceding-reader-conditional)
+                    (point)))
+      (goto-char end)
+      (when (search-backward-regexp slime-reader-conditionals-regexp beg t)
+        ;; Nested reader conditionals, yuck!
+        (while (when-let (pt (slime-search-directly-preceding-reader-conditional))
+                 (goto-char pt)))
+        (ignore-errors (slime-forward-reader-conditional))
+        (setq end (max end (point))))
+      (values (or (/= beg orig-beg) (/= end orig-end)) beg end))))
+
+
+(defun slime-activate-font-lock-magic ()
+  (if (featurep 'xemacs)
+      (let ((pattern `((slime-search-suppressed-forms
+                        (0 slime-reader-conditional-face t)))))
+        (dolist (sym '(lisp-font-lock-keywords
+                       lisp-font-lock-keywords-1
+                       lisp-font-lock-keywords-2))
+          (set sym (append (symbol-value sym) pattern))))
+      (font-lock-add-keywords
+       'lisp-mode
+       `((slime-search-suppressed-forms 0 ,''slime-reader-conditional-face t)))
+
+      (add-hook 'lisp-mode-hook 
+                #'(lambda () 
+                    (add-hook 'font-lock-extend-region-functions
+                              'slime-extend-region-for-font-lock t t)))
+      ))
+
+
 (defun slime-fontifying-fu-init ()
   (font-lock-add-keywords
-   'lisp-mode slime-additional-font-lock-keywords))
+   'lisp-mode slime-additional-font-lock-keywords)
+  (when slime-highlight-suppressed-forms
+    (slime-activate-font-lock-magic)))
 
 (defun slime-fontifying-fu-unload ()
   (font-lock-remove-keywords 
-   'lisp-mode slime-additional-font-lock-keywords))
+   'lisp-mode slime-additional-font-lock-keywords)
+  ;;; FIXME: remove `slime-search-suppressed-forms', and remove the
+  ;;; extend-region hook.
+  )
 
 (provide 'slime-fontifying-fu)
\ No newline at end of file




From trittweiler at common-lisp.net  Fri May 15 18:47:38 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 15 May 2009 14:47:38 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M52RW-0006jK-9u@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
	* swank-allegro.lisp (swank-compile-string): Forgot to remove old
	definition in changeset 2009-05-12.

	Patch by Stelian Ionescu.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/15 18:33:50	1.1752
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/15 18:47:38	1.1753
@@ -1,5 +1,12 @@
 2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-allegro.lisp (swank-compile-string): Forgot to remove old
+	definition in changeset 2009-05-12.
+
+	Patch by Stelian Ionescu.
+
+2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Move font-lock-magic into contrib/slime-fontifying-fu.el.
 
 	* slime.el (slime-highlight-suppressed-forms),
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2009/05/12 17:37:13	1.126
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2009/05/15 18:47:38	1.127
@@ -367,28 +367,6 @@
            string)))
     (reader-error () (values nil nil t))))
 
-(defimplementation swank-compile-string (string &key buffer position filename
-                                         policy)
-  (declare (ignore policy))
-  ;; We store the source buffer in excl::*source-pathname* as a string
-  ;; of the form <buffername>;<start-offset>.  Quite ugly encoding, but
-  ;; the fasl file is corrupted if we use some other datatype.
-  (with-compilation-hooks ()
-    (let ((*buffer-name* buffer)
-          (*buffer-start-position* position)
-          (*buffer-string* string)
-          (*default-pathname-defaults*
-           (if filename 
-               (merge-pathnames (pathname filename))
-               *default-pathname-defaults*)))
-      (compile-from-temp-file
-       (format nil "~S ~S~%~A" 
-               `(in-package ,(package-name *package*))
-               `(eval-when (:compile-toplevel :load-toplevel)
-                  (setq excl::*source-pathname*
-                        ',(format nil "~A;~D" buffer position)))
-               string)))))
-
 ;;;; Definition Finding
 
 (defun fspec-primary-name (fspec)




From trittweiler at common-lisp.net  Fri May 15 19:02:19 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 15 May 2009 15:02:19 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M52fj-0007so-MJ@common-lisp.net>

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

Modified Files:
	ChangeLog slime-repl.el 
Log Message:
	* slime-repl.el (with-canonicalized-slime-repl-buffer): XEmacs
	chokes on symbol-names with an initial dot.

	Patch by Fran??ois-Ren?? Rideau.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/15 18:37:10	1.207
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/15 19:02:19	1.208
@@ -1,5 +1,12 @@
 2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-repl.el (with-canonicalized-slime-repl-buffer): XEmacs
+	chokes on symbol-names with an initial dot.
+
+	Patch by Fran??ois-Ren?? Rideau.
+
+2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Moved font-lock-magic from slime.el to slime-fontifying-fu.el.
 
 	N.B. slime-fontifying-fu is automatically loaded by
--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2009/04/03 20:43:48	1.20
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2009/05/15 19:02:19	1.21
@@ -1573,14 +1573,14 @@
   "Evaluate BODY within a fresh REPL buffer. The REPL prompt is
 canonicalized to \"SWANK\"---we do actually switch to that
 package, though."
-  `(let ((.old-prompt. (slime-lisp-package-prompt-string)))
+  `(let ((%old-prompt% (slime-lisp-package-prompt-string)))
      (unwind-protect
           (progn (with-current-buffer (slime-output-buffer)
                    (setf (slime-lisp-package-prompt-string) "SWANK"))
                  (kill-buffer (slime-output-buffer))
                  (with-current-buffer (slime-output-buffer)
                    , at body))
-       (setf (slime-lisp-package-prompt-string) .old-prompt.))))
+       (setf (slime-lisp-package-prompt-string) %old-prompt%))))
 
 (put 'with-canonicalized-slime-repl-buffer 'lisp-indent-function 0)
 




From trittweiler at common-lisp.net  Fri May 15 20:02:43 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 15 May 2009 16:02:43 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M53cB-00024S-IT@common-lisp.net>

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

Modified Files:
	ChangeLog slime-fontifying-fu.el 
Log Message:
	* slime-fontifying-fu.el (slime-search-suppressed-forms-internal):
	Use `slime-reader-conditionals-regexp'.
	(slime-search-directly-preceding-reader-conditional): Catch scan
	errors due to improper feature expressions.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/15 19:02:19	1.208
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/15 20:02:43	1.209
@@ -1,5 +1,12 @@
 2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-fontifying-fu.el (slime-search-suppressed-forms-internal):
+	Use `slime-reader-conditionals-regexp'.
+	(slime-search-directly-preceding-reader-conditional): Catch scan
+	errors due to improper feature expressions.
+
+2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-repl.el (with-canonicalized-slime-repl-buffer): XEmacs
 	chokes on symbol-names with an initial dot.
 
--- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/15 18:37:10	1.2
+++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/15 20:02:43	1.3
@@ -30,7 +30,7 @@
   :group 'slime-mode-faces)
 
 (defun slime-search-suppressed-forms-internal (limit)
-  (when (re-search-forward "^\\([^;\n]*?[ \t(]\\)?#[-+]" limit t)
+  (when (search-forward-regexp slime-reader-conditionals-regexp limit t)
     (if (let ((state (slime-current-parser-state)))
           (or (nth 3 state)             ; inside string?
               (nth 4 state)))           ; inside comment?
@@ -92,26 +92,28 @@
   ;;; between the reader conditional and the point where we started is
   ;;; no other intervening sexp, and we check that the reader
   ;;; conditional is at the same nesting level.
-  (let ((orig-pt (point)))
-    (multiple-value-bind (reader-conditional-pt parser-state)
-        (save-excursion
-          (when-let (pt (search-backward-regexp slime-reader-conditionals-regexp
-                                                ;; We restrict the search to the
-                                                ;; beginning of the /previous/ defun.
-                                                (save-match-data
-                                                  (save-excursion
-                                                    (beginning-of-defun) (point)))
-                                                t))
-            (values pt (parse-partial-sexp (progn (goto-char (+ pt 2))
-                                                  (forward-sexp) ; skip feature expr.
-                                                  (point))
-                                           orig-pt))))
-      (let ((paren-depth  (nth 0 parser-state))
-            (last-sexp-pt (nth 2 parser-state)))
-        (if (and paren-depth (not (plusp paren-depth)) ; no opening parenthesis in between?
-                 (not last-sexp-pt))                   ; no complete sexp in between?
-            reader-conditional-pt
-            nil)))))
+  (condition-case nil
+      (let ((orig-pt (point)))
+        (multiple-value-bind (reader-conditional-pt parser-state)
+            (save-excursion
+              (when-let (pt (search-backward-regexp slime-reader-conditionals-regexp
+                                                    ;; We restrict the search to the
+                                                    ;; beginning of the /previous/ defun.
+                                                    (save-match-data
+                                                      (save-excursion
+                                                        (beginning-of-defun) (point)))
+                                                    t))
+                (values pt (parse-partial-sexp (progn (goto-char (+ pt 2))
+                                                      (forward-sexp) ; skip feature expr.
+                                                      (point))
+                                               orig-pt))))
+          (let ((paren-depth  (nth 0 parser-state))
+                (last-sexp-pt (nth 2 parser-state)))
+            (if (and paren-depth (not (plusp paren-depth)) ; no opening parenthesis in between?
+                     (not last-sexp-pt))                   ; no complete sexp in between?
+                reader-conditional-pt
+                nil))))
+    (scan-error nil)))                                     ; improper feature expression
 
 
 ;;; We'll push this onto `font-lock-extend-region-functions'. In past,




From heller at common-lisp.net  Sat May 16 11:28:31 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 16 May 2009 07:28:31 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5I47-0000YO-VP@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (*sldb-pprint-dispatch-table*): Be careful when
calling WRITE recursively: set :circle to nil which avoids
interference with cycle-detection.
(escape-string): New helper function.
(*backtrace-pprint-dispatch-table*): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/15 18:47:38	1.1753
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/16 11:28:31	1.1754
@@ -1,3 +1,11 @@
+2009-05-16  Helmut Eller  <heller at common-lisp.net>
+
+	* swank.lisp (*sldb-pprint-dispatch-table*): Be careful when
+	calling WRITE recursively: set :circle to nil which avoids
+	interference with cycle-detection.
+	(escape-string): New helper function.
+	(*backtrace-pprint-dispatch-table*): Use it.
+
 2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-allegro.lisp (swank-compile-string): Forgot to remove old
--- /project/slime/cvsroot/slime/swank.lisp	2009/05/08 17:56:06	1.641
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:28:31	1.642
@@ -98,40 +98,33 @@
 ;;;
 ;;; We use a customized pprint dispatch table to do it for us.
 
-(declaim (special *sldb-string-length*))
-(declaim (special *sldb-bitvector-length*))
+(defvar *sldb-string-length* nil)
+(defvar *sldb-bitvector-length* nil)
 
 (defvar *sldb-pprint-dispatch-table*
   (let ((initial-table (copy-pprint-dispatch nil))
         (result-table  (copy-pprint-dispatch nil)))
     (flet ((sldb-bitvector-pprint (stream bitvector)
              ;;; Truncate bit-vectors according to *SLDB-BITVECTOR-LENGTH*.
-             (if (or (not *print-array*) (not *print-length*))
-                 (let ((*print-pprint-dispatch* initial-table))
-                   (write bitvector :stream stream))
+             (if (not *sldb-bitvector-length*)
+                 (write bitvector :stream stream :circle nil
+                        :pprint-dispatch initial-table)
                  (loop initially (write-string "#*" stream)
                        for i from 0 and bit across bitvector do
                        (when (= i *sldb-bitvector-length*)
                          (write-string "..." stream)
                          (loop-finish))
-                       (write bit :stream stream))))
+                       (write-char (if bit #\1 #\0) stream))))
            (sldb-string-pprint (stream string)
              ;;; Truncate strings according to *SLDB-STRING-LENGTH*.
-             (cond ((or (not *print-array*) (not *print-length*))
-                    (let ((*print-pprint-dispatch* initial-table))
-                      (write string :stream stream)))
-                   ((not *print-escape*)
+             (cond ((not *print-escape*)
                     (write-string string stream))
+                   ((not *sldb-string-length*)
+                    (write string :stream stream :circle nil
+                           :pprint-dispatch initial-table))
                    (t
-                    (loop initially (write-char #\" stream)
-                          for i from 0 and char across string do
-                          (cond ((= i *sldb-string-length*)
-                                 (write-string "..." stream)
-                                 (loop-finish))
-                                ((char= char #\")
-                                 (write-string "\\\"" stream))
-                                (t (write-char char stream)))
-                          finally (write-char #\" stream))))))
+                    (escape-string string stream
+                                   :length *sldb-string-length*)))))
       (set-pprint-dispatch 'bit-vector #'sldb-bitvector-pprint 0 result-table)
       (set-pprint-dispatch 'string #'sldb-string-pprint 0 result-table)
       result-table)))
@@ -156,18 +149,15 @@
 
 (defvar *backtrace-pprint-dispatch-table*
   (let ((table (copy-pprint-dispatch nil)))
-    (flet ((escape-string (stream string)
+    (flet ((print-string (stream string)
              (cond (*print-escape* 
-                    (write-char #\" stream)
-                    (loop for c across string do
-                          (case c
-                            (#\" (write-string "\\\"" stream))
-                            (#\newline (write-string "\\n" stream))
-                            (#\return (write-string "\\r" stream))
-                            (t (write-char c stream))))
-                    (write-char #\" stream))
+                    (escape-string string stream
+                                   :map '((#\" . "\\\"")
+                                          (#\\ . "\\\\")
+                                          (#\newline . "\\n")
+                                          (#\return . "\\r"))))
                    (t (write-string string stream)))))
-      (set-pprint-dispatch 'string  #'escape-string 0 table)
+      (set-pprint-dispatch 'string  #'print-string 0 table)
       table)))
 
 (defvar *backtrace-printer-bindings*
@@ -2300,6 +2290,23 @@
           (finish-output stream)
           (subseq buffer 0 fill-pointer))))))
 
+(defun escape-string (string stream &key length (map '((#\" . "\\\"")
+                                                       (#\\ . "\\\\"))))
+  "Write STRING to STREAM with surronded by double-quotes.
+LENGTH -- if non-nil truncate output after LENGTH chars.
+MAP -- rewrite the chars in STRING according this alist."
+  (let ((limit (or length array-dimension-limit)))
+    (write-char #\" stream)
+    (loop for c across string 
+          for i from 0 do
+          (when (= i limit)
+            (write-string "..." stream)
+            (return))
+          (let ((probe (assoc c map)))
+            (cond (probe (write-string (cadr probe) stream))
+                  (t (write-char c stream)))))
+    (write-char #\" stream)))
+
 (defun package-string-for-prompt (package)
   "Return the shortest nickname (or canonical name) of PACKAGE."
   (unparse-name




From heller at common-lisp.net  Sat May 16 11:28:36 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 16 May 2009 07:28:36 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5I4C-0000Yu-Fk@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:28:31	1.642
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:28:36	1.643
@@ -2292,7 +2292,7 @@
 
 (defun escape-string (string stream &key length (map '((#\" . "\\\"")
                                                        (#\\ . "\\\\"))))
-  "Write STRING to STREAM with surronded by double-quotes.
+  "Write STRING to STREAM surronded by double-quotes.
 LENGTH -- if non-nil truncate output after LENGTH chars.
 MAP -- rewrite the chars in STRING according this alist."
   (let ((limit (or length array-dimension-limit)))




From heller at common-lisp.net  Sat May 16 11:28:41 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 16 May 2009 07:28:41 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5I4H-0000ZP-34@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:28:36	1.643
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:28:41	1.644
@@ -2294,7 +2294,7 @@
                                                        (#\\ . "\\\\"))))
   "Write STRING to STREAM surronded by double-quotes.
 LENGTH -- if non-nil truncate output after LENGTH chars.
-MAP -- rewrite the chars in STRING according this alist."
+MAP -- rewrite the chars in STRING according to this alist."
   (let ((limit (or length array-dimension-limit)))
     (write-char #\" stream)
     (loop for c across string 




From heller at common-lisp.net  Sat May 16 11:38:47 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 16 May 2009 07:38:47 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5IE3-0000s1-RZ@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
swank.lisp (escape-string): Fix thinko.

--- /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:28:41	1.644
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:38:47	1.645
@@ -2303,7 +2303,7 @@
             (write-string "..." stream)
             (return))
           (let ((probe (assoc c map)))
-            (cond (probe (write-string (cadr probe) stream))
+            (cond (probe (write-string (cdr probe) stream))
                   (t (write-char c stream)))))
     (write-char #\" stream)))
 




From trittweiler at common-lisp.net  Sat May 16 12:46:05 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 16 May 2009 08:46:05 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5JHB-0006GZ-Am@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-current-parser-state): Do not save
	match-data. This function is called so often that it makes a
	difference.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/16 11:28:31	1.1754
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/16 12:46:04	1.1755
@@ -1,3 +1,9 @@
+2009-05-16  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-current-parser-state): Do not save
+	match-data. This function is called so often that it makes a
+	difference.
+
 2009-05-16  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (*sldb-pprint-dispatch-table*): Be careful when
--- /project/slime/cvsroot/slime/slime.el	2009/05/15 18:33:51	1.1172
+++ /project/slime/cvsroot/slime/slime.el	2009/05/16 12:46:04	1.1173
@@ -8415,7 +8415,7 @@
       ;; `beginning-of-defun' implicitly which does not save match
       ;; data. This issue has been reported to the Emacs maintainer on
       ;; Feb27.
-      (save-match-data (syntax-ppss)))
+      (syntax-ppss))
     (defsubst slime-current-parser-state ()
       (let ((original-pos (point)))
         (save-excursion
@@ -8850,12 +8850,10 @@
           slime-end-of-symbol
           ;; Used implicitly during fontification:
           slime-current-parser-state
+          slime-eval-feature-expression
           slime-forward-sexp
           slime-forward-cruft
           slime-forward-any-comment
-          slime-extend-region-for-font-lock
-          slime-search-directly-preceding-reader-conditional
-          slime-search-suppressed-forms
           )))
 
 (provide 'slime)




From trittweiler at common-lisp.net  Sat May 16 12:54:33 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 16 May 2009 08:54:33 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M5JPN-0006LX-5v@common-lisp.net>

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

Modified Files:
	ChangeLog slime-fontifying-fu.el 
Log Message:

	Optimize font-lock-magic.

	* slime-fontifying-fu.el (slime-search-suppressed-forms-match-data):
	New var, to inhibit consing.
	(slime-search-suppressed-forms-internal): Use it.
	(slime-extend-region-for-font-lock): Do not call
	`slime-connected-p', it's not needed in this place.
	(slime-search-directly-preceding-reader-conditional): Do not use
	`values', and `multiple-value-bind'.
	(slime-beginning-of-tlf): When we know the current paren depth,
	use it to jump directly over all parens rather than jumping to
	each open paren in turn.
	(slime-compute-region-for-font-lock): Use it.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/15 20:02:43	1.209
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/16 12:54:33	1.210
@@ -1,3 +1,19 @@
+2009-05-16  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Optimize font-lock-magic.
+
+	* slime-fontifying-fu.el (slime-search-suppressed-forms-match-data):
+	New var, to inhibit consing.
+	(slime-search-suppressed-forms-internal): Use it.
+	(slime-extend-region-for-font-lock): Do not call
+	`slime-connected-p', it's not needed in this place.
+	(slime-search-directly-preceding-reader-conditional): Do not use
+	`values', and `multiple-value-bind'.
+	(slime-beginning-of-tlf): When we know the current paren depth,
+	use it to jump directly over all parens rather than jumping to
+	each open paren in turn.
+	(slime-compute-region-for-font-lock): Use it.
+
 2009-05-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-fontifying-fu.el (slime-search-suppressed-forms-internal):
--- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/15 20:02:43	1.3
+++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/16 12:54:33	1.4
@@ -29,6 +29,8 @@
   "Face for compiler notes while selected."
   :group 'slime-mode-faces)
 
+(defvar slime-search-suppressed-forms-match-data (list nil nil))
+
 (defun slime-search-suppressed-forms-internal (limit)
   (when (search-forward-regexp slime-reader-conditionals-regexp limit t)
     (if (let ((state (slime-current-parser-state)))
@@ -52,8 +54,7 @@
                 ;; With extending the region properly, this assertion
                 ;; would truly mean a bug now.
                 (assert (<= (point) limit))
-                (let ((md (match-data)))
-                  (fill md nil)
+                (let ((md (match-data nil slime-search-suppressed-forms-match-data)))
                   (setf (first md) start)
                   (setf (second md) (point))
                   (set-match-data md)
@@ -63,8 +64,7 @@
 (defun slime-search-suppressed-forms (limit)
   "Find reader conditionalized forms where the test is false."
   (when (and slime-highlight-suppressed-forms
-             (slime-connected-p)
-             (<= (point) limit))
+             (slime-connected-p))
     (condition-case condition
         (slime-search-suppressed-forms-internal limit)
       (end-of-file                      ; e.g. #+(
@@ -73,11 +73,11 @@
       ;; reason; however, there may still be other reader conditionals
       ;; before `limit'.
       (invalid-read-syntax              ; e.g. #+#.foo
-       (slime-search-suppressed-forms limit))
+       (slime-search-suppressed-forms-internal limit))
       (scan-error                       ; e.g. #| #+(or) #|
-       (slime-search-suppressed-forms limit)) 
+       (slime-search-suppressed-forms-internal limit)) 
       (slime-unknown-feature-expression ; e.g. #+(foo)
-       (slime-search-suppressed-forms limit)) 
+       (slime-search-suppressed-forms-internal limit)) 
       (error 
        (slime-bug 
         (concat "Caught error during fontification while searching for forms\n"
@@ -93,22 +93,20 @@
   ;;; no other intervening sexp, and we check that the reader
   ;;; conditional is at the same nesting level.
   (condition-case nil
-      (let ((orig-pt (point)))
-        (multiple-value-bind (reader-conditional-pt parser-state)
-            (save-excursion
-              (when-let (pt (search-backward-regexp slime-reader-conditionals-regexp
-                                                    ;; We restrict the search to the
-                                                    ;; beginning of the /previous/ defun.
-                                                    (save-match-data
-                                                      (save-excursion
-                                                        (beginning-of-defun) (point)))
-                                                    t))
-                (values pt (parse-partial-sexp (progn (goto-char (+ pt 2))
-                                                      (forward-sexp) ; skip feature expr.
-                                                      (point))
-                                               orig-pt))))
-          (let ((paren-depth  (nth 0 parser-state))
-                (last-sexp-pt (nth 2 parser-state)))
+      (let* ((orig-pt (point)))
+        (when-let (reader-conditional-pt 
+                   (search-backward-regexp slime-reader-conditionals-regexp
+                                           ;; We restrict the search to the
+                                           ;; beginning of the /previous/ defun.
+                                           (save-excursion (beginning-of-defun) (point))
+                                           t))
+          (let* ((parser-state 
+                  (parse-partial-sexp (progn (goto-char (+ reader-conditional-pt 2))
+                                             (forward-sexp) ; skip feature expr.
+                                             (point))
+                                      orig-pt))
+                 (paren-depth  (car  parser-state))
+                 (last-sexp-pt (caddr  parser-state)))
             (if (and paren-depth (not (plusp paren-depth)) ; no opening parenthesis in between?
                      (not last-sexp-pt))                   ; no complete sexp in between?
                 reader-conditional-pt
@@ -127,7 +125,7 @@
 ;;; to the beginning or end of a toplevel form. So we never miss a
 ;;; reader-conditional, or point in mid of one.
 (defun slime-extend-region-for-font-lock ()
-  (when (and slime-highlight-suppressed-forms (slime-connected-p))
+  (when slime-highlight-suppressed-forms
     (condition-case c
         (let (changedp)
           (multiple-value-setq (changedp font-lock-beg font-lock-end)
@@ -140,25 +138,32 @@
                 "Further: font-lock-beg=%d, font-lock-end=%d.")
         c font-lock-beg font-lock-end)))))
 
+(defun slime-beginning-of-tlf ()
+  (let* ((state (slime-current-parser-state))
+         (depth (nth 0 state)))
+    (if (plusp depth)
+        (up-list (- depth))
+        (when-let (upper-pt (nth 1 state)) 
+          (goto-char upper-pt)
+          (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
+                   (goto-char upper-pt)))))))
+
 (defun slime-compute-region-for-font-lock (orig-beg orig-end)
-  (flet ((beginning-of-tlf ()
-           (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
-                    (goto-char upper-pt)))))
-    (let ((beg orig-beg)
-          (end orig-end))
-      (goto-char beg)
-      (beginning-of-tlf)
-      (assert (not (plusp (nth 0 (slime-current-parser-state)))))
-      (setq beg (or (slime-search-directly-preceding-reader-conditional)
-                    (point)))
-      (goto-char end)
-      (when (search-backward-regexp slime-reader-conditionals-regexp beg t)
-        ;; Nested reader conditionals, yuck!
-        (while (when-let (pt (slime-search-directly-preceding-reader-conditional))
-                 (goto-char pt)))
-        (ignore-errors (slime-forward-reader-conditional))
-        (setq end (max end (point))))
-      (values (or (/= beg orig-beg) (/= end orig-end)) beg end))))
+  (let ((beg orig-beg)
+        (end orig-end))
+    (goto-char beg)
+    (inline (slime-beginning-of-tlf))
+    (assert (not (plusp (nth 0 (slime-current-parser-state)))))
+    (setq beg (or (slime-search-directly-preceding-reader-conditional)
+                  (point)))
+    (goto-char end)
+    (when (search-backward-regexp slime-reader-conditionals-regexp beg t)
+      ;; Nested reader conditionals, yuck!
+      (while (when-let (pt (slime-search-directly-preceding-reader-conditional))
+               (goto-char pt)))
+      (ignore-errors (slime-forward-reader-conditional))
+      (setq end (max end (point))))
+    (values (or (/= beg orig-beg) (/= end orig-end)) beg end)))
 
 
 (defun slime-activate-font-lock-magic ()
@@ -193,4 +198,12 @@
   ;;; extend-region hook.
   )
 
-(provide 'slime-fontifying-fu)
\ No newline at end of file
+(provide 'slime-fontifying-fu)
+
+(let ((byte-compile-warnings '())) 
+  (mapc #'byte-compile
+        '(slime-extend-region-for-font-lock
+          slime-compute-region-for-font-lock
+          slime-search-directly-preceding-reader-conditional
+          slime-search-suppressed-forms
+          slime-beginning-of-tlf)))




From trittweiler at common-lisp.net  Sat May 16 13:12:04 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 16 May 2009 09:12:04 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M5JgK-0007O6-PK@common-lisp.net>

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

Modified Files:
	ChangeLog slime-fontifying-fu.el 
Log Message:
	* slime-fontifying-fu.el (slime-beginning-of-tlf): Make sure to
	skip outside of comments and strings first.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/16 12:54:33	1.210
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/16 13:12:03	1.211
@@ -1,5 +1,10 @@
 2009-05-16  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-fontifying-fu.el (slime-beginning-of-tlf): Make sure to
+	skip outside of comments and strings first.
+
+2009-05-16  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Optimize font-lock-magic.
 
 	* slime-fontifying-fu.el (slime-search-suppressed-forms-match-data):
--- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/16 12:54:33	1.4
+++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/16 13:12:04	1.5
@@ -140,13 +140,17 @@
 
 (defun slime-beginning-of-tlf ()
   (let* ((state (slime-current-parser-state))
-         (depth (nth 0 state)))
-    (if (plusp depth)
-        (up-list (- depth))
-        (when-let (upper-pt (nth 1 state)) 
-          (goto-char upper-pt)
-          (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
-                   (goto-char upper-pt)))))))
+         (comment-start (nth 8 state)))
+    (when comment-start                 ; or string
+      (goto-char comment-start)
+      (setq state (slime-current-parser-state)))
+    (let ((depth (nth 0 state)))
+      (if (plusp depth)
+          (up-list (- depth))
+          (when-let (upper-pt (nth 1 state)) 
+            (goto-char upper-pt)
+            (while (when-let (upper-pt (nth 1 (slime-current-parser-state)))
+                     (goto-char upper-pt))))))))
 
 (defun slime-compute-region-for-font-lock (orig-beg orig-end)
   (let ((beg orig-beg)




From heller at common-lisp.net  Sat May 16 17:21:03 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 16 May 2009 13:21:03 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5NZH-0000aq-5X@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (swank-compile-string): Store the source
code, by setting CCL:*SAVE-SOURCE-LOCATIONS* to T, for better
disassembler output.
(function-source-location): Remove the old pre-1.3 version.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/16 12:46:04	1.1755
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/16 17:21:02	1.1756
@@ -1,3 +1,10 @@
+2009-05-16  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-openmcl.lisp (swank-compile-string): Store the source
+	code, by setting CCL:*SAVE-SOURCE-LOCATIONS* to T, for better
+	disassembler output.
+	(function-source-location): Remove the old pre-1.3 version.
+
 2009-05-16  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-current-parser-state): Do not save
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/04/29 22:29:18	1.162
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/16 17:21:02	1.163
@@ -368,7 +368,8 @@
   (with-compilation-hooks ()
     (let ((*buffer-name* buffer)
           (*buffer-offset* position)
-          (temp-file-name (temp-file-name)))
+          (temp-file-name (temp-file-name))
+          (ccl:*save-source-locations* t))
       (unwind-protect
            (progn
              (with-open-file (s temp-file-name :direction :output 
@@ -673,122 +674,67 @@
 ;; backward-compatible functions that deal with filenames only.  The plan
 ;; is to make Slime, and our IDE, use this eventually.
 
-#+#.(cl:if (cl:fboundp 'ccl::function-source-note) '(:or) '(:and))
-(progn
-  (defun function-source-location (function)
-    (or (car (source-locations function))
-        (list :error (format nil "No source info available for ~A" function))))
-  
-  (defun pc-source-location (function pc)
-    (function-source-location function))
+(defun function-source-location (function)
+  (source-note-to-source-location
+   (ccl:function-source-note function)
+   (lambda ()
+     (format nil "Function has no source note: ~A" function))))
+
+(defun pc-source-location (function pc)
+  (source-note-to-source-location
+   (or (ccl:find-source-note-at-pc function pc)
+       (ccl:function-source-note function))
+   (lambda ()
+     (format nil "No source note at PC: ~A:#x~x" function pc))))
 
-  ;; source-locations THING => LOCATIONS NAMES
-  ;; LOCATIONS ... a list of source-locations.  Most "specific" first.
-  ;; NAMES     ... a list of names.
-  (labels ((str (obj) (princ-to-string obj))
-           (str* (list) (mapcar #'princ-to-string list))
-           (unzip (list) (values (mapcar #'car list) (mapcar #'cdr list)))
-           (filename (file) (namestring (truename file)))
-           (src-loc (file pos)
-             (etypecase file
-               (null `(:error "No source-file info available"))
-               ((or string pathname)
-                (handler-case (make-location `(:file ,(filename file)) pos)
-                  (error (c) `(:error ,(princ-to-string c)))))))
-           (fallback (thing)
-             (cond ((functionp thing)
-                    (let ((name (ccl::function-name thing)))
-                      (and (consp name) (eq (car name) :internal)
-                           (ccl::edit-definition-p (second name))))))))
-
-    ;; FIXME: reorder result, e.g. if THING is a function then return
-    ;; the locations for type 'function before those with type
-    ;; 'variable.  (Otherwise the debugger jumps to compiler-macros
-    ;; instead of functions :-)
-    (defun source-locations (thing)
-      (multiple-value-bind (files name) (ccl::edit-definition-p thing)
-        (when (null files) 
-          (multiple-value-setq (files name) (fallback thing)))
-        (unzip
-         (loop for (type . file) in files collect
-               (etypecase type
-                 ((member function macro variable compiler-macro 
-                          ccl:defcallback ccl::x8664-vinsn)
-                  (cons (src-loc file (list :function-name (str name))) 
-                        (list type name)))
-                 (method
-                  (let* ((met type)
-                         (name (ccl::method-name met))
-                         (specs (ccl::method-specializers met))
-                         (specs (mapcar #'specializer-name specs))
-                         (quals (ccl::method-qualifiers met)))
-                    (cons (src-loc file (list :method (str name) 
-                                              (str* specs) (str* quals)))
-                          `(method ,name , at quals ,specs)))))))))))
-
-#+#.(cl:if (cl:fboundp 'ccl::function-source-note) '(:and) '(:or))
-(progn
-  (defun function-source-location (function)
-    (source-note-to-source-location
-     (ccl:function-source-note function)
-     (lambda ()
-       (format nil "Function has no source note: ~A" function))))
-
-  (defun pc-source-location (function pc)
-    (source-note-to-source-location
-     (or (ccl:find-source-note-at-pc function pc)
-         (ccl:function-source-note function))
-     (lambda ()
-       (format nil "No source note at PC: ~A:#x~x" function pc))))
-
-  (defun source-note-to-source-location (note if-nil-thunk)
-    (labels ((filename-to-buffer (filename)
-               (cond ((probe-file filename)
-                      (list :file (namestring (truename filename))))
-                     ((gethash filename *temp-file-map*)
-                      (list :buffer (gethash filename *temp-file-map*)))
-                     (t (error "File ~s doesn't exist" filename)))))
-      (cond (note
-             (handler-case
-                 (make-location 
-                  (filename-to-buffer (ccl:source-note-filename note))
-                  (list :position (1+ (ccl:source-note-start-pos note))))
-               (error (c) `(:error ,(princ-to-string c)))))
+(defun source-note-to-source-location (note if-nil-thunk)
+  (labels ((filename-to-buffer (filename)
+             (cond ((probe-file filename)
+                    (list :file (namestring (truename filename))))
+                   ((gethash filename *temp-file-map*)
+                    (list :buffer (gethash filename *temp-file-map*)))
+                   (t (error "File ~s doesn't exist" filename)))))
+    (cond (note
+           (handler-case
+               (make-location 
+                (filename-to-buffer (ccl:source-note-filename note))
+                (list :position (1+ (ccl:source-note-start-pos note))))
+             (error (c) `(:error ,(princ-to-string c)))))
           (t `(:error ,(funcall if-nil-thunk))))))
 
-  (defimplementation find-definitions (symbol)
-    (loop for (loc . name) in (source-locations symbol)
-          collect (list name loc)))
-
-  (defgeneric source-locations (thing))
-
-  (defmethod source-locations ((f function))
-    (list (cons (function-source-location f)
-                (list 'function (ccl:function-name f)))))
-
-  (defmethod source-locations ((s symbol))
-    (append
-     #+(or)
-     (if (and (fboundp s) 
-              (not (macro-function s))
-              (not (special-operator-p s))
-              (functionp (symbol-function s)))
-         (source-locations (symbol-function s)))
-     (loop for ((type . name) source) in (ccl:find-definition-sources s)
-           collect (cons (source-note-to-source-location 
-                          source (lambda () "No source info available"))
-                         (definition-name type name)))))
-
-  (defgeneric definition-name (type name)
-    (:method ((type ccl::definition-type) name)
-      (list (ccl::definition-type-name type) name)))
-
-  (defmethod definition-name ((type ccl::method-definition-type)
-                              (met method))
-    `(,(ccl::definition-type-name type)
-       ,(ccl::method-name met)
-       ,@(ccl::method-qualifiers met)
-       ,(mapcar #'specializer-name (ccl::method-specializers met)))))
+(defimplementation find-definitions (symbol)
+  (loop for (loc . name) in (source-locations symbol)
+        collect (list name loc)))
+
+(defgeneric source-locations (thing))
+
+(defmethod source-locations ((f function))
+  (list (cons (function-source-location f)
+              (list 'function (ccl:function-name f)))))
+
+(defmethod source-locations ((s symbol))
+  (append
+   #+(or)
+   (if (and (fboundp s) 
+            (not (macro-function s))
+            (not (special-operator-p s))
+            (functionp (symbol-function s)))
+       (source-locations (symbol-function s)))
+   (loop for ((type . name) source) in (ccl:find-definition-sources s)
+         collect (cons (source-note-to-source-location 
+                        source (lambda () "No source info available"))
+                       (definition-name type name)))))
+
+(defgeneric definition-name (type name)
+  (:method ((type ccl::definition-type) name)
+    (list (ccl::definition-type-name type) name)))
+
+(defmethod definition-name ((type ccl::method-definition-type)
+                            (met method))
+  `(,(ccl::definition-type-name type)
+     ,(ccl::method-name met)
+     ,@(ccl::method-qualifiers met)
+     ,(mapcar #'specializer-name (ccl::method-specializers met))))
   
 (defimplementation frame-source-location-for-emacs (index)
   "Return to Emacs the location of the source code for the




From heller at common-lisp.net  Sat May 16 17:21:12 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 16 May 2009 13:21:12 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5NZQ-0000bP-5r@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (sldb-bitvector-pprint): Oops, all bits are true.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/16 17:21:02	1.1756
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/16 17:21:12	1.1757
@@ -5,6 +5,8 @@
 	disassembler output.
 	(function-source-location): Remove the old pre-1.3 version.
 
+	* swank.lisp (sldb-bitvector-pprint): Oops, all bits are true.
+
 2009-05-16  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-current-parser-state): Do not save
--- /project/slime/cvsroot/slime/swank.lisp	2009/05/16 11:38:47	1.645
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/16 17:21:12	1.646
@@ -114,7 +114,7 @@
                        (when (= i *sldb-bitvector-length*)
                          (write-string "..." stream)
                          (loop-finish))
-                       (write-char (if bit #\1 #\0) stream))))
+                       (write-char (if (= bit 0) #\0 #\1) stream))))
            (sldb-string-pprint (stream string)
              ;;; Truncate strings according to *SLDB-STRING-LENGTH*.
              (cond ((not *print-escape*)




From heller at common-lisp.net  Sat May 16 18:17:13 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 16 May 2009 14:17:13 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5ORa-0002LQ-Vb@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
Minor refactoring.

* swank-openmcl.lisp (call/frame, with-frame): New macro.
(frame-visible-variables): New helper.
(frame-var-value, frame-locals, disassemble-frame): Use it.
(frame-catch-tags): Removed.  Way to much code for such a rarely
used function.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/16 17:21:12	1.1757
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/16 18:17:10	1.1758
@@ -1,5 +1,15 @@
 2009-05-16  Helmut Eller  <heller at common-lisp.net>
 
+	Minor refactoring.
+
+	* swank-openmcl.lisp (call/frame, with-frame): New macro.
+	(frame-visible-variables): New helper.
+	(frame-var-value, frame-locals, disassemble-frame): Use it.
+	(frame-catch-tags): Removed.  Way to much code for such a rarely
+	used function.
+
+2009-05-16  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-openmcl.lisp (swank-compile-string): Store the source
 	code, by setting CCL:*SAVE-SOURCE-LOCATIONS* to T, for better
 	disassembler output.
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/16 17:21:02	1.163
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/16 18:17:10	1.164
@@ -522,81 +522,50 @@
             (or (ccl::function-name lfun) lfun)
             (frame-arguments p context lfun pc))))
 
-(defimplementation frame-var-value (frame var)
-  (block frame-var-value
-    (map-backtrace  
-     #'(lambda(frame-number p context lfun pc)
-         (when (= frame frame-number)
-           (return-from frame-var-value 
-             (multiple-value-bind (total vsp parent-vsp)
-                 (ccl::count-values-in-frame p context)
-               (loop for count below total
-                     with varcount = -1
-                     for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp))
-                     when name do (incf varcount)
-                     until (= varcount var)
-                     finally (return value)))))))))
+(defun call/frame (frame-number if-found)
+  (map-backtrace  
+   (lambda (fnumber p context lfun pc)
+     (when (= fnumber frame-number)
+       (return-from call/frame 
+         (funcall if-found p context lfun pc))))))
 
-(defimplementation frame-locals (index)
-  (block frame-locals
-    (map-backtrace 
-     (lambda (frame-number p context lfun pc)
-       (when (= frame-number index)
-         (multiple-value-bind (count vsp parent-vsp)
-             (ccl::count-values-in-frame p context)
-           (let (result)
-             (dotimes (i count)
-               (multiple-value-bind (var type name)
-                   (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
-                 (declare (ignore type))
-                 (when name
-                   (push (list 
-                          :name name
-                          :id 0
-                          :value (if (typep var 'ccl::value-cell)
-                                     (ccl::uvref var 0)
-                                     var))
-                         result))))
-             (return-from frame-locals (nreverse result)))))))))
+(defmacro with-frame ((p context lfun pc) frame-number &body body)
+  `(call/frame ,frame-number (lambda (,p ,context ,lfun ,pc) . ,body)))
 
+(defimplementation frame-var-value (frame var)
+  (with-frame (p context lfun pc) frame
+    (cadr (nth var (frame-visible-variables p context lfun pc)))))
 
-#+(or) ;; Doesn't work well on x86-32
-(defimplementation frame-catch-tags (index &aux my-frame)
-  (block frame-catch-tags
-    (map-backtrace 
-     (lambda (frame-number p context lfun pc)
-       (declare (ignore pc lfun))
-       (if (= frame-number index) 
-           (setq my-frame p)
-           (when my-frame
-             (return-from frame-catch-tags
-               (loop for catch = (ccl::%catch-top (ccl::%current-tcr)) then (ccl::next-catch catch)
-                     while catch
-                     for csp = (ccl::uvref catch 3) ; ppc32::catch-frame.csp-cell) defined in arch.lisp
-                     for tag = (ccl::uvref catch 0) ; ppc32::catch-frame.catch-tag-cell)
-                     until (ccl::%stack< p csp context)
-                     when (ccl::%stack< my-frame csp context)
-                     collect (cond 
-                               ((symbolp tag)
-                                tag)
-                               ((and (listp tag)
-                                     (typep (car tag) 'restart))
-                                `(:restart ,(restart-name (car tag)))))))))))))
+(defimplementation frame-locals (index)
+  (with-frame (p context lfun pc) index
+    (loop for (name value) in (frame-visible-variables p context lfun pc)
+          collect (list :name name :value value :id 0))))
+
+(defun frame-visible-variables (p context lfun pc)
+  "Return a list ((NAME VALUE) ...) of the named variables for this frame."
+  (multiple-value-bind (count vsp parent-vsp) 
+      (ccl::count-values-in-frame p context)
+    (let (result)
+      (dotimes (i count)
+        (multiple-value-bind (var type name)
+            (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
+          (declare (ignore type))
+          (when name
+            (let ((value (typecase var
+                           (ccl::value-cell (ccl::uvref var 0))
+                           (t var))))
+              (push (list name value) result)))))
+      (reverse result))))
 
 (defimplementation disassemble-frame (the-frame-number)
-  (let ((function-to-disassemble nil))
-    (block find-frame
-      (map-backtrace
-       (lambda(frame-number p context lfun pc)
-         (declare (ignore p context pc))
-         (when (= frame-number the-frame-number)
-           (setq function-to-disassemble lfun)
-           (return-from find-frame)))))
+  (with-frame (p context lfun pc) the-frame-number
+    (declare (ignore p context pc))
     #+ppc (ccl::print-ppc-instructions 
            *standard-output* 
-           (ccl::function-to-dll-header function-to-disassemble)
+           (ccl::function-to-dll-header lfun)
            nil)
-    #+x86-64 (ccl::x8664-xdisassemble function-to-disassemble)))
+    #+x86-64 (ccl::x8664-xdisassemble lfun)
+    #+x8632-target (ccl::x8632-xdisassemble lfun)))
 
 ;;;
 




From heller at common-lisp.net  Sun May 17 08:59:31 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 17 May 2009 04:59:31 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5cDT-0005eV-Bt@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
More precise compiler-message location.

* swank-openmcl.lisp (handle-compiler-warning): Use the
source-note slot of the condition as source location, which is
more precise than the stream-position slot.
(compiler-warning-severity): New function. The distinction between
warning and style-warning is rather arbitrary but let's try it.
(swank-compile-file): Pass the external-format arg down to
compile file.
(*buffer-name*, *buffer-offset*, condition-source-position):
Deleted. No longer used.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/16 18:17:10	1.1758
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/17 08:59:31	1.1759
@@ -1,3 +1,17 @@
+2009-05-17  Helmut Eller  <heller at common-lisp.net>
+
+	More precise compiler-message location.
+
+	* swank-openmcl.lisp (handle-compiler-warning): Use the
+	source-note slot of the condition as source location, which is
+	more precise than the stream-position slot.
+	(compiler-warning-severity): New function. The distinction between
+	warning and style-warning is rather arbitrary but let's try it.
+	(swank-compile-file): Pass the external-format arg down to
+	compile file.
+	(*buffer-name*, *buffer-offset*, condition-source-position):
+	Deleted. No longer used.
+
 2009-05-16  Helmut Eller  <heller at common-lisp.net>
 
 	Minor refactoring.
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/16 18:17:10	1.164
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 08:59:31	1.165
@@ -227,41 +227,20 @@
 
 ;;; Compilation
 
-(defvar *buffer-offset* nil)
-(defvar *buffer-name* nil)
-
-(defun condition-source-position (condition)
-  "Return the position in the source file of a compiler condition."
-  (+ 1
-     (or *buffer-offset* 0)
-     ;; alanr sometimes returned stream position nil.
-     (or (ccl::compiler-warning-stream-position condition) 0))) 
-
-
 (defun handle-compiler-warning (condition)
-  "Construct a compiler note for Emacs from a compiler warning
-condition."
+  "Resignal a ccl:compiler-warning as swank-backend:compiler-warning."
   (signal (make-condition
            'compiler-condition
            :original-condition condition
            :message (format nil "~A" condition)
-           :severity :warning
-           :location
-           (let ((position (condition-source-position condition)))
-             (if *buffer-name*
-                 (make-location
-                  (list :buffer *buffer-name*)
-                  (list :offset position 0)
-                  (list :align t))
-                 (if (ccl::compiler-warning-file-name condition)
-                     (make-location
-                      (list :file (namestring (truename (ccl::compiler-warning-file-name condition))))
-                      (list :position position)
-                      (list :align t))))))))
-
-(defun temp-file-name ()
-  "Return a temporary file name to compile strings into."
-  (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
+           :severity (compiler-warning-severity condition)
+           :location (source-note-to-source-location 
+                      (ccl::compiler-warning-source-note condition)
+                      (lambda () "Unknown source")))))
+
+(defgeneric compiler-warning-severity (condition))
+(defmethod compiler-warning-severity ((c ccl::compiler-warning)) :warning)
+(defmethod compiler-warning-severity ((c ccl::style-warning)) :style-warning)
 
 (defimplementation call-with-compilation-hooks (function)
   (handler-bind ((ccl::compiler-warning 'handle-compiler-warning))
@@ -269,13 +248,11 @@
 
 (defimplementation swank-compile-file (input-file output-file
                                        load-p external-format)
-  (declare (ignore external-format))
   (with-compilation-hooks ()
-    (let ((*buffer-name* nil)
-          (*buffer-offset* nil))
-      (compile-file input-file 
-                    :output-file output-file
-                    :load load-p))))
+    (compile-file input-file 
+                  :output-file output-file 
+                  :load load-p
+                  :external-format external-format)))
 
 (defun xref-locations (relation name &optional (inverse nil))
   (flet ((function-source-location (entry)
@@ -362,13 +339,15 @@
            (mapcan 'who-specializes (ccl::%class-direct-subclasses class)))
    :test 'equal))
 
+(defun temp-file-name ()
+  "Return a temporary file name to compile strings into."
+  (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
+
 (defimplementation swank-compile-string (string &key buffer position filename
                                          policy)
   (declare (ignore policy))
   (with-compilation-hooks ()
-    (let ((*buffer-name* buffer)
-          (*buffer-offset* position)
-          (temp-file-name (temp-file-name))
+    (let ((temp-file-name (temp-file-name))
           (ccl:*save-source-locations* t))
       (unwind-protect
            (progn




From heller at common-lisp.net  Sun May 17 13:00:06 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 17 May 2009 09:00:06 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5fyI-00026l-IW@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (compile-temp-file): Remove backward
compatibility code.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/17 08:59:31	1.1759
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/17 13:00:06	1.1760
@@ -1,5 +1,10 @@
 2009-05-17  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-openmcl.lisp (compile-temp-file): Remove backward
+	compatibility code.
+
+2009-05-17  Helmut Eller  <heller at common-lisp.net>
+
 	More precise compiler-message location.
 
 	* swank-openmcl.lisp (handle-compiler-warning): Use the
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 08:59:31	1.165
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 13:00:06	1.166
@@ -205,7 +205,7 @@
 (defimplementation lisp-implementation-type-name ()
   "ccl")
 
-;;; Evaluation
+;;; Arglist
 
 (defimplementation arglist (fname)
   (arglist% fname))
@@ -254,6 +254,42 @@
                   :load load-p
                   :external-format external-format)))
 
+(defun temp-file-name ()
+  "Return a temporary file name to compile strings into."
+  (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
+
+(defimplementation swank-compile-string (string &key buffer position filename
+                                         policy)
+  (declare (ignore policy))
+  (with-compilation-hooks ()
+    (let ((temp-file-name (temp-file-name))
+          (ccl:*save-source-locations* t))
+      (unwind-protect
+           (progn
+             (with-open-file (s temp-file-name :direction :output 
+                                :if-exists :error)
+               (write-string string s))
+             (let ((binary-filename (compile-temp-file
+                                     temp-file-name filename buffer position)))
+               (delete-file binary-filename)))
+        (delete-file temp-file-name)))))
+
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+  "A mapping from tempfile names to Emacs buffer names.")
+
+(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
+  (compile-file temp-file-name
+                :load t
+                :compile-file-original-truename 
+                (or buffer-file-name
+                    (progn 
+                      (setf (gethash temp-file-name *temp-file-map*)
+                            buffer-name)
+                      temp-file-name))
+                :compile-file-original-buffer-offset (1- offset)))
+
+;;; Cross-referencing
+
 (defun xref-locations (relation name &optional (inverse nil))
   (flet ((function-source-location (entry)
            (multiple-value-bind (info name)
@@ -339,41 +375,6 @@
            (mapcan 'who-specializes (ccl::%class-direct-subclasses class)))
    :test 'equal))
 
-(defun temp-file-name ()
-  "Return a temporary file name to compile strings into."
-  (ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
-
-(defimplementation swank-compile-string (string &key buffer position filename
-                                         policy)
-  (declare (ignore policy))
-  (with-compilation-hooks ()
-    (let ((temp-file-name (temp-file-name))
-          (ccl:*save-source-locations* t))
-      (unwind-protect
-           (progn
-             (with-open-file (s temp-file-name :direction :output 
-                                :if-exists :error)
-               (write-string string s))
-             (let ((binary-filename (compile-temp-file
-                                     temp-file-name filename buffer position)))
-               (delete-file binary-filename)))
-        (delete-file temp-file-name)))))
-
-(defvar *temp-file-map* (make-hash-table :test #'equal)
-  "A mapping from tempfile names to Emacs buffer names.")
-
-(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
-  (if (fboundp 'ccl::function-source-note)
-      (compile-file temp-file-name
-                    :load t
-                    :compile-file-original-truename 
-                    (or buffer-file-name
-                        (progn 
-                          (setf (gethash temp-file-name *temp-file-map*)
-                                buffer-name)
-                          temp-file-name))
-                    :compile-file-original-buffer-offset (1- offset))
-      (compile-file temp-file-name :load t)))
 
 ;;; Profiling (alanr: lifted from swank-clisp)
 




From heller at common-lisp.net  Sun May 17 13:00:18 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 17 May 2009 09:00:18 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5fyS-0002H6-KE@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (eval-in-frame, frame-source-location-for-emacs)
(return-from-frame, restart-frame)
(disassemble-frame): Simplify.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/17 13:00:06	1.1760
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/17 13:00:16	1.1761
@@ -2,6 +2,9 @@
 
 	* swank-openmcl.lisp (compile-temp-file): Remove backward
 	compatibility code.
+	(eval-in-frame, frame-source-location-for-emacs)
+	(return-from-frame, restart-frame)
+	(disassemble-frame): Simplify.
 
 2009-05-17  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 13:00:06	1.166
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 13:00:16	1.167
@@ -537,15 +537,49 @@
               (push (list name value) result)))))
       (reverse result))))
 
+(defimplementation frame-source-location-for-emacs (index)
+  (with-frame (p context lfun pc) index
+    (declare (ignore p context))
+    (if pc
+        (pc-source-location lfun pc)
+        (function-source-location lfun))))
+
+(defimplementation eval-in-frame (form index)
+  (with-frame (p context lfun pc) index
+    (let ((vars (frame-visible-variables p context lfun pc)))
+      (eval `(let ,(loop for (var val) in vars collect `(,var ',val))
+               (declare (ignorable ,@(mapcar #'car vars)))
+               ,form)))))
+
+(defimplementation return-from-frame (index form)
+  (let ((values (multiple-value-list (eval-in-frame form index))))
+    (with-frame (p context lfun pc) index
+       (declare (ignore context lfun pc))
+       (ccl::apply-in-frame p #'values values))))
+
+(defimplementation restart-frame (index)
+  (with-frame (p context lfun pc) index
+    (ccl::apply-in-frame p lfun 
+                         (ccl::frame-supplied-args p lfun pc nil context))))
+
+(let ((ccl::*warn-if-redefine-kernel* nil))
+  (ccl::advise
+   ccl::cbreak-loop
+   (if *break-in-sldb* 
+       (apply #'break-in-sldb ccl::arglist)
+       (:do-it))
+   :when :around
+   :name sldb-break))
+
+(defun break-in-sldb (x y &rest args)
+  (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
+                                   (ccl::%get-frame-ptr))))
+    (apply #'cerror y (if args "Break: ~a" x) args)))
+
 (defimplementation disassemble-frame (the-frame-number)
   (with-frame (p context lfun pc) the-frame-number
     (declare (ignore p context pc))
-    #+ppc (ccl::print-ppc-instructions 
-           *standard-output* 
-           (ccl::function-to-dll-header lfun)
-           nil)
-    #+x86-64 (ccl::x8664-xdisassemble lfun)
-    #+x8632-target (ccl::x8632-xdisassemble lfun)))
+    (disassemble lfun)))
 
 ;;;
 
@@ -684,73 +718,6 @@
      ,(ccl::method-name met)
      ,@(ccl::method-qualifiers met)
      ,(mapcar #'specializer-name (ccl::method-specializers met))))
-  
-(defimplementation frame-source-location-for-emacs (index)
-  "Return to Emacs the location of the source code for the
-function in a debugger frame.  In OpenMCL, we are not able to
-find the precise position of the frame, but we do attempt to give
-at least the filename containing it."
-  (block frame-source-location-for-emacs
-    (map-backtrace
-     (lambda (frame-number p context lfun pc)
-       (declare (ignore p context))
-       (when (and (= frame-number index) lfun)
-         (return-from frame-source-location-for-emacs
-           (if pc
-               (pc-source-location lfun pc)
-               (function-source-location lfun))))))))
-
-(defimplementation eval-in-frame (form index)
-  (block eval-in-frame
-    (map-backtrace
-     (lambda (frame-number p context lfun pc)
-       (when (= frame-number index)
-         (multiple-value-bind (count vsp parent-vsp)
-             (ccl::count-values-in-frame p context)
-           (let ((bindings nil))
-             (dotimes (i count)
-               (multiple-value-bind (var type name)
-                   (ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
-                 (declare (ignore type))
-                 (when name
-                   (push (list name `',var) bindings))
-                 ))
-             (return-from eval-in-frame
-               (eval `(let ,bindings
-                        (declare (ignorable ,@(mapcar 'car bindings)))
-                        ,form)))
-             )))))))
-
-#+ppc
-(defimplementation return-from-frame (index form)
-  (let ((values (multiple-value-list (eval-in-frame form index))))
-    (map-backtrace
-     (lambda (frame-number p context lfun pc)
-       (declare (ignore context lfun pc))
-       (when (= frame-number index)
-         (ccl::apply-in-frame p #'values values))))))
-
-#+ppc
-(defimplementation restart-frame (index)
-  (map-backtrace
-   (lambda (frame-number p context lfun pc)
-     (when (= frame-number index)
-       (ccl::apply-in-frame p lfun 
-                            (ccl::frame-supplied-args p lfun pc nil context))))))
-
-(let ((ccl::*warn-if-redefine-kernel* nil))
-  (ccl::advise
-   ccl::cbreak-loop
-   (if *break-in-sldb* 
-       (apply #'break-in-sldb ccl::arglist)
-       (:do-it))
-   :when :around
-   :name sldb-break))
-
-(defun break-in-sldb (x y &rest args)
-  (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
-                                   (ccl::%get-frame-ptr))))
-    (apply #'cerror y (if args "Break: ~a" x) args)))
 
 ;;; Utilities
 




From heller at common-lisp.net  Sun May 17 13:00:25 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 17 May 2009 09:00:25 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5fyb-0002Or-1E@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (disassemble-frame, xref-locations): Simplify.
(list-callers): Use ccl::caller-functions which gives us more precise
src-locs than ccl::callers.
(canonicalize-location, remove-filename-quoting)
(maybe-method-location): Deleted.  No longer used.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/17 13:00:16	1.1761
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/17 13:00:24	1.1762
@@ -4,7 +4,11 @@
 	compatibility code.
 	(eval-in-frame, frame-source-location-for-emacs)
 	(return-from-frame, restart-frame)
-	(disassemble-frame): Simplify.
+	(disassemble-frame, xref-locations): Simplify.
+	(list-callers): Use ccl::caller-functions which gives us more precise
+	src-locs than ccl::callers.
+	(canonicalize-location, remove-filename-quoting)
+	(maybe-method-location): Deleted.  No longer used.
 
 2009-05-17  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 13:00:16	1.167
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 13:00:24	1.168
@@ -291,43 +291,13 @@
 ;;; Cross-referencing
 
 (defun xref-locations (relation name &optional (inverse nil))
-  (flet ((function-source-location (entry)
-           (multiple-value-bind (info name)
-               (ccl::edit-definition-p
-                (ccl::%db-key-from-xref-entry entry)
-                (if (eql (ccl::xref-entry-type entry)
-                         'macro)
-                  'function
-                  (ccl::xref-entry-type entry)))
-             (cond ((not info)
-                    (list :error
-                          (format nil "No source info available for ~A"
-                                  (ccl::xref-entry-name entry))))
-                   ((typep (caar info) 'ccl::method)
-                    `(:location 
-                      (:file ,(remove-filename-quoting
-                               (namestring (translate-logical-pathname
-                                            (cdr (car info))))))
-                      (:method
-                          ,(princ-to-string (ccl::method-name (caar info)))
-                        ,(mapcar 'princ-to-string
-                                 (mapcar #'specializer-name
-                                         (ccl::method-specializers
-                                          (caar info))))
-                        ,@(mapcar 'princ-to-string
-                                  (ccl::method-qualifiers (caar info))))
-                      nil))
-                   (t
-                    (canonicalize-location (cdr (first info)) name))))))
-    (declare (dynamic-extent #'function-source-location))
-    (loop for xref in (if inverse 
-                          (ccl::get-relation relation name
-                                             :wild :exhaustive t)
-                          (ccl::get-relation relation
-                                             :wild name :exhaustive t))
-       for function = (ccl::xref-entry-name xref)
-       collect `((function ,function)
-                 ,(function-source-location xref)))))
+  (loop for xref in (if inverse 
+                        (ccl::get-relation relation name
+                                           :wild :exhaustive t)
+                        (ccl::get-relation relation
+                                           :wild name :exhaustive t))
+        append (loop for (loc . name) in (source-locations xref)
+                     collect `(,name ,loc))))
 
 (defimplementation who-binds (name)
   (xref-locations :binds name))
@@ -353,13 +323,6 @@
     (xref-locations :macro-calls name t))
    :test 'equal))
 
-(defimplementation list-callees (name)
-  (remove-duplicates
-   (append
-   (xref-locations :direct-calls name t)
-   (xref-locations :macro-calls name nil))
-   :test 'equal))
-
 (defimplementation who-specializes (class)
   (if (symbolp class) (setq class (find-class class)))
   (remove-duplicates
@@ -376,6 +339,16 @@
    :test 'equal))
 
 
+(defimplementation list-callees (name)
+  (remove-duplicates
+   (append
+   (xref-locations :direct-calls name t)
+   (xref-locations :macro-calls name nil))
+   :test 'equal))
+
+(defimplementation list-callers (symbol)
+  (mapcan #'find-definitions (ccl::caller-functions symbol)))
+
 ;;; Profiling (alanr: lifted from swank-clisp)
 
 (defimplementation profile (fname)
@@ -581,39 +554,6 @@
     (declare (ignore p context pc))
     (disassemble lfun)))
 
-;;;
-
-(defun canonicalize-location (file symbol &optional snippet)
-  (etypecase file
-    ((or string pathname)
-     (multiple-value-bind (truename c) (ignore-errors (namestring (truename file)))
-       (cond (c (list :error (princ-to-string c)))
-             (t (make-location (list :file (remove-filename-quoting truename))
-                               (list :function-name (princ-to-string symbol))
-                               (if snippet
-                                   (list :snippet snippet)
-                                   '()))))))))
-
-(defun remove-filename-quoting (string)
-  (if (search "\\" string)
-      (read-from-string (format nil "\"~a\"" string))
-      string))
-
-(defun maybe-method-location (type)
-  (when (typep type 'ccl::method)
-    `((method ,(ccl::method-name type)
-              ,(mapcar #'specializer-name (ccl::method-specializers type))
-              ,@(ccl::method-qualifiers type))
-      ,(function-source-location (ccl::method-function type)))))
-
-(defimplementation find-definitions (symbol)
-  (let* ((info (ccl::get-source-files-with-types&classes symbol)))
-    (loop for (type . file) in info
-          when (not (equal "l1-boot-3" (pathname-name file))) ; alanr: This is a bug - there's nothing in there
-          collect (or (maybe-method-location type)
-                      (list (list type symbol) 
-                            (canonicalize-location file symbol))))))
-
 ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
 ;; contains some interesting details:
 ;; 
@@ -682,13 +622,16 @@
                (make-location 
                 (filename-to-buffer (ccl:source-note-filename note))
                 (list :position (1+ (ccl:source-note-start-pos note))))
-             (error (c) `(:error ,(princ-to-string c)))))
+             (error (c) 
+               ;;(break "~a" c)
+               `(:error ,(princ-to-string c)))))
           (t `(:error ,(funcall if-nil-thunk))))))
 
 (defimplementation find-definitions (symbol)
   (loop for (loc . name) in (source-locations symbol)
         collect (list name loc)))
 
+;; Return a list ((LOC . NAME) ...) of possible src-locs.
 (defgeneric source-locations (thing))
 
 (defmethod source-locations ((f function))
@@ -708,9 +651,24 @@
                         source (lambda () "No source info available"))
                        (definition-name type name)))))
 
-(defgeneric definition-name (type name)
-  (:method ((type ccl::definition-type) name)
-    (list (ccl::definition-type-name type) name)))
+(defmethod source-locations ((m method))
+  (list (cons (function-source-location (ccl::method-function m))
+              (definition-name ccl::*method-definition-type* m))))
+
+(defmethod source-locations ((xe ccl::xref-entry))
+  (with-slots (ccl::name type method-qualifiers ccl::method-specializers) xe
+    (let ((name (case type
+                  (method 
+                   `(,ccl::name , at method-qualifiers ,ccl::method-specializers))
+                  (t ccl::name))))
+      (loop for ((type . name) src) in (ccl:find-definition-sources name type)
+            collect (cons (source-note-to-source-location 
+                           src (lambda () "No source-note available"))
+                          (definition-name type name))))))
+    
+(defgeneric definition-name (type object)
+  (:method ((type ccl::definition-type) object)
+    (list (ccl::definition-type-name type) object)))
 
 (defmethod definition-name ((type ccl::method-definition-type)
                             (met method))
@@ -770,18 +728,6 @@
         (find-method (fdefinition name) qualifiers specializers)))))
   t)
 
-;;; XREF
-
-(defimplementation list-callers (symbol)
-  (loop for caller in (ccl::callers symbol)
-        append (multiple-value-bind (info name type specializers modifiers)
-                   (ccl::edit-definition-p caller)
-                 (loop for (nil . file) in info
-                       collect (list (if (eq t type)
-                                         name
-                                         `(,type ,name ,specializers
-                                           , at modifiers))
-                                     (canonicalize-location file name))))))
 ;;; Macroexpansion
 
 (defvar *value2tag* (make-hash-table))
@@ -794,7 +740,6 @@
 	   (< (symbol-value s) 255))
       (setf (gethash (symbol-value s) *value2tag*) s)))
 
-#+#.(swank-backend::with-symbol 'macroexpand-all 'ccl)
 (defimplementation macroexpand-all (form)
   (ccl:macroexpand-all form))
 




From heller at common-lisp.net  Sun May 17 14:21:55 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 17 May 2009 10:21:55 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5hFT-0006W0-8q@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (who-specializes): Simplify.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/17 13:00:24	1.1762
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/17 14:21:55	1.1763
@@ -9,6 +9,7 @@
 	src-locs than ccl::callers.
 	(canonicalize-location, remove-filename-quoting)
 	(maybe-method-location): Deleted.  No longer used.
+	(who-specializes): Simplify.
 
 2009-05-17  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 13:00:24	1.168
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 14:21:55	1.169
@@ -170,23 +170,19 @@
 
 (defimplementation accept-connection (socket &key external-format
                                              buffering timeout)
-  (declare (ignore buffering timeout
-                   #-openmcl-unicode-strings external-format))
-  #+openmcl-unicode-strings
+  (declare (ignore buffering timeout))
   (when external-format
     (let ((keys (ccl::socket-keys socket)))
       (setf (getf keys :external-format) external-format
             (slot-value socket 'ccl::keys) keys)))
   (ccl:accept-connection socket :wait t))
 
-#+openmcl-unicode-strings
 (defvar *external-format-to-coding-system*
   '((:iso-8859-1 
      "latin-1" "latin-1-unix" "iso-latin-1-unix" 
      "iso-8859-1" "iso-8859-1-unix")
     (:utf-8 "utf-8" "utf-8-unix")))
 
-#+openmcl-unicode-strings
 (defimplementation find-external-format (coding-system)
   (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
                   *external-format-to-coding-system*)))
@@ -324,20 +320,10 @@
    :test 'equal))
 
 (defimplementation who-specializes (class)
-  (if (symbolp class) (setq class (find-class class)))
-  (remove-duplicates
-   (append (mapcar (lambda(m)
-                     (let ((location (function-source-location (ccl::method-function m))))
-                       (if (eq (car location) :error)
-                           (setq location nil ))
-                       `((method ,(ccl::method-name m)
-                                 ,(mapcar #'specializer-name (ccl::method-specializers m))
-                                 ,@(ccl::method-qualifiers m))
-                         ,location)))
-                   (ccl::%class.direct-methods class))
-           (mapcan 'who-specializes (ccl::%class-direct-subclasses class)))
-   :test 'equal))
-
+  (mapcar (lambda (m)
+            (destructuring-bind ((loc . name)) (source-locations m)
+              (list name loc)))
+          (ccl::%class.direct-methods (find-class class))))
 
 (defimplementation list-callees (name)
   (remove-duplicates




From heller at common-lisp.net  Sun May 17 14:31:23 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 17 May 2009 10:31:23 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5hOd-0006eG-7K@common-lisp.net>

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

Modified Files:
	swank-openmcl.lisp 
Log Message:
Minor changes

--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 14:21:55	1.169
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 14:31:23	1.170
@@ -286,14 +286,11 @@
 
 ;;; Cross-referencing
 
-(defun xref-locations (relation name &optional (inverse nil))
-  (loop for xref in (if inverse 
-                        (ccl::get-relation relation name
-                                           :wild :exhaustive t)
-                        (ccl::get-relation relation
-                                           :wild name :exhaustive t))
-        append (loop for (loc . name) in (source-locations xref)
-                     collect `(,name ,loc))))
+(defun xref-locations (relation name &optional inverse)
+  (mapcan #'find-definitions
+          (if inverse 
+              (ccl::get-relation relation name :wild :exhaustive t)
+              (ccl::get-relation relation :wild name :exhaustive t))))
 
 (defimplementation who-binds (name)
   (xref-locations :binds name))
@@ -320,9 +317,8 @@
    :test 'equal))
 
 (defimplementation who-specializes (class)
-  (mapcar (lambda (m)
-            (destructuring-bind ((loc . name)) (source-locations m)
-              (list name loc)))
+  (mapcar (lambda (m) 
+            (car (find-definitions m)))
           (ccl::%class.direct-methods (find-class class))))
 
 (defimplementation list-callees (name)
@@ -613,8 +609,8 @@
                `(:error ,(princ-to-string c)))))
           (t `(:error ,(funcall if-nil-thunk))))))
 
-(defimplementation find-definitions (symbol)
-  (loop for (loc . name) in (source-locations symbol)
+(defimplementation find-definitions (obj)
+  (loop for (loc . name) in (source-locations obj)
         collect (list name loc)))
 
 ;; Return a list ((LOC . NAME) ...) of possible src-locs.




From trittweiler at common-lisp.net  Sun May 17 16:23:31 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 17 May 2009 12:23:31 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M5j99-0003bN-0R@common-lisp.net>

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

Modified Files:
	ChangeLog slime-fontifying-fu.el 
Log Message:
	* slime-fontifying-fu.el (slime-search-for-suppressed-forms):
	Shadow SBCL-specific #!+, #!- conditionals correctly.
	(slime-compute-region-for-font-lock): Fix small thinko.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/16 13:12:03	1.211
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/17 16:23:30	1.212
@@ -1,3 +1,9 @@
+2009-05-17  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-fontifying-fu.el (slime-search-for-suppressed-forms):
+	Shadow SBCL-specific #!+, #!- conditionals correctly.
+	(slime-compute-region-for-font-lock): Fix small thinko.
+
 2009-05-16  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-fontifying-fu.el (slime-beginning-of-tlf): Make sure to
--- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/16 13:12:04	1.5
+++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/17 16:23:30	1.6
@@ -37,7 +37,7 @@
           (or (nth 3 state)             ; inside string?
               (nth 4 state)))           ; inside comment?
         (slime-search-suppressed-forms-internal limit)
-      (let* ((start (- (point) 2))
+      (let* ((start (match-beginning 0))
              (char (char-before))
              (e (read (current-buffer)))
              (val (slime-eval-feature-expression e)))
@@ -131,7 +131,7 @@
           (multiple-value-setq (changedp font-lock-beg font-lock-end)
             (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
           changedp)
-      (error 
+      (error
        (slime-bug 
         (concat "Caught error when trying to extend the region for fontification.\n"
                 "The error was: %S\n"
@@ -158,8 +158,9 @@
     (goto-char beg)
     (inline (slime-beginning-of-tlf))
     (assert (not (plusp (nth 0 (slime-current-parser-state)))))
-    (setq beg (or (slime-search-directly-preceding-reader-conditional)
-                  (point)))
+    (setq beg (let ((pt (point))) 
+                (or (slime-search-directly-preceding-reader-conditional)
+                    pt)))
     (goto-char end)
     (when (search-backward-regexp slime-reader-conditionals-regexp beg t)
       ;; Nested reader conditionals, yuck!




From trittweiler at common-lisp.net  Sun May 17 19:12:53 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 17 May 2009 15:12:53 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M5ln3-0003ca-Uv@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
	* slime.el (slime-dispatch-event): New event
	`:read-from-minibuffer'.
	(slime-read-from-minibuffer-for-swank): New.

	* swank.lisp (dispatch-event): Pass through :read-from-minibuffer
	event.
	(read-from-minibuffer-in-emacs): Now uses new event rather than
	eval-in-emacs.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/17 14:21:55	1.1763
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/17 19:12:53	1.1764
@@ -1,3 +1,14 @@
+2009-05-17  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-dispatch-event): New event
+	`:read-from-minibuffer'.
+	(slime-read-from-minibuffer-for-swank): New.
+
+	* swank.lisp (dispatch-event): Pass through :read-from-minibuffer
+	event.
+	(read-from-minibuffer-in-emacs): Now uses new event rather than
+	eval-in-emacs.
+
 2009-05-17  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-openmcl.lisp (compile-temp-file): Remove backward
--- /project/slime/cvsroot/slime/slime.el	2009/05/16 12:46:04	1.1173
+++ /project/slime/cvsroot/slime/slime.el	2009/05/17 19:12:53	1.1174
@@ -2397,6 +2397,8 @@
                                msg))
           ((:emacs-channel-send id msg)
            (slime-send `(:emacs-channel-send ,id ,msg)))
+          ((:read-from-minibuffer thread tag prompt initial-value)
+           (slime-read-from-minibuffer-for-swank thread tag prompt initial-value))
           ((:y-or-n-p thread tag question)
            (slime-y-or-n-p thread tag question))
           ((:emacs-return-string thread tag string)
@@ -4072,6 +4074,11 @@
 (defun slime-y-or-n-p (thread tag question)
   (slime-dispatch-event `(:emacs-return ,thread ,tag ,(y-or-n-p question))))
 
+(defun slime-read-from-minibuffer-for-swank (thread tag prompt initial-value)
+  (let ((answer (condition-case nil 
+                    (slime-read-from-minibuffer prompt initial-value)
+                  (quit nil))))
+    (slime-dispatch-event `(:emacs-return ,thread ,tag ,answer))))
 
 ;;;; Interactive evaluation.
 
--- /project/slime/cvsroot/slime/swank.lisp	2009/05/16 17:21:12	1.646
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/17 19:12:53	1.647
@@ -1161,7 +1161,7 @@
        :presentation-start :presentation-end
        :new-package :new-features :ed :%apply :indentation-update
        :eval :eval-no-wait :background-message :inspect :ping
-       :y-or-n-p :read-string :read-aborted)
+       :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
       &rest _)
      (declare (ignore _))
      (encode-message event (current-socket-io)))
@@ -1820,7 +1820,18 @@
         (question (apply #'format nil format-string arguments)))
     (force-output)
     (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
-    (caddr (wait-for-event `(:emacs-return ,tag result)))))
+    (third (wait-for-event `(:emacs-return ,tag result)))))
+
+(defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
+  "Ask user a question in Emacs' minibuffer. Returns \"\" when user
+entered nothing, returns NIL when user pressed C-g."
+  (check-type prompt string) (check-type initial-value (or null string))
+  (let ((tag (make-tag)))
+    (force-output)
+    (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
+                                           ,prompt ,initial-value))
+    (third (wait-for-event `(:emacs-return ,tag result)))))
+
 
 (defun process-form-for-emacs (form)
   "Returns a string which emacs will read as equivalent to
@@ -1858,13 +1869,6 @@
 	       ((:ok value) value)
 	       ((:abort) (abort))))))))
 
-;;; FIXME: This should not use EVAL-IN-EMACS but get its own events.
-(defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
-  (eval-in-emacs
-   `(condition-case c
-        (slime-read-from-minibuffer ,prompt ,initial-value)
-      (quit nil))))
-
 (defvar *swank-wire-protocol-version* nil
   "The version of the swank/slime communication protocol.")
 




From nsiivola at common-lisp.net  Mon May 18 12:54:09 2009
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Mon, 18 May 2009 08:54:09 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M62M5-0000XH-4V@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
new variable: slime-description-autofocus

  Controls behaviour of popped up description buffers.



--- /project/slime/cvsroot/slime/ChangeLog	2009/05/17 19:12:53	1.1764
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/18 12:54:08	1.1765
@@ -1,3 +1,10 @@
+2009-05-18  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* slime.el (slime-description-autofocus): New variable.
+	(slime-show-description): Use it to decide if description
+	buffers should receive focus automatically.
+	* doc/slime.texi: Document it.
+
 2009-05-17  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-dispatch-event): New event
--- /project/slime/cvsroot/slime/slime.el	2009/05/17 19:12:53	1.1174
+++ /project/slime/cvsroot/slime/slime.el	2009/05/18 12:54:08	1.1175
@@ -4146,11 +4146,15 @@
   (slime-eval-async form (slime-rcurry #'slime-show-description
                                        (slime-current-package))))
 
+(defvar slime-description-autofocus nil
+  "If NIL (the default) Slime description buffers do not grab
+focus automatically.")
+
 (defun slime-show-description (string package)
   ;; So we can have one description buffer open per connection. Useful
   ;; for comparing the output of DISASSEMBLE across implementations.
   (let ((bufname (format "*SLIME Description <%s>*" (slime-connection-name))))
-    (slime-with-popup-buffer (bufname package t)
+    (slime-with-popup-buffer (bufname package t slime-description-autofocus)
       (princ string)
       (goto-char (point-min)))))
 




From nsiivola at common-lisp.net  Mon May 18 12:54:09 2009
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Mon, 18 May 2009 08:54:09 -0400
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1M62M5-0000XY-GG@common-lisp.net>

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

Modified Files:
	slime.texi 
Log Message:
new variable: slime-description-autofocus

  Controls behaviour of popped up description buffers.



--- /project/slime/cvsroot/slime/doc/slime.texi	2009/03/12 15:41:15	1.72
+++ /project/slime/cvsroot/slime/doc/slime.texi	2009/05/18 12:54:09	1.73
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2009/03/12 15:41:15 $}
+ at set UPDATED @code{$Date: 2009/05/18 12:54:09 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -657,6 +657,12 @@
 @SLIME{} commands available for describing symbols, looking up
 function definitions, and so on.
 
+ at vindex slime-description-autofocus
+Initial focus of those ``description'' buffers depends on the variable
+ at code{slime-description-autofocus}. If @code{nil} (the default),
+description buffers do not receive focus automatically, and vice
+versa.
+
 @c ----------------------- 
 @node Inferior-lisp
 @subsection @code{*inferior-lisp*} buffer




From heller at common-lisp.net  Tue May 19 09:51:58 2009
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 19 May 2009 05:51:58 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M6LzK-0005A2-Nr@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (source-note-to-source-location): Always
test *temp-file-map* first, because the temp-file might actually
exist during compilation but no longer when Emacs tries to open
it.
(slime-goto-location-buffer): Don't create buffers for
non-existent files.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/18 12:54:08	1.1765
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/19 09:51:54	1.1766
@@ -1,3 +1,12 @@
+2009-05-19  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-openmcl.lisp (source-note-to-source-location): Always
+	test *temp-file-map* first, because the temp-file might actually
+	exist during compilation but no longer when Emacs tries to open
+	it.
+	(slime-goto-location-buffer): Don't create buffers for
+	non-existent files.
+
 2009-05-18  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* slime.el (slime-description-autofocus): New variable.
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/17 14:31:23	1.170
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/19 09:51:55	1.171
@@ -594,10 +594,10 @@
 
 (defun source-note-to-source-location (note if-nil-thunk)
   (labels ((filename-to-buffer (filename)
-             (cond ((probe-file filename)
-                    (list :file (namestring (truename filename))))
-                   ((gethash filename *temp-file-map*)
+             (cond ((gethash filename *temp-file-map*)
                     (list :buffer (gethash filename *temp-file-map*)))
+                   ((probe-file filename)
+                    (list :file (namestring (truename filename))))
                    (t (error "File ~s doesn't exist" filename)))))
     (cond (note
            (handler-case




From nsiivola at common-lisp.net  Tue May 19 10:51:38 2009
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Tue, 19 May 2009 06:51:38 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M6Mv4-0007zf-IH@common-lisp.net>

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

Modified Files:
	ChangeLog swank-source-path-parser.lisp 
Log Message:
guard agains source path mapping hitting reader errors

  Example: compile (defun foo () (bar)) in a file. Edit
  the definition to look like (defun foo () (nopackage:bar)),
  close the file and hit M-. foo. Prior to this an error shows
  in the minibuffer, and nothing else happens.



--- /project/slime/cvsroot/slime/ChangeLog	2009/05/19 09:51:54	1.1766
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/19 10:51:38	1.1767
@@ -1,3 +1,10 @@
+2009-05-19  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* swank-source-path-parser.lisp (read-and-record-source-map):
+	ignore errors during the call to READ, so that we don't the
+	current version of the form we are looking at contains eg.
+	uninternable symbols.
+
 2009-05-19  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-openmcl.lisp (source-note-to-source-location): Always
--- /project/slime/cvsroot/slime/swank-source-path-parser.lisp	2009/01/08 06:45:19	1.21
+++ /project/slime/cvsroot/slime/swank-source-path-parser.lisp	2009/05/19 10:51:38	1.22
@@ -80,7 +80,7 @@
   (let* ((source-map (make-hash-table :test #'eq))
          (*readtable* (make-source-recording-readtable *readtable* source-map))
 	 (start (file-position stream))
-	 (form (read stream))
+	 (form (ignore-errors (read stream)))
 	 (end (file-position stream)))
     ;; ensure that at least FORM is in the source-map
     (unless (gethash form source-map)




From trittweiler at common-lisp.net  Tue May 19 20:42:22 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 19 May 2009 16:42:22 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M6W8k-0004QJ-TH@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (sldb-restartable-frame-line-face): Set a default value.
	(sldb-frame-restartable-p): New.
	(sldb-compute-frame-face): Use it.
	(sldb-show-frame-details): Use it, too.


--- /project/slime/cvsroot/slime/ChangeLog	2009/05/19 10:51:38	1.1767
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/19 20:42:22	1.1768
@@ -1,3 +1,10 @@
+2009-05-19  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (sldb-restartable-frame-line-face): Set a default value.
+	(sldb-frame-restartable-p): New.
+	(sldb-compute-frame-face): Use it.
+	(sldb-show-frame-details): Use it, too.
+
 2009-05-19  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* swank-source-path-parser.lisp (read-and-record-source-map):
--- /project/slime/cvsroot/slime/slime.el	2009/05/18 12:54:08	1.1175
+++ /project/slime/cvsroot/slime/slime.el	2009/05/19 20:42:22	1.1176
@@ -327,7 +327,8 @@
                   '(:bold t))
   (frame-line     "function names and arguments in the backtrace")
   (restartable-frame-line
-   "frames which are surely restartable")
+   "frames which are surely restartable"
+   '(:foreground "lime green"))
   (non-restartable-frame-line
    "frames which are surely not restartable")
   (detailed-frame-line
@@ -5520,6 +5521,9 @@
 (defun sldb-frame.plist (frame)
   (destructuring-bind (_ _ &optional plist) frame plist))
 
+(defun sldb-frame-restartable-p (frame)
+  (and (plist-get (sldb-frame.plist frame) :restartable) t))
+
 (defun sldb-prune-initial-frames (frames)
   "Return the prefix of FRAMES to initially present to the user.
 Regexp heuristics are used to avoid showing SWANK-internal frames."
@@ -5547,9 +5551,9 @@
     (insert "\n")))
 
 (defun sldb-compute-frame-face (frame)
-  (ecase (plist-get (sldb-frame.plist frame) :restartable)
-    ((nil) 'sldb-frame-line-face)
-    ((t) 'sldb-restartable-frame-line-face)))
+  (if (sldb-frame-restartable-p frame)
+      'sldb-restartable-frame-line-face
+      'sldb-frame-line-face))
 
 (defun sldb-insert-frame (frame &optional face)
   "Insert FRAME with FACE at point.
@@ -5802,7 +5806,10 @@
     (slime-save-coordinates start
       (delete-region start end)
       (slime-propertize-region `(frame ,frame details-visible-p t)
-        (sldb-insert-frame frame 'sldb-detailed-frame-line-face)
+        (sldb-insert-frame frame (if (sldb-frame-restartable-p frame)
+                                     'sldb-restartable-frame-line-face
+                                     ;; FIXME: can we somehow merge the two?
+                                     'sldb-detailed-frame-line-face))
         (let ((indent1 "      ")
               (indent2 "        "))
           (insert indent1 (in-sldb-face section




From trittweiler at common-lisp.net  Wed May 20 19:17:39 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 20 May 2009 15:17:39 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M6rIJ-0002ji-LW@common-lisp.net>

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

Modified Files:
	slime-fontifying-fu.el ChangeLog 
Log Message:
	* slime-fontifying-fu.el (slime-search-for-suppressed-forms):
	Retrieve match data early now that `slime-current-parser-state'
	does not save it anymore.


--- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/17 16:23:30	1.6
+++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/20 19:17:39	1.7
@@ -33,33 +33,32 @@
 
 (defun slime-search-suppressed-forms-internal (limit)
   (when (search-forward-regexp slime-reader-conditionals-regexp limit t)
-    (if (let ((state (slime-current-parser-state)))
-          (or (nth 3 state)             ; inside string?
-              (nth 4 state)))           ; inside comment?
-        (slime-search-suppressed-forms-internal limit)
-      (let* ((start (match-beginning 0))
-             (char (char-before))
-             (e (read (current-buffer)))
-             (val (slime-eval-feature-expression e)))
-        (when (<= (point) limit)
-          (if (or (and (eq char ?+) (not val))
-                  (and (eq char ?-) val))
-              (progn
-                (forward-sexp) (backward-sexp)
-                (slime-forward-sexp)
-                ;; There was an `ignore-errors' form around all this
-                ;; because the following assertion was triggered
-                ;; regularly (resulting in the "non-deterministic"
-                ;; behaviour mentioned in the comment further below.)
-                ;; With extending the region properly, this assertion
-                ;; would truly mean a bug now.
-                (assert (<= (point) limit))
-                (let ((md (match-data nil slime-search-suppressed-forms-match-data)))
-                  (setf (first md) start)
-                  (setf (second md) (point))
-                  (set-match-data md)
-                  t))
-              (slime-search-suppressed-forms-internal limit)))))))
+    (let ((start (match-beginning 0))   ; save match data
+          (state (slime-current-parser-state)))
+      (if (or (nth 3 state) (nth 4 state)) ; inside string or comment?
+          (slime-search-suppressed-forms-internal limit)
+        (let* ((char (char-before))
+               (expr (read (current-buffer)))
+               (val  (slime-eval-feature-expression expr)))
+          (when (<= (point) limit)
+            (if (or (and (eq char ?+) (not val))
+                    (and (eq char ?-) val))
+                (progn
+                  (forward-sexp) (backward-sexp)
+                  (slime-forward-sexp)
+                  ;; There was an `ignore-errors' form around all this
+                  ;; because the following assertion was triggered
+                  ;; regularly (resulting in the "non-deterministic"
+                  ;; behaviour mentioned in the comment further below.)
+                  ;; With extending the region properly, this assertion
+                  ;; would truly mean a bug now.
+                  (assert (<= (point) limit))
+                  (let ((md (match-data nil slime-search-suppressed-forms-match-data)))
+                    (setf (first md) start)
+                    (setf (second md) (point))
+                    (set-match-data md)
+                    t))
+                (slime-search-suppressed-forms-internal limit))))))))
 
 (defun slime-search-suppressed-forms (limit)
   "Find reader conditionalized forms where the test is false."
@@ -125,11 +124,13 @@
 ;;; to the beginning or end of a toplevel form. So we never miss a
 ;;; reader-conditional, or point in mid of one.
 (defun slime-extend-region-for-font-lock ()
+  (tcr:debugmsg "extend: pt=%S (%S, %S)" (point) font-lock-beg font-lock-end)
   (when slime-highlight-suppressed-forms
     (condition-case c
         (let (changedp)
           (multiple-value-setq (changedp font-lock-beg font-lock-end)
             (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
+          (tcr:debugmsg "--> %S (%S, %S)" changedp font-lock-beg font-lock-end)
           changedp)
       (error
        (slime-bug 
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/17 16:23:30	1.212
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/20 19:17:39	1.213
@@ -1,3 +1,9 @@
+2009-05-20  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-fontifying-fu.el (slime-search-for-suppressed-forms):
+	Retrieve match data early now that `slime-current-parser-state'
+	does not save it anymore.
+
 2009-05-17  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-fontifying-fu.el (slime-search-for-suppressed-forms):




From trittweiler at common-lisp.net  Wed May 20 19:25:58 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 20 May 2009 15:25:58 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M6rQM-0003Pm-Q3@common-lisp.net>

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

Modified Files:
	swank-arglists.lisp ChangeLog 
Log Message:
	* swank-arglists.lisp (arglist-dispatch [define-compiler-macro]):
	guard against when we're in the body of a compiler-macro
	definition for a function not yet compiled into the image.


--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/03/22 11:25:28	1.31
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2009/05/20 19:25:58	1.32
@@ -1165,14 +1165,15 @@
 	   (fn (and (valid-function-name-p fn-name)
 		    (fboundp fn-name)
 		    (fdefinition fn-name))))
-      (with-available-arglist (arglist) (arglist fn)
-        (return-from arglist-dispatch
-          (values (make-arglist :provided-args (if remove-args
-                                                   nil
-                                                   (list fn-name))
-                                :required-args (list arglist)
-                                :rest "body" :body-p t)
-                  t)))))
+      (when fn
+        (with-available-arglist (arglist) (arglist fn)
+          (return-from arglist-dispatch
+            (values (make-arglist :provided-args (if remove-args
+                                                     nil
+                                                     (list fn-name))
+                                  :required-args (list arglist)
+                                  :rest "body" :body-p t)
+                    t))))))
   (call-next-method))
 
 (defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'eval-when))
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/20 19:17:39	1.213
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/20 19:25:58	1.214
@@ -1,5 +1,11 @@
 2009-05-20  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-arglists.lisp (arglist-dispatch [define-compiler-macro]):
+	guard against when we're in the body of a compiler-macro
+	definition for a function not yet compiled into the image.
+
+2009-05-20  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime-fontifying-fu.el (slime-search-for-suppressed-forms):
 	Retrieve match data early now that `slime-current-parser-state'
 	does not save it anymore.




From trittweiler at common-lisp.net  Wed May 20 19:29:16 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 20 May 2009 15:29:16 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M6rTY-0003W4-8S@common-lisp.net>

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

Modified Files:
	slime-fontifying-fu.el 
Log Message:
forgot to delete debugging code


--- /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/20 19:17:39	1.7
+++ /project/slime/cvsroot/slime/contrib/slime-fontifying-fu.el	2009/05/20 19:29:16	1.8
@@ -124,13 +124,11 @@
 ;;; to the beginning or end of a toplevel form. So we never miss a
 ;;; reader-conditional, or point in mid of one.
 (defun slime-extend-region-for-font-lock ()
-  (tcr:debugmsg "extend: pt=%S (%S, %S)" (point) font-lock-beg font-lock-end)
   (when slime-highlight-suppressed-forms
     (condition-case c
         (let (changedp)
           (multiple-value-setq (changedp font-lock-beg font-lock-end)
             (slime-compute-region-for-font-lock font-lock-beg font-lock-end))
-          (tcr:debugmsg "--> %S (%S, %S)" changedp font-lock-beg font-lock-end)
           changedp)
       (error
        (slime-bug 




From trittweiler at common-lisp.net  Thu May 21 09:41:51 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 21 May 2009 05:41:51 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M74md-00005X-CY@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el (slime-symbol-at-point): Sometimes we can be too good,
	e.g. in "|# (defun foo () (getf" the above would return nil
	because the vertical bar is not terminated. The user probably
	wants "getf" nontheless.

	Reported by Madhu.


--- /project/slime/cvsroot/slime/slime.el	2009/05/19 20:42:22	1.1176
+++ /project/slime/cvsroot/slime/slime.el	2009/05/21 09:41:50	1.1177
@@ -8370,7 +8370,13 @@
     ;;           (>= (point) slime-repl-input-start-mark))
     ;;  (narrow-to-region slime-repl-input-start-mark (point-max)))
     (save-excursion
-      (let ((string (thing-at-point 'slime-symbol)))
+      (let ((string (or (thing-at-point 'slime-symbol)
+                        ;; Sometimes we can be too good, e.g.  in "|#
+                        ;; (defun foo () (getf" the above would return
+                        ;; nil because the vertical bar is not
+                        ;; terminated. The user probably wants "getf"
+                        ;; nontheless.
+                        (thing-at-point 'symbol))))
         (and string
              ;; (thing-at-point 'symbol) returns "" instead of nil
              ;; when called from an empty (or narrowed-to-empty)
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/19 20:42:22	1.1768
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/21 09:41:50	1.1769
@@ -1,5 +1,14 @@
 2009-05-19  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-symbol-at-point): Sometimes we can be too good,
+	e.g. in "|# (defun foo () (getf" the above would return nil
+	because the vertical bar is not terminated. The user probably
+	wants "getf" nontheless.
+
+	Reported by Madhu.
+
+2009-05-19  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (sldb-restartable-frame-line-face): Set a default value.
 	(sldb-frame-restartable-p): New.
 	(sldb-compute-frame-face): Use it.




From heller at common-lisp.net  Sat May 23 16:48:16 2009
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 23 May 2009 12:48:16 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M7uOO-0003Ak-RN@common-lisp.net>

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*.
That means that we can't use SIGNAL here and we have to invoke
SLDB directly.
(condition-for-break): New helper.
Reported by Bill St. Clair.

--- /project/slime/cvsroot/slime/ChangeLog	2009/05/21 09:41:50	1.1769
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/23 16:48:16	1.1770
@@ -1,3 +1,11 @@
+2009-05-23  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*.
+	That means that we can't use SIGNAL here and we have to invoke
+	SLDB directly.
+	(condition-for-break): New helper.
+	Reported by Bill St. Clair.
+
 2009-05-19  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-symbol-at-point): Sometimes we can be too good,
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/19 09:51:55	1.171
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/05/23 16:48:16	1.172
@@ -517,19 +517,25 @@
     (ccl::apply-in-frame p lfun 
                          (ccl::frame-supplied-args p lfun pc nil context))))
 
-(let ((ccl::*warn-if-redefine-kernel* nil))
-  (ccl::advise
-   ccl::cbreak-loop
-   (if *break-in-sldb* 
-       (apply #'break-in-sldb ccl::arglist)
-       (:do-it))
-   :when :around
-   :name sldb-break))
-
-(defun break-in-sldb (x y &rest args)
-  (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
-                                   (ccl::%get-frame-ptr))))
-    (apply #'cerror y (if args "Break: ~a" x) args)))
+(ccl::advise ccl::cbreak-loop
+             (if *break-in-sldb* 
+                 (apply #'break-in-sldb ccl::arglist)
+                 (:do-it))
+             :when :around
+             :name sldb-break)
+
+(defun break-in-sldb (msg cont-string condition error-pointer)
+  (let ((*sldb-stack-top-hint* error-pointer))
+    (with-simple-restart (continue "~a" cont-string)
+      (funcall (read-from-string "SWANK:INVOKE-SLIME-DEBUGGER")
+               (condition-for-break condition msg)))))
+
+(defun condition-for-break (condition msg)
+  (cond ((and (eq (type-of condition) 'simple-condition)
+              (equal (simple-condition-format-control condition) ""))
+         (make-condition 'simple-condition :format-control "~a" 
+                         :format-arguments (list msg)))
+        (t condition)))
 
 (defimplementation disassemble-frame (the-frame-number)
   (with-frame (p context lfun pc) the-frame-number




From trittweiler at common-lisp.net  Sun May 24 12:24:05 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 24 May 2009 08:24:05 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M8CkH-0001E5-3Q@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	(slime-goto-location-position): Only go to match-beginning if
	search succeeded.


--- /project/slime/cvsroot/slime/slime.el	2009/05/21 09:41:50	1.1177
+++ /project/slime/cvsroot/slime/slime.el	2009/05/24 12:24:04	1.1178
@@ -3331,14 +3331,14 @@
     ((:function-name name)
      (let ((case-fold-search t)
            (name (regexp-quote name)))
-       (or 
-        (re-search-forward 
-         (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t)
-        (re-search-forward 
-         (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t)
-        (re-search-forward 
-         (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)))
-     (goto-char (match-beginning 0)))
+       (when (or 
+              (re-search-forward 
+               (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\S_" name) nil t)
+              (re-search-forward 
+               (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t)
+              (re-search-forward 
+               (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))
+         (goto-char (match-beginning 0))))
     ((:method name specializers &rest qualifiers)
      (slime-search-method-location name specializers qualifiers))
     ((:source-path source-path start-position)
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/23 16:48:16	1.1770
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/24 12:24:04	1.1771
@@ -1,3 +1,10 @@
+2009-05-24  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	(slime-goto-location-position): Only go to match-beginning if
+	search succeeded.
+
+	Patch by Madhu.
+
 2009-05-23  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-openmcl.lisp (break-in-sldb): Honor *break-on-signals*.




From trittweiler at common-lisp.net  Sun May 24 12:45:09 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 24 May 2009 08:45:09 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M8D4f-0002Bd-Jl@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
fix missing paren


--- /project/slime/cvsroot/slime/slime.el	2009/05/24 12:24:04	1.1178
+++ /project/slime/cvsroot/slime/slime.el	2009/05/24 12:45:07	1.1179
@@ -3338,7 +3338,7 @@
                (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" name) nil t)
               (re-search-forward 
                (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t))
-         (goto-char (match-beginning 0))))
+         (goto-char (match-beginning 0)))))
     ((:method name specializers &rest qualifiers)
      (slime-search-method-location name specializers qualifiers))
     ((:source-path source-path start-position)




From trittweiler at common-lisp.net  Sun May 24 12:58:52 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 24 May 2009 08:58:52 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M8DHu-0002ZI-Dm@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el ([test] fancy-symbol-names): Add cases involving #|
	... |# style comments. Currently failing.

	Reported by Madhu.


--- /project/slime/cvsroot/slime/slime.el	2009/05/24 12:45:07	1.1179
+++ /project/slime/cvsroot/slime/slime.el	2009/05/24 12:58:47	1.1180
@@ -7359,6 +7359,53 @@
     (insert "#<") (insert symbol-name) (insert " {DEADBEEF}>")
     (slime-check-fancy-symbol-name (+ (point-min) 2) symbol-name)
     (erase-buffer)
+
+    (slime-test-message "*** fancy symbol-name wrapped in #<>:")
+    (insert "#<") (insert symbol-name) (insert " {DEADBEEF}>")
+    (slime-check-fancy-symbol-name (+ (point-min) 2) symbol-name)
+    (erase-buffer)
+
+    (slime-test-message "*** fancy symbol-name wrapped in #| ... |#:")
+    (insert "#|\n") (insert symbol-name) (insert "\n|#")
+    (slime-check-fancy-symbol-name (+ (point-min) 4) symbol-name)
+    (erase-buffer)
+
+    (slime-test-message "*** fancy symbol-name after #| )))(( |# (1):")
+    (let ((pre-content "#| )))(( #|\n"))
+      (insert pre-content)
+      (insert symbol-name) 
+      (slime-check-fancy-symbol-name (+ (point-min) (length pre-content))
+                                     symbol-name)
+      (erase-buffer))
+
+    (slime-test-message "*** fancy symbol-name after #| )))(( |# (2):")
+    (let ((pre-content "#| )))(( #|"))  ; no newline
+      (insert pre-content)
+      (insert symbol-name) 
+      (slime-check-fancy-symbol-name (+ (point-min) (length pre-content))
+                                     symbol-name)
+      (erase-buffer))
+
+    (slime-test-message "*** fancy symbol-name wrapped in \"...\":")
+    (insert "\"\n") (insert symbol-name) (insert "\n\"")
+    (slime-check-fancy-symbol-name (+ (point-min) 3) symbol-name)
+    (erase-buffer)
+
+    (slime-test-message "*** fancy symbol-name after \" )))(( \" (1):")
+    (let ((pre-content "\" )))(( \"\n"))
+      (insert pre-content)
+      (insert symbol-name) 
+      (slime-check-fancy-symbol-name (+ (point-min) (length pre-content))
+                                     symbol-name)
+      (erase-buffer))
+
+    (slime-test-message "*** fancy symbol-name after \" )))(( \" (2):")
+    (let ((pre-content "\" )))(( \"")) ; no newline
+      (insert pre-content)
+      (insert symbol-name) 
+      (slime-check-fancy-symbol-name (+ (point-min) (length pre-content))
+                                     symbol-name)
+      (erase-buffer))
     ))
 
 (defun* slime-initialize-lisp-buffer-for-test-suite 
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/24 12:24:04	1.1771
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/24 12:58:50	1.1772
@@ -1,6 +1,13 @@
 2009-05-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
-	(slime-goto-location-position): Only go to match-beginning if
+	* slime.el ([test] fancy-symbol-names): Add cases involving #|
+	... |# style comments. Currently failing.
+
+	Reported by Madhu.
+
+2009-05-24  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-goto-location-position): Only go to match-beginning if
 	search succeeded.
 
 	Patch by Madhu.




From trittweiler at common-lisp.net  Thu May 28 15:38:11 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 28 May 2009 11:38:11 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M9hgJ-0007aO-Dd@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el (slime-disconnect): Now only disconnects one
	connection, current one by default, or given by argument.
	(slime-disconnect-all): New. What `slime-disconnect' was before.
	(def-slime-test): Changed: expected failures are now given
	by (:fails-for ...) clauses. Extended: new clause (:style ...) to
	have a test run only on a certain communication style. Updated
	existing test cases accordingly.
	([struct] slime-test): New slot `skipped'.
	(slime-skipped-tests): New var.
	(slime-execute-tests): Adapted accordingly.
	([test] disconnect): Renamed to `disconnect-and-reconnect'
	([test] disconnect-one-conneciton): New.

	Adapted from patch by Stas Boukarev.


--- /project/slime/cvsroot/slime/slime.el	2009/05/24 12:58:47	1.1180
+++ /project/slime/cvsroot/slime/slime.el	2009/05/28 15:38:11	1.1181
@@ -1263,13 +1263,13 @@
   (apply #'slime-start options))
 
 (defun slime-connect (host port &optional coding-system)
-  "Connect to a running Swank server."
+  "Connect to a running Swank server. Returns the connection."
   (interactive (list (read-from-minibuffer "Host: " slime-lisp-host)
                      (read-from-minibuffer "Port: " (format "%d" slime-port)
                                            nil t)))
   (when (and (interactive-p) slime-net-processes
              (y-or-n-p "Close old connections first? "))
-    (slime-disconnect))
+    (slime-disconnect-all))
   (message "Connecting to Swank on port %S.." port)
   (let ((coding-system (or coding-system slime-net-coding-system)))
     (slime-check-coding-system coding-system)
@@ -2082,7 +2082,13 @@
 
 ;;;;; Commands on connections
 
-(defun slime-disconnect ()
+(defun slime-disconnect (&optional connection)
+  "If CONNECTION is non-nil disconnect it, otherwise disconnect
+the current slime connection."
+  (interactive)
+  (slime-net-close (or connection (slime-connection))))
+
+(defun slime-disconnect-all ()
   "Disconnect all connections."
   (interactive)
   (mapc #'slime-net-close slime-net-processes))
@@ -6974,7 +6980,7 @@
 ;;;; Test suite
 
 (defstruct (slime-test (:conc-name slime-test.))
-  name fname args doc inputs fails-for)
+  name fname args doc inputs fails-for style)
   
 (defvar slime-tests '()
   "Names of test functions.")
@@ -6988,6 +6994,9 @@
 (defvar slime-failed-tests nil
   "Total number of failed tests during a test run.")
 
+(defvar slime-skipped-tests nil
+  "Total number of skipped tests during a test run.")
+
 (defvar slime-expected-failures nil
   "Total number of expected failures during a test run")
 
@@ -7065,44 +7074,49 @@
 Return the number of failed tests."
   (save-window-excursion
     (let ((slime-total-tests 0)
+          (slime-skipped-tests 0)
           (slime-expected-passes 0)
           (slime-unexpected-failures 0)
           (slime-expected-failures 0)
           (slime-lisp-under-test (slime-lisp-implementation-name)))
       (dolist (slime-current-test slime-tests)
-        (with-struct (slime-test. name (function fname) inputs) 
+        (with-struct (slime-test. name (function fname) inputs style) 
             slime-current-test
-          (slime-test-heading 1 "%s" name)
-          (dolist (input inputs)
-            (incf slime-total-tests)
-            (message "%s: %s" name input)
-            (slime-test-heading 2 "input: %s" input)
-            (if slime-test-debug-on-error
-                (let ((debug-on-error t)
-                      (debug-on-quit t))
-                  (catch 'skip
-                    (apply function input)))
-              (condition-case err
-                  (apply function input)
-                (error
-                 (cond ((slime-test-should-fail-p)
-                        (incf slime-expected-failures)
-                        (slime-test-failure "ERROR (expected)"
-                                            (format "%S" err)))
-                       (t
-                        (incf slime-unexpected-failures)
-                        (slime-print-check-error err)))))))))
+          (if (and style (not (memq (slime-communication-style) style)))
+              (incf slime-skipped-tests)  
+            (slime-test-heading 1 "%s" name)
+            (dolist (input inputs)
+              (incf slime-total-tests)
+              (message "%s: %s" name input)
+              (slime-test-heading 2 "input: %s" input)
+              (if slime-test-debug-on-error
+                  (let ((debug-on-error t)
+                        (debug-on-quit t))
+                    (catch 'skip
+                      (apply function input)))
+                  (condition-case err
+                      (apply function input)
+                    (error
+                     (cond ((slime-test-should-fail-p)
+                            (incf slime-expected-failures)
+                            (slime-test-failure "ERROR (expected)"
+                                                (format "%S" err)))
+                           (t
+                            (incf slime-unexpected-failures)
+                            (slime-print-check-error err))))))))))
       (let ((summary 
-             (cond ((and (zerop slime-expected-failures)
-                         (zerop slime-unexpected-failures))
-                    (format "All %S tests completed successfully."
-                            slime-total-tests))
-                   (t
-                    (format "Failed on %S (%S expected) of %S tests."
-                            (+ slime-expected-failures
-                               slime-unexpected-failures)
-                            slime-expected-failures
-                            slime-total-tests)))))
+             (concat (if (and (zerop slime-expected-failures)
+                              (zerop slime-unexpected-failures))
+                         (format "All %d tests completed successfully."
+                                 slime-total-tests)
+                         (format "Failed on %d (%d expected) of %d tests."
+                                 (+ slime-expected-failures
+                                    slime-unexpected-failures)
+                                 slime-expected-failures
+                                 slime-total-tests))
+                     (if (zerop slime-skipped-tests)
+                         ""
+                         (format " Skipped %d tests." slime-skipped-tests)))))
         (save-excursion
           (with-current-buffer slime-test-buffer-name
             (goto-char (point-min))
@@ -7194,15 +7208,25 @@
 
 (defmacro def-slime-test (name args doc inputs &rest body)
   "Define a test case.
-NAME ::= SYMBOL | (SYMBOL (FAILS-FOR*)) is a symbol naming the test.
+NAME    ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test.
+OPTION  ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*)
 ARGS is a lambda-list.
 DOC is a docstring.
 INPUTS is a list of argument lists, each tested separately.
 BODY is the test case. The body can use `slime-check' to test
 conditions (assertions)."
-  (multiple-value-bind (name fails-for) (etypecase name
-                                          (symbol (values name '()))
-                                          (cons name))
+  (multiple-value-bind (name fails-for style)
+      (etypecase name
+        (symbol (values name nil nil))
+        (cons   (let* ((opts  (rest name))
+                       (name  (first name))
+                       (fails-for (cdr (assq :fails-for opts)))
+                       (style (cdr (assq :style opts))))
+                  (tcr:debugmsg "opts=%S" opts)
+                  ;; :style and :fails-for only options, given no more than one time?
+                  (assert (null (remove* :style (remove* :fails-for opts :key #'car)
+                                         :key #'car)))
+                  (values name fails-for style))))
     (let ((fname (intern (format "slime-test-%s" name))))
       `(progn
          (defun ,fname ,args
@@ -7214,6 +7238,7 @@
                (append (remove* ',name slime-tests :key 'slime-test.name)
                        (list (make-slime-test :name ',name :fname ',fname
                                               :fails-for ',fails-for
+                                              :style ',style
                                               :inputs ,inputs))))))))
 
 (put 'def-slime-test 'lisp-indent-function 4)
@@ -7583,7 +7608,7 @@
            (= orig-pos (point)))))
     (slime-check-top-level))
 
-(def-slime-test (find-definition.2 ("allegro" "lispworks"))
+(def-slime-test (find-definition.2 (:fails-for "allegro" "lispworks"))
     (buffer-content buffer-package snippet)
     "Check that we're able to find definitions even when
 confronted with nasty #.-fu."
@@ -7658,7 +7683,7 @@
                        (lambda (pattern arglist)
                          (and arglist (string-match pattern arglist))))))
 
-(def-slime-test (compile-defun ("allegro" "lispworks" "clisp" "ccl"))
+(def-slime-test (compile-defun (:fails-for "allegro" "lispworks" "clisp" "ccl"))
     (program subform)
     "Compile PROGRAM containing errors.
 Confirm that SUBFORM is correctly located."
@@ -7709,7 +7734,7 @@
              subform)))
   (slime-check-top-level))
 
-(def-slime-test (compile-file ("allegro" "lispworks" "clisp"))
+(def-slime-test (compile-file (:fails-for "allegro" "lispworks" "clisp"))
     (string)
     "Insert STRING in a file, and compile it."
     `((,(pp-to-string '(defun foo () nil))))
@@ -8059,7 +8084,7 @@
                           0.2))
   (slime-sync-to-top-level 1))
 
-(def-slime-test (break2 ("cmucl" "allegro" "ccl"))
+(def-slime-test (break2 (:fails-for "cmucl" "allegro" "ccl"))
     (times exp)
     "Backends should arguably make sure that BREAK does not depend
 on *DEBUGGER-HOOK*."
@@ -8142,7 +8167,29 @@
   (slime-sync-to-top-level 1))
 
 ;;; FIXME: reconnection is broken since the recent io-redirection changes.    
-(def-slime-test disconnect
+(def-slime-test (disconnect-one-connection (:style :spawn)) ()
+    "`slime-disconnect' should disconnect only the current connection"
+    '(())
+  (let ((connection-count (length slime-net-processes))
+        (old-connection slime-default-connection)
+        (slime-connected-hook nil))
+    (unwind-protect
+         (let ((slime-dispatching-connection 
+                (slime-connect "localhost" 
+                               ;; Here we assume that the request will
+                               ;; be evaluated in its own thread.
+                               (slime-eval `(swank:create-server 
+                                             :port 0 ; use random port
+                                             :style :spawn
+                                             :dont-close nil)))))
+           (slime-sync-to-top-level 3)
+           (slime-disconnect)
+           (slime-test-expect "Number of connections must remane the same"
+                              connection-count
+                              (length slime-net-processes)))
+      (slime-select-connection old-connection))))
+
+(def-slime-test disconnect-and-reconnect
     ()
     "Close the connetion.
 Confirm that the subprocess continues gracefully.
@@ -8170,6 +8217,8 @@
                             (lambda () 
                               (not (member hook slime-connected-hook)))
                             5))))
+
+
     
 
 ;;;; Utilities
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/24 12:58:50	1.1772
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/28 15:38:11	1.1773
@@ -1,3 +1,20 @@
+2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-disconnect): Now only disconnects one
+	connection, current one by default, or given by argument.
+	(slime-disconnect-all): New. What `slime-disconnect' was before.
+	(def-slime-test): Changed: expected failures are now given
+	by (:fails-for ...) clauses. Extended: new clause (:style ...) to
+	have a test run only on a certain communication style. Updated
+	existing test cases accordingly.
+	([struct] slime-test): New slot `skipped'.
+	(slime-skipped-tests): New var.
+	(slime-execute-tests): Adapted accordingly.
+	([test] disconnect): Renamed to `disconnect-and-reconnect'
+	([test] disconnect-one-conneciton): New.
+
+	Adapted from patch by Stas Boukarev.
+
 2009-05-24  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el ([test] fancy-symbol-names): Add cases involving #|




From trittweiler at common-lisp.net  Thu May 28 15:40:10 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 28 May 2009 11:40:10 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1M9hiE-0007gE-Ow@common-lisp.net>

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

Modified Files:
	slime-repl.el ChangeLog 
Log Message:
	* slime-repl.el (slime-repl-disconnect): Disconnect current connection.
	(slime-repl-disconnect-all): New; disconnect all connections.

	Patch by Stas Boukarev.


--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2009/05/15 19:02:19	1.21
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2009/05/28 15:40:10	1.22
@@ -1312,6 +1312,10 @@
 
 (defslime-repl-shortcut slime-repl-disconnect ("disconnect")
   (:handler 'slime-disconnect)
+  (:one-liner "Disconnect the current connection."))
+
+(defslime-repl-shortcut slime-repl-disconnect-all ("disconnect-all")
+  (:handler 'slime-disconnect-all)
   (:one-liner "Disconnect all connections."))
 
 (defslime-repl-shortcut slime-repl-sayoonara ("sayoonara")
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/20 19:25:58	1.214
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2009/05/28 15:40:10	1.215
@@ -1,3 +1,10 @@
+2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-repl.el (slime-repl-disconnect): Disconnect current connection.
+	(slime-repl-disconnect-all): New; disconnect all connections.
+
+	Patch by Stas Boukarev.
+
 2009-05-20  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-arglists.lisp (arglist-dispatch [define-compiler-macro]):




From trittweiler at common-lisp.net  Thu May 28 15:42:47 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 28 May 2009 11:42:47 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M9hkl-0008DN-Bl@common-lisp.net>

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

Modified Files:
	swank.lisp ChangeLog 
Log Message:
	* swank.lisp (tokenize-symbol-thoroughly): Make it work correctly
	on escaped symbols.


--- /project/slime/cvsroot/slime/swank.lisp	2009/05/17 19:12:53	1.647
+++ /project/slime/cvsroot/slime/swank.lisp	2009/05/28 15:42:47	1.648
@@ -363,7 +363,7 @@
          (close-connection ,var
                            (swank-error.condition condition)
                            (swank-error.backtrace condition)))))))
-  
+
 (defmacro with-panic-handler ((connection) &body body)
   (let ((var (gensym)))
   `(let ((,var ,connection))
@@ -1996,26 +1996,31 @@
         (backslash nil)
         (vertical nil)
         (internp nil))
-    (loop for char across string
-       do (cond
+    (loop for char across string do
+          (cond
             (backslash
              (vector-push-extend char token)
              (setq backslash nil))
             ((char= char #\\) ; Quotes next character, even within |...|
              (setq backslash t))
             ((char= char #\|)
-             (setq vertical t))
+             (setq vertical (not vertical)))
             (vertical
              (vector-push-extend char token))
             ((char= char #\:)
-             (if package
-                 (setq internp t)
-                 (setq package token
-                       token (make-array (length string)
-                                         :element-type 'character
-                                         :fill-pointer 0))))
+             (cond ((and package internp)
+                    (error "More than two colons in ~S" string))
+                   (package
+                    (setq internp t))
+                   (t
+                    (setq package token
+                          token (make-array (length string)
+                                            :element-type 'character
+                                            :fill-pointer 0)))))
             (t
              (vector-push-extend (casify-char char) token))))
+    (when vertical
+      (error "Unclosed vertical bar in ~S" string))
     (values token package (or (not package) internp))))
 
 (defun untokenize-symbol (package-name internal-p symbol-name)
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/28 15:38:11	1.1773
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/28 15:42:47	1.1774
@@ -1,5 +1,10 @@
 2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank.lisp (tokenize-symbol-thoroughly): Make it work correctly
+	on escaped symbols.
+
+2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (slime-disconnect): Now only disconnects one
 	connection, current one by default, or given by argument.
 	(slime-disconnect-all): New. What `slime-disconnect' was before.




From trittweiler at common-lisp.net  Thu May 28 16:57:01 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 28 May 2009 12:57:01 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M9iua-0003tE-5B@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el (slime-dispatch-event :emacs-rex): Make sure that we
	pop the continuation on erroneous send.

	Patch by Mark Cox <markcox80 at gmail.com>.


--- /project/slime/cvsroot/slime/slime.el	2009/05/28 15:38:11	1.1181
+++ /project/slime/cvsroot/slime/slime.el	2009/05/28 16:56:59	1.1182
@@ -2375,10 +2375,18 @@
           ((:emacs-rex form package thread continuation)
            (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
              (slime-display-oneliner "; pipelined request... %S" form))
-           (let ((id (incf (slime-continuation-counter))))
+           (let ((id (incf (slime-continuation-counter)))
+                 (send-ok nil))
              (push (cons id continuation) (slime-rex-continuations))
-             (slime-send `(:emacs-rex ,form ,package ,thread ,id))
-             (slime-recompute-modelines t)))
+             (unwind-protect 
+                  (progn 
+                    (slime-send `(:emacs-rex ,form ,package ,thread ,id))
+                    (setq send-ok t))
+               (unless send-ok
+                 (setf (slime-rex-continuations)
+                       (cdr (slime-rex-continuations)))
+                 (funcall continuation '(:abort)))
+               (slime-recompute-modelines t))))
           ((:return value id)
            (let ((rec (assq id (slime-rex-continuations))))
              (cond (rec (setf (slime-rex-continuations)
@@ -2403,6 +2411,7 @@
                                    (error "Invalid channel id: %S %S" id msg))
                                msg))
           ((:emacs-channel-send id msg)
+           ;; FIXME: Guard against errors like in :emacs-rex?
            (slime-send `(:emacs-channel-send ,id ,msg)))
           ((:read-from-minibuffer thread tag prompt initial-value)
            (slime-read-from-minibuffer-for-swank thread tag prompt initial-value))
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/28 15:42:47	1.1774
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/28 16:57:00	1.1775
@@ -1,5 +1,12 @@
 2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-dispatch-event :emacs-rex): Make sure that we
+	pop the continuation on erroneous send.
+
+	Patch by Mark Cox <markcox80 at gmail.com>.
+
+2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank.lisp (tokenize-symbol-thoroughly): Make it work correctly
 	on escaped symbols.
 




From trittweiler at common-lisp.net  Thu May 28 19:01:09 2009
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 28 May 2009 15:01:09 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1M9kqj-000203-OS@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:
	* slime.el (def-slime-test): Forgot to remove debugging code.


--- /project/slime/cvsroot/slime/slime.el	2009/05/28 16:56:59	1.1182
+++ /project/slime/cvsroot/slime/slime.el	2009/05/28 19:01:09	1.1183
@@ -7231,7 +7231,6 @@
                        (name  (first name))
                        (fails-for (cdr (assq :fails-for opts)))
                        (style (cdr (assq :style opts))))
-                  (tcr:debugmsg "opts=%S" opts)
                   ;; :style and :fails-for only options, given no more than one time?
                   (assert (null (remove* :style (remove* :fails-for opts :key #'car)
                                          :key #'car)))
--- /project/slime/cvsroot/slime/ChangeLog	2009/05/28 16:57:00	1.1775
+++ /project/slime/cvsroot/slime/ChangeLog	2009/05/28 19:01:09	1.1776
@@ -1,5 +1,9 @@
 2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (def-slime-test): Forgot to remove debugging code.
+
+2009-05-28  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (slime-dispatch-event :emacs-rex): Make sure that we
 	pop the continuation on erroneous send.