From trittweiler at common-lisp.net  Sun Sep  7 12:24:37 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun,  7 Sep 2008 08:24:37 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080907122437.8E47A72197@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv5878/contrib

Modified Files:
	slime-mdot-fu.el ChangeLog 
Added Files:
	slime-enclosing-context.el 
Log Message:

* slime-enclosing-context.el: New utility contrib on top of
  `slime-parse' to extract some context around point, like bound
  variables or bound functions.

* slime-mdot-fu.el: Move context stuff out to the new contrib.


--- /project/slime/cvsroot/slime/contrib/slime-mdot-fu.el	2008/08/07 14:49:51	1.2
+++ /project/slime/cvsroot/slime/contrib/slime-mdot-fu.el	2008/09/07 12:24:37	1.3
@@ -5,52 +5,7 @@
 ;; License: GNU GPL (same license as Emacs)
 ;;
 
-(require 'slime-parse)
-
-(defvar slime-binding-ops-alist
-  '((flet &bindings &body) 
-    (labels &bindings &body)
-    (macrolet &bindings &body)
-    (let &bindings &body)))
-
-(defun slime-lookup-binding-op (op)
-  (assoc* op slime-binding-ops-alist :test 'equalp :key 'symbol-name))
-
-(defun slime-binding-op-p (op)
-  (and (slime-lookup-binding-op op) t))
-
-(defun slime-binding-op-body-pos (op)
-  (when-let (special-lambda-list (slime-lookup-binding-op op))
-    (position '&body special-lambda-list)))
-
-(defun slime-binding-op-bindings-pos (op)
-  (when-let (special-lambda-list (slime-lookup-binding-op op))
-    (position '&bindings special-lambda-list)))
-
-(defun slime-enclosing-bound-names ()
-  "Returns all bound function names as first value, and the
-points where their bindings are established as second value."
-  (multiple-value-bind (ops indices points)
-      (slime-enclosing-form-specs)
-    (let ((binding-names) (binding-start-points))
-      (save-excursion
-	(loop for (op . nil) in ops
-	      for index in indices
-	      for point in points
-	      do (when (and (slime-binding-op-p op) 
-			    ;; Are the bindings of OP in scope?
-			    (= index (slime-binding-op-body-pos op)))
-		   (goto-char point) 
-		   (forward-sexp (slime-binding-op-bindings-pos op))
-		   (down-list)
-		   (ignore-errors
-		     (loop 
-		      (down-list) 
-		      (push (slime-symbol-name-at-point) binding-names)
-		      (push (save-excursion (backward-up-list) (point)) 
-			    binding-start-points)
-		      (up-list)))))
-      (values (nreverse binding-names) (nreverse binding-start-points))))))
+(require 'slime-enclosing-context)
 
 (defun slime-edit-local-definition (name &optional where)
   "Like `slime-edit-definition', but tries to find the definition
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/08/27 17:53:11	1.125
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/07 12:24:37	1.126
@@ -1,3 +1,11 @@
+2008-07-09  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-enclosing-context.el: New utility contrib on top of
+	`slime-parse' to extract some context around point, like bound
+	variables or bound functions.
+
+	* slime-mdot-fu.el: Move context stuff out to the new contrib.
+
 2008-08-27  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-arglists.lisp (variable-desc-for-echo-area): Limit the

--- /project/slime/cvsroot/slime/contrib/slime-enclosing-context.el	2008/09/07 12:24:37	NONE
+++ /project/slime/cvsroot/slime/contrib/slime-enclosing-context.el	2008/09/07 12:24:37	1.1
;;; slime-enclosing-context.el --- Utilities on top of slime-parse.
;;
;; Author:  Tobias C. Rittweiler <tcr at freebits.de>
;;
;; License: GNU GPL (same license as Emacs)
;;

(require 'slime-parse)

(defvar slime-variable-binding-ops-alist
  '((let &bindings &body)))

(defvar slime-function-binding-ops-alist
  '((flet &bindings &body) 
    (labels &bindings &body)
    (macrolet &bindings &body)))

(defun slime-lookup-binding-op (op &optional binding-type)
  (flet ((lookup-in (list) (assoc* op list :test 'equalp :key 'symbol-name)))
    (cond ((eq binding-type :variable) (lookup-in slime-variable-binding-ops-alist))
	  ((eq binding-type :function) (lookup-in slime-function-binding-ops-alist))
	  (t (or (lookup-in slime-variable-binding-ops-alist)
		 (lookup-in slime-function-binding-ops-alist))))))

(defun slime-binding-op-p (op &optional binding-type)
  (and (slime-lookup-binding-op op binding-type) t))

(defun slime-binding-op-body-pos (op)
  (when-let (special-lambda-list (slime-lookup-binding-op op))
    (position '&body special-lambda-list)))

(defun slime-binding-op-bindings-pos (op)
  (when-let (special-lambda-list (slime-lookup-binding-op op))
    (position '&bindings special-lambda-list)))


(defun slime-enclosing-bound-names ()
  "Returns all bound function names as first value, and the
points where their bindings are established as second value."
  (multiple-value-call #'slime-find-bound-names (slime-enclosing-form-specs)))

(defun slime-find-bound-names (ops indices points)
  (let ((binding-names) (binding-start-points))
    (save-excursion
      (loop for (op . nil) in ops
	    for index in indices
	    for point in points
	    do (when (and (slime-binding-op-p op) 
			  ;; Are the bindings of OP in scope?
			  (= index (slime-binding-op-body-pos op)))
		 (goto-char point) 
		 (forward-sexp (slime-binding-op-bindings-pos op))
		 (down-list)
		 (ignore-errors
		   (loop 
		    (down-list) 
		    (push (slime-symbol-name-at-point) binding-names)
		    (push (save-excursion (backward-up-list) (point)) 
			  binding-start-points)
		    (up-list)))))
      (values (nreverse binding-names) (nreverse binding-start-points)))))


(defun slime-enclosing-bound-functions ()
  (multiple-value-call #'slime-find-bound-functions (slime-enclosing-form-specs)))

(defun slime-find-bound-functions (ops indices points)
  (let ((names) (arglists) (start-points))
    (save-excursion
      (loop for (op . nil) in ops
	    for index in indices
	    for point in points
	    do (when (and (slime-binding-op-p op :function) 
			  ;; Are the bindings of OP in scope?
			  (= index (slime-binding-op-body-pos op)))
		 (goto-char point)
		 (forward-sexp (slime-binding-op-bindings-pos op))
		 (down-list)
		 (ignore-errors
		   (loop 
		    (down-list) 
		    (push (slime-symbol-name-at-point) names)
		    (slime-end-of-symbol) 
		    (push (slime-parse-sexp-at-point 1 t) arglists)
		    (push (save-excursion (backward-up-list) (point)) 
			  start-points)
		    (up-list)))))
      (values (nreverse names)
	      (nreverse arglists) 
	      (nreverse start-points)))))

(provide 'slime-enclosing-context)


From trittweiler at common-lisp.net  Sun Sep  7 12:34:23 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun,  7 Sep 2008 08:34:23 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080907123423.0C32313071@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv7171/contrib

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

Slime-autodoc now also displays arglists of local functions.

* swank-arglists.lisp (defslimefun format-arglist-for-echo-area):
  New RPC.

* slime-autodoc.el (slime-make-autodoc-cache-key): New; extracted
  from slime-autodoc-thing-at-point.
  (slime-make-autodoc-swank-form): New; partially extracted from
  slime-autodoc-thing-at-point. Use `slime-autodoc-local-arglist'.
  (slime-autodoc-local-arglist): New function.
  (slime-autodoc-thing-at-point): Use the two new functions.


--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2008/08/27 17:53:12	1.22
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2008/09/07 12:34:22	1.23
@@ -455,7 +455,15 @@
     (*print-length*   . 20)
     (*print-escape*   . nil))) ; no package qualifiers.
 
-(defun decoded-arglist-to-string (arglist
+(defslimefun format-arglist-for-echo-area
+    (arglist &rest args
+	     &key operator highlight (package *package*)
+	     print-right-margin print-lines)
+  "Formats ARGLIST (given as string) for Emacs' echo area."
+  (declare (ignore operator highlight package print-right-margin print-lines))
+  (apply #'decoded-arglist-to-string (decode-arglist (read-from-string arglist)) args))
+
+(defun decoded-arglist-to-string (decoded-arglist
                                   &key operator highlight (package *package*)
                                   print-right-margin print-lines)
   "Print the decoded ARGLIST for display in the echo area.  The
@@ -469,7 +477,7 @@
 	(let ((*package* package)
 	      (*print-right-margin* print-right-margin)
 	      (*print-lines* print-lines))       
-	  (print-arglist arglist :operator operator :highlight highlight))))))
+	  (print-arglist decoded-arglist :operator operator :highlight highlight))))))
 
 (defslimefun variable-desc-for-echo-area (variable-name)
   "Return a short description of VARIABLE-NAME, or NIL."
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2008/03/18 13:21:42	1.8
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2008/09/07 12:34:22	1.9
@@ -17,6 +17,7 @@
 ;;
 
 (require 'slime-parse)
+(require 'slime-enclosing-context)
 
 (defvar slime-use-autodoc-mode t
   "When non-nil always enable slime-autodoc-mode in slime-mode.")
@@ -88,8 +89,8 @@
   "Print some apropos information about the code at point, if applicable."
   (destructuring-bind (cache-key retrieve-form) (slime-autodoc-thing-at-point)
     (let ((cached (slime-get-cached-autodoc cache-key)))
-      (if cached 
-          (slime-autodoc-message cached)
+      (if cached
+	  (slime-autodoc-message cached)
         ;; Asynchronously fetch, cache, and display documentation
         (slime-eval-async 
          retrieve-form
@@ -146,21 +147,10 @@
     (if global
         (values (slime-qualify-cl-symbol-name global)
                 `(swank:variable-desc-for-echo-area ,global))
-      (multiple-value-bind (operators arg-indices points)
-          (slime-enclosing-form-specs)
-        (values (mapcar* (lambda (designator arg-index)
-                           (cons
-                            (if (symbolp designator)
-                                (slime-qualify-cl-symbol-name designator)
-                              designator)
-                            arg-index))
-                         operators arg-indices)
-                (multiple-value-bind (width height)
-                    (slime-autodoc-message-dimensions)
-                  `(swank:arglist-for-echo-area ',operators
-                                                :arg-indices ',arg-indices
-                                                :print-right-margin ,width
-                                                :print-lines ,height)))))))
+	(multiple-value-bind (operators arg-indices points)
+	    (slime-enclosing-form-specs)
+	  (values (slime-make-autodoc-cache-key operators arg-indices points)
+		  (slime-make-autodoc-swank-form operators arg-indices points))))))
 
 (defun slime-autodoc-global-at-point ()
   "Return the global variable name at point, if any."
@@ -180,6 +170,38 @@
   (and (< (length name) 80) ; avoid overflows in regexp matcher
        (string-match slime-global-variable-name-regexp name)))
 
+(defun slime-make-autodoc-cache-key (ops indices points)
+  (mapcar* (lambda (designator arg-index)
+	     (let ((designator (if (symbolp designator)
+				   (slime-qualify-cl-symbol-name designator)
+				   designator)))
+	       `(,designator . ,arg-index)))
+	   operators arg-indices))
+
+(defun slime-make-autodoc-swank-form (ops indices points)
+  (multiple-value-bind (width height)
+      (slime-autodoc-message-dimensions)
+    (let ((local-arglist (slime-autodoc-local-arglist ops indices points)))
+      (if local-arglist
+	  `(swank:format-arglist-for-echo-area ,local-arglist
+	     :operator ,(first (first ops))
+	     :highlight ,(first indices)
+	     :print-right-margin ,width
+	     :print-lines ,height)
+	  `(swank:arglist-for-echo-area ',ops 
+	     :arg-indices ',indices
+	     :print-right-margin ,width
+	     :print-lines ,height)))))
+
+(defun slime-autodoc-local-arglist (ops indices points)
+  (let* ((cur-op      (first ops))
+	 (cur-op-name (first cur-op)))
+    (multiple-value-bind (bound-fn-names arglists)
+	(slime-find-bound-functions ops indices points)
+      (when-let (pos (position cur-op-name bound-fn-names :test 'equal))
+	(nth pos arglists)))))
+
+
 (defun slime-get-cached-autodoc (symbol-name)
   "Return the cached autodoc documentation for SYMBOL-NAME, or nil."
   (ecase slime-autodoc-cache-type
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/07 12:24:37	1.126
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/07 12:34:22	1.127
@@ -1,4 +1,18 @@
-2008-07-09  Tobias C. Rittweiler  <tcr at freebits.de>
+2008-09-07  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Slime-autodoc now also displays arglists of local functions.
+
+	* swank-arglists.lisp (defslimefun format-arglist-for-echo-area):
+	New RPC.
+
+	* slime-autodoc.el (slime-make-autodoc-cache-key): New; extracted
+	from slime-autodoc-thing-at-point.
+	(slime-make-autodoc-swank-form): New; partially extracted from
+	slime-autodoc-thing-at-point. Use `slime-autodoc-local-arglist'.
+	(slime-autodoc-local-arglist): New function.
+	(slime-autodoc-thing-at-point): Use the two new functions.
+
+2008-09-07  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-enclosing-context.el: New utility contrib on top of
 	`slime-parse' to extract some context around point, like bound



From trittweiler at common-lisp.net  Sun Sep  7 12:44:11 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun,  7 Sep 2008 08:44:11 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080907124411.3739D3C047@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv10774/contrib

Modified Files:
	slime-autodoc.el ChangeLog 
Log Message:

* slime-autodoc.el (slime-make-autodoc-swank-form): Do not
  highlight operator in local arglist display.


--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2008/09/07 12:34:22	1.9
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2008/09/07 12:44:11	1.10
@@ -185,7 +185,7 @@
       (if local-arglist
 	  `(swank:format-arglist-for-echo-area ,local-arglist
 	     :operator ,(first (first ops))
-	     :highlight ,(first indices)
+	     :highlight ,(if (zerop (first indices)) nil (first indices))
 	     :print-right-margin ,width
 	     :print-lines ,height)
 	  `(swank:arglist-for-echo-area ',ops 
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/07 12:34:22	1.127
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/07 12:44:11	1.128
@@ -1,5 +1,10 @@
 2008-09-07  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime-autodoc.el (slime-make-autodoc-swank-form): Do not
+	highlight operator in local arglist display.
+
+2008-09-07  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Slime-autodoc now also displays arglists of local functions.
 
 	* swank-arglists.lisp (defslimefun format-arglist-for-echo-area):



From trittweiler at common-lisp.net  Mon Sep  8 22:35:59 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Mon,  8 Sep 2008 18:35:59 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080908223559.536CC7C04F@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv27461

Modified Files:
	swank.lisp ChangeLog 
Log Message:

A package "Foo.Bar.1.0" was truncated to "0>" as REPL
prompt. It'll now be displayed as "Bar.1.0>".

* swank.lisp (auto-abbreviated-package-name): Adapted accordingly.


--- /project/slime/cvsroot/slime/swank.lisp	2008/08/31 11:58:01	1.581
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/08 22:35:58	1.582
@@ -2003,11 +2003,21 @@
 
 N.B. this is not an actual package name or nickname."
   (when *auto-abbreviate-dotted-packages*
-    (let ((last-dot (position #\. (package-name package) :from-end t)))
-      (when last-dot (subseq (package-name package) (1+ last-dot))))))
+    (loop with package-name = (package-name package)
+          with offset = nil
+          do (let ((last-dot-pos (position #\. package-name :end offset :from-end t)))
+               (unless last-dot-pos
+                 (return nil))
+               ;; If a dot chunk contains only numbers, that chunk most
+               ;; likely represents a version number; so we collect the
+               ;; next chunks, too, until we find one with meat.
+               (let ((name (subseq package-name (1+ last-dot-pos) offset)))
+                 (if (notevery #'digit-char-p name)
+                     (return (subseq package-name (1+ last-dot-pos)))
+                     (setq offset last-dot-pos)))))))
 
 (defun shortest-package-nickname (package)
-  "Return the shortest nickname (or canonical name) of PACKAGE."
+  "Return the shortest nickname of PACKAGE."
   (loop for name in (cons (package-name package) (package-nicknames package))
         for shortest = name then (if (< (length name) (length shortest))
                                    name
--- /project/slime/cvsroot/slime/ChangeLog	2008/08/31 11:58:09	1.1491
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/08 22:35:58	1.1492
@@ -1,3 +1,10 @@
+2008-09-09  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	A package "Foo.Bar.1.0" was truncated to "0>" as REPL
+	prompt. It'll now be displayed as "Bar.1.0>".
+
+	* swank.lisp (auto-abbreviated-package-name): Adapted accordingly.
+
 2008-08-31  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-backend.lisp (*gray-stream-symbols*): Remove



From trittweiler at common-lisp.net  Tue Sep  9 12:35:46 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Tue,  9 Sep 2008 08:35:46 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080909123546.85B721C0CE@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17985

Modified Files:
	swank.lisp ChangeLog 
Log Message:

	A RETRY restart is provided for all Slime evaluation requests.

	The rationale is that restarting from a frame is mostly only
	possible for functions compiled with high debug settings; most
	functions aren't, however.

	[Alternatively, we could make EVAL-FOR-EMACS be compiled with a
	high debug level, so it'll become restartable. That would be
	non-obvious to the user, though, and would only work on those
	implementations that implement SWANK-BACKEND:RESTART-FRAME.]

	* swank.lisp (call-with-retry-restart): New function.
	(with-retry-restart): New macro.
	(eval-for-emacs): Use WITH-RETRY-RESTART.


--- /project/slime/cvsroot/slime/swank.lisp	2008/09/08 22:35:58	1.582
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/09 12:35:46	1.583
@@ -1795,6 +1795,22 @@
 
 ;;;; Evaluation
 
+(defun call-with-retry-restart (msg thunk)
+  (let ((%ok    (gensym "OK+"))
+	(%retry (gensym "RETRY+")))
+    (restart-bind
+	((retry
+	  (lambda () (throw %retry nil))
+	   :report-function
+	   (lambda (stream)
+	     (write msg :stream stream))))
+      (catch %ok
+	(loop (catch %retry (throw %ok (funcall thunk))))))))
+
+(defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
+  (check-type msg string)
+  `(call-with-retry-restart ,msg #'(lambda () , at body)))
+
 (defvar *pending-continuations* '()
   "List of continuations for Emacs. (thread local)")
 
@@ -1815,9 +1831,11 @@
                (*pending-continuations* (cons id *pending-continuations*)))
            (check-type *buffer-package* package)
            (check-type *buffer-readtable* readtable)
-           ;; APPLY would be cleaner than EVAL. 
-           ;;(setq result (apply (car form) (cdr form)))
-           (setq result (with-slime-interrupts (eval form)))
+           ;; We provide a general RETRY restart because RESTART-FRAME
+           ;; works only on functions compiled with high debug settings,
+           ;; and most aren't.
+           (with-retry-restart (:msg "Retry SLIME evaluation request.")
+             (setq result (with-slime-interrupts (eval form))))
            (run-hook *pre-reply-hook*)
            (setq ok t))
       (send-to-emacs `(:return ,(current-thread)
@@ -2418,7 +2436,7 @@
 (defun swank-compiler (function)
   (let ((notes-p))
     (multiple-value-bind (result usecs)
-        (with-simple-restart (abort "Abort SLIME compilation.")
+        (with-simple-restart (abort-compilation "Abort SLIME compilation request.")
           (handler-bind ((compiler-condition #'(lambda (c)
                                                  (setf notes-p t)
                                                  (record-note-for-condition c))))
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/08 22:35:58	1.1492
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/09 12:35:46	1.1493
@@ -1,5 +1,22 @@
 2008-09-09  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	A RETRY restart is provided for all Slime evaluation requests.
+
+	The rationale is that restarting from a frame is mostly only
+	possible for functions compiled with high debug settings; most
+	functions aren't, however.
+
+	[Alternatively, we could make EVAL-FOR-EMACS be compiled with a
+	high debug level, so it'll become restartable. That would be
+	non-obvious to the user, though, and would only work on those
+	implementations that implement SWANK-BACKEND:RESTART-FRAME.]
+
+	* swank.lisp (call-with-retry-restart): New function.
+	(with-retry-restart): New macro.
+	(eval-for-emacs): Use WITH-RETRY-RESTART.
+
+2008-09-09  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	A package "Foo.Bar.1.0" was truncated to "0>" as REPL
 	prompt. It'll now be displayed as "Bar.1.0>".
 



From trittweiler at common-lisp.net  Tue Sep  9 23:26:18 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Tue,  9 Sep 2008 19:26:18 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080909232618.784B37A091@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12973

Modified Files:
	swank.lisp ChangeLog 
Log Message:
	* swank.lisp (eval-for-emacs): Remove WITH-RETRY-RESTART again for
	simplicity reasons.

	(interactive-eval): Add WITH-RETRY-RESTART.
	(eval-and-grab-output): Ditto.
	(interactive-eval-region): Ditto.
	(re-evaluate-defvar): Ditto.
	(pprint-eval): Ditto.
	(repl-eval): Ditto.
	(eval-string-in-frame): Ditto.
	(pprint-eval-string-in-frame): Ditto.
	(init-inspector): Ditto.
	(inspect-in-frame): Ditto.


--- /project/slime/cvsroot/slime/swank.lisp	2008/09/09 12:35:46	1.583
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/09 23:26:18	1.584
@@ -400,6 +400,24 @@
         (with-io-redirection (*emacs-connection*)
           (call-with-debugger-hook #'swank-debugger-hook function))))))
 
+(defun call-with-retry-restart (msg thunk)
+  (let ((%ok    (gensym "OK+"))
+	(%retry (gensym "RETRY+")))
+    (restart-bind
+	((retry
+	  (lambda () (throw %retry nil))
+	   :report-function
+	   (lambda (stream)
+	     (write msg :stream stream))))
+      (catch %ok
+	(loop (catch %retry (throw %ok (funcall thunk))))))))
+
+(defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
+  (check-type msg string)
+  `(call-with-retry-restart ,msg #'(lambda () , at body)))
+
+;;; FIXME: Can this be removed with the introduction of
+;;;        WITH/WITHOUT-SLIME-INTERRUPTS.
 (defmacro without-interrupts (&body body)
   `(call-without-interrupts (lambda () , at body)))
 
@@ -461,6 +479,7 @@
 (defun current-thread-id ()
   (thread-id (current-thread)))
 
+
 
 ;;;;; Logging
 
@@ -1795,22 +1814,6 @@
 
 ;;;; Evaluation
 
-(defun call-with-retry-restart (msg thunk)
-  (let ((%ok    (gensym "OK+"))
-	(%retry (gensym "RETRY+")))
-    (restart-bind
-	((retry
-	  (lambda () (throw %retry nil))
-	   :report-function
-	   (lambda (stream)
-	     (write msg :stream stream))))
-      (catch %ok
-	(loop (catch %retry (throw %ok (funcall thunk))))))))
-
-(defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
-  (check-type msg string)
-  `(call-with-retry-restart ,msg #'(lambda () , at body)))
-
 (defvar *pending-continuations* '()
   "List of continuations for Emacs. (thread local)")
 
@@ -1831,11 +1834,9 @@
                (*pending-continuations* (cons id *pending-continuations*)))
            (check-type *buffer-package* package)
            (check-type *buffer-readtable* readtable)
-           ;; We provide a general RETRY restart because RESTART-FRAME
-           ;; works only on functions compiled with high debug settings,
-           ;; and most aren't.
-           (with-retry-restart (:msg "Retry SLIME evaluation request.")
-             (setq result (with-slime-interrupts (eval form))))
+           ;; APPLY would be cleaner than EVAL. 
+           ;;(setq result (apply (car form) (cdr form)))
+           (setq result (with-slime-interrupts (eval form)))
            (run-hook *pre-reply-hook*)
            (setq ok t))
       (send-to-emacs `(:return ,(current-thread)
@@ -1859,18 +1860,20 @@
 
 (defslimefun interactive-eval (string)
   (with-buffer-syntax ()
-    (let ((values (multiple-value-list (eval (from-string string)))))
-      (fresh-line)
-      (finish-output)
-      (format-values-for-echo-area values))))
+    (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
+      (let ((values (multiple-value-list (eval (from-string string)))))
+        (fresh-line)
+        (finish-output)
+        (format-values-for-echo-area values)))))
 
 (defslimefun eval-and-grab-output (string)
   (with-buffer-syntax ()
-    (let* ((s (make-string-output-stream))
-           (*standard-output* s)
-           (values (multiple-value-list (eval (from-string string)))))
-      (list (get-output-stream-string s) 
-            (format nil "~{~S~^~%~}" values)))))
+    (with-retry-restart (:msg "Retry SLIME evaluation request.")
+      (let* ((s (make-string-output-stream))
+             (*standard-output* s)
+             (values (multiple-value-list (eval (from-string string)))))
+        (list (get-output-stream-string s) 
+              (format nil "~{~S~^~%~}" values))))))
 
 (defun eval-region (string)
   "Evaluate STRING.
@@ -1888,16 +1891,18 @@
 
 (defslimefun interactive-eval-region (string)
   (with-buffer-syntax ()
-    (format-values-for-echo-area (eval-region string))))
+    (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
+      (format-values-for-echo-area (eval-region string)))))
 
 (defslimefun re-evaluate-defvar (form)
   (with-buffer-syntax ()
-    (let ((form (read-from-string form)))
-      (destructuring-bind (dv name &optional value doc) form
-	(declare (ignore value doc))
-	(assert (eq dv 'defvar))
-	(makunbound name)
-	(prin1-to-string (eval form))))))
+    (with-retry-restart (:msg "Retry SLIME evaluation request.")
+      (let ((form (read-from-string form)))
+        (destructuring-bind (dv name &optional value doc) form
+          (declare (ignore value doc))
+          (assert (eq dv 'defvar))
+          (makunbound name)
+          (prin1-to-string (eval form)))))))
 
 (defvar *swank-pprint-bindings*
   `((*print-pretty*   . t) 
@@ -1921,7 +1926,8 @@
   
 (defslimefun pprint-eval (string)
   (with-buffer-syntax ()
-    (swank-pprint (multiple-value-list (eval (read-from-string string))))))
+    (with-retry-restart (:msg "Retry SLIME evaluation request.")
+      (swank-pprint (multiple-value-list (eval (read-from-string string)))))))
 
 (defslimefun set-package (name)
   "Set *package* to the package named NAME.
@@ -1943,13 +1949,14 @@
 (defun repl-eval (string)
   (clear-user-input)
   (with-buffer-syntax ()
-    (track-package 
-     (lambda ()
-       (multiple-value-bind (values last-form) (eval-region string)
-         (setq *** **  ** *  * (car values)
-               /// //  // /  / values
-               +++ ++  ++ +  + last-form)
-         (funcall *send-repl-results-function* values)))))
+    (with-retry-restart (:msg "Retry SLIME REPL evaluation request.")
+      (track-package 
+       (lambda ()
+         (multiple-value-bind (values last-form) (eval-region string)
+           (setq *** **  ** *  * (car values)
+                 /// //  // /  / values
+                 +++ ++  ++ +  + last-form)
+           (funcall *send-repl-results-function* values))))))
   nil)
 
 (defun track-package (fun)
@@ -2322,13 +2329,16 @@
      ,form))
 
 (defslimefun eval-string-in-frame (string index)
-  (to-string (eval-in-frame (wrap-sldb-vars (from-string string))
-                            index)))
+  (to-string
+   (with-retry-restart (:msg "Retry SLIME evaluation request.")
+     (eval-in-frame (wrap-sldb-vars (from-string string))
+                    index))))
 
 (defslimefun pprint-eval-string-in-frame (string index)
   (swank-pprint
-   (multiple-value-list 
-    (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
+   (with-retry-restart (:msg "Retry SLIME evaluation request.")
+     (multiple-value-list 
+      (eval-in-frame (wrap-sldb-vars (from-string string)) index)))))
 
 (defslimefun frame-locals-for-emacs (index)
   "Return a property list ((&key NAME ID VALUE) ...) describing
@@ -2883,8 +2893,9 @@
   
 (defslimefun init-inspector (string)
   (with-buffer-syntax ()
-    (reset-inspector)
-    (inspect-object (eval (read-from-string string)))))
+    (with-retry-restart (:msg "Retry SLIME inspection request.")
+      (reset-inspector)
+      (inspect-object (eval (read-from-string string))))))
 
 (defun inspect-object (o)
   (let ((previous *istate*)
@@ -3025,8 +3036,9 @@
 
 (defslimefun inspect-in-frame (string index)
   (with-buffer-syntax ()
-    (reset-inspector)
-    (inspect-object (eval-in-frame (from-string string) index))))
+    (with-retry-restart (:msg "Retry SLIME inspection request.")
+      (reset-inspector)
+      (inspect-object (eval-in-frame (from-string string) index)))))
 
 (defslimefun inspect-current-condition ()
   (with-buffer-syntax ()
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/09 12:35:46	1.1493
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/09 23:26:18	1.1494
@@ -1,3 +1,19 @@
+2008-09-10  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank.lisp (eval-for-emacs): Remove WITH-RETRY-RESTART again for
+	simplicity reasons.
+
+	(interactive-eval): Add WITH-RETRY-RESTART.
+	(eval-and-grab-output): Ditto.
+	(interactive-eval-region): Ditto.
+	(re-evaluate-defvar): Ditto.
+	(pprint-eval): Ditto.
+	(repl-eval): Ditto.
+	(eval-string-in-frame): Ditto.
+	(pprint-eval-string-in-frame): Ditto.
+	(init-inspector): Ditto.
+	(inspect-in-frame): Ditto.
+
 2008-09-09  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	A RETRY restart is provided for all Slime evaluation requests.



From trittweiler at common-lisp.net  Tue Sep  9 23:29:45 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Tue,  9 Sep 2008 19:29:45 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080909232945.4E6F73E057@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13517

Modified Files:
	swank-backend.lisp ChangeLog 
Log Message:
	* swank-backend.lisp (*gray-stream-symbols*): Comment out
	STREAM-FILE-POSITION.


--- /project/slime/cvsroot/slime/swank-backend.lisp	2008/08/31 11:58:01	1.149
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/09 23:29:44	1.150
@@ -205,7 +205,9 @@
     :stream-read-char
     :stream-peek-char
     :stream-read-line
-    :stream-file-position
+    ;; STREAM-FILE-POSITION is not available on all implementations, or
+    ;; partially under a different name.
+    ; :stream-file-posiion
     :stream-listen
     :stream-unread-char
     :stream-clear-input
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/09 23:26:18	1.1494
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/09 23:29:44	1.1495
@@ -1,5 +1,10 @@
 2008-09-10  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* swank-backend.lisp (*gray-stream-symbols*): Comment out
+	STREAM-FILE-POSITION.
+
+2008-09-10  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* swank.lisp (eval-for-emacs): Remove WITH-RETRY-RESTART again for
 	simplicity reasons.
 



From trittweiler at common-lisp.net  Wed Sep 10 23:10:45 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 10 Sep 2008 19:10:45 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080910231045.F155F52035@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30696

Modified Files:
	swank.lisp slime.el ChangeLog 
Log Message:

	Reimplement recompilation support. The previous implementation
	involving specials was subtly broken with the :fd-handler
	communcation-style, because of serve-event's polite interplay with
	specials. (Cf. my slime-devel post "Per event bindings" on 2008-08-17.)

	* swank.lisp (with-swank-compilation-unit): Removed.
	(record-note-for-condition): Removed.
	(defstruct swank-compilation-unit): Renamed to
	`swank-compilation-result'.
	(swank-compilation-unit-for-emacs): Renamed to
	`swank-compilation-result-for-emacs'.
	(swank-compiler): Takes additional argument, the
	swank-compilation-result where caught notes should be accumulated
	into.
	(defslimefun compile-file-for-emacs): Adapted accordingly.
	(defslimefun compile-string-for-emacs): Ditto.
	(defslimefun compile-multiple-strings-for-emacs): New RPC call.

	* slime.el (slime-make-compile-expression-for-swank): Removed.
	(slime-compile-string): Don't use above function anymore. Adapted.
	(slime-recompile-locations): Rewritten to use new RPC call above.


--- /project/slime/cvsroot/slime/swank.lisp	2008/09/09 23:26:18	1.584
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/10 23:10:45	1.585
@@ -57,8 +57,7 @@
            #:profile-package
            #:default-directory
            #:set-default-directory
-           #:quit-lisp
-           #:with-swank-compilation-unit))
+           #:quit-lisp))
 
 (in-package :swank)
 
@@ -2384,17 +2383,15 @@
 
 ;;;; Compilation Commands.
 
-(defstruct (:swank-compilation-unit
+(defstruct (:swank-compilation-result
              (:type list) :named
-             (:conc-name swank-compilation-unit.)
-             (:constructor make-swank-compilation-unit ()))
+             (:conc-name swank-compilation-result.)
+             (:constructor make-swank-compilation-result ()))
   notes      ; 
-  results    ; a result is of type (MEMBER T NIL :COMPLAINED)
+  results    ; one result is of type (MEMBER T NIL :COMPLAINED)
   durations  ;
   )
 
-(defvar *swank-compilation-unit* nil)
-
 (defun measure-time-interval (fn)
   "Call FN and return the first return value and the elapsed time.
 The time is measured in microseconds."
@@ -2405,12 +2402,6 @@
      (* (- (get-internal-real-time) before)
         (/ 1000000 internal-time-units-per-second)))))
 
-(defun record-note-for-condition (condition)
-  "Record a note for a compiler-condition into the currently active
-Swank-Compilation-Unit."
-  (push (make-compiler-note condition)
-        (swank-compilation-unit.notes *swank-compilation-unit*)))
-
 (defun make-compiler-note (condition)
   "Make a compiler note data structure from a compiler-condition."
   (declare (type compiler-condition condition))
@@ -2421,67 +2412,80 @@
          (let ((s (short-message condition)))
            (if s (list :short-message s)))))
 
-(defmacro with-swank-compilation-unit ((&key override) &body body)
-  "Similiar to CL:WITH-COMPILATION-UNIT. Within a
-Swank-Compilation-Unit all notes, results etc. produced by
-COMPILE-FILE-FOR-EMACS and COMPILE-STRING-FOR-EMACS (possibly called
-more than once) will be collected into this unit."
-  (if override
-      `(let ((*swank-compilation-unit* (make-swank-compilation-unit)))
-         , at body)
-      `(let ((*swank-compilation-unit* (or *swank-compilation-unit*
-                                           (make-swank-compilation-unit))))
-         , at body)))
-
-(defun swank-compilation-unit-for-emacs (unit)
+(defun swank-compilation-result-for-emacs (old)
   "Make a Swank-Compilation-Unit suitable for Emacs."
-  (let ((new (make-swank-compilation-unit)))
-    (with-struct (swank-compilation-unit. notes results durations) unit
-      (setf (swank-compilation-unit.notes new)   (reverse notes))
-      (setf (swank-compilation-unit.results new) (reverse results))
-      (setf (swank-compilation-unit.durations new)
+  (let ((new (make-swank-compilation-result)))
+    (with-struct (swank-compilation-result. notes results durations) old
+      (setf (swank-compilation-result.notes new)   (reverse notes))
+      (setf (swank-compilation-result.results new) (reverse results))
+      (setf (swank-compilation-result.durations new)
             (reverse (mapcar #'(lambda (usecs) (/ usecs 1000000.0)) durations))))
     new))
 
-(defun swank-compiler (function)
-  (let ((notes-p))
+(defun swank-compiler (swank-compilation-result function)
+  (let ((swank-result swank-compilation-result))
     (multiple-value-bind (result usecs)
         (with-simple-restart (abort-compilation "Abort SLIME compilation request.")
-          (handler-bind ((compiler-condition #'(lambda (c)
-                                                 (setf notes-p t)
-                                                 (record-note-for-condition c))))
+          (handler-bind ((compiler-condition
+                          #'(lambda (c)
+                              (push (make-compiler-note c)
+                                    (swank-compilation-result.notes swank-result)))))
             (measure-time-interval function)))
-      (when result        (setf result (if notes-p :complained t)))
-      (when (eql usecs t) (setf usecs 0)) ; compilation aborted.
-      (push result (swank-compilation-unit.results *swank-compilation-unit*))
-      (push usecs  (swank-compilation-unit.durations *swank-compilation-unit*))
-      (swank-compilation-unit-for-emacs *swank-compilation-unit*))))
+      (when (eql usecs t) (setf usecs 0)) ; compilation aborted.      
+      (when result
+        (let ((notes-p (swank-compilation-result.notes swank-result)))
+          (setf result (if notes-p :complained t))))
+      (push result (swank-compilation-result.results swank-result))
+      (push usecs  (swank-compilation-result.durations swank-result))
+      swank-result)))
 
 (defslimefun compile-file-for-emacs (filename load-p)
   "Compile FILENAME and, when LOAD-P, load the result.
 Record compiler notes signalled as `compiler-condition's."
-  (with-swank-compilation-unit (:override nil)
-    (with-buffer-syntax ()    
-      (let ((*compile-print* nil))
-        (swank-compiler 
-         (lambda ()
-           (let ((pathname (parse-emacs-filename filename)))
-             (swank-compile-file pathname load-p
-                                 (or (guess-external-format pathname)
-                                     :default)))))))))
+  (with-buffer-syntax ()
+    (swank-compilation-result-for-emacs
+     (swank-compiler (make-swank-compilation-result)
+                     (lambda ()
+                       (let ((pathname (parse-emacs-filename filename))
+                             (*compile-print* nil) (*compile-verbose* t))
+                         (swank-compile-file pathname load-p
+                                             (or (guess-external-format pathname)
+                                                 :default))))))))
 
 (defslimefun compile-string-for-emacs (string buffer position directory debug)
   "Compile STRING (exerpted from BUFFER at POSITION).
 Record compiler notes signalled as `compiler-condition's."
-  (with-swank-compilation-unit (:override nil)
-    (with-buffer-syntax ()
-      (swank-compiler
-       (lambda () 
-         (let ((*compile-print* nil) (*compile-verbose* t))
-           (swank-compile-string string :buffer buffer :position position 
-                                 :directory directory
-                                 :debug debug)))))))
+  (with-buffer-syntax ()
+    (swank-compilation-result-for-emacs
+     (swank-compiler (make-swank-compilation-result)
+                     (lambda () 
+                       (let ((*compile-print* t) (*compile-verbose* nil))
+                         (swank-compile-string string
+                                               :buffer buffer
+                                               :position position 
+                                               :directory directory
+                                               :debug debug)))))))
 
+(defslimefun compile-multiple-strings-for-emacs
+    (strings buffers packages positions directories debug)
+  "Compile STRING (exerpted from BUFFER at POSITION).
+Record compiler notes signalled as `compiler-condition's."
+  (let ((swank-compilation-result (make-swank-compilation-result)))
+    (loop for string in strings
+          for buffer in buffers
+          for package in packages
+          for position in positions
+          for directory in directories do
+          (swank-compiler swank-compilation-result
+                          (lambda ()
+                            (with-buffer-syntax (package)
+                              (let ((*compile-print* t) (*compile-verbose* nil))
+                                (swank-compile-string string
+                                                      :buffer buffer
+                                                      :position position 
+                                                      :directory directory
+                                                      :debug debug))))))
+    (swank-compilation-result-for-emacs swank-compilation-result)))
   
 (defun file-newer-p (new-file old-file)
   "Returns true if NEW-FILE is newer than OLD-FILE."
--- /project/slime/cvsroot/slime/slime.el	2008/08/30 15:33:46	1.1008
+++ /project/slime/cvsroot/slime/slime.el	2008/09/10 23:10:45	1.1009
@@ -3945,17 +3945,14 @@
 
 (defun slime-compile-string (string start-offset)
   (slime-eval-async 
-   (slime-make-compile-expression-for-swank string start-offset)
+   `(swank:compile-string-for-emacs
+     ,string
+     ,(buffer-name)
+     ,start-offset
+     ,(if (buffer-file-name) (file-name-directory (buffer-file-name)))
+     ',slime-compilation-debug-level)
    (slime-make-compilation-finished-continuation (current-buffer))))
 
-(defun slime-make-compile-expression-for-swank (string start-offset) 
-  `(swank:compile-string-for-emacs
-    ,string
-    ,(buffer-name)
-    ,start-offset
-    ,(if (buffer-file-name) (file-name-directory (buffer-file-name)))
-    ',slime-compilation-debug-level))
-
 (defun slime-make-compilation-finished-continuation (current-buffer &optional emacs-snapshot)
   (lexical-let ((buffer current-buffer) (snapshot emacs-snapshot))
     (lambda (result)
@@ -4033,32 +4030,26 @@
     (slime-compile-defun debug-level)))
 
 (defun slime-recompile-locations (locations &optional debug-level)
-  (flet ((make-compile-expr (loc)
-           (save-excursion
-             (slime-pop-to-location loc 'excursion)
-             (multiple-value-bind (start end) (slime-region-for-defun-at-point)
-               ;; FIXME: Kludge. The slime-eval-async may send a buffer-package
-               ;; that is not necessarily the same as the one the LOC points to.
-               `(cl:let ((swank::*buffer-package* (swank::guess-buffer-package 
-                                                   ,(slime-current-package))))
-                  ,(slime-make-compile-expression-for-swank
-                    (buffer-substring-no-properties start end)
-                    start))))))
-    (let ((slime-compilation-debug-level debug-level))
+  (let (strings buffers packages positions directories)
+    (flet ((push-location-data (loc)
+             (save-excursion
+               (slime-pop-to-location loc 'excursion)
+               (multiple-value-bind (start end) (slime-region-for-defun-at-point)
+                 (push (buffer-substring-no-properties start end) strings)
+                 (push (buffer-name) buffers)
+                 (push (slime-current-package) packages)
+                 (push start positions)
+                 (push (if (buffer-file-name)
+                           (file-name-directory (buffer-file-name))
+                           nil)
+                       directories)))))
+      (mapc #'push-location-data locations)
       (slime-eval-async 
-       `(swank:with-swank-compilation-unit (:override t) 
-          ;; We have to compile each location separately because of
-          ;; buffer and offset tracking during notes generation.
-          ,@(loop for loc in locations 
-                  collect (make-compile-expr loc)))
+       `(swank:compile-multiple-strings-for-emacs
+         ',(nreverse strings)   ',(nreverse buffers)     ',(nreverse packages)
+         ',(nreverse positions) ',(nreverse directories)  ,debug-level)
        (slime-make-compilation-finished-continuation (current-buffer))))))
 
-;;; FIXME: implement:
-
-;; (defun slime-recompile-symbol-at-point (name)
-;;   (interactive (list (slime-read-symbol-name "Name: ")))
-;; )
-
 
 
 ;;;;; Merging together compiler notes in the same location.
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/09 23:29:44	1.1495
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/10 23:10:45	1.1496
@@ -1,3 +1,27 @@
+2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Reimplement recompilation support. The previous implementation
+	involving specials was subtly broken with the :fd-handler
+	communcation-style, because of serve-event's polite interplay with
+	specials. (Cf. my slime-devel post "Per event bindings" on 2008-08-17.)
+
+	* swank.lisp (with-swank-compilation-unit): Removed.
+	(record-note-for-condition): Removed.
+	(defstruct swank-compilation-unit): Renamed to
+	`swank-compilation-result'.
+	(swank-compilation-unit-for-emacs): Renamed to
+	`swank-compilation-result-for-emacs'.
+	(swank-compiler): Takes additional argument, the
+	swank-compilation-result where caught notes should be accumulated
+	into.
+	(defslimefun compile-file-for-emacs): Adapted accordingly.
+	(defslimefun compile-string-for-emacs): Ditto.
+	(defslimefun compile-multiple-strings-for-emacs): New RPC call.
+
+	* slime.el (slime-make-compile-expression-for-swank): Removed.
+	(slime-compile-string): Don't use above function anymore. Adapted.
+	(slime-recompile-locations): Rewritten to use new RPC call above.
+
 2008-09-10  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-backend.lisp (*gray-stream-symbols*): Comment out



From trittweiler at common-lisp.net  Wed Sep 10 23:12:43 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 10 Sep 2008 19:12:43 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080910231243.CE6E5702EF@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv31101

Modified Files:
	slime.el ChangeLog 
Log Message:

	* slime.el (slime-popup-buffer-restore-snapshot): Make sure that
	the buffer-local variable containing the popup buffer's snapshot
	is set to nil in the right buffer.


--- /project/slime/cvsroot/slime/slime.el	2008/09/10 23:10:45	1.1009
+++ /project/slime/cvsroot/slime/slime.el	2008/09/10 23:12:43	1.1010
@@ -1047,9 +1047,10 @@
   (let ((buffer (current-buffer)))
     (when (slime-popup-buffer-snapshot-unchanged-p)
       (slime-popup-buffer-restore-snapshot))
-    (setq slime-popup-buffer-saved-emacs-snapshot nil)
-    (cond (kill-buffer-p (kill-buffer buffer))
-          (t (with-current-buffer buffer (bury-buffer))))))
+    (with-current-buffer buffer
+      (setq slime-popup-buffer-saved-emacs-snapshot nil) ; buffer-local var!
+      (cond (kill-buffer-p (kill-buffer nil))
+            (t (bury-buffer))))))
 
 (defun slime-popup-buffer-snapshot-unchanged-p ()
   (equalp (slime-current-emacs-snapshot-fingerprint)
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/10 23:10:45	1.1496
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/10 23:12:43	1.1497
@@ -1,5 +1,11 @@
 2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-popup-buffer-restore-snapshot): Make sure that
+	the buffer-local variable containing the popup buffer's snapshot
+	is set to nil in the right buffer.
+
+2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	Reimplement recompilation support. The previous implementation
 	involving specials was subtly broken with the :fd-handler
 	communcation-style, because of serve-event's polite interplay with



From trittweiler at common-lisp.net  Wed Sep 10 23:18:36 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 10 Sep 2008 19:18:36 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080910231836.066003E056@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv32010

Modified Files:
	slime.el ChangeLog 
Log Message:

	* slime.el (slime-compilation-unit): Renamed to
	`slime-compilation-result'.
	(slime-last-compilation-unit): Renamed to
	`slime-last-compilation-result'.
	(slime-compiler-notes, slime-compiler-results): Adapted accordingly.
	(slime-compilation-finished): Ditto.


--- /project/slime/cvsroot/slime/slime.el	2008/09/10 23:12:43	1.1010
+++ /project/slime/cvsroot/slime/slime.el	2008/09/10 23:18:35	1.1011
@@ -3868,23 +3868,23 @@
         ((< n 0) 0)
         (t n)))
 
-(defstruct (slime-compilation-unit
+(defstruct (slime-compilation-result
              (:type list)
-             (:conc-name slime-compilation-unit.)
+             (:conc-name slime-compilation-result.)
              (:constructor nil)
              (:copier nil))
   tag notes results durations)
 
-(defvar slime-last-compilation-unit nil
+(defvar slime-last-compilation-result nil
   "The result of the most recently issued compilation.")
 
 (defun slime-compiler-notes ()
   "Return all compiler notes, warnings, and errors."
-  (slime-compilation-unit.notes slime-last-compilation-unit))
+  (slime-compilation-result.notes slime-last-compilation-result))
 
 (defun slime-compiler-results ()
   "Return the results of the most recently issued compilations."
-  (slime-compilation-unit.results slime-last-compilation-unit))
+  (slime-compilation-result.results slime-last-compilation-result))
 
 
 (defun slime-compile-and-load-file ()
@@ -3959,11 +3959,11 @@
     (lambda (result)
       (slime-compilation-finished result buffer snapshot))))
 
-(defun slime-compilation-finished (compilation-unit buffer &optional emacs-snapshot)
-  (with-struct (slime-compilation-unit. notes durations) compilation-unit
+(defun slime-compilation-finished (compilation-result buffer &optional emacs-snapshot)
+  (with-struct (slime-compilation-result. notes durations) compilation-result
     (with-current-buffer buffer
       (setf slime-compilation-just-finished t)
-      (setf slime-last-compilation-unit compilation-unit)
+      (setf slime-last-compilation-result compilation-result)
       (slime-show-note-counts notes (reduce #'+ durations))
       (when slime-highlight-compiler-notes
         (slime-highlight-notes notes)))
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/10 23:12:43	1.1497
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/10 23:18:36	1.1498
@@ -1,5 +1,14 @@
 2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	* slime.el (slime-compilation-unit): Renamed to
+	`slime-compilation-result'.
+	(slime-last-compilation-unit): Renamed to
+	`slime-last-compilation-result'.
+	(slime-compiler-notes, slime-compiler-results): Adapted accordingly.
+	(slime-compilation-finished): Ditto.
+
+2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	* slime.el (slime-popup-buffer-restore-snapshot): Make sure that
 	the buffer-local variable containing the popup buffer's snapshot
 	is set to nil in the right buffer.



From trittweiler at common-lisp.net  Wed Sep 10 23:51:17 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 10 Sep 2008 19:51:17 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080910235117.DEBB952035@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv8710/contrib

Modified Files:
	swank-asdf.lisp ChangeLog 
Log Message:

	* swank-asdf.lisp (operate-on-system-for-emacs): Adapted to recent
	changes wrt. swank-compilation-unit.


--- /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2008/07/16 18:44:27	1.4
+++ /project/slime/cvsroot/slime/contrib/swank-asdf.lisp	2008/09/10 23:51:17	1.5
@@ -15,10 +15,10 @@
 (defslimefun operate-on-system-for-emacs (system-name operation &rest keywords)
   "Compile and load SYSTEM using ASDF.
 Record compiler notes signalled as `compiler-condition's."
-  (with-swank-compilation-unit (:override nil)
-    (swank-compiler 
-     (lambda ()
-       (apply #'operate-on-system system-name operation keywords)))))
+  (swank-compilation-result-for-emacs
+   (swank-compiler (make-swank-compilation-result)
+		   (lambda ()
+		     (apply #'operate-on-system system-name operation keywords)))))
 
 (defun operate-on-system (system-name operation-name &rest keyword-args)
   "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/07 12:44:11	1.128
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/10 23:51:17	1.129
@@ -1,3 +1,8 @@
+2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-asdf.lisp (operate-on-system-for-emacs): Adapted to recent
+	changes wrt. swank-compilation-unit.
+
 2008-09-07  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-autodoc.el (slime-make-autodoc-swank-form): Do not



From heller at common-lisp.net  Thu Sep 11 10:31:36 2008
From: heller at common-lisp.net (heller)
Date: Thu, 11 Sep 2008 06:31:36 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080911103136.A2E362200B@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv28251

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
Fix stream buffering for CMUCL.

* swank-cmucl.lisp (slime-output-stream): Remove last-flush-time
slot.
(sos/flush): Renamed from sos/misc-force-output.  Don't try to be
clever: no timestamps and no line buffering.
(sos/write-char, sos/write-string): Renamed from sos/out
resp. sos/sout.  Call output-fn outside without-interrupts.
(sos/reset-buffer): New function.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/10 23:18:36	1.1498
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/11 10:31:35	1.1499
@@ -1,3 +1,13 @@
+2008-09-11  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-cmucl.lisp (slime-output-stream): Remove last-flush-time
+	slot.
+	(sos/flush): Renamed from sos/misc-force-output.  Don't try to be
+	clever: no timestamps and no line buffering.
+	(sos/write-char, sos/write-string): Renamed from sos/out
+	resp. sos/sout.  Call output-fn outside without-interrupts.
+	(sos/reset-buffer): New function.
+
 2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-compilation-unit): Renamed to
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/08/31 11:58:01	1.191
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/11 10:31:35	1.192
@@ -205,67 +205,59 @@
 (defstruct (slime-output-stream
              (:include lisp::lisp-stream
                        (lisp::misc #'sos/misc)
-                       (lisp::out #'sos/out)
-                       (lisp::sout #'sos/sout))
+                       (lisp::out #'sos/write-char)
+                       (lisp::sout #'sos/write-string))
              (:conc-name sos.)
              (:print-function %print-slime-output-stream)
              (:constructor make-slime-output-stream (output-fn)))
   (output-fn nil :type function)
-  (buffer (make-string 8000) :type string)
+  (buffer (make-string 4000) :type string)
   (index 0 :type kernel:index)
-  (column 0 :type kernel:index)
-  (last-flush-time (get-internal-real-time) :type unsigned-byte))
+  (column 0 :type kernel:index))
 
 (defun %print-slime-output-stream (s stream d)
   (declare (ignore d))
   (print-unreadable-object (s stream :type t :identity t)))
 
-(defun sos/out (stream char)
-  (system:without-interrupts 
-    (let ((buffer (sos.buffer stream))
-          (index (sos.index stream)))
-      (setf (schar buffer index) char)
-      (setf (sos.index stream) (1+ index))
-      (incf (sos.column stream))
-      (when (char= #\newline char)
-        (setf (sos.column stream) 0)
-        (force-output stream))
-      (when (= index (1- (length buffer)))
-        (finish-output stream)))
-    char))
+(defun sos/write-char (stream char)
+  (let ((pending-output nil))
+    (system:without-interrupts 
+      (let ((buffer (sos.buffer stream))
+            (index (sos.index stream)))
+        (setf (schar buffer index) char)
+        (setf (sos.index stream) (1+ index))
+        (incf (sos.column stream))
+        (when (char= #\newline char)
+          (setf (sos.column stream) 0)
+          #+(or)(setq pending-output (sos/reset-buffer stream))
+          )
+        (when (= index (1- (length buffer)))
+          (setq pending-output (sos/reset-buffer stream)))))
+    (when pending-output
+      (funcall (sos.output-fn stream) pending-output)))
+  char)
+
+(defun sos/write-string (stream string start end)
+  (loop for i from start below end 
+        do (sos/write-char stream (aref string i))))
+
+(defun sos/flush (stream)
+  (let ((string (sos/reset-buffer stream)))
+    (when string
+      (funcall (sos.output-fn stream) string))
+    nil))
 
-(defun sos/sout (stream string start end)
+(defun sos/reset-buffer (stream)
   (system:without-interrupts 
-    (loop for i from start below end 
-          do (sos/out stream (aref string i)))))
+    (let ((end (sos.index stream)))
+      (unless (zerop end)
+        (prog1 (subseq (sos.buffer stream) 0 end)
+          (setf (sos.index stream) 0))))))
 
-(defun log-stream-op (stream operation)
-  stream operation
-  #+(or)
-  (progn 
-    (format sys:*tty* "~S @ ~D ~A~%" operation 
-            (sos.index stream)
-            (/ (- (get-internal-real-time) (sos.last-flush-time stream))
-             (coerce internal-time-units-per-second 'double-float)))
-    (finish-output sys:*tty*)))
-  
 (defun sos/misc (stream operation &optional arg1 arg2)
   (declare (ignore arg1 arg2))
   (case operation
-    (:finish-output
-     (log-stream-op stream operation)
-     (system:without-interrupts 
-       (let ((end (sos.index stream)))
-         (unless (zerop end)
-           (let ((s (subseq (sos.buffer stream) 0 end)))
-             (setf (sos.index stream) 0)
-             (funcall (sos.output-fn stream) s))
-           (setf (sos.last-flush-time stream) (get-internal-real-time)))))
-     nil)
-    (:force-output
-     (log-stream-op stream operation)
-     (sos/misc-force-output stream)
-     nil)
+    ((:force-output :finish-output) (sos/flush stream))
     (:charpos (sos.column stream))
     (:line-length 75)
     (:file-position nil)
@@ -274,19 +266,6 @@
     (:close nil)
     (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
 
-(defun sos/misc-force-output (stream)
-  (system:without-interrupts 
-    (unless (or (zerop (sos.index stream))
-                (loop with buffer = (sos.buffer stream)
-                      for i from 0 below (sos.index stream)
-                      always (char= (aref buffer i) #\newline)))
-      (let ((last (sos.last-flush-time stream))
-            (now (get-internal-real-time)))
-        (when (> (/ (- now last)
-                    (coerce internal-time-units-per-second 'double-float))
-                 0.1)
-          (finish-output stream))))))
-
 (defstruct (slime-input-stream
              (:include string-stream
                        (lisp::in #'sis/in)



From heller at common-lisp.net  Thu Sep 11 11:12:46 2008
From: heller at common-lisp.net (heller)
Date: Thu, 11 Sep 2008 07:12:46 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080911111246.89A1E47147@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv7537

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (fspec-definition-locations): add declare
ignores to prevent warnings

(emacs-inspect): remove first definition on function since it
was being overwritten by the next one. Wrap the method on t with
a excl:without-redefinition-warnings to prevent warning.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/11 10:31:35	1.1499
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/11 11:12:45	1.1500
@@ -1,3 +1,12 @@
+2008-09-11  Gary King <gwking at metabang.com>
+
+	* swank-allegro.lisp (fspec-definition-locations): add declare
+	ignores to prevent warnings
+
+	(emacs-inspect): remove first definition on function since it
+	was being overwritten by the next one. Wrap the method on t with
+	a excl:without-redefinition-warnings to prevent warning.
+
 2008-09-11  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-cmucl.lisp (slime-output-stream): Remove last-flush-time
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2008/08/11 07:40:23	1.110
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/11 11:12:46	1.111
@@ -402,12 +402,14 @@
    ((and (listp fspec)
          (eql (car fspec) :top-level-form))
     (destructuring-bind (top-level-form file &optional position) fspec 
+      (declare (ignore top-level-form))
       (list
        (list (list nil fspec)
              (make-location (list :buffer file)
                             (list :position position t))))))
    ((and (listp fspec) (eq (car fspec) :internal))
     (destructuring-bind (_internal next _n) fspec
+      (declare (ignore _internal _n))
       (fspec-definition-locations next)))
    (t
     (let ((defs (excl::find-source-file fspec)))
@@ -570,6 +572,9 @@
 
 ;;;; Inspecting
 
+#+no
+;; use the one below that calls allegro-inspect instead
+;;?? remove
 (defmethod emacs-inspect ((f function))
           (append
            (label-value-line "Name" (function-name f))
@@ -578,8 +583,9 @@
              (when doc
                `("Documentation:" (:newline) ,doc)))))
 
+(excl:without-redefinition-warnings
 (defmethod emacs-inspect ((o t))
-  (allegro-inspect o))
+  (allegro-inspect o)))
 
 (defmethod emacs-inspect ((o function))
   (allegro-inspect o))



From heller at common-lisp.net  Thu Sep 11 12:27:38 2008
From: heller at common-lisp.net (heller)
Date: Thu, 11 Sep 2008 08:27:38 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080911122738.01DB8751B7@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2784

Modified Files:
	swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (emacs-inspect): Actually remove the
unused method for functions.  Even the remaining one could be removed.

--- /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/11 11:12:46	1.111
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/11 12:27:38	1.112
@@ -572,17 +572,6 @@
 
 ;;;; Inspecting
 
-#+no
-;; use the one below that calls allegro-inspect instead
-;;?? remove
-(defmethod emacs-inspect ((f function))
-          (append
-           (label-value-line "Name" (function-name f))
-           `("Formals" ,(princ-to-string (arglist f)) (:newline))
-           (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
-             (when doc
-               `("Documentation:" (:newline) ,doc)))))
-
 (excl:without-redefinition-warnings
 (defmethod emacs-inspect ((o t))
   (allegro-inspect o)))



From heller at common-lisp.net  Thu Sep 11 12:32:01 2008
From: heller at common-lisp.net (heller)
Date: Thu, 11 Sep 2008 08:32:01 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080911123201.C353F751B7@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv3682

Modified Files:
	ChangeLog 
Log Message:
* doc/slime-refcard.tex: Fix typos.


--- /project/slime/cvsroot/slime/ChangeLog	2008/09/11 11:12:45	1.1500
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/11 12:32:01	1.1501
@@ -1,3 +1,7 @@
+2008-09-11  Helmut Eller  <heller at common-lisp.net>
+
+	* doc/slime-refcard.tex: Fix typos.
+
 2008-09-11  Gary King <gwking at metabang.com>
 
 	* swank-allegro.lisp (fspec-definition-locations): add declare



From heller at common-lisp.net  Thu Sep 11 12:32:02 2008
From: heller at common-lisp.net (heller)
Date: Thu, 11 Sep 2008 08:32:02 -0400 (EDT)
Subject: [slime-cvs] CVS slime/doc
Message-ID: <20080911123202.1AE627634B@common-lisp.net>

Update of /project/slime/cvsroot/slime/doc
In directory clnet:/tmp/cvs-serv3682/doc

Modified Files:
	slime-refcard.tex 
Log Message:
* doc/slime-refcard.tex: Fix typos.


--- /project/slime/cvsroot/slime/doc/slime-refcard.tex	2007/08/09 09:18:50	1.1
+++ /project/slime/cvsroot/slime/doc/slime-refcard.tex	2008/09/11 12:32:01	1.2
@@ -33,7 +33,7 @@
 \subgroup{Closure}
 
 \key{C-c C-q}{close parens at point}
-\key{C-]}{cl}{close all sexp}
+\key{C-]}{close all sexp}
 
 \subgroup{Indentation}
 
@@ -74,7 +74,7 @@
 \subgroup{Macro expansion commands}
 
 \key{C-c C-m or C-c RET}{macroexpand-1}
-\key{C-c C-m}{macroexpand-all}
+\key{C-c M-m}{macroexpand-all}
 \key{C-c C-t}{toggle tracing of the function at point}
 
 \subgroup{Disassembly}



From trittweiler at common-lisp.net  Fri Sep 12 12:27:47 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 12 Sep 2008 08:27:47 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080912122747.676385204E@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv21121

Modified Files:
	swank.lisp swank-scl.lisp swank-sbcl.lisp swank-openmcl.lisp 
	swank-lispworks.lisp swank-corman.lisp swank-cmucl.lisp 
	swank-clisp.lisp swank-backend.lisp swank-allegro.lisp 
	swank-abcl.lisp slime.el ChangeLog 
Log Message:

	New faces: `sldb-restartable-frame-line-face',
	           `sldb-non-restartable-frame-line-face'.

	The former is the face for frames that are surely restartable, the
	latter for frames that are surely not restartable. If
	restartability of a frame cannot be reliably determined, the face
	`sldb-frame-line-face' is used.

	At the moment, determination of frame restartability is supported
	by the SBCL backend only.

	* slime.el (sldb-frame.string): New.
	(sldb-frame.number): New.
	(sldb-frame.plist): New.
	(sldb-prune-initial-frames): Use them.
	(sldb-insert-frames): Ditto.
	(sldb-compute-frame-face): New.
	(sldb-insert-frame): Use `sldb-compute-frame-face' to insert
	frames with one of the faces described above.

	* swank.lisp (defslimefun backtrace): Changed return value; each
	frame is now accompanied with a PLIST which at the moment can
	contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
	is restartable, or not.

	* swank-backend.lisp (defstruct swank-frame): New structure.
	(compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
	(print-frame): Renamed to PRINT-SWANK-FRAME.

	* swank-sbcl.lisp, swank-cmucl.lisp, swank-lispworks.lisp,
	* swank-allegro.lisp, swank-scl.lisp, swank-openmcl.lisp,
	* swank-abcl.lisp, swank-clisp.lisp: Adapted to swank-backend changes.


--- /project/slime/cvsroot/slime/swank.lisp	2008/09/10 23:10:45	1.585
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/12 12:27:37	1.586
@@ -2245,19 +2245,26 @@
    (list :debug-activate (current-thread-id) *sldb-level* t)))
 
 (defslimefun backtrace (start end)
-  "Return a list ((I FRAME) ...) of frames from START to END.
-I is an integer describing and FRAME a string."
-  (loop for frame in (compute-backtrace start end)
-        for i from start collect 
-        (list i 
-              (call/truncated-output-to-string 
-               100
-               (lambda (stream)
-                 (handler-case
-                     (with-bindings *backtrace-printer-bindings*
-                       (print-frame frame stream))
-                   (t ()
-                     (format stream "[error printing frame]"))))))))
+  "Return a list ((I FRAME PLIST) ...) of frames from START to END.
+
+I is an integer, and can be used to reference the corresponding frame
+from Emacs; FRAME is a string representation of an implementation's
+frame."
+  (flet ((print-swank-frame-to-string (frame)
+           (call/truncated-output-to-string 
+            100
+            (lambda (stream)
+              (handler-case
+                  (with-bindings *backtrace-printer-bindings*
+                    (print-swank-frame frame stream))
+                (t ()
+                  (format stream "[error printing frame]")))))))
+    (loop for frame in (compute-backtrace start end)
+          for i from start collect 
+          (list i (print-swank-frame-to-string frame)
+                (list :restartable (let ((r (swank-frame.restartable frame)))
+                                     (check-type r (member nil t :unknown))
+                                     r))))))
 
 (defslimefun debugger-info-for-emacs (start end)
   "Return debugger state, with stack frames from START to END.
@@ -2266,9 +2273,11 @@
 where
   condition   ::= (description type [extra])
   restart     ::= (name description)
-  stack-frame ::= (number description)
+  stack-frame ::= (number description [plist])
   extra       ::= (:references and other random things)
   cont        ::= continutation
+  plist       ::= (:restartable {nil | t | :unknown})
+
 condition---a pair of strings: message, and type.  If show-source is
 not nil it is a frame number for which the source should be displayed.
 
@@ -2288,7 +2297,7 @@
    \"[Condition of type DIVISION-BY-ZERO]\")
   ((\"ABORT\" \"Return to Slime toplevel.\")
    (\"ABORT\" \"Return to Top-Level.\"))
-  ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
+  ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil)))
   (4))"
   (list (debugger-condition-for-emacs)
         (format-restarts-for-emacs)
--- /project/slime/cvsroot/slime/swank-scl.lisp	2008/08/31 11:58:01	1.23
+++ /project/slime/cvsroot/slime/swank-scl.lisp	2008/09/12 12:27:38	1.24
@@ -1372,11 +1372,11 @@
   (let ((end (or end most-positive-fixnum)))
     (loop for f = (nth-frame start) then (frame-down f)
 	  for i from start below end
-	  while f
-	  collect f)))
+	  while f collect (make-swank-frame :%frame f :restartable :unknown))))
 
-(defimplementation print-frame (frame stream)
-  (let ((*standard-output* stream))
+(defimplementation print-swank-frame (swank-frame stream)
+  (let ((frame (swank-frame.%frame swank-frame))
+        (*standard-output* stream))
     (handler-case 
         (debug::print-frame-call frame :verbosity 1 :number nil)
       (error (e)
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/08/30 15:33:56	1.217
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/09/12 12:27:38	1.218
@@ -262,7 +262,7 @@
 
 (defun sbcl-source-file-p (filename)
   (when filename
-    (loop for (_ pattern) in (logical-pathname-translations "SYS")
+    (loop for (nil pattern) in (logical-pathname-translations "SYS")
           thereis (pathname-match-p filename pattern))))
 
 (defun guess-readtable-for-filename (filename)
@@ -849,11 +849,16 @@
   (let ((end (or end most-positive-fixnum)))
     (loop for f = (nth-frame start) then (sb-di:frame-down f)
 	  for i from start below end
-	  while f
-	  collect f)))
-
-(defimplementation print-frame (frame stream)
-  (sb-debug::print-frame-call frame stream))
+	  while f collect (make-swank-frame
+                           :%frame f
+                           :restartable (frame-restartable-p f)))))
+
+(defimplementation print-swank-frame (swank-frame stream)
+  (sb-debug::print-frame-call (swank-frame.%frame swank-frame) stream))
+
+(defun frame-restartable-p (frame)
+  #+#.(swank-backend::sbcl-with-restart-frame)
+  (sb-debug:frame-has-debug-tag-p frame))
 
 ;;;; Code-location -> source-location translation
 
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/08/11 07:40:23	1.132
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/12 12:27:38	1.133
@@ -538,25 +538,25 @@
       (format nil "~{ ~A~}" (nreverse result)))))
 
 
-;; XXX should return something less stringy
-;; alanr May 13, 2004: put #<> around anonymous functions in the backtrace.
-
 (defimplementation compute-backtrace (start-frame-number end-frame-number)
   (let (result)
-    (map-backtrace (lambda (frame-number p  context lfun pc)
-		     (declare (ignore  frame-number))
-                     (push (with-output-to-string (s)
-                             (format s "(~A~A)"
-                                     (if (ccl::function-name lfun)
-					 (ccl::%lfun-name-string lfun)
-					 lfun)
-                                     (frame-arguments p context lfun pc)))
+    (map-backtrace (lambda (frame-number p context lfun pc)
+                     (declare (ignore frame-number))
+                     (push (make-swank-frame :%frame (list :openmcl-frame p context lfun pc)
+                                             :restartable :unknown)
                            result))
                    start-frame-number end-frame-number)
     (nreverse result)))
 
-(defimplementation print-frame (frame stream)
-  (princ frame stream))
+(defimplementation print-swank-frame (swank-frame stream)
+  (let ((frame (swank-frame.%frame swank-frame)))
+    (assert (eq (first frame) :openmcl-frame))
+    (destructuring-bind (p context lfun pc) (rest frame)
+      (format stream "(~A~A)"
+              (if (ccl::function-name lfun)
+                  (ccl::%lfun-name-string lfun)
+                  lfun)
+              (frame-arguments p context lfun pc)))))
 
 (defimplementation frame-locals (index)
   (block frame-locals
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/08/11 07:39:15	1.113
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/12 12:27:38	1.114
@@ -291,7 +291,8 @@
 	((or (not frame) (= i end)) (nreverse backtrace))
       (when (interesting-frame-p frame)
 	(incf i)
-	(push frame backtrace)))))
+	(push (make-swank-frame :%frame frame :restartable :unknown)
+              backtrace)))))
 
 (defun frame-actual-args (frame)
   (let ((*break-on-signals* nil))
@@ -303,12 +304,13 @@
                    (error (e) (format nil "<~A>" arg))))))
             (dbg::call-frame-arglist frame))))
 
-(defimplementation print-frame (frame stream)
-  (cond ((dbg::call-frame-p frame)
-         (format stream "~S ~S"
-                 (dbg::call-frame-function-name frame)
-                 (frame-actual-args frame)))
-        (t (princ frame stream))))
+(defimplementation print-swank-frame (swank-frame stream)
+  (let ((frame (swank-frame.%frame swank-frame)))
+    (cond ((dbg::call-frame-p frame)
+           (format stream "~S ~S"
+                   (dbg::call-frame-function-name frame)
+                   (frame-actual-args frame)))
+          (t (princ frame stream)))))
 
 (defun frame-vars (frame)
   (first (dbg::frame-locals-format-list frame #'list 75 0)))
--- /project/slime/cvsroot/slime/swank-corman.lisp	2008/04/17 14:56:43	1.16
+++ /project/slime/cvsroot/slime/swank-corman.lisp	2008/09/12 12:27:38	1.17
@@ -176,10 +176,11 @@
     (funcall fn)))
 
 (defimplementation compute-backtrace (start end)
-  (subseq *stack-trace* start (min end (length *stack-trace*))))
+  (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
+	collect (make-swank-frame :%frame f :restartable :unknown)))
 
-(defimplementation print-frame (frame stream)
-  (format stream "~S" frame))
+(defimplementation print-swank-frame (frame stream)
+  (format stream "~S" (swank-frame.%frame frame)))
 
 (defun get-frame-debug-info (frame)
   (or (frame-debug-info frame)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/11 10:31:35	1.192
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/12 12:27:38	1.193
@@ -1503,11 +1503,11 @@
   (let ((end (or end most-positive-fixnum)))
     (loop for f = (nth-frame start) then (frame-down f)
 	  for i from start below end
-	  while f
-	  collect f)))
+	  while f collect (make-swank-frame :%frame f :restartable :unknown))))
 
-(defimplementation print-frame (frame stream)
-  (let ((*standard-output* stream))
+(defimplementation print-swank-frame (swank-frame stream)
+  (let ((frame (swank-frame.%frame swank-frame))
+        (*standard-output* stream))
     (handler-case 
         (debug::print-frame-call frame :verbosity 1 :number nil)
       (error (e)
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2008/08/12 17:54:43	1.74
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2008/09/12 12:27:38	1.75
@@ -330,7 +330,8 @@
 (defimplementation compute-backtrace (start end)
   (let* ((bt *sldb-backtrace*)
          (len (length bt)))
-    (subseq bt start (min (or end len) len))))
+    (loop for f in (subseq bt start (min (or end len) len))
+          collect (make-swank-frame :%frame f :restartable :unknown))))
 
 ;;; CLISP's REPL sets up an ABORT restart that kills SWANK.  Here we
 ;;; can omit that restart so that users don't select it by mistake.
@@ -339,9 +340,9 @@
   ;; list, hopefully that's our unwanted ABORT restart.
   (butlast (compute-restarts condition)))
 
-(defimplementation print-frame (frame stream)
-  (let ((str (frame-to-string frame)))
-    ;; (format stream "~A " (frame-string-type str))
+(defimplementation print-swank-frame (swank-frame stream)
+  (let* ((frame (swank-frame.%frame swank-frame))
+         (str (frame-to-string frame)))
     (write-string (extract-frame-line str)
                   stream)))
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/09 23:29:44	1.150
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/12 12:27:38	1.151
@@ -20,6 +20,9 @@
            #:condition
            #:severity
            #:with-compilation-hooks
+           #:swank-frame
+           #:swank-frame-p
+           #:swank-frame.restartable
            #:location
            #:location-p
            #:location-buffer
@@ -641,21 +644,22 @@
 ;;; The following functions in this section are supposed to be called
 ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
 
+(defstruct (swank-frame (:conc-name swank-frame.))
+  %frame
+  restartable)
+
 (definterface compute-backtrace (start end)
    "Returns a backtrace of the condition currently being debugged,
-that is an ordered list consisting of frames. (What constitutes a
-frame is implementation dependent, but PRINT-FRAME must be defined on
-it.)
-
-``Ordered list'' means that the i-th. frame is associated to the
-frame-number i.
+that is an ordered list consisting of swank-frames. ``Ordered list''
+means that an integer I can be mapped back to the i-th frame of this
+backtrace.
 
 START and END are zero-based indices constraining the number of frames
-returned.  Frame zero is defined as the frame which invoked the
-debugger.  If END is nil, return the frames from START to the end of
+returned. Frame zero is defined as the frame which invoked the
+debugger. If END is nil, return the frames from START to the end of
 the stack.")
 
-(definterface print-frame (frame stream)
+(definterface print-swank-frame (frame stream)
   "Print frame to stream.")
 
 (definterface frame-source-location-for-emacs (frame-number)
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/11 12:27:38	1.112
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/12 12:27:38	1.113
@@ -163,11 +163,10 @@
   (let ((end (or end most-positive-fixnum)))
     (loop for f = (nth-frame start) then (next-frame f)
 	  for i from start below end
-	  while f
-	  collect f)))
+	  while f collect (make-swank-frame :%frame f :restartable :unknown))))
 
-(defimplementation print-frame (frame stream)
-  (debugger:output-frame stream frame :moderate))
+(defimplementation print-swank-frame (frame stream)
+  (debugger:output-frame stream (swank-frame.%frame frame) :moderate))
 
 (defimplementation frame-locals (index)
   (let ((frame (nth-frame index)))
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2008/08/31 11:58:01	1.53
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2008/09/12 12:27:38	1.54
@@ -252,11 +252,12 @@
 
 (defimplementation compute-backtrace (start end)
   (let ((end (or end most-positive-fixnum)))
-    (subseq (backtrace-as-list-ignoring-swank-calls) start end)))
+    (loop for f in (subseq (backtrace-as-list-ignoring-swank-calls) start end)
+          collect (make-swank-frame :%frame f :restartable :unknown))))
 
-(defimplementation print-frame (frame stream)
+(defimplementation print-swank-frame (frame stream)
   (write-string (string-trim '(#\space #\newline)
-                             (prin1-to-string frame))
+                             (prin1-to-string (swank-frame.%frame frame)))
                 stream))
 
 (defimplementation frame-locals (index)
--- /project/slime/cvsroot/slime/slime.el	2008/09/10 23:18:35	1.1011
+++ /project/slime/cvsroot/slime/slime.el	2008/09/12 12:27:38	1.1012
@@ -323,6 +323,10 @@
   (restart-number "restart numbers (correspond to keystrokes to invoke)"
                   '(:bold t))
   (frame-line     "function names and arguments in the backtrace")
+  (restartable-frame-line
+   "frames which are surely restartable")
+  (non-restartable-frame-line
+   "frames which are surely not restartable")
   (detailed-frame-line
    "function names and arguments in a detailed (expanded) frame")
   (local-name     "local variable names")
@@ -6750,7 +6754,7 @@
   "Setup a new SLDB buffer.
 CONDITION is a string describing the condition to debug.
 RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart.
-FRAMES is a list (NUMBER DESCRIPTION) describing the initial
+FRAMES is a list (NUMBER DESCRIPTION &optional PLIST) describing the initial
 portion of the backtrace. Frames are numbered from 0.
 CONTS is a list of pending Emacs continuations."
   (with-current-buffer (sldb-get-buffer thread)
@@ -6856,14 +6860,22 @@
          (in-sldb-face restart string))
         (insert "\n")))
 
+(defun sldb-frame.string (frame)
+  (destructuring-bind (_ str &optional _) frame str))
+
+(defun sldb-frame.number (frame)
+  (destructuring-bind (n _ &optional _) frame n))
+
+(defun sldb-frame.plist (frame)
+  (destructuring-bind (_ _ &optional plist) frame plist))
+
 (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."
   (let* ((case-fold-search t)
          (rx "^\\([() ]\\|lambda\\)*swank\\>"))
     (or (loop for frame in frames
-              for (_ string) = frame
-              until (string-match rx string)
+              until (string-match rx (sldb-frame.string frame))
               collect frame)
         frames)))
 
@@ -6872,29 +6884,39 @@
 If MORE is non-nil, more frames are on the Lisp stack."
   (mapc #'sldb-insert-frame frames)
   (when more
-    (destructuring-bind ((num _)) (last frames)
-      (slime-insert-propertized
-       `(, at nil sldb-default-action sldb-fetch-more-frames
-               sldb-previous-frame-number ,num
-               point-entered sldb-fetch-more-frames
-               start-open t
-               face sldb-section-face
-               mouse-face highlight)
-       " --more--")
-      (insert "\n"))))
+    (slime-insert-propertized
+     `(, at nil sldb-default-action sldb-fetch-more-frames
+             sldb-previous-frame-number ,(sldb-frame.number (first (last frames)))
+             point-entered sldb-fetch-more-frames
+             start-open t
+             face sldb-section-face
+             mouse-face highlight)
+     " --more--")
+    (insert "\n")))
+
+(defun sldb-compute-frame-face (frame)
+  (let ((restartable (getf (sldb-frame.plist frame) :restartable)))
+    (cond ((eq restartable 't)
+           'sldb-restartable-frame-line-face)
+          ((eq restartable :unknown)
+           'sldb-frame-line-face)
+          ((eq restartable 'nil)
+           'sldb-non-restartable-frame-line-face)
+          (t (error "fall through")))))
 
 (defun sldb-insert-frame (frame &optional face)
   "Insert FRAME with FACE at point.
-If FACE is nil use `sldb-frame-line-face'."
-  (destructuring-bind (number string) frame
-    (let ((props `(frame ,frame sldb-default-action sldb-toggle-details)))
-      (slime-propertize-region props
-        (slime-propertize-region '(mouse-face highlight)
-          (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ")
-          (slime-insert-indented
-           (slime-add-face (or face 'sldb-frame-line-face)
-                           string)))
-        (insert "\n")))))
+If FACE is nil, `sldb-compute-frame-face' is used to determine the face."
+  (setq face (or face (sldb-compute-frame-face frame)))
+  (let ((number (sldb-frame.number frame))
+        (string (sldb-frame.string frame))
+        (props `(frame ,frame sldb-default-action sldb-toggle-details)))
+    (slime-propertize-region props
+      (slime-propertize-region '(mouse-face highlight)
+        (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ")
+        (slime-insert-indented
+         (slime-add-face face string)))
+      (insert "\n"))))
 
 (defun sldb-fetch-more-frames (&rest ignore)
   "Fetch more backtrace frames.
@@ -7174,9 +7196,9 @@
   (let* ((frame (get-text-property (point) 'frame))
          (num (car frame))
          (catches (sldb-catch-tags num))
-         (locals (sldb-frame-locals num)))
+         (locals  (sldb-frame-locals num))
     (destructuring-bind (start end) (sldb-frame-region)
-      (list start end frame locals catches))))
+      (list start end frame locals catches)))))
 
 (defvar sldb-insert-frame-variable-value-function 'sldb-insert-frame-variable-value)
 
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/11 12:32:01	1.1501
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/12 12:27:38	1.1502
@@ -1,3 +1,38 @@
+2008-09-12  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	New faces: `sldb-restartable-frame-line-face',
+	           `sldb-non-restartable-frame-line-face'.
+
+	The former is the face for frames that are surely restartable, the
+	latter for frames that are surely not restartable. If
+	restartability of a frame cannot be reliably determined, the face
+	`sldb-frame-line-face' is used.
+
+	At the moment, determination of frame restartability is supported
+	by the SBCL backend only.
+
+	* slime.el (sldb-frame.string): New.
+	(sldb-frame.number): New.
+	(sldb-frame.plist): New.
+	(sldb-prune-initial-frames): Use them.
+	(sldb-insert-frames): Ditto.
+	(sldb-compute-frame-face): New.
+	(sldb-insert-frame): Use `sldb-compute-frame-face' to insert
+	frames with one of the faces described above.
+
+	* swank.lisp (defslimefun backtrace): Changed return value; each
+	frame is now accompanied with a PLIST which at the moment can
+	contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
+	is restartable, or not.
+
+	* swank-backend.lisp (defstruct swank-frame): New structure.
+	(compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
+	(print-frame): Renamed to PRINT-SWANK-FRAME.
+
+	* swank-sbcl.lisp, swank-cmucl.lisp, swank-lispworks.lisp,
+	* swank-allegro.lisp, swank-scl.lisp, swank-openmcl.lisp,
+	* swank-abcl.lisp, swank-clisp.lisp: Adapted to swank-backend changes.
+
 2008-09-11  Helmut Eller  <heller at common-lisp.net>
 
 	* doc/slime-refcard.tex: Fix typos.



From trittweiler at common-lisp.net  Fri Sep 12 15:51:06 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 12 Sep 2008 11:51:06 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080912155106.2DB957A095@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv24829

Modified Files:
	slime.el ChangeLog 
Log Message:

	In an SLDB buffer, `C-c C-c' will now recompile the source behind
	a frame. In particular, `C-u C-c C-c' will recompile the frame
	with high debug settings.

	* slime.el (sldb-recompile-frame-source): New function.
	(sldb-mode-map): Bind `C-c C-c' to it.

	* slime.el (sldb-overlays, sldb-delete-overlays, slime-xref-cleanup):
	Removed. Sldb-overlays weren't created anymore since 2008-08-17.


--- /project/slime/cvsroot/slime/slime.el	2008/09/12 12:27:38	1.1012
+++ /project/slime/cvsroot/slime/slime.el	2008/09/12 15:51:02	1.1013
@@ -6109,7 +6109,6 @@
   "Kill the current xref buffer, restore the window configuration
 if appropriate."
   (interactive)
-  (slime-xref-cleanup)
   ;; We can't simply use `slime-popup-buffer-quit' because we also
   ;; want the Xref window be deleted.
   (if (slime-popup-buffer-snapshot-unchanged-p)
@@ -6124,17 +6123,10 @@
 (defun slime-xref-retract ()
   "Leave the Xref buffer, and make everything as of before."
   (interactive)
-  (slime-xref-cleanup)
   (let ((buffer (current-buffer)))
     (slime-popup-buffer-restore-snapshot)
     (kill-buffer buffer)))
 
-(defun slime-xref-cleanup ()
-  "Delete overlays created by xref mode and kill the xref buffer."
-  (sldb-delete-overlays))
-
-
-
 (defun slime-insert-xrefs (xref-alist)
   "Insert XREF-ALIST in the current-buffer.
 XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...).
@@ -6656,8 +6648,7 @@
   (set-syntax-table sldb-mode-syntax-table)
   (slime-set-truncate-lines)
   ;; Make original slime-connection "sticky" for SLDB commands in this buffer
-  (setq slime-buffer-connection (slime-connection))
-  (slime-add-local-hook 'kill-buffer-hook 'sldb-delete-overlays))
+  (setq slime-buffer-connection (slime-connection)))
 
 (slime-define-keys sldb-mode-map
   ("h"    'describe-mode)
@@ -6692,6 +6683,7 @@
   ("P"    'sldb-print-condition)
   ("C"    'sldb-inspect-condition)
   (":"    'slime-interactive-eval)
+  ("\C-c\C-c" 'sldb-recompile-frame-source)
   ("\C-c\C-d" slime-doc-map))
 
 ;; Inherit bindings from slime-mode
@@ -6817,6 +6809,8 @@
       (setq sldb-level nil))
     (when (and (= level 1) (not stepping))
       (kill-buffer sldb))))
+
+;;;;;; SLDB buffer insertion
 
 (defun sldb-insert-condition (condition)
   "Insert the text for CONDITION.
@@ -7119,16 +7113,12 @@
 
 ;;;;;; SLDB show source
 
-(defvar sldb-overlays '()
-  "List of overlays created in source code buffers to highlight expressions.")
-
 (defun sldb-show-source ()
   "Highlight the frame at point's expression in a source code buffer."
   (interactive)
   (sldb-show-frame-source (sldb-frame-number-at-point)))
 
 (defun sldb-show-frame-source (frame-number)
-  (sldb-delete-overlays)
   (slime-eval-async
    `(swank:frame-source-location-for-emacs ,frame-number)
    (lambda (source-location)
@@ -7147,14 +7137,10 @@
 
 (defun sldb-highlight-sexp (&optional start end)
   "Highlight the first sexp after point."
-  (sldb-delete-overlays)
   (let ((start (or start (point)))
 	(end (or end (save-excursion (ignore-errors (forward-sexp)) (point)))))
     (slime-flash-region start end)))
 
-(defun sldb-delete-overlays ()
-  (mapc #'delete-overlay sldb-overlays)
-  (setq sldb-overlays '()))
 
 
 ;;;;;; SLDB toggle details
@@ -7196,9 +7182,9 @@
   (let* ((frame (get-text-property (point) 'frame))
          (num (car frame))
          (catches (sldb-catch-tags num))
-         (locals  (sldb-frame-locals num))
+         (locals  (sldb-frame-locals num)))
     (destructuring-bind (start end) (sldb-frame-region)
-      (list start end frame locals catches)))))
+      (list start end frame locals catches))))
 
 (defvar sldb-insert-frame-variable-value-function 'sldb-insert-frame-variable-value)
 
@@ -7433,6 +7419,28 @@
       ((:abort)))))
 
 
+;;;;;; SLDB recompilation commands
+
+(defun sldb-recompile-frame-source (&optional raw-prefix-arg)
+  (interactive "P")
+  (slime-eval-async
+   `(swank:frame-source-location-for-emacs ,(sldb-frame-number-at-point))
+   (lexical-let ((debug-level (slime-normalize-optimization-level
+                               (and raw-prefix-arg 
+                                    (prefix-numeric-value raw-prefix-arg)))))
+     (lambda (source-location)
+       (destructure-case source-location
+         ((:error message)
+          (message "%s" message)
+          (ding))
+         (t
+          (slime-recompile-location source-location debug-level)))))))
+
+
+
+
+
+
 ;;;; Thread control panel
 
 (defvar slime-threads-buffer-name "*SLIME Threads*")
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/12 12:27:38	1.1502
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/12 15:51:02	1.1503
@@ -1,5 +1,17 @@
 2008-09-12  Tobias C. Rittweiler  <tcr at freebits.de>
 
+	In an SLDB buffer, `C-c C-c' will now recompile the source behind
+	a frame. In particular, `C-u C-c C-c' will recompile the frame
+	with high debug settings.
+
+	* slime.el (sldb-recompile-frame-source): New function.
+	(sldb-mode-map): Bind `C-c C-c' to it.
+
+	* slime.el (sldb-overlays, sldb-delete-overlays, slime-xref-cleanup):
+	Removed. Sldb-overlays weren't created anymore since 2008-08-17.
+
+2008-09-12  Tobias C. Rittweiler  <tcr at freebits.de>
+
 	New faces: `sldb-restartable-frame-line-face',
 	           `sldb-non-restartable-frame-line-face'.
 



From heller at common-lisp.net  Fri Sep 12 18:55:43 2008
From: heller at common-lisp.net (heller)
Date: Fri, 12 Sep 2008 14:55:43 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080912185543.186EC5C189@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17292

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
For Lispworks, parse the $LWHOME/lwdoc file.

* swank-lispworks.lisp (lwdoc, lookup-lwdoc, parse-lwdoc-record):
New functions.
(describe-symbol-for-emacs): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/12 15:51:02	1.1503
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/12 18:55:42	1.1504
@@ -1,3 +1,11 @@
+2008-09-12  Helmut Eller  <heller at common-lisp.net>
+
+	For Lispworks, parse the $LWHOME/lwdoc file.
+
+	* swank-lispworks.lisp (lwdoc, lookup-lwdoc, parse-lwdoc-record):
+	New functions.
+	(describe-symbol-for-emacs): Use it.
+
 2008-09-12  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	In an SLDB buffer, `C-c C-c' will now recompile the source behind
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/12 12:27:38	1.114
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/12 18:55:42	1.115
@@ -154,7 +154,12 @@
                (let ((pos (position #\newline string)))
                  (if (null pos) string (subseq string 0 pos))))
              (doc (kind &optional (sym symbol))
-               (let ((string (documentation sym kind)))
+               (let ((string (or
+                              (documentation sym kind)
+                              (lwdoc (symbol-name sym)
+                                     (package-name (symbol-package sym))
+                                     kind))))
+                     
                  (if string 
                      (first-line string)
                      :not-documented)))
@@ -208,6 +213,66 @@
   (when (fboundp sym)
     (describe-function sym)))
 
+(defvar *lwdoc-types*
+  '(("%FUN-DOCUMENTATION" . function)
+    ("%VAR-DOCUMENTATION" . variable)
+    ("%SETF-DOCUMENTATION" . setf)
+    ("%STRUCT-DOCUMENTATION" . structure)))
+
+;; (lwdoc 'cons 'common-lisp 't)
+(defun lwdoc (name package type)
+  "Search in $LWHOME/lwdoc for entries matching NAME and PACKAGE."
+  (lw:when-let (doc (lookup-lwdoc name package))
+    (destructuring-bind (kind description) doc
+      (when (or (eq type t)
+                (eq (cdr (assoc kind *lwdoc-types* :test #'string-equal))
+                    type))
+        description))))
+
+(defun lookup-lwdoc (name package)
+  (when (probe-file (sys:lispworks-file "lwdoc"))
+    (with-open-file (file (sys:lispworks-file "lwdoc"))
+      (lwdoc-search file 0 (file-length file) package name))))
+
+;; Use binary search, assuming that the entries are ordered alphabetically
+(defun lwdoc-search (file min max package name)
+  (declare (optimize (sys:interruptable 3)))
+  (let ((pos (+ min (floor (- max min) 2))))
+    (and (< min (1- max))
+         (let ((record (parse-lwdoc-record file pos)))
+           (and record
+                (destructuring-bind (rpackage rname kind doc) record
+                  ;;(format t "~d ~d ~a ~a~%" min max rpackage rname)
+                  (ecase (cond ((string-equal package rpackage)
+                                (cond ((string-equal name rname) '=)
+                                      ((string-lessp name rname) '<)
+                                      (t '>)))
+                               ((string-lessp package rpackage) '<)
+                               (t '>))
+                    (= (list kind doc))
+                    (< (lwdoc-search file min pos package name))
+                    (> (lwdoc-search file pos max package name)))))))))
+
+(defun parse-lwdoc-record (file position)
+  (declare (optimize (sys:interruptable 3)))
+  (file-position file position)
+  (when (peek-char #\null file nil nil)
+    ;; Search previous #\null or beginning of file
+    (do* ((end (file-position file))
+          (start end (max (- start 10) 0)))
+         (nil)
+      (file-position file start)
+      (when (= start 0) (return))
+      (peek-char #\null file)
+      (when (< (file-position file) end) (return)))
+    (peek-char #\" file)
+    (let ((key (read file)) 
+          (doc (read file)))
+      (peek-char #\null file)
+      (read-char file)
+      (append (lw:split-sequence ":" key :coalesce-separators t)
+              (list doc)))))
+
 ;;; Debugging
 
 (defclass slime-env (env:environment) 



From trittweiler at common-lisp.net  Sat Sep 13 10:39:03 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sat, 13 Sep 2008 06:39:03 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080913103903.F1F2721069@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv22359/contrib

Modified Files:
	slime-parse.el slime-enclosing-context.el ChangeLog 
Log Message:

	* slime-parse.el (slime-has-symbol-syntax-p): New.
	(slime-parse-symbol-name-at-point): New; works on top of
	`slime-parse-sexp-at-point'.
	(slime-enclosing-form-specs): Use it.

	* slime-enclosing-context.el (slime-find-bound-names): Use
	`slime-parse-symbol-name-at-point'.
	(slime-find-bound-functions): Ditto.
	(def-slime-test enclosing-context.1): New test case. Thanks to
	John Pallister for reporting this bug.


--- /project/slime/cvsroot/slime/contrib/slime-parse.el	2008/06/07 11:46:06	1.11
+++ /project/slime/cvsroot/slime/contrib/slime-parse.el	2008/09/13 10:39:02	1.12
@@ -63,6 +63,17 @@
               (first result)
               (nreverse result)))))))
 
+(defun slime-has-symbol-syntax-p (string)
+  (if (and string (not (zerop (length string))))
+      (member (char-syntax (aref string 0)) 
+	      '(?w ?_ ?\' ?\\))))
+
+(defun slime-parse-symbol-name-at-point (&optional n skip-blanks-p)
+  (let ((symbols (slime-parse-sexp-at-point n skip-blanks-p)))
+    (if (every #'slime-has-symbol-syntax-p (slime-ensure-list symbols))
+	symbols
+	nil)))
+
 (defun slime-incomplete-sexp-at-point (&optional n)
   (interactive "p") (or n (setq n 1))
   (buffer-substring-no-properties (save-excursion (backward-up-list n) (point))
@@ -291,16 +302,17 @@
               (when (member (char-syntax (char-after)) '(?\( ?')) 
                 (incf level)
                 (forward-char 1)
-                (let ((name (slime-symbol-name-at-point)))
+                (let ((name (slime-parse-symbol-name-at-point 1 nil)))
                   (cond
                     (name
                      (save-restriction
                        (widen) ; to allow looking-ahead/back in extended parsing.
                        (multiple-value-bind (new-result new-indices new-points)
-                           (slime-parse-extended-operator-name initial-point
-                                                               (cons `(,name) result) ; minimal form spec
-                                                               (cons arg-index arg-indices)
-                                                               (cons (point) points))
+                           (slime-parse-extended-operator-name 
+			    initial-point
+			    (cons `(,name) result) ; minimal form spec
+			    (cons arg-index arg-indices)
+			    (cons (point) points))
                          (setq result new-result)
                          (setq arg-indices new-indices)
                          (setq points new-points))))
--- /project/slime/cvsroot/slime/contrib/slime-enclosing-context.el	2008/09/07 12:24:37	1.1
+++ /project/slime/cvsroot/slime/contrib/slime-enclosing-context.el	2008/09/13 10:39:02	1.2
@@ -54,7 +54,7 @@
 		 (ignore-errors
 		   (loop 
 		    (down-list) 
-		    (push (slime-symbol-name-at-point) binding-names)
+		    (push (slime-parse-symbol-name-at-point 1) binding-names)
 		    (push (save-excursion (backward-up-list) (point)) 
 			  binding-start-points)
 		    (up-list)))))
@@ -79,14 +79,47 @@
 		 (ignore-errors
 		   (loop 
 		    (down-list) 
-		    (push (slime-symbol-name-at-point) names)
-		    (slime-end-of-symbol) 
-		    (push (slime-parse-sexp-at-point 1 t) arglists)
-		    (push (save-excursion (backward-up-list) (point)) 
-			  start-points)
+		    (destructuring-bind (name arglist)
+			(slime-ensure-list (slime-parse-sexp-at-point 2))
+		      (assert (slime-has-symbol-syntax-p name)) (assert arglist)
+		      (push name names)
+		      (push arglist arglists)
+		      (push (save-excursion (backward-up-list) (point)) 
+			    start-points))
 		    (up-list)))))
       (values (nreverse names)
 	      (nreverse arglists) 
 	      (nreverse start-points)))))
 
+
+(def-slime-test enclosing-context.1
+    (buffer-sexpr wished-bound-names wished-bound-functions)
+    "Check that finding local definitions work."
+    '(("(flet ((,nil ()))
+	 (let ((bar 13)
+	       (,foo 42))
+	   *HERE*))" 
+       (",nil" "bar" ",foo")
+       ((",nil" "()"))))
+  (slime-check-top-level)
+  (with-temp-buffer
+    (let ((tmpbuf (current-buffer)))
+      (lisp-mode)
+      (insert buffer-sexpr)
+      (search-backward "*HERE*")
+      (multiple-value-bind (bound-names points) 
+	  (slime-enclosing-bound-names)
+	(slime-check "Check enclosing bound names"
+	  (loop for name in wished-bound-names
+		always (member name bound-names))))
+      (multiple-value-bind (fn-names fn-arglists points) 
+	  (slime-enclosing-bound-functions)
+	(slime-check "Check enclosing bound functions"
+	  (loop for (name arglist) in wished-bound-functions
+		always (and (member name fn-names)
+			    (member arglist fn-arglists)))))
+      )))
+
+
+
 (provide 'slime-enclosing-context)
\ No newline at end of file
--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/10 23:51:17	1.129
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/09/13 10:39:02	1.130
@@ -1,3 +1,16 @@
+2008-09-13  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-parse.el (slime-has-symbol-syntax-p): New.
+	(slime-parse-symbol-name-at-point): New; works on top of
+	`slime-parse-sexp-at-point'.
+	(slime-enclosing-form-specs): Use it.
+
+	* slime-enclosing-context.el (slime-find-bound-names): Use
+	`slime-parse-symbol-name-at-point'.
+	(slime-find-bound-functions): Ditto.
+	(def-slime-test enclosing-context.1): New test case. Thanks to
+	John Pallister for reporting this bug.
+
 2008-09-11  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-asdf.lisp (operate-on-system-for-emacs): Adapted to recent



From heller at common-lisp.net  Sun Sep 14 17:10:35 2008
From: heller at common-lisp.net (heller)
Date: Sun, 14 Sep 2008 13:10:35 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080914171035.79FDC6D07A@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30540

Modified Files:
	ChangeLog slime.el swank-backend.lisp swank-clisp.lisp 
	swank-cmucl.lisp swank.lisp 
Log Message:
Introduce a WAIT-FOR-INPUT backend function.
CMUCL's blocking input functions READ-CHAR etc.
are hard to use with interrupts.  In the backend
we have a more realistic chance to get interrupts working.

* swank-backend.lisp (wait-for-input): New function.

* swank-cmucl.lisp, swank-clisp.lisp (wait-for-input): Implement
it.

* swank.lisp (wait-for-event/event-loop): Use WAIT-FOR-INPUT and
rescan the event-queue if WAIT-FOR-INPUT was interrupted.
(reader-event): Deleted. Merged into wait-for-event/event-loop
resp.  dispatch-loop.
(decode-message): Drop the timeout argument.
(*events-enqueued*): A counter to quickly detect new events after
a wait.
(call-with-connection): If the argument is already the current
connection, don't rebind anything.
(without-slime-interrupts, with-slime-interrupts): Don't rebind
*pending-slime-interrupts*. Just to be save.

* slime.el (sldb-maybe-kill-buffer): New function, to handle
the case when the debugger was interrupted in WAIT-FOR-INPUT and
we want to return to the previous debug level.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/12 18:55:42	1.1504
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/14 17:10:34	1.1505
@@ -1,3 +1,31 @@
+2008-09-14  Helmut Eller  <heller at common-lisp.net>
+
+	Introduce a WAIT-FOR-INPUT backend function.
+	CMUCL's blocking input functions READ-CHAR etc.
+	are hard to use with interrupts.  In the backend
+	we have a more realistic chance to get interrupts working.
+
+	* swank-backend.lisp (wait-for-input): New function.
+
+	* swank-cmucl.lisp, swank-clisp.lisp (wait-for-input): Implement
+	it.
+
+	* swank.lisp (wait-for-event/event-loop): Use WAIT-FOR-INPUT and
+	rescan the event-queue if WAIT-FOR-INPUT was interrupted.
+	(reader-event): Deleted. Merged into wait-for-event/event-loop
+	resp.  dispatch-loop.
+	(decode-message): Drop the timeout argument.
+	(*events-enqueued*): A counter to quickly detect new events after
+	a wait.
+	(call-with-connection): If the argument is already the current
+	connection, don't rebind anything.
+	(without-slime-interrupts, with-slime-interrupts): Don't rebind
+	*pending-slime-interrupts*. Just to be save.
+
+	* slime.el (sldb-maybe-kill-buffer): New function, to handle
+	the case when the debugger was interrupted in WAIT-FOR-INPUT and
+	we want to return to the previous debug level.
+
 2008-09-12  Helmut Eller  <heller at common-lisp.net>
 
 	For Lispworks, parse the $LWHOME/lwdoc file.
--- /project/slime/cvsroot/slime/slime.el	2008/09/12 15:51:02	1.1013
+++ /project/slime/cvsroot/slime/slime.el	2008/09/14 17:10:34	1.1014
@@ -2347,7 +2347,7 @@
                         (funcall (cdr rec) value))
                    (t
                     (error "Unexpected reply: %S %S" id value)))))
-          ((:debug-activate thread level select)
+          ((:debug-activate thread level &optional select)
            (assert thread)
            (sldb-activate thread level select))
           ((:debug thread level condition restarts frames conts)
@@ -6807,8 +6807,24 @@
       (let ((inhibit-read-only t))
         (erase-buffer))
       (setq sldb-level nil))
-    (when (and (= level 1) (not stepping))
-      (kill-buffer sldb))))
+    (cond ((and (= level 1) (not stepping))
+           (kill-buffer sldb))
+          (t (sldb-maybe-kill-buffer thread (slime-connection))))))
+
+;; If we return to a lower debug level we wait a little before closing
+;; the debugger window.  We also send a ping, just in case Lisp was
+;; interrupted in swank:wait-for-input.
+(defun sldb-maybe-kill-buffer (thread connection)
+  (slime-eval-async `(swank:ping nil))
+  (run-with-idle-timer
+   0.3 nil 
+   (lambda (thead connection)
+     (when-let (sldb (sldb-find-buffer thread connection))
+       (with-current-buffer sldb
+         (when (not sldb-level)
+           (kill-buffer sldb)))))
+   thread connection))
+
 
 ;;;;;; SLDB buffer insertion
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/12 12:27:38	1.151
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/14 17:10:34	1.152
@@ -1027,16 +1027,44 @@
 (definterface receive-if (predicate &optional timeout)
   "Return the first message satisfiying PREDICATE.")
 
-(defvar *pending-slime-interrupts*)
+(defvar *pending-slime-interrupts* '())
 
 (defun check-slime-interrupts ()
   "Execute pending interrupts if any.
 This should be called periodically in operations which
 can take a long time to complete."
-  (when (and (boundp '*pending-slime-interrupts*)
-             *pending-slime-interrupts*)
+  (when (and *pending-slime-interrupts*)
     (funcall (pop *pending-slime-interrupts*))))
 
+(definterface wait-for-input (streams &optional timeout)
+  "Wait for input on a list of streams.  Return those that are ready.
+STREAMS is a list of streams
+TIMEOUT nil, t, or real number. If TIMEOUT is t, return
+those streams which are ready immediately, without waiting.
+If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
+return nil.
+
+Return :interrupt if an interrupt occurs while waiting."
+  (assert (= (length streams) 1))
+  (let ((stream (car streams)))
+    (case timeout
+      ((nil)
+       (cond (*pending-slime-interrupts* :interrupt)
+             (t (peek-char nil stream nil nil) 
+                streams)))
+      ((t) 
+       (let ((c (read-char-no-hang stream nil nil)))
+         (cond (c 
+                (unread-char c stream) 
+                streams)
+               (t '()))))
+      (t 
+       (loop
+        (if *pending-slime-interrupts* (return :interrupt))
+        (when (wait-for-input streams t) (return streams))
+        (sleep 0.1)
+        (when (<= (decf timeout 0.1) 0) (return nil)))))))
+
 (definterface toggle-trace (spec)
   "Toggle tracing of the function(s) given with SPEC.
 SPEC can be:
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2008/09/12 12:27:38	1.75
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2008/09/14 17:10:34	1.76
@@ -104,6 +104,8 @@
                   (lambda (c)
                     (declare (ignore c))
                     (funcall handler)
+                    (when (find-restart 'socket-status)
+                      (invoke-restart (find-restart 'socket-status)))
                     (continue))))
     (funcall function)))
 
@@ -134,6 +136,22 @@
                         :element-type 'character
                         :external-format external-format))
 
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
+    (loop
+     (cond (*pending-slime-interrupts* (return :interrupt))
+           (timeout 
+            (socket:socket-status streams 0 0)
+            (return (loop for (s _ . x) in streams
+                          if x collect s)))
+           (t
+            (with-simple-restart (socket-status "Return from socket-status.")
+              (socket:socket-status streams 0 500000))
+            (let ((ready (loop for (s _ . x) in streams
+                               if x collect s)))
+              (when ready (return ready))))))))
+
 ;;;; Coding systems
 
 (defvar *external-format-to-coding-system*
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/12 12:27:38	1.193
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/14 17:10:34	1.194
@@ -192,6 +192,30 @@
 (defimplementation remove-fd-handlers (socket)
   (sys:invalidate-descriptor (socket-fd socket)))
 
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (loop
+   (let ((ready (remove-if-not #'listen streams)))
+     (when ready (return ready)))
+   (when timeout (return nil))
+   (if *pending-slime-interrupts* (return :interrupt))
+   (let* ((f (constantly t))
+          (handlers (loop for s in streams
+                          collect (add-one-shot-handler s f))))
+     (unwind-protect
+          (sys:serve-event 0.2)
+       (mapc #'sys:remove-fd-handler handlers)))))
+
+(defun add-one-shot-handler (stream function)
+  (let (handler)
+    (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input
+                                      (lambda (fd)
+                                        (declare (ignore fd))
+                                        (sys:remove-fd-handler handler)
+                                        (funcall function stream))))))
+
+
+
 
 ;;;; Stream handling
 ;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/12 12:27:37	1.586
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/14 17:10:34	1.587
@@ -285,6 +285,9 @@
   "Return the value of *SWANK-STATE-STACK*."
   *swank-state-stack*)
 
+(defslimefun ping (tag)
+  tag)
+
 ;; A conditions to include backtrace information
 (define-condition swank-error (error) 
   ((condition :initarg :condition :reader swank-error.condition)
@@ -342,18 +345,18 @@
 (defmacro with-slime-interrupts (&body body)
   `(progn
      (check-slime-interrupts)
-     (let ((*slime-interrupts-enabled* t)
-           (*pending-slime-interrupts* '()))
-       (multiple-value-prog1 (progn , at body) 
-         (check-slime-interrupts)))))
+     (multiple-value-prog1
+         (let ((*slime-interrupts-enabled* t))
+           , at body)
+       (check-slime-interrupts))))
 
 (defmacro without-slime-interrupts (&body body)
   `(progn
      (check-slime-interrupts)
-     (let ((*slime-interrupts-enabled* nil)
-           (*pending-slime-interrupts* '()))
-       (multiple-value-prog1 (progn , at body)
-         (check-slime-interrupts)))))
+     (multiple-value-prog1
+         (let ((*slime-interrupts-enabled* t))
+           , at body)
+       (check-slime-interrupts))))
 
 (defun invoke-or-queue-interrupt (function)
   (log-event "invoke-or-queue-interrupt: ~a" function)
@@ -362,11 +365,14 @@
            (funcall function)))
         (*slime-interrupts-enabled*
          (funcall function))
-        ((cdr *pending-slime-interrupts*)
-         (simple-break "Two many queued interrupts"))
         (t
-         (log-event "queue-interrupt: ~a" function)
-         (push function *pending-slime-interrupts*))))
+         (setq *pending-slime-interrupts*
+               (nconc *pending-slime-interrupts*
+                      (list function)))
+         (cond ((cdr *pending-slime-interrupts*)
+                (check-slime-interrupts))
+               (t
+                (log-event "queue-interrupt: ~a" function))))))
 
 (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
   (with-simple-restart (continue "Continue from break.")
@@ -393,11 +399,13 @@
   `(call-with-connection ,connection (lambda () , at body)))
 
 (defun call-with-connection (connection function)
-  (let ((*emacs-connection* connection))
-    (without-slime-interrupts
-      (with-swank-error-handler (*emacs-connection*)
-        (with-io-redirection (*emacs-connection*)
-          (call-with-debugger-hook #'swank-debugger-hook function))))))
+  (if (eq *emacs-connection* connection)
+      (funcall function)
+      (let ((*emacs-connection* connection))
+        (without-slime-interrupts
+          (with-swank-error-handler (*emacs-connection*)
+            (with-io-redirection (*emacs-connection*)
+              (call-with-debugger-hook #'swank-debugger-hook function)))))))
 
 (defun call-with-retry-restart (msg thunk)
   (let ((%ok    (gensym "OK+"))
@@ -991,7 +999,7 @@
 (defun dispatch-loop (connection)
   (let ((*emacs-connection* connection))
     (with-panic-handler (connection)
-      (loop (dispatch-event (read-event))))))
+      (loop (dispatch-event (receive))))))
 
 (defvar *auto-flush-interval* 0.2)
 
@@ -1088,15 +1096,14 @@
                      (current-socket-io)))))
 
 (defvar *event-queue* '())
+(defvar *events-enqueued* 0)
 
 (defun send-event (thread event)
   (log-event "send-event: ~s ~s~%" thread event)
   (cond ((use-threads-p) (send thread event))
-        (t (setf *event-queue* (nconc *event-queue* (list event))))))
-
-(defun read-event (&optional timeout)
-  (cond ((use-threads-p) (receive timeout))
-        (t (decode-message (current-socket-io) timeout))))
+        (t (setf *event-queue* (nconc *event-queue* (list event)))
+           (setf *events-enqueued* (mod (1+ *events-enqueued*)
+                                        most-positive-fixnum)))))
 
 (defun send-to-emacs (event)
   "Send EVENT to Emacs."
@@ -1112,25 +1119,37 @@
 
 (defun wait-for-event (pattern &optional timeout)
   (log-event "wait-for-event: ~s ~s~%" pattern timeout)
-  (cond ((use-threads-p) 
-         (without-slime-interrupts
-           (receive-if (lambda (e) (event-match-p e pattern)) timeout)))
-        (t 
-         (wait-for-event/event-loop pattern timeout))))
+  (without-slime-interrupts
+    (cond ((use-threads-p) 
+           (receive-if (lambda (e) (event-match-p e pattern)) timeout))
+          (t 
+           (wait-for-event/event-loop pattern timeout)))))
 
 (defun wait-for-event/event-loop (pattern timeout)
   (assert (or (not timeout) (eq timeout t)))
   (loop 
    (check-slime-interrupts)
-   (let ((tail (member-if (lambda (e) (event-match-p e pattern))
-                          *event-queue*)))
-     (when tail 
-       (setq *event-queue* 
-	     (nconc (ldiff *event-queue* tail) (cdr tail)))
-       (return (car tail))))
-   (multiple-value-bind (event timeout?) (read-event timeout)
-     (when timeout? (return (values nil t)))
-     (dispatch-event event))))
+   (let ((event (poll-for-event pattern)))
+     (when event (return (car event))))
+   (let ((events-enqueued *events-enqueued*)
+         (ready (wait-for-input (list (current-socket-io)) timeout)))
+     (cond ((and timeout (not ready))
+            (return (values nil t)))
+           ((or (/= events-enqueued *events-enqueued*)
+                (eq ready :interrupt))
+            ;; rescan event queue, interrupts may enqueue new events 
+            )
+           (t
+            (assert (equal ready (list (current-socket-io))))
+            (dispatch-event (decode-message (current-socket-io))))))))
+
+(defun poll-for-event (pattern)
+  (let ((tail (member-if (lambda (e) (event-match-p e pattern))
+                         *event-queue*)))
+    (when tail 
+      (setq *event-queue* (nconc (ldiff *event-queue* tail)
+                                 (cdr tail)))
+      tail)))
 
 (defun event-match-p (event pattern)
   (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
@@ -1209,9 +1228,12 @@
            (invoke-or-queue-interrupt
             (lambda () 
               (with-connection (connection)
-                (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))))))
+                (dispatch-interrupt-event)))))))
   (handle-or-process-requests connection))
 
+(defun dispatch-interrupt-event ()
+  (dispatch-event `(:emacs-interrupt ,(current-thread-id))))
+
 (defun deinstall-fd-handler (connection)
   (log-event "deinstall-fd-handler~%")
   (remove-fd-handlers (connection.socket-io connection))
@@ -1223,9 +1245,7 @@
   (unwind-protect 
        (call-with-user-break-handler
         (lambda () 
-          (invoke-or-queue-interrupt 
-           (lambda () 
-             (dispatch-event `(:emacs-interrupt ,(current-thread-id))))))
+          (invoke-or-queue-interrupt #'dispatch-interrupt-event))
         (lambda ()
           (with-simple-restart (close-connection "Close SLIME connection")
             (handle-requests connection))))
@@ -1455,24 +1475,17 @@
 (defmacro with-thread-description (description &body body)
   `(call-with-thread-description ,description #'(lambda () , at body)))
 
-(defun decode-message (stream &optional timeout)
+(defun decode-message (stream)
   "Read an S-expression from STREAM using the SLIME protocol."
-  (assert (or (not timeout) (eq timeout t)))
   ;;(log-event "decode-message~%")
   (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
     (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
-      (let ((c (read-char-no-hang stream)))
-        (cond ((and (not c) timeout) (values nil t))
-              (t
-               (and c (unread-char c stream))
-               (let ((packet (read-packet stream)))
-                 (handler-case (values (read-form packet) nil)
-                   (reader-error (c) 
-                     `(:reader-error ,packet ,c))))))))))
+      (let ((packet (read-packet stream)))
+        (handler-case (values (read-form packet) nil)
+          (reader-error (c) 
+            `(:reader-error ,packet ,c)))))))
 
 (defun read-packet (stream)
-  (peek-char nil stream) ; wait while queuing interrupts
-  (check-slime-interrupts)
   (let* ((header (read-chunk stream 6))
          (length (parse-integer header :radix #x10))
          (payload (read-chunk stream length)))



From heller at common-lisp.net  Mon Sep 15 08:26:41 2008
From: heller at common-lisp.net (heller)
Date: Mon, 15 Sep 2008 04:26:41 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080915082641.03460731FE@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv27369

Modified Files:
	swank-backend.lisp swank.lisp 
Log Message:
More interrupt related frobbing.

--- /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/14 17:10:34	1.152
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/15 08:26:41	1.153
@@ -1027,14 +1027,20 @@
 (definterface receive-if (predicate &optional timeout)
   "Return the first message satisfiying PREDICATE.")
 
-(defvar *pending-slime-interrupts* '())
+;; List of delayed interrupts.  
+;; This should only have thread-local bindings, so no init form.
+(defvar *pending-slime-interrupts*)
 
-(defun check-slime-interrupts ()
+(defun check-slime-interrupts (&optional test-only)
   "Execute pending interrupts if any.
 This should be called periodically in operations which
-can take a long time to complete."
-  (when (and *pending-slime-interrupts*)
-    (funcall (pop *pending-slime-interrupts*))))
+can take a long time to complete.
+Return a boolean indicating whether any interrupts are queued."
+  (when (and (boundp '*pending-slime-interrupts*)
+             *pending-slime-interrupts*)
+    (unless test-only
+      (funcall (pop *pending-slime-interrupts*)))
+    t))
 
 (definterface wait-for-input (streams &optional timeout)
   "Wait for input on a list of streams.  Return those that are ready.
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/14 17:10:34	1.587
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/15 08:26:41	1.588
@@ -340,23 +340,23 @@
 
 ;;;;; Helper macros
 
+;; If true execute interrupts, otherwise queue them.
+;; Note: `with-connection' binds *pending-slime-interrupts*.
 (defvar *slime-interrupts-enabled*)
 
-(defmacro with-slime-interrupts (&body body)
+(defmacro with-interrupts-enabled% (flag body)
   `(progn
      (check-slime-interrupts)
      (multiple-value-prog1
-         (let ((*slime-interrupts-enabled* t))
+         (let ((*slime-interrupts-enabled* ,flag))
            , at body)
        (check-slime-interrupts))))
 
+(defmacro with-slime-interrupts (&body body)
+  `(with-interrupts-enabled% t ,body))
+
 (defmacro without-slime-interrupts (&body body)
-  `(progn
-     (check-slime-interrupts)
-     (multiple-value-prog1
-         (let ((*slime-interrupts-enabled* t))
-           , at body)
-       (check-slime-interrupts))))
+  `(with-interrupts-enabled% nil ,body))
 
 (defun invoke-or-queue-interrupt (function)
   (log-event "invoke-or-queue-interrupt: ~a" function)
@@ -401,7 +401,8 @@
 (defun call-with-connection (connection function)
   (if (eq *emacs-connection* connection)
       (funcall function)
-      (let ((*emacs-connection* connection))
+      (let ((*emacs-connection* connection)
+            (*pending-slime-interrupts* '()))
         (without-slime-interrupts
           (with-swank-error-handler (*emacs-connection*)
             (with-io-redirection (*emacs-connection*)
@@ -946,8 +947,9 @@
 (defun process-requests (timeout just-one)
   "Read and process requests from Emacs."
   (loop
-   (multiple-value-bind (event timeout?)
-       (wait-for-event `(:emacs-rex . _) timeout)
+   (multiple-value-bind (event timeout? interrupt?)
+       (wait-for-event `(:emacs-rex . _) timeout just-one)
+     (when interrupt? (return nil))
      (when timeout? (return t))
      (apply #'eval-for-emacs (cdr event))
      (when just-one (return nil)))))
@@ -1117,18 +1119,21 @@
   (cond ((use-threads-p) (interrupt-thread thread interrupt))
         (t (funcall interrupt))))
 
-(defun wait-for-event (pattern &optional timeout)
+(defun wait-for-event (pattern &optional timeout report-interrupts)
   (log-event "wait-for-event: ~s ~s~%" pattern timeout)
   (without-slime-interrupts
     (cond ((use-threads-p) 
            (receive-if (lambda (e) (event-match-p e pattern)) timeout))
           (t 
-           (wait-for-event/event-loop pattern timeout)))))
+           (wait-for-event/event-loop pattern timeout report-interrupts)))))
 
-(defun wait-for-event/event-loop (pattern timeout)
+(defun wait-for-event/event-loop (pattern timeout report-interrupts)
   (assert (or (not timeout) (eq timeout t)))
   (loop 
-   (check-slime-interrupts)
+   (when *pending-slime-interrupts*
+     (check-slime-interrupts)
+     (when report-interrupts (return (values nil nil t)))
+     (when timeout (return (values nil t))))
    (let ((event (poll-for-event pattern)))
      (when event (return (car event))))
    (let ((events-enqueued *events-enqueued*)



From heller at common-lisp.net  Mon Sep 15 08:26:50 2008
From: heller at common-lisp.net (heller)
Date: Mon, 15 Sep 2008 04:26:50 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080915082650.7C10F790E1@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv27422

Modified Files:
	ChangeLog slime.el 
Log Message:
Interrupt related hacking.

* swank-backend.lisp (*pending-slime-interrupts*): Should be
thread-local.  Leave global value unbound.

* swank.lisp (with-interrupts-enabled%): New helper macro.
(with-slime-interrupts, without-slime-interrupts): Use it.
(call-with-connection): Bind *pending-slime-interrupts* here.
(wait-for-event): Add a report-interrupt argument.  Currently used
by the debugger to detect when a nested debugger session, which
was triggered by an interrupt in wait-for-event, returns.  Doesn't
work well, though.

* slime.el (slime-test-interrupt-in-debugger): New test.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/14 17:10:34	1.1505
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/15 08:26:49	1.1506
@@ -1,3 +1,20 @@
+2008-09-15  Helmut Eller  <heller at common-lisp.net>
+
+	Interrupt related hacking.
+
+	* swank-backend.lisp (*pending-slime-interrupts*): Should be
+	thread-local.  Leave global value unbound.
+
+	* swank.lisp (with-interrupts-enabled%): New helper macro.
+	(with-slime-interrupts, without-slime-interrupts): Use it.
+	(call-with-connection): Bind *pending-slime-interrupts* here.
+	(wait-for-event): Add a report-interrupt argument.  Currently used
+	by the debugger to detect when a nested debugger session, which
+	was triggered by an interrupt in wait-for-event, returns.  Doesn't
+	work well, though.
+
+	* slime.el (slime-test-interrupt-in-debugger): New test.
+
 2008-09-14  Helmut Eller  <heller at common-lisp.net>
 
 	Introduce a WAIT-FOR-INPUT backend function.
--- /project/slime/cvsroot/slime/slime.el	2008/09/14 17:10:34	1.1014
+++ /project/slime/cvsroot/slime/slime.el	2008/09/15 08:26:49	1.1015
@@ -1412,9 +1412,9 @@
   (let ((file (slime-swank-port-file))) 
     (unless (active-minibuffer-window)
       (message "Polling %S.. (Abort with `M-x slime-abort-connection'.)" file))
-    (slime-cancel-connect-retry-timer)
     (cond ((and (file-exists-p file)
                 (> (nth 7 (file-attributes file)) 0)) ; file size
+           (slime-cancel-connect-retry-timer)
            (let ((port (slime-read-swank-port))
                  (args (slime-inferior-lisp-args process)))
              (slime-delete-swank-port-file 'message)
@@ -1422,6 +1422,7 @@
                                      (plist-get args :coding-system))))
                (slime-set-inferior-process c process))))
           ((and retries (zerop retries))
+           (slime-cancel-connect-retry-timer)
            (message "Failed to connect to Swank."))
           (t
            (when (and (file-exists-p file) 
@@ -1429,11 +1430,13 @@
              (message "(Zero length port file)")
              ;; the file may be in the filesystem but not yet written
              (unless retries (setq retries 3)))
-           (setq slime-connect-retry-timer
-                 (run-with-timer 0.3 nil
-                                 #'slime-timer-call #'slime-attempt-connection 
-                                 process (and retries (1- retries)) 
-                                 (1+ attempt)))))))
+           (unless slime-connect-retry-timer
+             (setq slime-connect-retry-timer
+                   (run-with-timer
+                    0.3 0.3
+                    #'slime-timer-call #'slime-attempt-connection 
+                    process (and retries (1- retries)) 
+                    (1+ attempt))))))))
     
 (defun slime-timer-call (fun &rest args)
   "Call function FUN with ARGS, reporting all errors.
@@ -8747,9 +8750,7 @@
       sldb-level)))
 
 (defun slime-sldb-level= (level)
-  (when-let (sldb (sldb-get-default-buffer))
-    (with-current-buffer sldb
-      (equal sldb-level level))))
+  (equal level (sldb-level)))
 
 (def-slime-test narrowing
     ()
@@ -8828,7 +8829,8 @@
 
 (def-slime-test find-definition.2
     (buffer-content buffer-package snippet)
-    "Check that we're able to find definitions even when confronted with nasty #.-fu."
+    "Check that we're able to find definitions even when
+confronted with nasty #.-fu."
     '(("#.(prog1 nil (defvar *foobar* 42))
 
        (defun .foo. (x)
@@ -8861,8 +8863,8 @@
     (prefix expected-completions)
     "Find the completions of a symbol-name prefix."
     '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname"
-                      "cl:compiled-function" "cl:compiled-function-p" "cl:compiler-macro"
-                      "cl:compiler-macro-function")
+                      "cl:compiled-function" "cl:compiled-function-p" 
+                      "cl:compiler-macro" "cl:compiler-macro-function")
                      "cl:compile"))
       ("cl:foobar" (nil ""))
       ("swank::compile-file" (("swank::compile-file" 
@@ -9354,6 +9356,7 @@
    0)
   (slime-sync-to-top-level 2)
   (slime-eval-async '(cl-user::quux))
+  ;; FIXME: slime-wait-condition returns immediately if the test returns true
   (slime-wait-condition "Checking that Debugger does not popup" 
                         (lambda () 
                           (not (sldb-get-default-buffer)))
@@ -9407,6 +9410,28 @@
 #\\X
 SWANK> " (buffer-string))))
 
+(def-slime-test interrupt-in-debugger (interrupts continues)
+    "Let's see what happens if we interrupt the debugger.
+INTERRUPTS ... number of nested interrupts
+CONTINUES  ... how often the continue restart should be invoked"
+    '((1 0) (2 1) (4 2))
+  (slime-check "No debugger" (not (sldb-get-default-buffer)))
+  (dotimes (i interrupts)
+    (slime-interrupt)
+    (let ((level (1+ i)))
+      (slime-wait-condition (format "Debug level %d reachend" lx1evel)
+                            (lambda () (equal (sldb-level) level))
+                            2)))
+  (dotimes (i continues)
+    (sldb-continue)
+    (let ((level (- interrupts (1+ i))))
+      (slime-wait-condition (format "Return to debug level %d" level)
+                            (lambda () (equal (sldb-level) level))
+                            2)))
+  (when (sldb-get-default-buffer)
+    (sldb-quit))
+  (slime-sync-to-top-level 1))
+    
 (def-slime-test disconnect
     ()
     "Close the connetion.



From heller at common-lisp.net  Mon Sep 15 10:41:04 2008
From: heller at common-lisp.net (heller)
Date: Mon, 15 Sep 2008 06:41:04 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080915104104.D439B1B000@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30458

Modified Files:
	ChangeLog slime.el swank-backend.lisp swank-clisp.lisp 
	swank-cmucl.lisp swank.lisp 
Log Message:
* swank.lisp (sldb-loop): Send a :sldb-return event to ourselfes
to inform the debug session at the lower level.
(wait-for-event): Drop the report-interrupt argument.  No longer
needed.
(event-match-p): Add an OR pattern operator.  Used to wait for
different events simultaneously.

(read-packet): Use peek-char to detect EOF. read-sequence wouldn't
work.

* slime.el (slime-test-interrupt-in-debugger): Call sldb-quit and
sldb-continue in the right buffer.

* swank-backend.lisp (wait-for-input):
* swank-cmucl.lisp (wait-for-input):
* swank-clisp.lisp (wait-for-input): Use the idiom
"(when (check-slime-interrupts) (return :interrupt))".

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/15 08:26:49	1.1506
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/15 10:41:02	1.1507
@@ -1,5 +1,25 @@
 2008-09-15  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (sldb-loop): Send a :sldb-return event to ourselfes
+	when returning to inform the debug session at the lower level.
+	(wait-for-event): Drop the report-interrupt argument.  No longer
+	needed.
+	(event-match-p): Add an OR pattern operator.  Used to wait for
+	different events simultaneously.
+
+	(read-packet): Use peek-char to detect EOF. read-sequence wouldn't
+	work.
+
+	* slime.el (slime-test-interrupt-in-debugger): Call sldb-quit and
+	sldb-continue in the right buffer.
+
+	* swank-backend.lisp (wait-for-input):
+	* swank-cmucl.lisp (wait-for-input):
+	* swank-clisp.lisp (wait-for-input): Use the idiom
+	"(when (check-slime-interrupts) (return :interrupt))".
+
+2008-09-15  Helmut Eller  <heller at common-lisp.net>
+
 	Interrupt related hacking.
 
 	* swank-backend.lisp (*pending-slime-interrupts*): Should be
--- /project/slime/cvsroot/slime/slime.el	2008/09/15 08:26:49	1.1015
+++ /project/slime/cvsroot/slime/slime.el	2008/09/15 10:41:02	1.1016
@@ -6818,7 +6818,6 @@
 ;; the debugger window.  We also send a ping, just in case Lisp was
 ;; interrupted in swank:wait-for-input.
 (defun sldb-maybe-kill-buffer (thread connection)
-  (slime-eval-async `(swank:ping nil))
   (run-with-idle-timer
    0.3 nil 
    (lambda (thead connection)
@@ -7339,6 +7338,7 @@
 (defun sldb-quit ()
   "Quit to toplevel."
   (interactive)
+  (assert sldb-restarts () "sldb-quit called outside of sldb buffer")
   (slime-rex () ('(swank:throw-to-toplevel))
     ((:ok _) (error "sldb-quit returned"))
     ((:abort))))
@@ -7346,6 +7346,7 @@
 (defun sldb-continue ()
   "Invoke the \"continue\" restart."
   (interactive)
+  (assert sldb-restarts () "sldb-continue called outside of sldb buffer")
   (slime-rex ()
       ('(swank:sldb-continue))
     ((:ok _)
@@ -9419,16 +9420,17 @@
   (dotimes (i interrupts)
     (slime-interrupt)
     (let ((level (1+ i)))
-      (slime-wait-condition (format "Debug level %d reachend" lx1evel)
+      (slime-wait-condition (format "Debug level %d reachend" level)
                             (lambda () (equal (sldb-level) level))
                             2)))
   (dotimes (i continues)
-    (sldb-continue)
+    (with-current-buffer (sldb-get-default-buffer)
+      (sldb-continue))
     (let ((level (- interrupts (1+ i))))
       (slime-wait-condition (format "Return to debug level %d" level)
                             (lambda () (equal (sldb-level) level))
                             2)))
-  (when (sldb-get-default-buffer)
+  (with-current-buffer (sldb-get-default-buffer)
     (sldb-quit))
   (slime-sync-to-top-level 1))
     
--- /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/15 08:26:41	1.153
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/15 10:41:03	1.154
@@ -1031,15 +1031,14 @@
 ;; This should only have thread-local bindings, so no init form.
 (defvar *pending-slime-interrupts*)
 
-(defun check-slime-interrupts (&optional test-only)
+(defun check-slime-interrupts ()
   "Execute pending interrupts if any.
 This should be called periodically in operations which
 can take a long time to complete.
-Return a boolean indicating whether any interrupts are queued."
+Return a boolean indicating whether any interrupts was processed."
   (when (and (boundp '*pending-slime-interrupts*)
              *pending-slime-interrupts*)
-    (unless test-only
-      (funcall (pop *pending-slime-interrupts*)))
+    (funcall (pop *pending-slime-interrupts*))
     t))
 
 (definterface wait-for-input (streams &optional timeout)
@@ -1055,7 +1054,7 @@
   (let ((stream (car streams)))
     (case timeout
       ((nil)
-       (cond (*pending-slime-interrupts* :interrupt)
+       (cond ((check-slime-interrupts) :interrupt)
              (t (peek-char nil stream nil nil) 
                 streams)))
       ((t) 
@@ -1066,7 +1065,7 @@
                (t '()))))
       (t 
        (loop
-        (if *pending-slime-interrupts* (return :interrupt))
+        (if (check-slime-interrupts) (return :interrupt))
         (when (wait-for-input streams t) (return streams))
         (sleep 0.1)
         (when (<= (decf timeout 0.1) 0) (return nil)))))))
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2008/09/14 17:10:34	1.76
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2008/09/15 10:41:03	1.77
@@ -140,7 +140,7 @@
   (assert (member timeout '(nil t)))
   (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
     (loop
-     (cond (*pending-slime-interrupts* (return :interrupt))
+     (cond ((check-slime-interrupts) (return :interrupt))
            (timeout 
             (socket:socket-status streams 0 0)
             (return (loop for (s _ . x) in streams
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/14 17:10:34	1.194
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/15 10:41:03	1.195
@@ -198,7 +198,7 @@
    (let ((ready (remove-if-not #'listen streams)))
      (when ready (return ready)))
    (when timeout (return nil))
-   (if *pending-slime-interrupts* (return :interrupt))
+   (when (check-slime-interrupts) (return :interrupt))
    (let* ((f (constantly t))
           (handlers (loop for s in streams
                           collect (add-one-shot-handler s f))))
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/15 08:26:41	1.588
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/15 10:41:03	1.589
@@ -947,9 +947,8 @@
 (defun process-requests (timeout just-one)
   "Read and process requests from Emacs."
   (loop
-   (multiple-value-bind (event timeout? interrupt?)
-       (wait-for-event `(:emacs-rex . _) timeout just-one)
-     (when interrupt? (return nil))
+   (multiple-value-bind (event timeout?)
+       (wait-for-event `(:emacs-rex . _) timeout)
      (when timeout? (return t))
      (apply #'eval-for-emacs (cdr event))
      (when just-one (return nil)))))
@@ -1119,21 +1118,18 @@
   (cond ((use-threads-p) (interrupt-thread thread interrupt))
         (t (funcall interrupt))))
 
-(defun wait-for-event (pattern &optional timeout report-interrupts)
+(defun wait-for-event (pattern &optional timeout)
   (log-event "wait-for-event: ~s ~s~%" pattern timeout)
   (without-slime-interrupts
     (cond ((use-threads-p) 
            (receive-if (lambda (e) (event-match-p e pattern)) timeout))
           (t 
-           (wait-for-event/event-loop pattern timeout report-interrupts)))))
+           (wait-for-event/event-loop pattern timeout)))))
 
-(defun wait-for-event/event-loop (pattern timeout report-interrupts)
+(defun wait-for-event/event-loop (pattern timeout)
   (assert (or (not timeout) (eq timeout t)))
   (loop 
-   (when *pending-slime-interrupts*
-     (check-slime-interrupts)
-     (when report-interrupts (return (values nil nil t)))
-     (when timeout (return (values nil t))))
+   (check-slime-interrupts)
    (let ((event (poll-for-event pattern)))
      (when event (return (car event))))
    (let ((events-enqueued *events-enqueued*)
@@ -1162,10 +1158,12 @@
 	 (equal event pattern))
 	((symbolp pattern) t)
 	((consp pattern)
-         (and (consp event)
-              (and (event-match-p (car event) (car pattern))
-                   (event-match-p (cdr event) (cdr pattern)))))
-	(t (error "Invalid pattern: ~S" pattern))))
+         (case (car pattern)
+           ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
+           (t (and (consp event)
+                   (and (event-match-p (car event) (car pattern))
+                        (event-match-p (cdr event) (cdr pattern)))))))
+        (t (error "Invalid pattern: ~S" pattern))))
 
 (defun spawn-threads-for-connection (connection)
   (setf (connection.control-thread connection) 
@@ -1490,7 +1488,10 @@
           (reader-error (c) 
             `(:reader-error ,packet ,c)))))))
 
+;; use peek-char to detect EOF, read-sequence may return 0 instead of
+;; signaling a condition.
 (defun read-packet (stream)
+  (peek-char nil stream) 
   (let* ((header (read-chunk stream 6))
          (length (parse-integer header :radix #x10))
          (payload (read-chunk stream length)))
@@ -2207,13 +2208,22 @@
           (send-to-emacs 
            (list* :debug (current-thread-id) level
                   (debugger-info-for-emacs 0 *sldb-initial-frames*)))
+          (send-to-emacs 
+           (list :debug-activate (current-thread-id) level nil))
           (loop 
-           (send-to-emacs (list :debug-activate (current-thread-id) level nil))
-           (handler-case (process-requests nil t)
+           (handler-case 
+               (destructure-case (wait-for-event 
+                                  `(or (:emacs-rex . _)
+                                       (:sldb-return ,(1+ level))))
+                 ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
+                 ((:sldb-return _) (declare (ignore _)) (return nil))) 
              (sldb-condition (c) 
                (handle-sldb-condition c))))))
     (send-to-emacs `(:debug-return
-                     ,(current-thread-id) ,level ,*sldb-stepping-p*))))
+                     ,(current-thread-id) ,level ,*sldb-stepping-p*))
+    (wait-for-event `(:sldb-return ,(1+ level)) t) ; clean event-queue
+    (when (> level 1)
+      (send-event (current-thread) `(:sldb-return ,level)))))
 
 (defun handle-sldb-condition (condition)
   "Handle an internal debugger condition.



From heller at common-lisp.net  Mon Sep 15 21:11:19 2008
From: heller at common-lisp.net (heller)
Date: Mon, 15 Sep 2008 17:11:19 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080915211119.7677A3964F@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv28587

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
* swank-lispworks.lisp (describe-symbol-for-emacs): Revert last
change.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/15 10:41:02	1.1507
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/15 21:11:19	1.1508
@@ -1,7 +1,12 @@
 2008-09-15  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-lispworks.lisp (describe-symbol-for-emacs): Revert last
+	change.
+
+2008-09-15  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (sldb-loop): Send a :sldb-return event to ourselfes
-	when returning to inform the debug session at the lower level.
+	to inform the debug session at the lower level.
 	(wait-for-event): Drop the report-interrupt argument.  No longer
 	needed.
 	(event-match-p): Add an OR pattern operator.  Used to wait for
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/12 18:55:42	1.115
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/15 21:11:19	1.116
@@ -154,12 +154,7 @@
                (let ((pos (position #\newline string)))
                  (if (null pos) string (subseq string 0 pos))))
              (doc (kind &optional (sym symbol))
-               (let ((string (or
-                              (documentation sym kind)
-                              (lwdoc (symbol-name sym)
-                                     (package-name (symbol-package sym))
-                                     kind))))
-                     
+               (let ((string (or (documentation sym kind))))
                  (if string 
                      (first-line string)
                      :not-documented)))
@@ -213,66 +208,6 @@
   (when (fboundp sym)
     (describe-function sym)))
 
-(defvar *lwdoc-types*
-  '(("%FUN-DOCUMENTATION" . function)
-    ("%VAR-DOCUMENTATION" . variable)
-    ("%SETF-DOCUMENTATION" . setf)
-    ("%STRUCT-DOCUMENTATION" . structure)))
-
-;; (lwdoc 'cons 'common-lisp 't)
-(defun lwdoc (name package type)
-  "Search in $LWHOME/lwdoc for entries matching NAME and PACKAGE."
-  (lw:when-let (doc (lookup-lwdoc name package))
-    (destructuring-bind (kind description) doc
-      (when (or (eq type t)
-                (eq (cdr (assoc kind *lwdoc-types* :test #'string-equal))
-                    type))
-        description))))
-
-(defun lookup-lwdoc (name package)
-  (when (probe-file (sys:lispworks-file "lwdoc"))
-    (with-open-file (file (sys:lispworks-file "lwdoc"))
-      (lwdoc-search file 0 (file-length file) package name))))
-
-;; Use binary search, assuming that the entries are ordered alphabetically
-(defun lwdoc-search (file min max package name)
-  (declare (optimize (sys:interruptable 3)))
-  (let ((pos (+ min (floor (- max min) 2))))
-    (and (< min (1- max))
-         (let ((record (parse-lwdoc-record file pos)))
-           (and record
-                (destructuring-bind (rpackage rname kind doc) record
-                  ;;(format t "~d ~d ~a ~a~%" min max rpackage rname)
-                  (ecase (cond ((string-equal package rpackage)
-                                (cond ((string-equal name rname) '=)
-                                      ((string-lessp name rname) '<)
-                                      (t '>)))
-                               ((string-lessp package rpackage) '<)
-                               (t '>))
-                    (= (list kind doc))
-                    (< (lwdoc-search file min pos package name))
-                    (> (lwdoc-search file pos max package name)))))))))
-
-(defun parse-lwdoc-record (file position)
-  (declare (optimize (sys:interruptable 3)))
-  (file-position file position)
-  (when (peek-char #\null file nil nil)
-    ;; Search previous #\null or beginning of file
-    (do* ((end (file-position file))
-          (start end (max (- start 10) 0)))
-         (nil)
-      (file-position file start)
-      (when (= start 0) (return))
-      (peek-char #\null file)
-      (when (< (file-position file) end) (return)))
-    (peek-char #\" file)
-    (let ((key (read file)) 
-          (doc (read file)))
-      (peek-char #\null file)
-      (read-char file)
-      (append (lw:split-sequence ":" key :coalesce-separators t)
-              (list doc)))))
-
 ;;; Debugging
 
 (defclass slime-env (env:environment) 



From trittweiler at common-lisp.net  Tue Sep 16 18:15:15 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Tue, 16 Sep 2008 14:15:15 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080916181515.194371D115@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv853

Modified Files:
	slime.el ChangeLog 
Log Message:

	* slime.el (slime-end-of-list): `backward-down-list' was used
	there which is defined by paredit.el.
	Use `(down-list -1)' instead.


--- /project/slime/cvsroot/slime/slime.el	2008/09/15 10:41:02	1.1016
+++ /project/slime/cvsroot/slime/slime.el	2008/09/16 18:15:14	1.1017
@@ -5799,7 +5799,7 @@
 (defun slime-end-of-list (&optional up)
   (backward-up-list (or up 1))
   (forward-list 1)
-  (backward-down-list 1))
+  (down-list -1))
 
 (defun slime-parse-toplevel-form ()
   (ignore-errors                        ; (foo)
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/15 21:11:19	1.1508
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/16 18:15:14	1.1509
@@ -1,3 +1,9 @@
+2008-09-16  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-end-of-list): `backward-down-list' was used
+	there which is defined by paredit.el.
+	Use `(down-list -1)' instead.
+
 2008-09-15  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-lispworks.lisp (describe-symbol-for-emacs): Revert last



From heller at common-lisp.net  Wed Sep 17 06:19:56 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 02:19:56 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917061956.5C9163700E@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv24065

Modified Files:
	ChangeLog slime.el swank-abcl.lisp swank-allegro.lisp 
	swank-clisp.lisp swank-cmucl.lisp swank-corman.lisp 
	swank-ecl.lisp swank-lispworks.lisp swank-openmcl.lisp 
	swank-sbcl.lisp swank-scl.lisp 
Log Message:
Adjust positions in files with CRLF-style end-on-line markers.

* slime.el (slime-eol-conversion-fixup): New function.
(slime-goto-location-position): Use it.  Also add a new position
type :offset, so that we don't adjust offsets in strings that were
sent over the wire (which uses LF eol-convention).

* swank-abcl.lisp
* swank-allegro.lisp
* swank-clisp.lisp
* swank-cmucl.lisp
* swank-corman.lisp
* swank-ecl.lisp
* swank-lispworks.lisp
* swank-openmcl.lisp
* swank-sbcl.lisp
* swank-scl.lisp: Create :offset style positions where needed.

* swank-lispworks.lisp (skip-comments): New function.
(dspec-stream-position): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/16 18:15:14	1.1509
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 06:19:47	1.1510
@@ -4,6 +4,29 @@
 	there which is defined by paredit.el.
 	Use `(down-list -1)' instead.
 
+2008-09-16  Helmut Eller  <heller at common-lisp.net>
+
+	Adjust positions in files with CRLF style end-on-line markers.
+
+	* slime.el (slime-eol-conversion-fixup): New function.
+	(slime-goto-location-position): Use it.  Also add a new position
+	type :offset, so that we don't adjust offsets in strings that were
+	sent over the wire (which uses LF eol-convention).
+
+	* swank-abcl.lisp
+	* swank-allegro.lisp
+	* swank-clisp.lisp
+	* swank-cmucl.lisp
+	* swank-corman.lisp
+	* swank-ecl.lisp
+	* swank-lispworks.lisp
+	* swank-openmcl.lisp
+	* swank-sbcl.lisp
+	* swank-scl.lisp: Create :offset style positions where needed.
+
+	* swank-lispworks.lisp (skip-comments): New function.
+	(dspec-stream-position): Use it.
+
 2008-09-15  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-lispworks.lisp (describe-symbol-for-emacs): Revert last
--- /project/slime/cvsroot/slime/slime.el	2008/09/16 18:15:14	1.1017
+++ /project/slime/cvsroot/slime/slime.el	2008/09/17 06:19:47	1.1018
@@ -4627,11 +4627,12 @@
 
 (defun slime-goto-location-position (position)
   (destructure-case position
-    ((:position pos &optional align-p)
-     (goto-char pos)
-     (when align-p
-       (slime-forward-sexp)
-       (beginning-of-sexp)))
+    ((:position pos)
+     (goto-char 1)
+     (forward-char (- (1- pos) (slime-eol-conversion-fixup (1- pos)))))
+    ((:offset start offset)
+     (goto-char start)
+     (forward-char offset))
     ((:line start &optional column)
      (goto-line start)
      (cond (column (move-to-column column))
@@ -4654,13 +4655,22 @@
             (goto-char start-position)
             (slime-forward-positioned-source-path source-path))
            (t
-            (slime-forward-source-path source-path))))
-    ;; Goes to "start" then looks for the anchor text, then moves
-    ;; delta from that position.
-    ((:text-anchored start text delta)
-     (goto-char start)
-     (slime-isearch text)
-     (forward-char delta))))
+            (slime-forward-source-path source-path))))))
+
+(defun slime-eol-conversion-fixup (n)
+  ;; Return the number of \r\n eol markers that we need to cross when
+  ;; moving N chars forward.  N is the number of chars but \r\n are
+  ;; counted as 2 separate chars.
+  (let* ((eol-type (coding-system-eol-type buffer-file-coding-system)))
+    (ecase eol-type
+      ((0 2) 0)
+      ((1) 
+       (save-excursion 
+         (do ((pos (+ (point) n))
+              (count 0 (1+ count)))
+             ((>= (point) pos) (1- count))
+           (forward-line)
+           (decf pos)))))))
 
 (defun slime-search-method-location (name specializers qualifiers)
   ;; Look for a sequence of words (def<something> method name
@@ -4710,11 +4720,11 @@
              | (:source-form <string>)
              | (:zip <file> <entry>)
 
-<position> ::= (:position <fixnum> [<align>]) ; 1 based
+<position> ::= (:position <fixnum>) ; 1 based (for files)
+             | (:offset <start> <offset>) ; start+offset (for C-c C-c)
              | (:line <line> [<column>])
              | (:function-name <string>)
              | (:source-path <list> <start-position>) 
-             | (:text-anchored <fixnum> <string> <fixnum>) 
              | (:method <name string> <specializer strings> . <qualifiers strings>)"
   (destructure-case location
     ((:location buffer position hints)
@@ -4738,7 +4748,10 @@
       (when-let (snippet (getf hints :snippet))
         (slime-isearch snippet))
       (when-let (fname (getf hints :call-site))
-        (slime-search-call-site fname)))
+        (slime-search-call-site fname))
+      (when (getf hints :align)
+        (slime-forward-sexp)
+        (beginning-of-sexp)))
     (point)))
 
 
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2008/09/12 12:27:38	1.54
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2008/09/17 06:19:48	1.55
@@ -317,7 +317,7 @@
                :location (cond (*buffer-name*
                                 (make-location 
                                  (list :buffer *buffer-name*)
-                                 (list :position *buffer-start-position*)))
+                                 (list :offset *buffer-start-position* 0)))
                                (loc
                                 (destructuring-bind (file . pos) loc
                                   (make-location
@@ -385,8 +385,8 @@
     `(((,symbol)
        (:location 
         (:file ,(namestring (ext:source-pathname symbol)))
-        (:position ,(or (ext:source-file-position symbol) 0) t)
-        (:snippet nil))))))
+        (:position ,(or (ext:source-file-position symbol) 1))
+        (:align t))))))
 
 
 (defimplementation find-definitions (symbol)
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/12 12:27:38	1.113
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/17 06:19:48	1.114
@@ -255,7 +255,7 @@
     (cond (*buffer-name*
            (make-location 
             (list :buffer *buffer-name*)
-            (list :position *buffer-start-position*)))
+            (list :offset *buffer-start-position* 0)))
           (loc
            (destructuring-bind (file . pos) loc
              (make-location
@@ -366,7 +366,7 @@
          (start (and part
                      (scm::source-part-start part)))
          (pos (if start
-                  (list :position (1+ (- start (count-cr file start))))
+                  (list :position (1+ start))
                   (list :function-name (string (fspec-primary-name fspec))))))
     (make-location (list :file (namestring (truename file)))
                    pos)))
@@ -375,7 +375,7 @@
   (let ((pos (position #\; filename :from-end t)))
     (make-location
      (list :buffer (subseq filename 0 pos))
-     (list :position (parse-integer (subseq filename (1+ pos)))))))
+     (list :offset (parse-integer (subseq filename (1+ pos))) 0))))
 
 (defun find-fspec-location (fspec type file top-level)
   (etypecase file
@@ -404,8 +404,9 @@
       (declare (ignore top-level-form))
       (list
        (list (list nil fspec)
-             (make-location (list :buffer file)
-                            (list :position position t))))))
+             (make-location (list :buffer file) ; FIXME: should use :file
+                            (list :position position)
+                            (list :align t))))))
    ((and (listp fspec) (eq (car fspec) :internal))
     (destructuring-bind (_internal next _n) fspec
       (declare (ignore _internal _n))
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2008/09/15 10:41:03	1.77
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2008/09/17 06:19:48	1.78
@@ -559,7 +559,7 @@
                           (list ':line lineno1)))
           (*buffer-name*
            (make-location (list ':buffer *buffer-name*)
-                          (list ':position *buffer-offset*)))
+                          (list ':offset *buffer-offset* 0)))
           (t
            (list :error "No error location available")))))
 
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/15 10:41:03	1.195
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/09/17 06:19:48	1.196
@@ -199,7 +199,8 @@
      (when ready (return ready)))
    (when timeout (return nil))
    (when (check-slime-interrupts) (return :interrupt))
-   (let* ((f (constantly t))
+   (let* (#+(or)(lisp::*descriptor-handlers* '()) ; ignore other handlers
+          (f (constantly t))
           (handlers (loop for s in streams
                           collect (add-one-shot-handler s f))))
      (unwind-protect
@@ -449,7 +450,7 @@
          (pos (c::compiler-read-error-position condition)))
     (cond ((and (eq file :stream) *buffer-name*)
            (make-location (list :buffer *buffer-name*)
-                          (list :position (+ *buffer-start-position* pos))))
+                          (list :offset *buffer-start-position* pos)))
           ((and (pathnamep file) (not *buffer-name*))
            (make-location (list :file (unix-truename file))
                           (list :position (1+ pos))))
@@ -474,17 +475,15 @@
 (defun locate-compiler-note (file source source-path)
   (cond ((and (eq file :stream) *buffer-name*)
          ;; Compiling from a buffer
-         (let ((position (+ *buffer-start-position*
-                            (source-path-string-position
-                             source-path *buffer-substring*))))
-           (make-location (list :buffer *buffer-name*)
-                          (list :position position))))
+         (make-location (list :buffer *buffer-name*)
+                        (list :offset *buffer-start-position*
+                              (source-path-string-position
+                               source-path *buffer-substring*))))
         ((and (pathnamep file) (null *buffer-name*))
          ;; Compiling from a file
          (make-location (list :file (unix-truename file))
-                        (list :position
-                              (1+ (source-path-file-position
-                                   source-path file)))))
+                        (list :position (1+ (source-path-file-position
+                                             source-path file)))))
         ((and (eq file :lisp) (stringp source))
          ;; No location known, but we have the source form.
          ;; XXX How is this case triggered?  -luke (16/May/2004) 
@@ -784,7 +783,7 @@
                     string)))
     (make-location
      (list :buffer (getf info :emacs-buffer))
-     (list :position (+ (getf info :emacs-buffer-offset) position))
+     (list :offset (getf info :emacs-buffer-offset) position)
      (list :snippet (with-input-from-string (s string)
                       (file-position s position)
                       (read-snippet s))))))
@@ -1131,7 +1130,7 @@
       (with-input-from-string (s emacs-buffer-string)
         (let ((pos (form-number-stream-position tlf-number form-number s)))
           (make-location `(:buffer ,emacs-buffer)
-                         `(:position ,(+ emacs-buffer-offset pos))))))))
+                         `(:offset ,emacs-buffer-offset ,pos)))))))
 
 ;; XXX predicates for 18e backward compatibilty.  Remove them when
 ;; we're 19a only.
--- /project/slime/cvsroot/slime/swank-corman.lisp	2008/09/12 12:27:38	1.17
+++ /project/slime/cvsroot/slime/swank-corman.lisp	2008/09/17 06:19:48	1.18
@@ -356,7 +356,7 @@
                                    (cond (*buffer-name*
                                           (make-location
                                            (list :buffer *buffer-name*)
-                                           (list :position *buffer-position*)))
+                                           (list :offset *buffer-position* 0)))
                                          (*compile-filename*
                                           (make-location
                                            (list :file *compile-filename*)
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2008/08/27 17:53:16	1.29
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2008/09/17 06:19:48	1.30
@@ -122,7 +122,7 @@
    :location
    (if *buffer-name*
        (make-location (list :buffer *buffer-name*)
-                      (list :position *buffer-start-position*))
+                      (list :offset *buffer-start-position* 0))
        ;; ;; compiler::*current-form*
        ;; (if compiler::*current-function*
        ;;     (make-location (list :file *compile-filename*)
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/15 21:11:19	1.116
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/09/17 06:19:49	1.117
@@ -459,14 +459,14 @@
              (delete-file binary-filename))))
     (delete-file filename)))
 
-(defun dspec-buffer-position (dspec offset)
+(defun dspec-function-name-position (dspec fallback)
   (etypecase dspec
     (cons (let ((name (dspec:dspec-primary-name dspec)))
             (typecase name
               ((or symbol string) 
                (list :function-name (string name)))
-              (t (list :position offset)))))
-    (null (list :position offset))
+              (t fallback))))
+    (null fallback)
     (symbol (list :function-name (string dspec)))))
 
 (defmacro with-fairly-standard-io-syntax (&body body)
@@ -480,10 +480,17 @@
               (*readtable* ,readtable))
           , at body)))))
 
+(defun skip-comments (stream)
+  (let ((pos0 (file-position stream)))
+    (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
+                  '(()))
+           (file-position stream (1- (file-position stream))))
+          (t (file-position stream pos0)))))
+
 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
 (defun dspec-stream-position (stream dspec)
   (with-fairly-standard-io-syntax
-    (loop (let* ((pos (file-position stream))
+    (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
                  (form (read stream nil '#1=#:eof)))
             (when (eq form '#1#)
               (return nil))
@@ -517,8 +524,8 @@
              #-(or lispworks4.1 lispworks4.2)
              (dspec-stream-position stream dspec)))
         (if pos
-            (list :position (1+ pos) t)
-            (dspec-buffer-position dspec 1))))))
+            (list :position (1+ pos))
+            (dspec-function-name-position dspec `(:position 1)))))))
 
 (defun emacs-buffer-location-p (location)
   (and (consp location)
@@ -540,7 +547,7 @@
      (destructuring-bind (_ buffer offset string) location
        (declare (ignore _ string))
        (make-location `(:buffer ,buffer)
-                      (dspec-buffer-position dspec offset)
+                      (dspec-function-name-position dspec `(:offset ,offset 0))
                       hints)))))
 
 (defun make-dspec-progenitor-location (dspec location)
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/12 12:27:38	1.133
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/17 06:19:49	1.134
@@ -300,11 +300,13 @@
              (if *buffer-name*
                  (make-location
                   (list :buffer *buffer-name*)
-                  (list :position position t))
+                  (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 t))))))))
+                      (list :position position)
+                      (list :align t))))))))
 
 (defun temp-file-name ()
   "Return a temporary file name to compile strings into."
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/09/12 12:27:38	1.218
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/09/17 06:19:49	1.219
@@ -371,17 +371,15 @@
 (defun locate-compiler-note (file source-path source)
   (cond ((and (not (eq file :lisp)) *buffer-name*)
          ;; Compiling from a buffer
-         (let ((position (+ *buffer-offset*
-                            (source-path-string-position
-                             source-path *buffer-substring*))))
-           (make-location (list :buffer *buffer-name*)
-                          (list :position position))))
+         (make-location (list :buffer *buffer-name*)
+                        (list :offset  *buffer-offset* 
+                              (source-path-string-position
+                               source-path *buffer-substring*))))
         ((and (pathnamep file) (null *buffer-name*))
          ;; Compiling from a file
          (make-location (list :file (namestring file))
-                        (list :position
-                              (1+ (source-path-file-position
-                                   source-path file)))))
+                        (list :position (1+ (source-path-file-position
+                                             source-path file)))))
         ((and (eq file :lisp) (stringp source))
          ;; Compiling macro generated code
          (make-location (list :source-form source)
@@ -590,7 +588,7 @@
                          character-offset))
                 (snippet (string-path-snippet emacs-string form-path pos)))
            (make-location `(:buffer ,emacs-buffer)
-                          `(:position ,(+ pos emacs-position))
+                          `(:offset ,emacs-position ,pos)
                           `(:snippet ,snippet))))
         ((not pathname)
          `(:error ,(format nil "Source definition of ~A ~A not found"
@@ -603,7 +601,7 @@
            (make-location `(:file ,namestring)
                           ;; /file positions/ in Common Lisp start
                           ;; from 0, in Emacs they start from 1.
-                          `(:position ,(1+ pos))
+                          `(:position (1+ ,pos))
                           `(:snippet ,snippet))))))))
 
 (defun string-path-snippet (string form-path position)
@@ -905,7 +903,7 @@
 (defun lisp-source-location (code-location)
   (let ((source (prin1-to-string
                  (sb-debug::code-location-source-form code-location 100))))
-    (make-location `(:source-form ,source) '(:position 0))))
+    (make-location `(:source-form ,source) '(:position 1))))
 
 (defun emacs-buffer-source-location (code-location plist)
   (if (code-location-has-debug-block-info-p code-location)
@@ -916,7 +914,7 @@
                (snipped (with-input-from-string (s emacs-string)
                           (read-snippet s pos))))
           (make-location `(:buffer ,emacs-buffer)
-                         `(:position ,(+ emacs-position pos))
+                         `(:offset ,emacs-position ,pos)
                          `(:snippet ,snipped))))
       (fallback-source-location code-location)))
 
@@ -930,7 +928,7 @@
         (let* ((pos (stream-source-position code-location s))
                (snippet (read-snippet s pos)))
           (make-location `(:file ,filename)
-                         `(:position ,(1+ pos))
+                         `(:position ,pos)
                          `(:snippet ,snippet)))))))
 
 (defun code-location-debug-source-name (code-location)
--- /project/slime/cvsroot/slime/swank-scl.lisp	2008/09/12 12:27:38	1.24
+++ /project/slime/cvsroot/slime/swank-scl.lisp	2008/09/17 06:19:49	1.25
@@ -455,7 +455,7 @@
          (pos (c::compiler-read-error-position condition)))
     (cond ((and (eq file :stream) *buffer-name*)
            (make-location (list :buffer *buffer-name*)
-                          (list :position (+ *buffer-start-position* pos))))
+                          (list :offset *buffer-start-position* pos)))
           ((and (pathnamep file) (not *buffer-name*))
            (make-location (list :file (unix-truename file))
                           (list :position (1+ pos))))
@@ -480,17 +480,15 @@
 (defun locate-compiler-note (file source source-path)
   (cond ((and (eq file :stream) *buffer-name*)
          ;; Compiling from a buffer
-         (let ((position (+ *buffer-start-position*
-                            (source-path-string-position
-                             source-path *buffer-substring*))))
-           (make-location (list :buffer *buffer-name*)
-                          (list :position position))))
+	 (make-location (list :buffer *buffer-name*)
+			(list :offset *buffer-start-position*
+			      (source-path-string-position
+			       source-path *buffer-substring*))))
         ((and (pathnamep file) (null *buffer-name*))
          ;; Compiling from a file
          (make-location (list :file (unix-truename file))
-                        (list :position
-                              (1+ (source-path-file-position
-                                   source-path file)))))
+                        (list :position (1+ (source-path-file-position
+					     source-path file)))))
         ((and (eq file :lisp) (stringp source))
          ;; No location known, but we have the source form.
          ;; XXX How is this case triggered?  -luke (16/May/2004) 
@@ -712,7 +710,7 @@
     (with-input-from-string (s source-code)
       (make-location (list :file (unix-truename filename))
                      (list :position (1+ (code-location-stream-position
-                                          code-location s)))
+					  code-location s)))
                      `(:snippet ,(read-snippet s))))))
 
 (defun location-in-stream (code-location debug-source)
@@ -727,7 +725,7 @@
                     string)))
     (make-location
      (list :buffer (getf info :emacs-buffer))
-     (list :position (+ (getf info :emacs-buffer-offset) position))
+     (list :offset (getf info :emacs-buffer-offset) position)
      (list :snippet (with-input-from-string (s string)
                       (file-position s position)
                       (read-snippet s))))))



From heller at common-lisp.net  Wed Sep 17 06:20:22 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 02:20:22 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917062022.51CBB6D07A@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv24191

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-connection): Optionally select a new default
connection.
(slime-auto-select-connection): New variable.
(slime-auto-select-connection): New function.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 06:19:47	1.1510
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 06:20:05	1.1511
@@ -6,6 +6,13 @@
 
 2008-09-16  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-connection): Optionally select a new default
+	connection.
+	(slime-auto-select-connection): New variable.
+	(slime-auto-select-connection): New function.
+
+2008-09-16  Helmut Eller  <heller at common-lisp.net>
+
 	Adjust positions in files with CRLF style end-on-line markers.
 
 	* slime.el (slime-eol-conversion-fixup): New function.
--- /project/slime/cvsroot/slime/slime.el	2008/09/17 06:19:47	1.1018
+++ /project/slime/cvsroot/slime/slime.el	2008/09/17 06:20:09	1.1019
@@ -1816,7 +1816,8 @@
 Signal an error if there's no connection."
   (let ((conn (slime-current-connection)))
     (cond ((and (not conn) slime-net-processes)
-           (error "No default connection selected."))
+           (or (slime-auto-select-connection)
+               (error "No default connection selected.")))
           ((not conn)
            (or (slime-auto-connect)
                (error "Not connected.")))
@@ -1837,6 +1838,21 @@
            (slime-connection)))
         (t nil)))
 
+(defvar slime-auto-select-connection 'ask)
+
+(defun slime-auto-select-connection ()
+  (let* ((c0 (car slime-net-processes))
+         (c (cond ((eq slime-auto-select-connection 'always) c0)
+                  ((and (eq slime-auto-select-connection 'ask)
+                        (y-or-n-p 
+                         (format "No default connection selected.  %s %s? "
+                                 "Switch to" (slime-connection-name c0))))
+                   c0))))
+    (when c
+      (slime-select-connection c)
+      (message "Switching to connection: %s" (slime-connection-name c))
+      c)))
+
 (defun slime-select-connection (process)
   "Make PROCESS the default connection."
   (setq slime-default-connection process))
@@ -4661,16 +4677,15 @@
   ;; Return the number of \r\n eol markers that we need to cross when
   ;; moving N chars forward.  N is the number of chars but \r\n are
   ;; counted as 2 separate chars.
-  (let* ((eol-type (coding-system-eol-type buffer-file-coding-system)))
-    (ecase eol-type
-      ((0 2) 0)
-      ((1) 
-       (save-excursion 
-         (do ((pos (+ (point) n))
-              (count 0 (1+ count)))
-             ((>= (point) pos) (1- count))
-           (forward-line)
-           (decf pos)))))))
+  (case (coding-system-eol-type buffer-file-coding-system)
+    ((0 2) 0)
+    ((1) 
+     (save-excursion 
+       (do ((pos (+ (point) n))
+            (count 0 (1+ count)))
+           ((>= (point) pos) (1- count))
+         (forward-line)
+         (decf pos))))))
 
 (defun slime-search-method-location (name specializers qualifiers)
   ;; Look for a sequence of words (def<something> method name



From heller at common-lisp.net  Wed Sep 17 06:21:13 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 02:21:13 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917062113.2A25312064@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv24401

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
* slime.el (slime-test-find-top-level-restart): New function.
[def-slime-test] (interrupt-at-toplevel, interrupt-in-debugger):
Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 06:20:05	1.1511
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 06:20:34	1.1512
@@ -1,8 +1,8 @@
-2008-09-16  Tobias C. Rittweiler  <tcr at freebits.de>
+2008-09-17  Helmut Eller  <heller at common-lisp.net>
 
-	* slime.el (slime-end-of-list): `backward-down-list' was used
-	there which is defined by paredit.el.
-	Use `(down-list -1)' instead.
+	* slime.el (slime-test-find-top-level-restart): New function.
+	[def-slime-test] (interrupt-at-toplevel, interrupt-in-debugger):
+	Use it.
 
 2008-09-16  Helmut Eller  <heller at common-lisp.net>
 
@@ -34,6 +34,12 @@
 	* swank-lispworks.lisp (skip-comments): New function.
 	(dspec-stream-position): Use it.
 
+2008-09-16  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-end-of-list): `backward-down-list' was used
+	there which is defined by paredit.el.
+	Use `(down-list -1)' instead.
+
 2008-09-15  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-lispworks.lisp (describe-symbol-for-emacs): Revert last
--- /project/slime/cvsroot/slime/slime.el	2008/09/17 06:20:09	1.1019
+++ /project/slime/cvsroot/slime/slime.el	2008/09/17 06:20:39	1.1020
@@ -9405,9 +9405,17 @@
                                (get-buffer-window (sldb-get-default-buffer))))
                         5)
   (with-current-buffer (sldb-get-default-buffer)
-    (sldb-quit))
+    (sldb-invoke-restart (slime-test-find-top-level-restart)))
   (slime-sync-to-top-level 5))
 
+(defun slime-test-find-top-level-restart ()
+  (let ((case-fold-search t))
+    (or (loop for i from 0  for (name str) in sldb-restarts 
+              when (string-match "SLIME's top level" str) return i)
+        (loop for i from 0  for (name str) in sldb-restarts 
+              when (and (string-match "abort" name) (string-match "top" str))
+              return i))))
+
 (def-slime-test interrupt-in-blocking-read
     ()
     "Let's see what happens if we interrupt a blocking read operation."
@@ -9459,7 +9467,7 @@
                             (lambda () (equal (sldb-level) level))
                             2)))
   (with-current-buffer (sldb-get-default-buffer)
-    (sldb-quit))
+    (sldb-invoke-restart (slime-test-find-top-level-restart)))
   (slime-sync-to-top-level 1))
     
 (def-slime-test disconnect
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/15 10:41:03	1.589
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/17 06:20:39	1.590
@@ -2347,7 +2347,8 @@
 (defslimefun throw-to-toplevel ()
   "Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
 If we are not evaluating an RPC then ABORT instead."
-  (let ((restart (find-restart *sldb-quit-restart*)))
+  (let ((restart (and (not (symbolp *sldb-quit-restart*))
+                      (find-restart *sldb-quit-restart*))))
     (cond (restart (invoke-restart restart))
           (t (format nil
                      "Restart not found: ~a"



From heller at common-lisp.net  Wed Sep 17 06:21:18 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 02:21:18 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917062118.AB54C81022@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv24620

Modified Files:
	slime.el 
Log Message:
(slime-repl-insert-prompt): Don't move the output end makers
before prompt.  Let output accumulate before the result.
(slime-insert-transcript-delimiter): Insert the delimiter
at the end of the buffer.  Update markers accordingly.

--- /project/slime/cvsroot/slime/slime.el	2008/09/17 06:20:39	1.1020
+++ /project/slime/cvsroot/slime/slime.el	2008/09/17 06:21:16	1.1021
@@ -2667,16 +2667,25 @@
   ;; insert the string STRING in the output buffer
   (with-current-buffer (slime-output-buffer)
     (slime-with-output-end-mark 
-     (slime-insert-propertized '(face slime-repl-output-face
-                                      rear-nonsticky (face))
-                               string)
-     (set-marker slime-output-end (point))
+     (slime-repl-insert-at-markers slime-output-start slime-output-end
+                                   string '(face slime-repl-output-face
+                                                 rear-nonsticky (face)))
+     (goto-char slime-output-end)
      (when (and (= (point) slime-repl-prompt-start-mark)
                 (not (bolp)))
        (insert "\n")
        (set-marker slime-output-end (1- (point))))
-     (when (< slime-repl-input-start-mark (point))
-       (set-marker slime-repl-input-start-mark (point))))))
+     (assert (<= (point) slime-repl-input-start-mark)))))
+
+(defun slime-repl-insert-at-markers (marker1 marker2 string &optional props)
+  (goto-char marker2)
+  (let ((start (point)))
+    (insert-before-markers string)
+    (cond ((< marker1 marker2))
+          ((= marker1 marker2) (set-marker marker1 start))
+          (t (assert (<= marker1 marker2))))
+    (when props
+      (add-text-properties start marker2 props))))
 
 (defun slime-repl-emit-result (string &optional bol)
   ;; insert STRING and mark it as evaluation result
@@ -2965,7 +2974,6 @@
     (set-marker slime-repl-input-end-mark (point-max))
     (set-marker slime-repl-prompt-start-mark prompt-start)
     (goto-char slime-repl-prompt-start-mark)
-    (slime-mark-output-start)
     (goto-char (point-max)))
   (slime-repl-show-maximum-output))
 
@@ -5464,8 +5472,10 @@
 
 (defun slime-insert-transcript-delimiter (string)
   (with-current-buffer (slime-output-buffer)
-    (slime-with-output-end-mark
-     (unless (bolp) (insert-before-markers "\n"))
+    (goto-char (point-max))
+    (unless (bolp) (insert-before-markers "\n"))
+    (slime-mark-output-start)
+    (slime-mark-input-start)
      (slime-propertize-region '(slime-transcript-delimiter t)
        (insert-before-markers
         ";;;; " (subst-char-in-string ?\n ?\ 
@@ -9286,15 +9296,18 @@
 (def-slime-test interactive-eval-output
     (input result-contents visiblep)
     "Test simple commands in the minibuffer."
-    '(("(+ 1 2)" ";;;; (+ 1 2) ...
-SWANK> " nil)
-      ("(princ 10)" ";;;; (princ 10) ...
+    '(("(+ 1 2)" "SWANK> 
+;;;; (+ 1 2) ...
+" nil)
+      ("(princ 10)" "SWANK> 
+;;;; (princ 10) ...
 10
-SWANK> " t)
+" t)
       ("(princ \"????????????????????????????\")"
-       ";;;; (princ \"????????????????????????????\") ...
+       "SWANK> 
+;;;; (princ \"????????????????????????????\") ...
 ????????????????????????????
-SWANK> " t))
+" t))
   (when (and (fboundp 'string-to-multibyte)
              (with-current-buffer (process-buffer (slime-connection))
                enable-multibyte-characters))



From heller at common-lisp.net  Wed Sep 17 08:25:35 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 04:25:35 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917082535.6972E81022@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv25912

Modified Files:
	slime.el 
Log Message:
Fix parens.

--- /project/slime/cvsroot/slime/slime.el	2008/09/17 06:21:16	1.1021
+++ /project/slime/cvsroot/slime/slime.el	2008/09/17 08:25:34	1.1022
@@ -5481,7 +5481,7 @@
         ";;;; " (subst-char-in-string ?\n ?\ 
                                       (substring string 0 
                                                  (min 60 (length string))))
-        " ...\n")))))
+        " ...\n"))))
 
 (defun slime-display-buffer-region (buffer start end &optional other-window)
   "Like `display-buffer', but only display the specified region."



From trittweiler at common-lisp.net  Wed Sep 17 17:48:11 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Wed, 17 Sep 2008 13:48:11 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917174811.0E3EC81003@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv28440

Modified Files:
	swank-sbcl.lisp ChangeLog 
Log Message:
	* swank-sbcl.lisp (make-definition-source-location): Fix typo
	introduced with crlf-related commit on 2008-09-16.


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/09/17 06:19:49	1.219
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/09/17 17:48:08	1.220
@@ -601,7 +601,7 @@
            (make-location `(:file ,namestring)
                           ;; /file positions/ in Common Lisp start
                           ;; from 0, in Emacs they start from 1.
-                          `(:position (1+ ,pos))
+                          `(:position ,(1+ pos))
                           `(:snippet ,snippet))))))))
 
 (defun string-path-snippet (string form-path position)
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 06:20:34	1.1512
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 17:48:08	1.1513
@@ -1,3 +1,8 @@
+2008-09-17  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-sbcl.lisp (make-definition-source-location): Fix typo
+	introduced with crlf-related commit on 2008-09-16.
+
 2008-09-17  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-test-find-top-level-restart): New function.



From heller at common-lisp.net  Wed Sep 17 18:42:12 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 14:42:12 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917184212.C07607A090@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13939

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (send-user-output): Lifted from make-output-function.
Make this a top-level function for easier redefinition.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 17:48:08	1.1513
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 18:42:12	1.1514
@@ -5,6 +5,9 @@
 
 2008-09-17  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (send-user-output): Lifted from make-output-function.
+	Make this a top-level function for easier redefinition.
+
 	* slime.el (slime-test-find-top-level-restart): New function.
 	[def-slime-test] (interrupt-at-toplevel, interrupt-in-debugger):
 	Use it.
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/17 06:20:39	1.590
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/17 18:42:12	1.591
@@ -872,25 +872,29 @@
              :name "auto-flush-thread"))
     (values dedicated-output in out io repl-results)))
 
-(defvar *maximum-pipelined-output-chunks* 20)
-
 ;; FIXME: if wait-for-event aborts the event will stay in the queue forever.
 (defun make-output-function (connection)
   "Create function to send user output to Emacs."
   (let ((i 0) (tag 0) (l 0))
     (lambda (string)
       (with-connection (connection)
-        (with-simple-restart (abort "Abort sending output to Emacs.")
-          (when (or (= i *maximum-pipelined-output-chunks*) 
-                    (> l (* 80 20 5)))
-            (setf tag (mod (1+ tag) 1000))
-            (send-to-emacs `(:ping ,(current-thread-id) ,tag))
-            (wait-for-event `(:emacs-pong ,tag))
-            (setf i 0) 
-            (setf l 0))
-          (incf i)
-          (incf l (length string))
-          (send-to-emacs `(:write-string ,string)))))))
+        (multiple-value-setq (i tag l) 
+          (send-user-output string i tag l))))))
+
+(defvar *maximum-pipelined-output-chunks* 50)
+(defvar *maximum-pipelined-output-length* (* 80 20 5))
+(defun send-user-output (string pcount tag plength)
+  ;; send output with flow control
+  (when (or (> pcount *maximum-pipelined-output-chunks*) 
+            (> plength *maximum-pipelined-output-length*))
+    (setf tag (mod (1+ tag) 1000))
+    (send-to-emacs `(:ping ,(current-thread-id) ,tag))
+    (with-simple-restart (abort "Abort sending output to Emacs.")
+      (wait-for-event `(:emacs-pong ,tag)))
+    (setf pcount 0) 
+    (setf plength 0))
+  (send-to-emacs `(:write-string ,string))
+  (values (1+ pcount) tag (+ plength (length string))))
 
 (defun make-output-function-for-target (connection target)
   "Create a function to send user output to a specific TARGET in Emacs."



From heller at common-lisp.net  Wed Sep 17 18:42:17 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 14:42:17 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917184217.929401D165@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13964

Modified Files:
	ChangeLog swank.lisp 
Log Message:
(*pre-reply-hook*): Add 'force-user-output.
[def-slime-test] (interrupt-at-toplevel, interrupt-in-debugger):
Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 18:42:12	1.1514
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 18:42:17	1.1515
@@ -8,6 +8,8 @@
 	* swank.lisp (send-user-output): Lifted from make-output-function.
 	Make this a top-level function for easier redefinition.
 
+	(*pre-reply-hook*): Add 'force-user-output.
+
 	* slime.el (slime-test-find-top-level-restart): New function.
 	[def-slime-test] (interrupt-at-toplevel, interrupt-in-debugger):
 	Use it.
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/17 18:42:12	1.591
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/17 18:42:17	1.592
@@ -1551,6 +1551,8 @@
 (defun force-user-output ()
   (force-output (connection.user-io *emacs-connection*)))
 
+(add-hook *pre-reply-hook* 'force-user-output)
+
 (defun clear-user-input  ()
   (clear-input (connection.user-input *emacs-connection*)))
 



From heller at common-lisp.net  Wed Sep 17 18:42:27 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 14:42:27 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917184227.5210323300@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv14019

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-repl-popup-on-output): New variable.
(slime-repl-emit): Honor slime-repl-popup-on-output.
(slime-eval-with-transcript): Use slime-repl-popup-on-output.
Also remove the function argument, as it was only used once
and that was slime-message.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 18:42:17	1.1515
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 18:42:26	1.1516
@@ -5,10 +5,22 @@
 
 2008-09-17  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-repl-popup-on-output): New variable.
+	(slime-repl-emit): Honor slime-repl-popup-on-output.
+	(slime-eval-with-transcript): Use slime-repl-popup-on-output.
+	Also remove the function argument, as it was only used once
+	and that was slime-message.
+
+2008-09-17  Helmut Eller  <heller at common-lisp.net>
+
+	(*pre-reply-hook*): Add 'force-user-output.
+
+2008-09-17  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (send-user-output): Lifted from make-output-function.
 	Make this a top-level function for easier redefinition.
 
-	(*pre-reply-hook*): Add 'force-user-output.
+2008-09-17  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-test-find-top-level-restart): New function.
 	[def-slime-test] (interrupt-at-toplevel, interrupt-in-debugger):
--- /project/slime/cvsroot/slime/slime.el	2008/09/17 08:25:34	1.1022
+++ /project/slime/cvsroot/slime/slime.el	2008/09/17 18:42:26	1.1023
@@ -2663,6 +2663,10 @@
     (:repl-result (slime-repl-emit-result string))
     (t (slime-emit-string string target))))
 
+(defvar slime-repl-popup-on-output nil
+  "Display the output buffer when some output is written.
+This is set to nil after displaying the buffer.")
+
 (defun slime-repl-emit (string)
   ;; insert the string STRING in the output buffer
   (with-current-buffer (slime-output-buffer)
@@ -2675,7 +2679,10 @@
                 (not (bolp)))
        (insert "\n")
        (set-marker slime-output-end (1- (point))))
-     (assert (<= (point) slime-repl-input-start-mark)))))
+     (assert (<= (point) slime-repl-input-start-mark))
+     (when slime-repl-popup-on-output
+       (setq slime-repl-popup-on-output nil)
+       (display-buffer (current-buffer))))))
 
 (defun slime-repl-insert-at-markers (marker1 marker2 string &optional props)
   (goto-char marker2)
@@ -5427,8 +5434,7 @@
   (interactive (list (slime-read-from-minibuffer "Slime Eval: ")))
   (slime-insert-transcript-delimiter string)
   (cond ((not current-prefix-arg)
-         (slime-eval-with-transcript `(swank:interactive-eval ,string) 
-                                     'slime-display-eval-result))
+         (slime-eval-with-transcript `(swank:interactive-eval ,string)))
         (t
          (slime-eval-print string))))
 
@@ -5444,21 +5450,15 @@
                           (destructuring-bind (output value) result
                             (insert output value)))))))
 
-(defun slime-eval-with-transcript (form &optional fn)
-  "Send FROM and PACKAGE to Lisp and pass the result to FN.
-Display the result in the message area, if FN is nil.
-Show the output buffer if the evaluation causes any output."
-  (with-current-buffer (slime-output-buffer)
-    (slime-with-output-end-mark 
-     (slime-mark-output-start)))
-  (slime-eval-async form
-                    (slime-rcurry 
-                     (lambda (value fn)
-                       (with-current-buffer (slime-output-buffer)
-                         (slime-show-last-output)
-                         (cond (fn (funcall fn value))
-                               (t (message "%s" value)))))
-                     fn)))
+(defun slime-eval-with-transcript (form)
+  "Eval FROM in Lisp.  Display output, if any, caused by the evaluation."
+  (setq slime-repl-popup-on-output t)
+  (slime-eval-async 
+   form
+   (lambda (value)
+     (run-with-timer 0.2 nil (lambda ()
+                               (setq slime-repl-popup-on-output nil)))
+     (slime-display-eval-result value))))
 
 (defun slime-eval-describe (form)
   "Evaluate FORM in Lisp and display the result in a new buffer."



From heller at common-lisp.net  Wed Sep 17 23:14:45 2008
From: heller at common-lisp.net (heller)
Date: Wed, 17 Sep 2008 19:14:45 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080917231445.D15BA21041@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv6722

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-eval-with-transcript): Accept some more arguments
so that we can also use it for compile-file.
(slime-eval-with-transcript-cont): New. Insert prompt.
(slime-compile-file): Use slime-eval-with-transcript.
(slime-repl-show-maximum-output): Update window point.
(slime-repl-insert-prompt): Don't use insert-before-markers.
(slime-repl-emit): No longer use slime-with-output-end-mark.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 18:42:26	1.1516
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/17 23:14:45	1.1517
@@ -1,3 +1,13 @@
+2008-09-18  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-eval-with-transcript): Accept some more arguments
+	so that we can also use it for compile-file.
+	(slime-eval-with-transcript-cont): New. Insert prompt.
+	(slime-compile-file): Use slime-eval-with-transcript.
+	(slime-repl-show-maximum-output): Update window point.
+	(slime-repl-insert-prompt): Don't use insert-before-markers.
+	(slime-repl-emit): No longer use slime-with-output-end-mark.
+
 2008-09-17  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-sbcl.lisp (make-definition-source-location): Fix typo
--- /project/slime/cvsroot/slime/slime.el	2008/09/17 18:42:26	1.1023
+++ /project/slime/cvsroot/slime/slime.el	2008/09/17 23:14:45	1.1024
@@ -2670,19 +2670,21 @@
 (defun slime-repl-emit (string)
   ;; insert the string STRING in the output buffer
   (with-current-buffer (slime-output-buffer)
-    (slime-with-output-end-mark 
-     (slime-repl-insert-at-markers slime-output-start slime-output-end
-                                   string '(face slime-repl-output-face
-                                                 rear-nonsticky (face)))
-     (goto-char slime-output-end)
-     (when (and (= (point) slime-repl-prompt-start-mark)
-                (not (bolp)))
-       (insert "\n")
-       (set-marker slime-output-end (1- (point))))
-     (assert (<= (point) slime-repl-input-start-mark))
-     (when slime-repl-popup-on-output
-       (setq slime-repl-popup-on-output nil)
-       (display-buffer (current-buffer))))))
+    (save-excursion
+      (slime-repl-insert-at-markers slime-output-start slime-output-end
+                                    string '(face slime-repl-output-face
+                                                  rear-nonsticky (face)))
+      (goto-char slime-output-end)
+      (when (and (= (point) slime-repl-prompt-start-mark)
+                 (not (bolp)))
+        (insert "\n")
+        (set-marker slime-output-end (1- (point))))
+      (assert (<= (point) slime-repl-input-start-mark))
+      (when slime-repl-popup-on-output
+        (setq slime-repl-popup-on-output nil)
+        (display-buffer (current-buffer))))
+    (when (eobp)
+      (slime-repl-show-maximum-output))))
 
 (defun slime-repl-insert-at-markers (marker1 marker2 string &optional props)
   (goto-char marker2)
@@ -2976,11 +2978,10 @@
                rear-nonsticky (slime-repl-prompt read-only face intangible)
                ;; xemacs stuff
                start-open t end-open t)
-      (insert-before-markers prompt))
+      (insert prompt))
     (slime-mark-input-start)
     (set-marker slime-repl-input-end-mark (point-max))
     (set-marker slime-repl-prompt-start-mark prompt-start)
-    (goto-char slime-repl-prompt-start-mark)
     (goto-char (point-max)))
   (slime-repl-show-maximum-output))
 
@@ -2990,6 +2991,7 @@
   (let ((win (get-buffer-window (current-buffer))))
     (when win
       (with-selected-window win
+        (set-window-point win (point-max)) 
         (recenter -1)))))
 
 (defvar slime-repl-current-input-hooks)
@@ -3950,10 +3952,9 @@
     (save-buffer))
   (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max))
   (let ((file (slime-to-lisp-filename (buffer-file-name))))
-    (slime-insert-transcript-delimiter (format "Compile file %s" file))
-    (when slime-display-compilation-output
-      (slime-display-output-buffer))
-    (slime-eval-async 
+    (slime-eval-with-transcript
+     (format "Compile file %s" file)
+     slime-display-compilation-output
      `(swank:compile-file-for-emacs ,file ,(if load t nil))
      (slime-rcurry #'slime-compilation-finished (current-buffer)))
     (message "Compiling %s..." file)))
@@ -5432,9 +5433,9 @@
 Note: If a prefix argument is in effect then the result will be
 inserted in the current buffer."
   (interactive (list (slime-read-from-minibuffer "Slime Eval: ")))
-  (slime-insert-transcript-delimiter string)
   (cond ((not current-prefix-arg)
-         (slime-eval-with-transcript `(swank:interactive-eval ,string)))
+         (slime-eval-with-transcript string t `(swank:interactive-eval ,string)
+                                     'slime-display-eval-result))
         (t
          (slime-eval-print string))))
 
@@ -5450,15 +5451,24 @@
                           (destructuring-bind (output value) result
                             (insert output value)))))))
 
-(defun slime-eval-with-transcript (form)
+(defun slime-eval-with-transcript (msg show-output form cont)
   "Eval FROM in Lisp.  Display output, if any, caused by the evaluation."
-  (setq slime-repl-popup-on-output t)
-  (slime-eval-async 
-   form
-   (lambda (value)
-     (run-with-timer 0.2 nil (lambda ()
-                               (setq slime-repl-popup-on-output nil)))
-     (slime-display-eval-result value))))
+  (slime-insert-transcript-delimiter msg)
+  (setq slime-repl-popup-on-output show-output)
+  (slime-rex (cont) (form)
+    ((:ok value) (slime-eval-with-transcript-cont t value cont))
+    ((:abort) (slime-eval-with-transcript-cont nil nil nil))))
+
+(defun slime-eval-with-transcript-cont (ok result cont)
+  (run-with-timer 0.2 nil (lambda ()
+                            (setq slime-repl-popup-on-output nil)))
+  (with-current-buffer (slime-output-buffer)
+    (let ((output-start (point-max)))
+      (goto-char (point-max))
+      (slime-repl-insert-prompt)
+      (slime-mark-output-start output-start)))
+  (cond (ok (funcall cont result))
+        (t (message "Evaluation aborted."))))
 
 (defun slime-eval-describe (form)
   "Evaluate FORM in Lisp and display the result in a new buffer."
@@ -5474,14 +5484,14 @@
   (with-current-buffer (slime-output-buffer)
     (goto-char (point-max))
     (unless (bolp) (insert-before-markers "\n"))
+    (slime-propertize-region '(slime-transcript-delimiter t)
+      (insert-before-markers
+       ";;;; " (subst-char-in-string ?\n ?\ 
+                                     (substring string 0 
+                                                (min 60 (length string))))
+       " ...\n"))
     (slime-mark-output-start)
-    (slime-mark-input-start)
-     (slime-propertize-region '(slime-transcript-delimiter t)
-       (insert-before-markers
-        ";;;; " (subst-char-in-string ?\n ?\ 
-                                      (substring string 0 
-                                                 (min 60 (length string))))
-        " ...\n"))))
+    (slime-mark-input-start)))
 
 (defun slime-display-buffer-region (buffer start end &optional other-window)
   "Like `display-buffer', but only display the specified region."
@@ -9298,16 +9308,16 @@
     "Test simple commands in the minibuffer."
     '(("(+ 1 2)" "SWANK> 
 ;;;; (+ 1 2) ...
-" nil)
+SWANK> " nil)
       ("(princ 10)" "SWANK> 
 ;;;; (princ 10) ...
 10
-" t)
+SWANK> " t)
       ("(princ \"????????????????????????????\")"
        "SWANK> 
 ;;;; (princ \"????????????????????????????\") ...
 ????????????????????????????
-" t))
+SWANK> " t))
   (when (and (fboundp 'string-to-multibyte)
              (with-current-buffer (process-buffer (slime-connection))
                enable-multibyte-characters))



From trittweiler at common-lisp.net  Thu Sep 18 10:08:41 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Thu, 18 Sep 2008 06:08:41 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918100841.18EA312069@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16916

Modified Files:
	swank-ecl.lisp ChangeLog 
Log Message:

* swank-ecl.lisp: Forgot to update ECL's backend when introducing
  swank-frames in commit on 2008-09-12.


--- /project/slime/cvsroot/slime/swank-ecl.lisp	2008/09/17 06:19:48	1.30
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2008/09/18 10:08:34	1.31
@@ -272,11 +272,11 @@
   (declare (type function debugger-loop-fn))
   (let* ((*tpl-commands* si::tpl-commands)
          (*ihs-top* (ihs-top 'call-with-debugging-environment))
-	 (*ihs-current* *ihs-top*)
-	 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
-	 (*frs-top* (frs-top))
-	 (*read-suppress* nil)
-	 (*tpl-level* (1+ *tpl-level*))
+         (*ihs-current* *ihs-top*)
+         (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
+         (*frs-top* (frs-top))
+         (*read-suppress* nil)
+         (*tpl-level* (1+ *tpl-level*))
          (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
                             collect (list (si::ihs-fun ihs)
                                           (si::ihs-env ihs)
@@ -289,7 +289,7 @@
                    (unless (si::fixnump name)
                      (push name (third x)))))))
     (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
-    (Setf *tmp* *backtrace*)
+    (setf *tmp* *backtrace*)
     (set-break-env)
     (set-current-ihs)
     (let ((*ihs-base* *ihs-top*))
@@ -303,7 +303,8 @@
 (defimplementation compute-backtrace (start end)
   (when (numberp end)
     (setf end (min end (length *backtrace*))))
-  (subseq *backtrace* start end))
+  (loop for f in (subseq *backtrace* start end)
+        collect (make-swank-frame :%frame f :restartable :unknown)))
 
 (defun frame-name (frame)
   (let ((x (first frame)))
@@ -343,8 +344,9 @@
 	       ))))
     (values functions blocks variables)))
 
-(defimplementation print-frame (frame stream)
-  (format stream "~A" (first frame)))
+(defimplementation print-swank-frame (swank-frame stream)
+  (let ((frame (swank-frame.%frame swank-frame)))
+    (format stream "~A" (first frame))))
 
 (defimplementation frame-source-location-for-emacs (frame-number)
   (nth-value 1 (frame-function (elt *backtrace* frame-number))))
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/17 23:14:45	1.1517
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/18 10:08:37	1.1518
@@ -1,3 +1,8 @@
+2008-09-18  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-ecl.lisp: Forgot to update ECL's backend when introducing
+	swank-frames in commit on 2008-09-12.
+
 2008-09-18  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-eval-with-transcript): Accept some more arguments



From heller at common-lisp.net  Thu Sep 18 15:23:31 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 11:23:31 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918152331.5313F1B000@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26888

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-show-last-output)
(slime-show-last-output-function)
(slime-show-last-output-region)
(slime-maybe-display-output-buffer): Delete unused code.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/18 10:08:37	1.1518
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/18 15:23:25	1.1519
@@ -5,6 +5,13 @@
 
 2008-09-18  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-show-last-output)
+	(slime-show-last-output-function)
+	(slime-show-last-output-region)
+	(slime-maybe-display-output-buffer): Delete unused code.
+
+2008-09-18  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-eval-with-transcript): Accept some more arguments
 	so that we can also use it for compile-file.
 	(slime-eval-with-transcript-cont): New. Insert prompt.
--- /project/slime/cvsroot/slime/slime.el	2008/09/17 23:14:45	1.1024
+++ /project/slime/cvsroot/slime/slime.el	2008/09/18 15:23:30	1.1025
@@ -2544,31 +2544,6 @@
           slime-repl-package-stack '())
     (slime-repl-update-banner)))
 
-(defvar slime-show-last-output-function 
-  'slime-maybe-display-output-buffer
-  "*This function is called when a evaluation request is finished.
-It is called in the slime-output buffer and receives the region of the
-output as arguments.")
-
-(defun slime-show-last-output-region (start end)
-  (when (< start end)
-    (slime-display-buffer-region (current-buffer) (1- start)
-                                 slime-repl-input-start-mark)))
-
-(defun slime-maybe-display-output-buffer (start end)
-  (when (and (< start end)
-             (not (get-buffer-window (current-buffer) t)))
-    (display-buffer (current-buffer)))
-  (when (eobp)
-    (slime-repl-show-maximum-output t)))
-
-(defun slime-show-last-output ()
-  "Show the output from the last Lisp evaluation."
-  (with-current-buffer (slime-output-buffer)
-    (let ((start slime-output-start)
-          (end slime-output-end))
-      (funcall slime-show-last-output-function start end))))
-
 (defun slime-display-output-buffer ()
   "Display the output buffer and scroll to bottom."
   (with-current-buffer (slime-output-buffer)
@@ -2985,7 +2960,7 @@
     (goto-char (point-max)))
   (slime-repl-show-maximum-output))
 
-(defun slime-repl-show-maximum-output (&optional force)
+(defun slime-repl-show-maximum-output ()
   "Put the end of the buffer at the bottom of the window."
   (assert (eobp))
   (let ((win (get-buffer-window (current-buffer))))



From heller at common-lisp.net  Thu Sep 18 15:23:38 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 11:23:38 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918152338.114726A17C@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv26945

Modified Files:
	ChangeLog slime.el swank.lisp test.sh 
Log Message:
Some cleanups for the REPL code.

* slime.el (slime-show-last-output)
(slime-show-last-output-function)
(slime-show-last-output-region)
(slime-maybe-display-output-buffer)
(slime-repl-last-input-start-mark): Delete unused code.

(slime-repl-emit-result, slime-repl-insert-prompt)
(slime-repl-show-abort, slime-repl-insert-result)
(slime-insert-transcript-delimiter)
(slime-eval-with-transcript-cont): Consistently use save-excursion
and insert-before-markers.  We always want to preserve the cursor
position in the input region (for type-ahead).

(slime-batch-test): Use a timer.
(slime-check-buffer-contents): New function to test contents and
current position.  Use it in various places.

(sldb-recenter-region, def-slime-test interactive-eval)
(def-slime-test interactive-eval-output): Act slightly differently
when the test suite is executed in batch mode (without terminal).

* swank.lisp (handle-requests): Flush output.
(interactive-eval, interactive-eval): Don't use fresh-line, as
that makes it harder to test the REPL code.

* test.sh (Usage): Add a -T switch to run slime in the current
directory without copying (and compiling) everything to a
temporary directory.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/18 15:23:25	1.1519
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/18 15:23:37	1.1520
@@ -5,10 +5,36 @@
 
 2008-09-18  Helmut Eller  <heller at common-lisp.net>
 
+	Some cleanups for the REPL code.
+
 	* slime.el (slime-show-last-output)
 	(slime-show-last-output-function)
 	(slime-show-last-output-region)
-	(slime-maybe-display-output-buffer): Delete unused code.
+	(slime-maybe-display-output-buffer)
+	(slime-repl-last-input-start-mark): Delete unused code.
+
+	(slime-repl-emit-result, slime-repl-insert-prompt)
+	(slime-repl-show-abort, slime-repl-insert-result)
+	(slime-insert-transcript-delimiter)
+	(slime-eval-with-transcript-cont): Consistently use save-excursion
+	and insert-before-markers.  We always want to preserve the cursor
+	position in the input region (for type-ahead).
+
+	(slime-batch-test): Use a timer.
+	(slime-check-buffer-contents): New function to test contents and
+	current position.  Use it in various places.
+
+	(sldb-recenter-region, def-slime-test interactive-eval)
+	(def-slime-test interactive-eval-output): Act slightly differently
+	when the test suite is executed in batch mode (without terminal).
+
+	* swank.lisp (handle-requests): Flush output.
+	(interactive-eval, interactive-eval): Don't use fresh-line, as
+	that makes it harder to test the REPL code.
+
+	* test.sh (Usage): Add a -T switch to run slime in the current
+	directory without copying (and compiling) everything to a
+	temporary directory.
 
 2008-09-18  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/slime.el	2008/09/18 15:23:30	1.1025
+++ /project/slime/cvsroot/slime/slime.el	2008/09/18 15:23:37	1.1026
@@ -53,12 +53,13 @@
   (require 'cl)
   (unless (fboundp 'define-minor-mode)
     (require 'easy-mmode)
-    (defalias 'define-minor-mode 'easy-mmode-define-minor-mode)))
+    (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))
+  (when (locate-library "hyperspec")
+    (require 'hyperspec)))
 (require 'comint)
 (require 'timer)
 (require 'pp)
 (require 'hideshow)
-(require 'hyperspec)
 (require 'font-lock)
 (when (featurep 'xemacs)
   (require 'overlay))
@@ -2674,12 +2675,12 @@
 (defun slime-repl-emit-result (string &optional bol)
   ;; insert STRING and mark it as evaluation result
   (with-current-buffer (slime-output-buffer)
-    (goto-char slime-repl-input-start-mark)
-    (when (and bol (not (bolp))) (insert "\n"))
-    (slime-insert-propertized `(face slime-repl-result-face
-                                     rear-nonsticky (face)) 
-                              string)
-    (set-marker slime-repl-input-start-mark (point))))
+    (save-excursion
+      (goto-char slime-repl-input-start-mark)
+      (when (and bol (not (bolp))) (insert-before-markers "\n"))
+      (slime-propertize-region `(face slime-repl-result-face
+                                      rear-nonsticky (face))
+        (insert-before-markers string)))))
 
 (defvar slime-last-output-target-id 0
   "The last integer we used as a TARGET id.")
@@ -2790,7 +2791,6 @@
  (defvar slime-repl-prompt-start-mark)
  (defvar slime-repl-input-start-mark)
  (defvar slime-repl-input-end-mark)
- (defvar slime-repl-last-input-start-mark)
  (defvar slime-repl-old-input-counter 0
    "Counter used to generate unique `slime-repl-old-input' properties.
 This property value must be unique to avoid having adjacent inputs be
@@ -2801,8 +2801,7 @@
                       slime-output-end
                       slime-repl-prompt-start-mark
                       slime-repl-input-start-mark
-                      slime-repl-input-end-mark
-                      slime-repl-last-input-start-mark))
+                      slime-repl-input-end-mark))
     (set markname (make-marker))
     (set-marker (symbol-value markname) (point)))
   ;; (set-marker-insertion-type slime-output-end t)
@@ -2921,29 +2920,33 @@
 
 (defun slime-repl-insert-result (result)
   (with-current-buffer (slime-output-buffer)
-    (goto-char (point-max))
-    (when result
-      (destructure-case result
-        ((:values &rest strings)
-         (cond ((null strings)
-                (slime-repl-emit-result "; No value\n" t))
-               (t
-                (dolist (s strings)
-                  (slime-repl-emit-result s t)))))))
-    (slime-repl-insert-prompt)))
+    (save-excursion
+      (when result
+        (destructure-case result
+          ((:values &rest strings)
+           (cond ((null strings)
+                  (slime-repl-emit-result "; No value\n" t))
+                 (t
+                  (dolist (s strings)
+                    (slime-repl-emit-result s t)))))))
+      (slime-repl-insert-prompt))
+    (slime-repl-show-maximum-output)))
 
 (defun slime-repl-show-abort ()
   (with-current-buffer (slime-output-buffer)
-    (slime-with-output-end-mark 
-     (unless (bolp) (insert-before-markers "\n"))
-     (insert-before-markers "; Evaluation aborted.\n"))
-    (slime-repl-insert-prompt)))
+    (save-excursion
+      (goto-char slime-repl-input-start-mark)
+      (let ((output-start (point)))
+        (insert-before-markers "; Evaluation aborted.\n")
+        (slime-repl-insert-prompt)
+        (slime-mark-output-start output-start)))
+    (slime-repl-show-maximum-output)))
 
 (defun slime-repl-insert-prompt ()
-  "Goto to point max, and insert the prompt."
-  (goto-char slime-repl-input-start-mark)
+  "Insert the prompt (before markers!)."
   (assert (= slime-repl-input-end-mark (point-max)))
-  (unless (bolp) (insert "\n"))
+  (goto-char slime-repl-input-start-mark)
+  (unless (bolp) (insert-before-markers "\n"))
   (let ((prompt-start (point))
         (prompt (format "%s> " (slime-lisp-package-prompt-string))))
     (slime-propertize-region
@@ -2953,21 +2956,17 @@
                rear-nonsticky (slime-repl-prompt read-only face intangible)
                ;; xemacs stuff
                start-open t end-open t)
-      (insert prompt))
-    (slime-mark-input-start)
-    (set-marker slime-repl-input-end-mark (point-max))
-    (set-marker slime-repl-prompt-start-mark prompt-start)
-    (goto-char (point-max)))
-  (slime-repl-show-maximum-output))
+      (insert-before-markers prompt))
+    (set-marker slime-repl-prompt-start-mark prompt-start)))
 
 (defun slime-repl-show-maximum-output ()
   "Put the end of the buffer at the bottom of the window."
-  (assert (eobp))
-  (let ((win (get-buffer-window (current-buffer))))
-    (when win
-      (with-selected-window win
-        (set-window-point win (point-max)) 
-        (recenter -1)))))
+  (when (eobp)
+    (let ((win (get-buffer-window (current-buffer))))
+      (when win
+        (with-selected-window win
+          (set-window-point win (point-max)) 
+          (recenter -1))))))
 
 (defvar slime-repl-current-input-hooks)
 
@@ -2990,8 +2989,6 @@
     (next-single-property-change 0 text-property object)))
   
 (defun slime-mark-input-start ()
-  (set-marker slime-repl-last-input-start-mark
-              (marker-position slime-repl-input-start-mark))
   (set-marker slime-repl-input-start-mark (point) (current-buffer))
   (set-marker slime-repl-input-end-mark (point) (current-buffer)))
 
@@ -3244,7 +3241,6 @@
 (defun slime-repl-clear-buffer ()
   "Delete the output generated by the Lisp process."
   (interactive)
-  (set-marker slime-repl-last-input-start-mark nil)
   (let ((inhibit-read-only t))
     (delete-region (point-min) slime-repl-prompt-start-mark)
     (delete-region slime-output-start slime-output-end)
@@ -5434,16 +5430,33 @@
     ((:ok value) (slime-eval-with-transcript-cont t value cont))
     ((:abort) (slime-eval-with-transcript-cont nil nil nil))))
 
+(defun slime-insert-transcript-delimiter (string)
+  (with-current-buffer (slime-output-buffer)
+    (save-excursion
+      (goto-char slime-repl-input-start-mark)
+      (assert (= (point-max) slime-repl-input-end-mark))
+      (unless (bolp) (insert-before-markers "\n"))
+      (slime-propertize-region '(slime-transcript-delimiter t)
+        (insert-before-markers
+         ";;;; " (subst-char-in-string ?\n ?\ 
+                                       (substring string 0 
+                                                  (min 60 (length string))))
+         " ...\n"))
+      (assert (= (point) slime-repl-input-start-mark))
+      (slime-mark-output-start))
+    (slime-repl-show-maximum-output)))
+
 (defun slime-eval-with-transcript-cont (ok result cont)
   (run-with-timer 0.2 nil (lambda ()
                             (setq slime-repl-popup-on-output nil)))
   (with-current-buffer (slime-output-buffer)
-    (let ((output-start (point-max)))
-      (goto-char (point-max))
-      (slime-repl-insert-prompt)
-      (slime-mark-output-start output-start)))
-  (cond (ok (funcall cont result))
-        (t (message "Evaluation aborted."))))
+    (save-excursion
+      (let ((output-start slime-repl-input-start-mark))
+        (slime-repl-insert-prompt)
+        (slime-mark-output-start output-start)))
+    (slime-repl-show-maximum-output)
+    (cond (ok (funcall cont result))
+        (t (message "Evaluation aborted.")))))
 
 (defun slime-eval-describe (form)
   "Evaluate FORM in Lisp and display the result in a new buffer."
@@ -5455,19 +5468,6 @@
     (princ string)
     (goto-char (point-min))))
 
-(defun slime-insert-transcript-delimiter (string)
-  (with-current-buffer (slime-output-buffer)
-    (goto-char (point-max))
-    (unless (bolp) (insert-before-markers "\n"))
-    (slime-propertize-region '(slime-transcript-delimiter t)
-      (insert-before-markers
-       ";;;; " (subst-char-in-string ?\n ?\ 
-                                     (substring string 0 
-                                                (min 60 (length string))))
-       " ...\n"))
-    (slime-mark-output-start)
-    (slime-mark-input-start)))
-
 (defun slime-display-buffer-region (buffer start end &optional other-window)
   "Like `display-buffer', but only display the specified region."
   (let ((window-min-height 1))
@@ -7070,7 +7070,8 @@
                   (goto-char pos))
                  (t
                   (goto-char start)
-                  (next-line (- (window-height) 2))))))))
+                  (unless noninteractive ; for running the test suite
+                    (next-line (- (window-height) 2)))))))))
 
 ;; not sure yet, whether this is a good idea.
 (defmacro slime-save-coordinates (origin &rest body)
@@ -8598,13 +8599,18 @@
   (let ((slime-test-debug-on-error nil))
     (slime)
     ;; Block until we are up and running.
-    (let ((i 0))
+    (let* ((timeout 30)
+           (cell (cons nil nil))
+           (timer (run-with-timer timeout nil (lambda (cell) 
+                                                (setcar cell t))
+                                  cell)))
       (while (not (slime-connected-p))
-        (incf i)
-        (when (> i 30)
-          (with-temp-file results-file (insert "Failed to connect."))
-          (kill-emacs 255))
-        (sit-for 1)))
+        (sit-for 1)
+        (when (car cell)
+          (with-temp-file results-file 
+            (insert (format "TIMEOUT: Failed to connect within %s seconds."
+                            timeout)))
+          (kill-emacs 252))))
     (slime-sync-to-top-level 5)
     (switch-to-buffer "*scratch*")
     (let ((failed-tests (slime-run-tests)))
@@ -8683,7 +8689,8 @@
          (defun ,fname ,args
            ,doc
            (slime-sync-to-top-level 0.3)
-           , at body)
+           , at body
+           (slime-sync-to-top-level 0.3))
          (setq slime-tests 
                (append (remove* ',name slime-tests :key 'slime-test.name)
                        (list (make-slime-test :name ',name :fname ',fname
@@ -8711,7 +8718,7 @@
            (debug (format "Check failed: %S" ,check-name)))))))
 
 (defun slime-print-check-ok (test-name)
-  (slime-test-message test-name))
+  (slime-test-message (concat "OK: " test-name)))
 
 (defun slime-print-check-failed (test-name)
   (slime-test-failure "FAILED" test-name))
@@ -8981,7 +8988,6 @@
 (def-slime-test async-eval-debugging (depth)
   "Test recursive debugging of asynchronous evaluation requests."
   '((1) (2) (3))
-  (slime-check-top-level)
   (lexical-let ((depth depth)
                 (debug-hook-max-depth 0))
     (let ((debug-hook
@@ -8998,7 +9004,6 @@
       (let ((sldb-hook (cons debug-hook sldb-hook)))
         (slime-eval-async '(error))
         (slime-sync-to-top-level 5)
-        (slime-check-top-level)
         (slime-check ("Maximum depth reached (%S) is %S."
                       debug-hook-max-depth depth)
           (= debug-hook-max-depth depth))))))
@@ -9091,9 +9096,10 @@
       (while (not done) (slime-accept-process-output))
       (slime-sync-to-top-level 5)
       (slime-check-top-level)
-      (let ((message (current-message)))
-        (slime-check "Minibuffer contains: \"3\""
-          (equal "=> 3 (#x3, #o3, #b11)" message))))))
+      (unless noninteractive
+        (let ((message (current-message)))
+          (slime-check "Minibuffer contains: \"3\""
+            (equal "=> 3 (#x3, #o3, #b11)" message)))))))
 
 (def-slime-test interrupt-bubbling-idiot 
     ()
@@ -9140,15 +9146,13 @@
     "Test simple commands in the minibuffer."
     '(("(+ 1 2)" "SWANK> (+ 1 2)
 3
-SWANK> ")
+SWANK> *")
       ("(princ 10)" "SWANK> (princ 10)
-10
-10
-SWANK> ")
+1010
+SWANK> *")
       ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
-1020
-20
-SWANK> ")
+102020
+SWANK> *")
       ("(dotimes (i 10 77) (princ i) (terpri))" 
        "SWANK> (dotimes (i 10 77) (princ i) (terpri))
 0
@@ -9162,19 +9166,33 @@
 8
 9
 77
-SWANK> "))
+SWANK> *")
+      ("(abort)" "SWANK> (abort)
+; Evaluation aborted.
+SWANK> *")
+      ("(progn (princ 10) (finish-output) (abort))" 
+       "SWANK> (progn (princ 10) (finish-output) (abort))
+10; Evaluation aborted.
+SWANK> *")
+      ("(progn (princ 10) (abort))" "SWANK> (progn (princ 10) (abort))
+10; Evaluation aborted.
+SWANK> *"))
   (with-current-buffer (slime-output-buffer)
     (setf (slime-lisp-package-prompt-string) "SWANK"))
   (kill-buffer (slime-output-buffer))
   (with-current-buffer (slime-output-buffer)
     (insert input)
-    (slime-test-expect "Buffer contains input" 
-                       (concat "SWANK> " input)
-                       (buffer-string))
+    (slime-check-buffer-contents "Buffer contains input" 
+                                 (concat "SWANK> " input "*"))
     (call-interactively 'slime-repl-return)
     (slime-sync-to-top-level 5)
-    (slime-test-expect "Buffer contains result" 
-                       result-contents (buffer-string))))
+    (slime-check-buffer-contents "Buffer contains result" result-contents)))
+
+(defun slime-check-buffer-contents (msg expected)
+  (let ((point (position ?* expected))
+        (string (delete* ?* expected)))
+    (slime-test-expect (concat msg "[content]") string (buffer-string))
+    (slime-test-expect (concat msg "[point]") (1+ point) (point))))
 
 (def-slime-test repl-return 
     (before after result-contents)
@@ -9264,51 +9282,65 @@
     (command input final-contents)
     "Ensure that user input is preserved correctly.
 In particular, input inserted while waiting for a result."
-    '(("(sleep 1)" "foo" "SWANK> (sleep 1)
+    '(("(sleep 0.1)" "foo*" "SWANK> (sleep 0.1)
+NIL
+SWANK> foo*")
+      ("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1)
 NIL
-SWANK> foo"))
+SWANK> *foo")
+      ("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort))
+; Evaluation aborted.
+SWANK> *foo"))
   (when (slime-output-buffer)
     (kill-buffer (slime-output-buffer)))
   (setf (slime-lisp-package-prompt-string) "SWANK")
   (with-current-buffer (slime-output-buffer)
     (insert command)
     (call-interactively 'slime-repl-return)
-    (insert input)
+    (save-excursion (insert (delete* ?* input)))
+    (forward-char (position ?* input))
     (slime-sync-to-top-level 5)
-    (slime-check "Buffer contains result"
-      (equal final-contents (buffer-string)))))
+    (slime-check-buffer-contents "Buffer contains result" final-contents)))
 
 (def-slime-test interactive-eval-output
     (input result-contents visiblep)
     "Test simple commands in the minibuffer."
-    '(("(+ 1 2)" "SWANK> 
+    `(("(+ 1 2)" "SWANK> 
 ;;;; (+ 1 2) ...
-SWANK> " nil)
+SWANK> *" nil)
       ("(princ 10)" "SWANK> 
 ;;;; (princ 10) ...
 10
-SWANK> " t)
-      ("(princ \"????????????????????????????\")"

[53 lines skipped]
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/17 18:42:17	1.592
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/18 15:23:37	1.593
@@ -946,7 +946,8 @@
          (let* ((*sldb-quit-restart* (find-restart 'abort))
                 (timeout? (process-requests timeout just-one)))
            (when (or just-one timeout?) 
-             (return))))))))
+             (return))))
+       (force-user-output)))))
 
 (defun process-requests (timeout just-one)
   "Read and process requests from Emacs."
@@ -1886,7 +1887,6 @@
   (with-buffer-syntax ()
     (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
       (let ((values (multiple-value-list (eval (from-string string)))))
-        (fresh-line)
         (finish-output)
         (format-values-for-echo-area values)))))
 
@@ -1991,7 +1991,6 @@
                              (package-string-for-prompt *package*)))))))
 
 (defun send-repl-results-to-emacs (values)    
-  (fresh-line)
   (finish-output)
   (if (null values)
       (send-to-emacs `(:write-string "; No value" :repl-result))
--- /project/slime/cvsroot/slime/test.sh	2008/08/17 23:01:19	1.15
+++ /project/slime/cvsroot/slime/test.sh	2008/09/18 15:23:37	1.16
@@ -16,21 +16,24 @@
 function usage () {
     cat <<EOF
 Usage: $name [-b] [-s] [-r]  <emacs> <lisp>"
-  -b  disable batch mode
-  -s  use screen to hide emacs
   -r  show results file
+  -s  use screen to hide emacs
+  -B  disable batch mode
+  -T  no temp directory (use slime in current directory)
 EOF
     exit 1
 }
 
 name=$0
-batch_mode=-batch
+batch_mode=-batch # command line arg for emacs
+use_temp_dir=true
 
-while getopts srb opt; do
+while getopts srBT opt; do
     case $opt in
 	s) use_screen=true;;
 	r) dump_results=true;;
-	b) batch_mode="";;
+	B) batch_mode="";;
+	T) use_temp_dir=false;;
 	*) usage;;
     esac
 done
@@ -44,18 +47,23 @@
 # for the current lisp.
 
 slimedir=$(dirname $name)
-testdir=/tmp/slime-test.$$
-results=$testdir/results
-dribble=$testdir/dribble
-statusfile=$testdir/status
-
-test -d $testdir && rm -r $testdir
-
-trap "rm -r $testdir" EXIT	# remove temporary directory on exit
-
-mkdir $testdir
-cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib  $testdir
-mkfifo $dribble
+tmpdir=/tmp/slime-test.$$
+if [ $use_temp_dir == true ] ; then
+    testdir=$tmpdir
+else
+    testdir=$(pwd)
+fi
+results=$tmpdir/results
+statusfile=$tmpdir/status
+
+test -d $tmpdir && rm -r $tmpdir
+
+trap "rm -r $tmpdir" EXIT	# remove temporary directory on exit
+
+mkdir $tmpdir
+if [ $use_temp_dir == true ] ; then 
+    cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib  $tmpdir
+fi
 
 cmd=($emacs -nw -q -no-site-file $batch_mode --no-site-file
        --eval "(setq debug-on-quit t)"



From heller at common-lisp.net  Thu Sep 18 15:23:44 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 11:23:44 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918152344.059C1232DA@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv27007

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-eval-with-transcript): Change order of arguments to
make the common case easier to use.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/18 15:23:37	1.1520
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/18 15:23:43	1.1521
@@ -19,6 +19,8 @@
 	(slime-eval-with-transcript-cont): Consistently use save-excursion
 	and insert-before-markers.  We always want to preserve the cursor
 	position in the input region (for type-ahead).
+	(slime-eval-with-transcript):  Change order of arguments to
+	make the common case easier to use.
 
 	(slime-batch-test): Use a timer.
 	(slime-check-buffer-contents): New function to test contents and
@@ -32,7 +34,7 @@
 	(interactive-eval, interactive-eval): Don't use fresh-line, as
 	that makes it harder to test the REPL code.
 
-	* test.sh (Usage): Add a -T switch to run slime in the current
+	* test.sh (usage): Add a -T switch to run slime in the current
 	directory without copying (and compiling) everything to a
 	temporary directory.
 
--- /project/slime/cvsroot/slime/slime.el	2008/09/18 15:23:37	1.1026
+++ /project/slime/cvsroot/slime/slime.el	2008/09/18 15:23:43	1.1027
@@ -3924,9 +3924,9 @@
   (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max))
   (let ((file (slime-to-lisp-filename (buffer-file-name))))
     (slime-eval-with-transcript
+     `(swank:compile-file-for-emacs ,file ,(if load t nil))
      (format "Compile file %s" file)
      slime-display-compilation-output
-     `(swank:compile-file-for-emacs ,file ,(if load t nil))
      (slime-rcurry #'slime-compilation-finished (current-buffer)))
     (message "Compiling %s..." file)))
 
@@ -5405,8 +5405,8 @@
 inserted in the current buffer."
   (interactive (list (slime-read-from-minibuffer "Slime Eval: ")))
   (cond ((not current-prefix-arg)
-         (slime-eval-with-transcript string t `(swank:interactive-eval ,string)
-                                     'slime-display-eval-result))
+         (slime-eval-with-transcript `(swank:interactive-eval ,string) 
+                                     string))
         (t
          (slime-eval-print string))))
 
@@ -5422,10 +5422,11 @@
                           (destructuring-bind (output value) result
                             (insert output value)))))))
 
-(defun slime-eval-with-transcript (msg show-output form cont)
+(defun slime-eval-with-transcript (form &optional msg no-popups cont)
   "Eval FROM in Lisp.  Display output, if any, caused by the evaluation."
-  (slime-insert-transcript-delimiter msg)
-  (setq slime-repl-popup-on-output show-output)
+  (when msg (slime-insert-transcript-delimiter msg))
+  (setq slime-repl-popup-on-output (not no-popups))
+  (setq cont (or cont #'slime-display-eval-result))
   (slime-rex (cont) (form)
     ((:ok value) (slime-eval-with-transcript-cont t value cont))
     ((:abort) (slime-eval-with-transcript-cont nil nil nil))))
@@ -5514,7 +5515,7 @@
 (defun slime-eval-region (start end)
   "Evaluate region."
   (interactive "r")
-  (slime-eval-with-transcript
+  (slime-eval-with-transcript 
    `(swank:interactive-eval-region 
      ,(buffer-substring-no-properties start end))))
 
@@ -5864,8 +5865,6 @@
   (let ((lisp-filename (slime-to-lisp-filename (expand-file-name filename))))
     (slime-eval-with-transcript `(swank:load-file ,lisp-filename))))
 
-
-
 
 ;;;; Profiling
 



From heller at common-lisp.net  Thu Sep 18 22:35:34 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 18:35:34 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918223534.86C494204D@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2717

Modified Files:
	slime.el 
Log Message:
(slime-eval-with-transcript-cont): Save the position of the
input-start-mark not the marker itself.

--- /project/slime/cvsroot/slime/slime.el	2008/09/18 15:23:43	1.1027
+++ /project/slime/cvsroot/slime/slime.el	2008/09/18 22:35:31	1.1028
@@ -5452,7 +5452,7 @@
                             (setq slime-repl-popup-on-output nil)))
   (with-current-buffer (slime-output-buffer)
     (save-excursion
-      (let ((output-start slime-repl-input-start-mark))
+      (let ((output-start (marker-position slime-repl-input-start-mark)))
         (slime-repl-insert-prompt)
         (slime-mark-output-start output-start)))
     (slime-repl-show-maximum-output)
@@ -9323,6 +9323,10 @@
       ("(progn (princ 10) (finish-output) (abort))" "SWANK> 
 ;;;; (progn (princ 10) (finish-output) (abort)) ...
 10
+SWANK> *" t)
+      ("(progn (princ 10) (abort))" "SWANK> 
+;;;; (progn (princ 10) (abort)) ...
+10
 SWANK> *" t))
   (with-current-buffer (slime-output-buffer)
     (setf (slime-lisp-package-prompt-string) "SWANK"))



From heller at common-lisp.net  Thu Sep 18 22:35:37 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 18:35:37 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918223537.F23F842056@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2747

Modified Files:
	slime.el 
Log Message:
* slime.el (slime-compile-file): Invert logic for the display-output arg.

--- /project/slime/cvsroot/slime/slime.el	2008/09/18 22:35:31	1.1028
+++ /project/slime/cvsroot/slime/slime.el	2008/09/18 22:35:37	1.1029
@@ -3926,7 +3926,7 @@
     (slime-eval-with-transcript
      `(swank:compile-file-for-emacs ,file ,(if load t nil))
      (format "Compile file %s" file)
-     slime-display-compilation-output
+     (not slime-display-compilation-output)
      (slime-rcurry #'slime-compilation-finished (current-buffer)))
     (message "Compiling %s..." file)))
 



From heller at common-lisp.net  Thu Sep 18 22:35:46 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 18:35:46 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918223546.000566A166@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2780

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-save-marker): New marcro. Use it in combination
with insert-before-markers.
(slime-check-buffer-contents): Use {} resp. [] to describe the
position of output resp. input markers.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/18 15:23:43	1.1521
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/18 22:35:46	1.1522
@@ -1,3 +1,10 @@
+2008-09-19  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-save-marker): New marcro. Use it in combination
+	with insert-before-markers.
+	(slime-check-buffer-contents): Use {} resp. [] to describe the
+	position of output resp. input markers.
+
 2008-09-18  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-ecl.lisp: Forgot to update ECL's backend when introducing
--- /project/slime/cvsroot/slime/slime.el	2008/09/18 22:35:37	1.1029
+++ /project/slime/cvsroot/slime/slime.el	2008/09/18 22:35:46	1.1030
@@ -2643,44 +2643,44 @@
   "Display the output buffer when some output is written.
 This is set to nil after displaying the buffer.")
 
+(defmacro slime-save-marker (marker &rest body)
+  (let ((pos (gensym "pos")))
+  `(let ((,pos (marker-position ,marker)))
+     (prog1 (progn . ,body)
+       (set-marker ,marker ,pos)))))
+
+(put 'slime-save-marker 'lisp-indent-function 1)
+
 (defun slime-repl-emit (string)
   ;; insert the string STRING in the output buffer
   (with-current-buffer (slime-output-buffer)
     (save-excursion
-      (slime-repl-insert-at-markers slime-output-start slime-output-end
-                                    string '(face slime-repl-output-face
-                                                  rear-nonsticky (face)))
       (goto-char slime-output-end)
-      (when (and (= (point) slime-repl-prompt-start-mark)
-                 (not (bolp)))
-        (insert "\n")
-        (set-marker slime-output-end (1- (point))))
-      (assert (<= (point) slime-repl-input-start-mark))
-      (when slime-repl-popup-on-output
-        (setq slime-repl-popup-on-output nil)
-        (display-buffer (current-buffer))))
+      (slime-save-marker slime-output-start
+        (slime-propertize-region '(face slime-repl-output-face 
+                                        rear-nonsticky (face))
+          (insert-before-markers string)
+          (when (and (= (point) slime-repl-prompt-start-mark)
+                     (not (bolp)))
+            (insert-before-markers "\n")
+            (set-marker slime-output-end (1- (point)))))))
+    (when slime-repl-popup-on-output
+      (setq slime-repl-popup-on-output nil)
+      (display-buffer (current-buffer)))
     (when (eobp)
       (slime-repl-show-maximum-output))))
 
-(defun slime-repl-insert-at-markers (marker1 marker2 string &optional props)
-  (goto-char marker2)
-  (let ((start (point)))
-    (insert-before-markers string)
-    (cond ((< marker1 marker2))
-          ((= marker1 marker2) (set-marker marker1 start))
-          (t (assert (<= marker1 marker2))))
-    (when props
-      (add-text-properties start marker2 props))))
-
 (defun slime-repl-emit-result (string &optional bol)
   ;; insert STRING and mark it as evaluation result
   (with-current-buffer (slime-output-buffer)
     (save-excursion
-      (goto-char slime-repl-input-start-mark)
-      (when (and bol (not (bolp))) (insert-before-markers "\n"))
-      (slime-propertize-region `(face slime-repl-result-face
-                                      rear-nonsticky (face))
-        (insert-before-markers string)))))
+      (slime-save-marker slime-output-start
+        (slime-save-marker slime-output-end
+          (goto-char slime-repl-input-start-mark)
+          (when (and bol (not (bolp))) (insert-before-markers "\n"))
+          (slime-propertize-region `(face slime-repl-result-face
+                                          rear-nonsticky (face))
+            (insert-before-markers string)))))))
 
 (defvar slime-last-output-target-id 0
   "The last integer we used as a TARGET id.")
@@ -2804,7 +2804,6 @@
                       slime-repl-input-end-mark))
     (set markname (make-marker))
     (set-marker (symbol-value markname) (point)))
-  ;; (set-marker-insertion-type slime-output-end t)
   (set-marker-insertion-type slime-repl-input-end-mark t)
   (set-marker-insertion-type slime-repl-prompt-start-mark t))
 
@@ -2935,29 +2934,33 @@
 (defun slime-repl-show-abort ()
   (with-current-buffer (slime-output-buffer)
     (save-excursion
-      (goto-char slime-repl-input-start-mark)
-      (let ((output-start (point)))
-        (insert-before-markers "; Evaluation aborted.\n")
-        (slime-repl-insert-prompt)
-        (slime-mark-output-start output-start)))
+      (goto-char (slime-repl-insert-prompt))
+      (slime-save-marker slime-output-start
+        (slime-save-marker slime-output-end
+          (insert "; Evaluation aborted.\n"))))
     (slime-repl-show-maximum-output)))
 
 (defun slime-repl-insert-prompt ()
-  "Insert the prompt (before markers!)."
+  "Insert the prompt (before markers!).
+Set point after the prompt.  
+Return the position of the prompt beginning."
   (assert (= slime-repl-input-end-mark (point-max)))
   (goto-char slime-repl-input-start-mark)
-  (unless (bolp) (insert-before-markers "\n"))
-  (let ((prompt-start (point))
-        (prompt (format "%s> " (slime-lisp-package-prompt-string))))
-    (slime-propertize-region
-        '(face slime-repl-prompt-face read-only t intangible t
-               slime-repl-prompt t
-               ;; emacs stuff
-               rear-nonsticky (slime-repl-prompt read-only face intangible)
-               ;; xemacs stuff
-               start-open t end-open t)
-      (insert-before-markers prompt))
-    (set-marker slime-repl-prompt-start-mark prompt-start)))
+  (slime-save-marker slime-output-start
+    (slime-save-marker slime-output-end
+      (unless (bolp) (insert-before-markers "\n"))
+      (let ((prompt-start (point))
+            (prompt (format "%s> " (slime-lisp-package-prompt-string))))
+        (slime-propertize-region
+            '(face slime-repl-prompt-face read-only t intangible t
+                   slime-repl-prompt t
+                   ;; emacs stuff
+                   rear-nonsticky (slime-repl-prompt read-only face intangible)
+                   ;; xemacs stuff
+                   start-open t end-open t)
+          (insert-before-markers prompt))
+        (set-marker slime-repl-prompt-start-mark prompt-start)
+        prompt-start))))
 
 (defun slime-repl-show-maximum-output ()
   "Put the end of the buffer at the bottom of the window."
@@ -2992,10 +2995,9 @@
   (set-marker slime-repl-input-start-mark (point) (current-buffer))
   (set-marker slime-repl-input-end-mark (point) (current-buffer)))
 
-(defun slime-mark-output-start (&optional position)
-  (let ((position (or position (point))))
-    (set-marker slime-output-start position)
-    (set-marker slime-output-end position)))
+(defun slime-mark-output-start ()
+  (set-marker slime-output-start (point))
+  (set-marker slime-output-end (point)))
 
 (defun slime-mark-output-end ()
   ;; Don't put slime-repl-output-face again; it would remove the
@@ -5451,10 +5453,7 @@
   (run-with-timer 0.2 nil (lambda ()
                             (setq slime-repl-popup-on-output nil)))
   (with-current-buffer (slime-output-buffer)
-    (save-excursion
-      (let ((output-start (marker-position slime-repl-input-start-mark)))
-        (slime-repl-insert-prompt)
-        (slime-mark-output-start output-start)))
+    (save-excursion (slime-repl-insert-prompt))
     (slime-repl-show-maximum-output)
     (cond (ok (funcall cont result))
         (t (message "Evaluation aborted.")))))
@@ -9144,17 +9143,17 @@
     (input result-contents)
     "Test simple commands in the minibuffer."
     '(("(+ 1 2)" "SWANK> (+ 1 2)
-3
-SWANK> *")
+{}3
+SWANK> *[]")
       ("(princ 10)" "SWANK> (princ 10)
-1010
-SWANK> *")
+{10}10
+SWANK> *[]")
       ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
-102020
-SWANK> *")
+{1020}20
+SWANK> *[]")
       ("(dotimes (i 10 77) (princ i) (terpri))" 
        "SWANK> (dotimes (i 10 77) (princ i) (terpri))
-0
+{0
 1
 2
 3
@@ -9164,34 +9163,64 @@
 7
 8
 9
-77
-SWANK> *")
+}77
+SWANK> *[]")
       ("(abort)" "SWANK> (abort)
-; Evaluation aborted.
-SWANK> *")
+{}; Evaluation aborted.
+SWANK> *[]")
       ("(progn (princ 10) (finish-output) (abort))" 
        "SWANK> (progn (princ 10) (finish-output) (abort))
-10; Evaluation aborted.
-SWANK> *")
-      ("(progn (princ 10) (abort))" "SWANK> (progn (princ 10) (abort))
-10; Evaluation aborted.
-SWANK> *"))
+{10}
+; Evaluation aborted.
+SWANK> *[]")
+      ("(values 1 2 3)" "SWANK> (values 1 2 3)
+{}1
+2
+3
+SWANK> *[]"))
   (with-current-buffer (slime-output-buffer)
     (setf (slime-lisp-package-prompt-string) "SWANK"))
   (kill-buffer (slime-output-buffer))
   (with-current-buffer (slime-output-buffer)
     (insert input)
     (slime-check-buffer-contents "Buffer contains input" 
-                                 (concat "SWANK> " input "*"))
+                                 (concat "{}SWANK> [" input "*]"))
     (call-interactively 'slime-repl-return)
     (slime-sync-to-top-level 5)
     (slime-check-buffer-contents "Buffer contains result" result-contents)))
 
 (defun slime-check-buffer-contents (msg expected)
-  (let ((point (position ?* expected))
-        (string (delete* ?* expected)))
-    (slime-test-expect (concat msg "[content]") string (buffer-string))
-    (slime-test-expect (concat msg "[point]") (1+ point) (point))))
+  (let* ((marks '((point . ?*) 
+                  (output-start . ?{) (output-end . ?}) 
+                  (repl-input-start-mark . ?\[) (repl-input-end-mark . ?\])))
+         (marks (remove-if-not (lambda (m) (position (cdr m) expected))
+                               marks))
+         (marks (sort (copy-sequence marks) 
+                      (lambda (x y)
+                        (< (position (cdr x) expected)
+                           (position (cdr y) expected)))))
+         (content (remove-if (lambda (c) (member* c marks :key #'cdr))
+                             expected))
+         (marks (do ((result '() (acons (caar m) (1+ (position (cdar m) s))
+                                        result))
+                     (m marks (cdr m))
+                     (s expected (remove* (cdar m) s)))
+                    ((null m) (reverse result)))))
+    (slime-test-expect (concat msg " [content]") content (buffer-string))
+    (slime-test-expect (concat msg " [point]") 
+                       (cdr (assoc 'point marks))
+                       (point))
+    (macrolet ((test-mark 
+                (mark)
+                `(when (assoc ',mark marks)
+                   (slime-test-expect (format "%s [%s]" msg ',mark)
+                                      (cdr (assoc ',mark marks))
+                                      ,(intern (format "slime-%s" mark))
+                                      #'=))))
+      (test-mark output-end)
+      (test-mark output-start)
+      (test-mark repl-input-end-mark)
+      (test-mark repl-input-start-mark))))
 
 (def-slime-test repl-return 
     (before after result-contents)
@@ -9282,14 +9311,14 @@
     "Ensure that user input is preserved correctly.
 In particular, input inserted while waiting for a result."
     '(("(sleep 0.1)" "foo*" "SWANK> (sleep 0.1)
-NIL
-SWANK> foo*")
+{}NIL
+SWANK> [foo*]")
       ("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1)
-NIL
-SWANK> *foo")
+{}NIL
+SWANK> [*foo]")
       ("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort))
-; Evaluation aborted.
-SWANK> *foo"))
+{}; Evaluation aborted.
+SWANK> [*foo]"))
   (when (slime-output-buffer)
     (kill-buffer (slime-output-buffer)))
   (setf (slime-lisp-package-prompt-string) "SWANK")
@@ -9302,38 +9331,50 @@
     (slime-check-buffer-contents "Buffer contains result" final-contents)))
 
 (def-slime-test interactive-eval-output
-    (input result-contents visiblep)
+    (input result-contents visiblep &optional later)
     "Test simple commands in the minibuffer."
     `(("(+ 1 2)" "SWANK> 
 ;;;; (+ 1 2) ...
-SWANK> *" nil)
+{}SWANK> *[]" nil)
       ("(princ 10)" "SWANK> 
 ;;;; (princ 10) ...
-10
-SWANK> *" t)
-      ,@(when (eq window-system 'x)
-          '(("(princ \"????????????????????????????\")"
-             "SWANK> 
-;;;; (princ \"????????????????????????????\") ...
-????????????????????????????
-SWANK> *" t)))
+{10}
+SWANK> *[]" t)
+      ("(princ 11)" "SWANK> 
+;;;; (princ 11) ...
+{1122}
+SWANK> *[]" t "22")
+;;       ,@(when (eq window-system 'x)
+;;           '(("(princ \"????????????????????????????\")"
+;;              "SWANK> 
+;; ;;;; (princ \"????????????????????????????\") ...
+;; ????????????????????????????
+;; SWANK> *" t)))
       ("(abort)" "SWANK> 
 ;;;; (abort) ...
-SWANK> *" nil)
+{}SWANK> *[]" nil)
       ("(progn (princ 10) (finish-output) (abort))" "SWANK> 
 ;;;; (progn (princ 10) (finish-output) (abort)) ...
-10
-SWANK> *" t)
-      ("(progn (princ 10) (abort))" "SWANK> 
-;;;; (progn (princ 10) (abort)) ...
-10
-SWANK> *" t))
+{10}
+SWANK> *[]" t)
+      ("(progn (princ 11) (finish-output) (abort))" "SWANK> 
+;;;; (progn (princ 11) (finish-output) (abort)) ...
+{1122}
+SWANK> *[]" t "22")
+      ("(+ 3 4)" "SWANK> 
+;;;; (+ 3 4) ...
+{22}
+SWANK> *[]" nil "22"))
   (with-current-buffer (slime-output-buffer)
     (setf (slime-lisp-package-prompt-string) "SWANK"))
   (kill-buffer (slime-output-buffer))
   (with-current-buffer (slime-output-buffer)
     (slime-interactive-eval input) 
-    (slime-sync-to-top-level 5)
+    (slime-sync-to-top-level 2)
+    (when later
+      (setq slime-repl-popup-on-output nil)
+      (slime-eval-async `(cl:write-string ,later))
+      (slime-sync-to-top-level 2))
     (slime-check-buffer-contents "Buffer contains result" result-contents)
     (unless noninteractive
       (sit-for 0.1)



From heller at common-lisp.net  Thu Sep 18 22:35:49 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 18:35:49 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918223549.6A1C71B01C@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2855

Modified Files:
	test.sh 
Log Message:
Change defaults.

--- /project/slime/cvsroot/slime/test.sh	2008/09/18 15:23:37	1.16
+++ /project/slime/cvsroot/slime/test.sh	2008/09/18 22:35:47	1.17
@@ -16,23 +16,24 @@
 function usage () {
     cat <<EOF
 Usage: $name [-b] [-s] [-r]  <emacs> <lisp>"
-  -r  show results file
+  -b  use batch mode
   -s  use screen to hide emacs
-  -B  disable batch mode
+  -R  don't show results file
   -T  no temp directory (use slime in current directory)
 EOF
     exit 1
 }
 
 name=$0
-batch_mode=-batch # command line arg for emacs
+batch_mode="" # command line arg for emacs
 use_temp_dir=true
+dump_results=false
 
-while getopts srBT opt; do
+while getopts bsRT opt; do
     case $opt in
+	b) batch_mode="-batch";;
 	s) use_screen=true;;
-	r) dump_results=true;;
-	B) batch_mode="";;
+	R) dump_results=false;;
 	T) use_temp_dir=false;;
 	*) usage;;
     esac



From heller at common-lisp.net  Thu Sep 18 22:35:51 2008
From: heller at common-lisp.net (heller)
Date: Thu, 18 Sep 2008 18:35:51 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080918223551.CA7911B01C@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2872

Modified Files:
	test.sh 
Log Message:
Fix usage string.

--- /project/slime/cvsroot/slime/test.sh	2008/09/18 22:35:47	1.17
+++ /project/slime/cvsroot/slime/test.sh	2008/09/18 22:35:50	1.18
@@ -15,7 +15,7 @@
 
 function usage () {
     cat <<EOF
-Usage: $name [-b] [-s] [-r]  <emacs> <lisp>"
+Usage: $name [-b] [-s] [-R] [-T]  <emacs> <lisp>"
   -b  use batch mode
   -s  use screen to hide emacs
   -R  don't show results file



From heller at common-lisp.net  Fri Sep 19 09:48:17 2008
From: heller at common-lisp.net (heller)
Date: Fri, 19 Sep 2008 05:48:17 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080919094817.9852B5C189@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv7737

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-repl-emit-result): Update window-point.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/18 22:35:46	1.1522
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/19 09:48:16	1.1523
@@ -5,6 +5,8 @@
 	(slime-check-buffer-contents): Use {} resp. [] to describe the
 	position of output resp. input markers.
 
+	(slime-repl-emit-result): Update window-point.
+
 2008-09-18  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-ecl.lisp: Forgot to update ECL's backend when introducing
--- /project/slime/cvsroot/slime/slime.el	2008/09/18 22:35:46	1.1030
+++ /project/slime/cvsroot/slime/slime.el	2008/09/19 09:48:16	1.1031
@@ -2680,7 +2680,8 @@
           (when (and bol (not (bolp))) (insert-before-markers "\n"))
           (slime-propertize-region `(face slime-repl-result-face
                                           rear-nonsticky (face))
-            (insert-before-markers string)))))))
+            (insert-before-markers string)))))
+    (slime-repl-show-maximum-output)))
 
 (defvar slime-last-output-target-id 0
   "The last integer we used as a TARGET id.")



From heller at common-lisp.net  Fri Sep 19 09:48:23 2008
From: heller at common-lisp.net (heller)
Date: Fri, 19 Sep 2008 05:48:23 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080919094823.87CEB5C19B@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv7784

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-randomize-test-order): New variable.
(slime-shuffle-list): New function.
(slime-run-tests): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/19 09:48:16	1.1523
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/19 09:48:22	1.1524
@@ -7,6 +7,10 @@
 
 	(slime-repl-emit-result): Update window-point.
 
+	(slime-randomize-test-order): New variable.
+	(slime-shuffle-list): New function.
+	(slime-run-tests): Use it.
+
 2008-09-18  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-ecl.lisp: Forgot to update ECL's backend when introducing
--- /project/slime/cvsroot/slime/slime.el	2008/09/19 09:48:16	1.1031
+++ /project/slime/cvsroot/slime/slime.el	2008/09/19 09:48:23	1.1032
@@ -2935,10 +2935,11 @@
 (defun slime-repl-show-abort ()
   (with-current-buffer (slime-output-buffer)
     (save-excursion
-      (goto-char (slime-repl-insert-prompt))
       (slime-save-marker slime-output-start
         (slime-save-marker slime-output-end
-          (insert "; Evaluation aborted.\n"))))
+          (goto-char slime-output-end)
+          (insert-before-markers "; Evaluation aborted.\n")
+          (slime-repl-insert-prompt))))
     (slime-repl-show-maximum-output)))
 
 (defun slime-repl-insert-prompt ()
@@ -8498,6 +8499,10 @@
 (defvar slime-lisp-under-test nil
   "The name of Lisp currently executing the tests.")
 
+(defvar slime-randomize-test-order t
+  "If t execute tests in random order.
+If nil, execute them in definition order.")
+
 ;; dynamically bound during a single test
 (defvar slime-current-test)
 (defvar slime-unexpected-failures)
@@ -8514,7 +8519,10 @@
   (slime-create-test-results-buffer)
   (unwind-protect
       (let ((slime-repl-history-file 
-             (expand-file-name "slime-repl-history" (slime-temp-directory))))
+             (expand-file-name "slime-repl-history" (slime-temp-directory)))
+            (slime-tests (if slime-randomize-test-order
+                             (slime-shuffle-list slime-tests)
+                           slime-tests)))
         (slime-execute-tests))
     (pop-to-buffer slime-test-buffer-name)
     (goto-char (point-min))
@@ -8542,6 +8550,18 @@
 (defun slime-test-should-fail-p ()
   (member slime-lisp-under-test (slime-test.fails-for slime-current-test)))
 
+(defun slime-shuffle-list (list)
+  (let* ((len (length list))
+         (taken (make-vector len nil))
+         (result (make-vector len nil)))
+    (dolist (e list)
+      (while (let ((i (random len)))
+               (cond ((aref taken i))
+                     (t (aset taken i t)
+                        (aset result i e)
+                        nil)))))
+    (append result '())))
+
 (defun slime-execute-tests ()
   "Execute each test case with each input.
 Return the number of failed tests."
@@ -9169,10 +9189,14 @@
       ("(abort)" "SWANK> (abort)
 {}; Evaluation aborted.
 SWANK> *[]")
-      ("(progn (princ 10) (finish-output) (abort))" 
-       "SWANK> (progn (princ 10) (finish-output) (abort))
-{10}
-; Evaluation aborted.
+      ("(progn (princ 10) (force-output) (abort))" 
+       "SWANK> (progn (princ 10) (force-output) (abort))
+{10}; Evaluation aborted.
+SWANK> *[]")
+      ("(progn (princ 10) (abort))" 
+       ;; output can be flushed after aborting
+       "SWANK> (progn (princ 10) (abort))
+{10}; Evaluation aborted.
 SWANK> *[]")
       ("(values 1 2 3)" "SWANK> (values 1 2 3)
 {}1



From heller at common-lisp.net  Fri Sep 19 09:48:29 2008
From: heller at common-lisp.net (heller)
Date: Fri, 19 Sep 2008 05:48:29 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080919094829.AB0D65C189@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv7841

Modified Files:
	ChangeLog slime.el test.sh 
Log Message:
* slime.el (slime-batch-test): Accept test-name and randomize arguments.
* test.sh (usage): Accept -n and -S options.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/19 09:48:22	1.1524
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/19 09:48:29	1.1525
@@ -10,6 +10,9 @@
 	(slime-randomize-test-order): New variable.
 	(slime-shuffle-list): New function.
 	(slime-run-tests): Use it.
+	(slime-batch-test): Accept test-name and randomize arguments.
+
+	* test.sh (usage): Accept -n and -S options.
 
 2008-09-18  Tobias C. Rittweiler  <tcr at freebits.de>
 
--- /project/slime/cvsroot/slime/slime.el	2008/09/19 09:48:23	1.1032
+++ /project/slime/cvsroot/slime/slime.el	2008/09/19 09:48:29	1.1033
@@ -8612,7 +8612,7 @@
         (message "%s" summary)
         slime-unexpected-failures))))
 
-(defun slime-batch-test (results-file)
+(defun slime-batch-test (results-file &optional test-name randomize)
   "Run the test suite in batch-mode.
 Exits Emacs when finished. The exit code is the number of failed tests."
   (let ((slime-test-debug-on-error nil))
@@ -8632,7 +8632,9 @@
           (kill-emacs 252))))
     (slime-sync-to-top-level 5)
     (switch-to-buffer "*scratch*")
-    (let ((failed-tests (slime-run-tests)))
+    (let ((slime-randomize-test-order (when randomize (random t) t))
+          (failed-tests (cond (test-name (slime-run-one-test test-name))
+                              (t (slime-run-tests)))))
       (with-current-buffer slime-test-buffer-name
         (slime-delete-hidden-outline-text)
         (goto-char (point-min))
--- /project/slime/cvsroot/slime/test.sh	2008/09/18 22:35:50	1.18
+++ /project/slime/cvsroot/slime/test.sh	2008/09/19 09:48:29	1.19
@@ -15,24 +15,30 @@
 
 function usage () {
     cat <<EOF
-Usage: $name [-b] [-s] [-R] [-T]  <emacs> <lisp>"
+Usage: $name [-bsRTS] [-n <name>] <emacs> <lisp>"
   -b  use batch mode
   -s  use screen to hide emacs
   -R  don't show results file
   -T  no temp directory (use slime in current directory)
+  -S  don't execute tests in random order (use default ordering)
+  -n <name>  run only the test with name <name>
 EOF
     exit 1
 }
 
 name=$0
 batch_mode="" # command line arg for emacs
+dump_results=true
 use_temp_dir=true
-dump_results=false
+test_name=nil
+randomize=t
 
-while getopts bsRT opt; do
+while getopts bsRTn: opt; do
     case $opt in
 	b) batch_mode="-batch";;
 	s) use_screen=true;;
+	n) test_name="'$OPTARG";;
+	S) randomize=nil;;
 	R) dump_results=false;;
 	T) use_temp_dir=false;;
 	*) usage;;
@@ -63,7 +69,7 @@
 
 mkdir $tmpdir
 if [ $use_temp_dir == true ] ; then 
-    cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib  $tmpdir
+    cp -r $slimedir/*.{el,lisp} ChangeLog $slimedir/contrib $tmpdir
 fi
 
 cmd=($emacs -nw -q -no-site-file $batch_mode --no-site-file
@@ -71,7 +77,7 @@
        --eval "(add-to-list 'load-path \"$testdir\")"
        --eval "(require 'slime)"
        --eval "(setq inferior-lisp-program \"$lisp\")"
-       --eval "(slime-batch-test \"$results\")")
+       --eval "(slime-batch-test \"$results\" $test_name $randomize)")
 
 if [ "$use_screen" = "" ]; then
     "${cmd[@]}"



From heller at common-lisp.net  Fri Sep 19 11:20:16 2008
From: heller at common-lisp.net (heller)
Date: Fri, 19 Sep 2008 07:20:16 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080919112016.87D4D2E228@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4059

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (frob-allegro-field-def): There seems to be a
new type :func handle it like :lisp.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/19 09:48:29	1.1525
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/19 11:20:15	1.1526
@@ -1,5 +1,10 @@
 2008-09-19  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-allegro.lisp (frob-allegro-field-def): There seems to be a
+	new type :func handle it like :lisp.
+
+2008-09-19  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-save-marker): New marcro. Use it in combination
 	with insert-before-markers.
 	(slime-check-buffer-contents): Use {} resp. [] to describe the
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/17 06:19:48	1.114
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2008/09/19 11:20:15	1.115
@@ -594,7 +594,7 @@
                        :unsigned-long :unsigned-half-long 
                        :unsigned-3byte)
        (label-value-line name (inspect::component-ref-v object access type)))
-      ((:lisp :value)
+      ((:lisp :value :func)
        (label-value-line name (inspect::component-ref object access)))
       (:indirect 
        (destructuring-bind (prefix count ref set) access



From heller at common-lisp.net  Fri Sep 19 11:20:25 2008
From: heller at common-lisp.net (heller)
Date: Fri, 19 Sep 2008 07:20:25 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080919112025.218A33F082@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4152

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el ([def-slime-test] break): Split it up in two versions
to make the debugger-hook issue more explicit.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/19 11:20:15	1.1526
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/19 11:20:22	1.1527
@@ -1,5 +1,8 @@
 2008-09-19  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el ([def-slime-test] break): Split it up in two versions
+	to make the debugger-hook issue more explicit.
+
 	* swank-allegro.lisp (frob-allegro-field-def): There seems to be a
 	new type :func handle it like :lisp.
 
--- /project/slime/cvsroot/slime/slime.el	2008/09/19 09:48:29	1.1033
+++ /project/slime/cvsroot/slime/slime.el	2008/09/19 11:20:23	1.1034
@@ -8718,6 +8718,8 @@
                                               :fails-for ',fails-for
                                               :inputs ,inputs))))))))
 
+(put 'def-slime-test 'lisp-indent-function 4)
+
 (defmacro slime-check (test-name &rest body)
   "Check a condition (assertion.)
 TEST-NAME can be a symbol, a string, or a (FORMAT-STRING . ARGS) list.
@@ -8747,7 +8749,6 @@
 (defun slime-print-check-error (reason)
   (slime-test-failure "ERROR" (format "%S" reason)))
 
-(put 'def-slime-test 'lisp-indent-function 4)
 (put 'slime-check 'lisp-indent-function 1)
 
 
@@ -8804,10 +8805,9 @@
 (defun slime-sldb-level= (level)
   (equal level (sldb-level)))
 
-(def-slime-test narrowing
-    ()
-    "Check that narrowing is properly sustained."
-    '(())
+(def-slime-test narrowing ()
+  "Check that narrowing is properly sustained."
+  '(())
   (slime-check-top-level)
   (let ((random-buffer-name (symbol-name (gensym)))
         (defun-pos) (tmpbuffer))
@@ -9438,18 +9438,11 @@
     (string-match "\\*Slime Inspector\\*" 
                   (buffer-name buffer))))
 
-(def-slime-test break 
+(def-slime-test break
     (times exp)
     "Test whether BREAK invokes SLDB."
-    (let ((exp1 '(break))
-          (exp2 
-           ;; Backends should arguably make sure that BREAK does not
-           ;; depend on *DEBUGGER-HOOK*.
-           '(block outta
-              (let ((*debugger-hook* (lambda (c h) (return-from outta 42))))
-                (break)))))
-      `((1 ,exp1) (2 ,exp1) (3 ,exp1)
-        (1 ,exp2) (2 ,exp2) (3 ,exp2)))
+    (let ((exp1 '(break)))
+      `((1 ,exp1) (2 ,exp1) (3 ,exp1)))
   (slime-accept-process-output nil 0.2)
   (slime-check-top-level)
   (slime-eval-async 
@@ -9469,6 +9462,17 @@
                           0.2))
   (slime-sync-to-top-level 1))
 
+(def-slime-test (break2 ("cmucl" "allegro"))
+    (times exp)
+    "Backends should arguably make sure that BREAK does not depend
+on *DEBUGGER-HOOK*."
+    (let ((exp2 
+           '(block outta
+              (let ((*debugger-hook* (lambda (c h) (return-from outta 42))))
+                (break)))))
+      `((1 ,exp2) (2 ,exp2) (3 ,exp2)))
+  (slime-test-break times exp))
+
 (def-slime-test locally-bound-debugger-hook
     ()
     "Test that binding *DEBUGGER-HOOK* locally works properly."



From heller at common-lisp.net  Sat Sep 20 16:33:41 2008
From: heller at common-lisp.net (heller)
Date: Sat, 20 Sep 2008 12:33:41 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080920163341.4935773205@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4158

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (call-with-debugging-environment): Don't set
*debugger-hook* to nil.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/19 11:20:22	1.1527
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/20 16:33:40	1.1528
@@ -1,3 +1,8 @@
+2008-09-20  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-openmcl.lisp (call-with-debugging-environment): Don't set
+	*debugger-hook* to nil.
+
 2008-09-19  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el ([def-slime-test] break): Split it up in two versions
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/17 06:19:49	1.134
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 16:33:41	1.135
@@ -478,7 +478,7 @@
 (defvar *sldb-stack-top* nil)
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
-  (let* ((*debugger-hook* nil)
+  (let* (;;(*debugger-hook* nil)
          (*sldb-stack-top* (grab-stack-top))
          (ccl::*signal-printing-errors* nil)) ; don't let error while printing error take us down
     (funcall debugger-loop-fn)))



From heller at common-lisp.net  Sat Sep 20 16:33:55 2008
From: heller at common-lisp.net (heller)
Date: Sat, 20 Sep 2008 12:33:55 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080920163355.BCB1321041@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4221

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
Fix BREAK and backtraces after interrupts for CCL.

* swank-openmcl.lisp (*sldb-stack-top-hint*): New variable.
(call-with-debugging-environment, break-in-sldb)
(interrupt-thread): Use it.
(*process-to-stack-top*, record-stack-top)
(grab-stack-top): Deleted. Use *sldb-stack-top-hint* instead.
(backtrace-context): Deleted. Use %current-tcr directly.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/20 16:33:40	1.1528
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/20 16:33:55	1.1529
@@ -1,5 +1,16 @@
 2008-09-20  Helmut Eller  <heller at common-lisp.net>
 
+	Fix BREAK and backtraces after interrupts.
+
+	* swank-openmcl.lisp (*sldb-stack-top-hint*): New variable.
+	(call-with-debugging-environment, break-in-sldb)
+	(interrupt-thread): Use it.
+	(*process-to-stack-top*, record-stack-top)
+	(grab-stack-top): Deleted. Use *sldb-stack-top-hint* instead.
+	(backtrace-context): Deleted. Use %current-tcr directly.
+
+2008-09-20  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-openmcl.lisp (call-with-debugging-environment): Don't set
 	*debugger-hook* to nil.
 
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 16:33:41	1.135
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 16:33:55	1.136
@@ -204,62 +204,6 @@
 (defimplementation lisp-implementation-type-name ()
   "openmcl")
 
-(defvar *break-in-sldb* t)
-
-
-(let ((ccl::*warn-if-redefine-kernel* nil))
-  (ccl::advise
-   ccl::cbreak-loop
-   (if (and *break-in-sldb* 
-            (find ccl::*current-process*
-                  (symbol-value (intern (string :*connections*) :swank))
-                  :key (intern (string :connection.repl-thread) :swank)))
-       (apply 'break-in-sldb ccl::arglist)
-       (:do-it))
-   :when :around
-   :name sldb-break))
-
-(defun break-in-sldb (&optional string &rest args)
-  (let ((c (make-condition 'simple-condition
-                           :format-control (or string "Break")
-                           :format-arguments args)))
-    (let ((previous-f nil)
-          (previous-f2 nil))
-      (block find-frame
-        (map-backtrace  
-         #'(lambda(frame-number p context lfun pc)
-             (declare (ignore frame-number context pc))
-             (when (eq  previous-f2 'break-in-sldb) 
-               (record-stack-top p)
-               (return-from find-frame))
-             (setq previous-f2 previous-f)
-             (setq previous-f (ccl::lfun-name lfun)))))
-      (restart-case (invoke-debugger c)
-        (continue () :report (lambda (stream) (write-string "Resume interrupted evaluation" stream)) t))
-      )))
-
-; In previous version the code that recorded the function that had an
-; error or which was interrupted was not thread safe. This code repairs that by
-; associating the frame pointer with a process via the *process-to-stack-top* hash.
-
-(defvar *process-to-stack-top* (make-hash-table :test 'eql))
-
-(defun record-stack-top (frame)
-  (setf (gethash (ccl::process-serial-number ccl::*current-process*) *process-to-stack-top* )
-        frame))
-          
-(defun grab-stack-top ()
-  (let ((psn (ccl::process-serial-number ccl::*current-process*)))
-    (ccl::without-interrupts
-      (prog1
-          (gethash  psn *process-to-stack-top*)
-        (setf (gethash psn *process-to-stack-top*) nil)))))
-
-(defmethod ccl::application-error :before (application condition error-pointer)
-  (declare (ignore application condition))
-  (record-stack-top error-pointer)
-  nil)
-
 ;;; Evaluation
 
 (defimplementation arglist (fname)
@@ -476,26 +420,24 @@
   (ccl::start-xref))
 
 (defvar *sldb-stack-top* nil)
+(defvar *sldb-stack-top-hint* nil)
+(defvar *break-in-sldb* nil)
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (let* (;;(*debugger-hook* nil)
-         (*sldb-stack-top* (grab-stack-top))
-         (ccl::*signal-printing-errors* nil)) ; don't let error while printing error take us down
-    (funcall debugger-loop-fn)))
-
-(defun backtrace-context ()
-  (if (and (= ccl::*openmcl-major-version* 0)
-           (<= ccl::*openmcl-minor-version* 14)
-           (< ccl::*openmcl-revision* 2))
-      (ccl::%current-tcr)
-      nil))
+         (*sldb-stack-top* (or *sldb-stack-top-hint*
+                               (ccl::%get-frame-ptr)))
+         (*sldb-stack-top-hint* nil)
+         ;; don't let error while printing error take us down
+         (ccl::*signal-printing-errors* nil))
+    (funcall debugger-loop-xfn)))
 
 (defun map-backtrace (function &optional
                       (start-frame-number 0)
                       (end-frame-number most-positive-fixnum))
   "Call FUNCTION passing information about each stack frame
  from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
-  (let ((context (backtrace-context))
+  (let ((context (ccl::%current-tcr))
         (frame-number 0)
         (top-stack-frame (or *sldb-stack-top*
                              (ccl::%get-frame-ptr))))
@@ -718,6 +660,20 @@
        (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 (&optional string &rest args)
+  (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
+                                   (ccl::%get-frame-ptr))))
+    (apply #'cerror "Continue from break" (or string "Break") args)))
+
 ;;; Utilities
 
 (defimplementation describe-symbol-for-emacs (symbol)
@@ -914,23 +870,13 @@
 (defimplementation kill-thread (thread)
   (ccl:process-kill thread))
 
-;; September  5, 2004 alanr. record the frame interrupted
-(defimplementation interrupt-thread (thread fn)
+(defimplementation interrupt-thread (thread function)
   (ccl:process-interrupt 
    thread 
-   (lambda(&rest args)
-     (let ((previous-f nil))
-       (block find-frame
-         (map-backtrace  
-          #'(lambda(frame-number p context lfun pc)
-              (declare (ignore frame-number context pc))
-              (when (eq  previous-f 'ccl::%pascal-functions%) 
-                (record-stack-top p)
-                (return-from find-frame))
-              (setq previous-f (ccl::lfun-name lfun)))))
-       (apply fn args)))))
-
-
+   (lambda ()
+     (let ((*sldb-stack-top-hint* (ccl::%get-frame-ptr)))
+       (funcall function)))))
+  
 (defun mailbox (thread)
   (ccl:with-lock-grabbed (*known-processes-lock*)
     (let ((probe (rassoc thread *known-processes* :key #'car)))



From heller at common-lisp.net  Sat Sep 20 16:34:08 2008
From: heller at common-lisp.net (heller)
Date: Sat, 20 Sep 2008 12:34:08 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080920163408.D436273205@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv4277

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
Fix inspecting of arrays.

* swank-openmcl.lisp (emacs-inspect :around (t)): call-next-method
may return a lazy list.  Detect that case and only append to
ordinary lists.
(emacs-inspect (t)): Don't mark labels as inspectable. Just print
them.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/20 16:33:55	1.1529
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/20 16:34:08	1.1530
@@ -1,5 +1,15 @@
 2008-09-20  Helmut Eller  <heller at common-lisp.net>
 
+	Fix inspecting of arrays.
+
+	* swank-openmcl.lisp (emacs-inspect :around (t)): call-next-method
+	may return a lazy list.  Detect that case and only append to
+	ordinary lists.
+	(emacs-inspect (t)): Don't mark labels as inspectable. Just print
+	them.
+
+2008-09-20  Helmut Eller  <heller at common-lisp.net>
+
 	Fix BREAK and backtraces after interrupts.
 
 	* swank-openmcl.lisp (*sldb-stack-top-hint*): New variable.
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 16:33:55	1.136
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 16:34:08	1.137
@@ -764,7 +764,7 @@
              for l below count
              for (value label) = (multiple-value-list 
                                   (inspector::line-n i l))
-             collect `(:value ,label ,(string-capitalize (format nil "~a" label)))
+             collect (if label (format nil "~(~a~)" label) i)
              collect " = "
              collect `(:value ,value)
              collect '(:newline))))
@@ -774,10 +774,13 @@
   (if (or (uvector-inspector-p o)
           (not (ccl:uvectorp o)))
       (call-next-method)
-      (append (call-next-method)
-                 `((:newline)
-                   (:value ,(make-instance 'uvector-inspector :object o)
-                           "Underlying UVECTOR")))))
+      (let ((value (call-next-method)))
+        (cond ((listp value)
+               (append value
+                       `((:newline)
+                         (:value ,(make-instance 'uvector-inspector :object o)
+                                 "Underlying UVECTOR"))))
+              (t value)))))
 
 (defclass uvector-inspector ()
   ((object :initarg :object)))
@@ -787,13 +790,11 @@
   (:method ((object uvector-inspector)) t))
 
 (defmethod emacs-inspect ((uv uvector-inspector))
-  (with-slots (object)
-      uv
-            (loop
-               for index below (ccl::uvsize object)
-               collect (format nil "~D: " index)
-               collect `(:value ,(ccl::uvref object index))
-               collect `(:newline))))
+  (with-slots (object) uv
+    (loop for index below (ccl::uvsize object)
+          collect (format nil "~D: " index)
+          collect `(:value ,(ccl::uvref object index))
+          collect `(:newline))))
 
 (defun closure-closed-over-values (closure)
   (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure)))))
@@ -874,7 +875,8 @@
   (ccl:process-interrupt 
    thread 
    (lambda ()
-     (let ((*sldb-stack-top-hint* (ccl::%get-frame-ptr)))
+     (let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
+                                      (ccl::%get-frame-ptr))))
        (funcall function)))))
   
 (defun mailbox (thread)



From heller at common-lisp.net  Sat Sep 20 21:46:16 2008
From: heller at common-lisp.net (heller)
Date: Sat, 20 Sep 2008 17:46:16 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080920214616.A250E21041@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv19258

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
Fix some of the bugs that I introduced with the last commits.

* swank-openmcl.lisp (call-with-debugging-environment): Fix typo.
(call-with-debugger-hook): Bind *break-in-sldb*.
(backtrace-context): Return nil, not tcr!
(map-backtrace): Remove the stack< test. Only test for nil.
(lisp-implementation-type-name): Return "ccl".

(emacs-inspect (t)): Fix typo.

(kill-thread): Use join-process. Otherwise we get strange
"process-reset" errors when disconnecting.
(thread-alive-p): Implemented with ccl::process-exhausted-p.

(source-locations): Use labels for helper functions.
(function-source-location): No implemented on top of
source-locations.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/20 16:34:08	1.1530
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/20 21:46:16	1.1531
@@ -1,5 +1,32 @@
 2008-09-20  Helmut Eller  <heller at common-lisp.net>
 
+	Fix some of the bugs that I introduced with the last commits.
+
+	* swank-openmcl.lisp (call-with-debugging-environment): Fix typo.
+	(call-with-debugger-hook): Bind *break-in-sldb*.
+	(backtrace-context): Return nil, not tcr!
+	(map-backtrace): Remove the stack< test. Only test for nil.
+	(lisp-implementation-type-name): Return "ccl".
+
+	(emacs-inspect (t)): Fix typo.
+
+	(kill-thread): Use join-process. Otherwise we get strange
+	"process-reset" errors when disconnecting.
+	(thread-alive-p): Implemented with ccl::process-exhausted-p.
+
+	(source-locations): Use labels for helper functions.
+	(function-source-location): No implemented on top of
+	source-locations.
+
+2008-09-20  Helmut Eller  <heller at common-lisp.net>
+
+	Fix frame-source-location-for-emacs for CCL.
+
+	* swank-openmcl.lisp (source-locations): New function.
+	(create-source-location): New function.
+	(frame-source-location-for-emacs): Use it.
+
+2008-09-20  Helmut Eller  <heller at common-lisp.net>
 	Fix inspecting of arrays.
 
 	* swank-openmcl.lisp (emacs-inspect :around (t)): call-next-method
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 16:34:08	1.137
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 21:46:16	1.138
@@ -202,7 +202,7 @@
   (ccl::getpid))
 
 (defimplementation lisp-implementation-type-name ()
-  "openmcl")
+  "ccl")
 
 ;;; Evaluation
 
@@ -430,21 +430,27 @@
          (*sldb-stack-top-hint* nil)
          ;; don't let error while printing error take us down
          (ccl::*signal-printing-errors* nil))
-    (funcall debugger-loop-xfn)))
+    (funcall debugger-loop-fn)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+  (let ((*debugger-hook* hook)
+        (*break-in-sldb* t))
+    (funcall fun)))
+
+(defun backtrace-context ()
+  nil)
 
 (defun map-backtrace (function &optional
                       (start-frame-number 0)
                       (end-frame-number most-positive-fixnum))
   "Call FUNCTION passing information about each stack frame
  from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
-  (let ((context (ccl::%current-tcr))
+  (let ((context (backtrace-context))
         (frame-number 0)
         (top-stack-frame (or *sldb-stack-top*
                              (ccl::%get-frame-ptr))))
-    (do* ((p top-stack-frame (ccl::parent-frame p context))
-          (q (ccl::last-frame-ptr context)))
-         ((or (null p) (eq p q) (ccl::%stack< q p context))
-          (values))
+    (do ((p top-stack-frame (ccl::parent-frame p context)))
+        ((null p))
       (multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
         (when lfun
           (if (and (>= frame-number start-frame-number)
@@ -595,19 +601,44 @@
                             (canonicalize-location file symbol))))))
 
 (defun function-source-location (function)
-  (multiple-value-bind (info name)
-      (ccl::edit-definition-p function)
-    (cond ((not info) (list :error (format nil "No source info available for ~A" function)))
-          ((typep (caar info) 'ccl::method)
-           `(:location 
-             (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) )))
-             (:method  ,(princ-to-string (ccl::method-name (caar info)))
-                       ,(mapcar 'princ-to-string
-                                (mapcar #'specializer-name
-                                        (ccl::method-specializers (caar info))))
-                       ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info))))
-             nil))
-          (t (canonicalize-location (second (first info)) name (third (first info)))))))
+  (or (car (source-locations function))
+      (list :error (format nil "No source info available for ~A" function))))
+
+;; 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))
+         (filename (file) (namestring (truename file)))
+         (src-loc (file pos)
+           (assert (or (null file) (stringp file) (pathnamep file)))
+           (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))))))))
+  
+  (defun source-locations (thing)
+    (multiple-value-bind (files name) (ccl::edit-definition-p thing)
+      (let ((locs '())  (names '()))
+        (loop for (type . file) in files do
+              (etypecase type
+                ((member function macro variable compiler-macro 
+                         ccl:defcallback ccl::x8664-vinsn)
+                 (push (src-loc file (list :function-name (str name))) 
+                       locs)
+                 (push (list type name) names))
+                (method
+                 (let* ((m type)
+                        (name (ccl::method-name m))
+                        (specs (ccl::method-specializers m))
+                        (specs (mapcar #'specializer-name specs))
+                        (quals (ccl::method-qualifiers m)))
+                   (push (src-loc file (list :method (str name) (str* specs) 
+                                             (str* quals)))
+                         locs)
+                   (push `(method ,name ,quals ,specs) names)))))
+        (values (nreverse locs) (nreverse names))))))
 
 (defimplementation frame-source-location-for-emacs (index)
   "Return to Emacs the location of the source code for the
@@ -764,7 +795,7 @@
              for l below count
              for (value label) = (multiple-value-list 
                                   (inspector::line-n i l))
-             collect (if label (format nil "~(~a~)" label) i)
+             collect (format nil "~(~a~)" (or label l))
              collect " = "
              collect `(:value ,value)
              collect '(:newline))))
@@ -868,8 +899,14 @@
 (defimplementation all-threads ()
   (ccl:all-processes))
 
+;; our thread-alive-p implementation will not work well if we don't
+;; wait.  join-process should have a timeout argument.
 (defimplementation kill-thread (thread)
-  (ccl:process-kill thread))
+  (ccl:process-kill thread)
+  (ccl:join-process thread))
+
+(defimplementation thread-alive-p (thread)
+  (not (ccl::process-exhausted-p thread)))
 
 (defimplementation interrupt-thread (thread function)
   (ccl:process-interrupt 
@@ -887,13 +924,10 @@
                  (setq *known-processes*
                        (acons (ccl::process-serial-number thread) 
                               (list thread mailbox)
-                              (remove-if 
-                               (lambda(entry) 
-                                 (string= (ccl::process-whostate (second entry)) "Exhausted")) 
-                               *known-processes*)
-                              ))
+                              (remove-if  #'ccl::process-exhausted-p
+					  *known-processes*)))
                  mailbox))))))
-          
+
 (defimplementation send (thread message)
   (assert message)
   (let* ((mbox (mailbox thread))



From heller at common-lisp.net  Sat Sep 20 21:46:24 2008
From: heller at common-lisp.net (heller)
Date: Sat, 20 Sep 2008 17:46:24 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080920214624.A1ED1731FE@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv19293

Modified Files:
	ChangeLog slime.el test.sh 
Log Message:
* test.sh: Parse the -S option as advertized.

* slime.el (slime-randomize-test-order): Add the * to the
docstring.
([def-slime-test] break2): Also CCL is expected to fail here.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/20 21:46:16	1.1531
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/20 21:46:22	1.1532
@@ -1,5 +1,13 @@
 2008-09-20  Helmut Eller  <heller at common-lisp.net>
 
+	* test.sh: Parse the -S option as advertized.
+
+	* slime.el (slime-randomize-test-order): Add the * to the
+	docstring.
+	([def-slime-test] break2): Also CCL is expected to fail here.
+
+2008-09-20  Helmut Eller  <heller at common-lisp.net>
+
 	Fix some of the bugs that I introduced with the last commits.
 
 	* swank-openmcl.lisp (call-with-debugging-environment): Fix typo.
@@ -15,7 +23,7 @@
 	(thread-alive-p): Implemented with ccl::process-exhausted-p.
 
 	(source-locations): Use labels for helper functions.
-	(function-source-location): No implemented on top of
+	(function-source-location): Now implemented on top of
 	source-locations.
 
 2008-09-20  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/slime.el	2008/09/19 11:20:23	1.1034
+++ /project/slime/cvsroot/slime/slime.el	2008/09/20 21:46:23	1.1035
@@ -8500,7 +8500,7 @@
   "The name of Lisp currently executing the tests.")
 
 (defvar slime-randomize-test-order t
-  "If t execute tests in random order.
+  "*If t execute tests in random order.
 If nil, execute them in definition order.")
 
 ;; dynamically bound during a single test
@@ -9462,7 +9462,7 @@
                           0.2))
   (slime-sync-to-top-level 1))
 
-(def-slime-test (break2 ("cmucl" "allegro"))
+(def-slime-test (break2 ("cmucl" "allegro" "ccl"))
     (times exp)
     "Backends should arguably make sure that BREAK does not depend
 on *DEBUGGER-HOOK*."
--- /project/slime/cvsroot/slime/test.sh	2008/09/19 09:48:29	1.19
+++ /project/slime/cvsroot/slime/test.sh	2008/09/20 21:46:23	1.20
@@ -33,7 +33,7 @@
 test_name=nil
 randomize=t
 
-while getopts bsRTn: opt; do
+while getopts bsRTSn: opt; do
     case $opt in
 	b) batch_mode="-batch";;
 	s) use_screen=true;;



From heller at common-lisp.net  Sat Sep 20 21:46:30 2008
From: heller at common-lisp.net (heller)
Date: Sat, 20 Sep 2008 17:46:30 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080920214630.70EC873205@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv19371

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-with-output-end-mark):
slime-repl-show-maximum-output no longer accepts any arguments.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/20 21:46:22	1.1532
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/20 21:46:30	1.1533
@@ -1,3 +1,8 @@
+2008-09-20  Ariel Badichi <abadichi at bezeqint.net>
+
+	* slime.el (slime-with-output-end-mark):
+	slime-repl-show-maximum-output no longer accepts any arguments.
+
 2008-09-20  Helmut Eller  <heller at common-lisp.net>
 
 	* test.sh: Parse the -S option as advertized.
--- /project/slime/cvsroot/slime/slime.el	2008/09/20 21:46:23	1.1035
+++ /project/slime/cvsroot/slime/slime.el	2008/09/20 21:46:30	1.1036
@@ -2572,8 +2572,7 @@
               (goto-char slime-output-end)
               (funcall body..))))
      (when updatep..
-       (slime-repl-show-maximum-output 
-        (> (- slime-output-end slime-output-start) 1000)))))
+       (slime-repl-show-maximum-output))))
 
 (defun slime-output-filter (process string)
   (with-current-buffer (process-buffer process)
@@ -2667,8 +2666,7 @@
     (when slime-repl-popup-on-output
       (setq slime-repl-popup-on-output nil)
       (display-buffer (current-buffer)))
-    (when (eobp)
-      (slime-repl-show-maximum-output))))
+    (slime-repl-show-maximum-output)))
 
 (defun slime-repl-emit-result (string &optional bol)
   ;; insert STRING and mark it as evaluation result



From heller at common-lisp.net  Sat Sep 20 22:04:01 2008
From: heller at common-lisp.net (heller)
Date: Sat, 20 Sep 2008 18:04:01 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080920220401.CE20A7A099@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv24561

Modified Files:
	swank-openmcl.lisp 
Log Message:
Fx typo

--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 21:46:16	1.138
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 22:04:01	1.139
@@ -924,8 +924,10 @@
                  (setq *known-processes*
                        (acons (ccl::process-serial-number thread) 
                               (list thread mailbox)
-                              (remove-if  #'ccl::process-exhausted-p
-					  *known-processes*)))
+                              (remove-if  
+                               (lambda (entry)
+                                 (ccl::process-exhausted-p (cadr entry)))
+                               *known-processes*)))
                  mailbox))))))
 
 (defimplementation send (thread message)



From heller at common-lisp.net  Sun Sep 21 11:17:43 2008
From: heller at common-lisp.net (heller)
Date: Sun, 21 Sep 2008 07:17:43 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080921111743.E57DF601DE@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2036

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (*backtrace-pprint-dispatch-table*):
Honor *print-escape*.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/20 21:46:30	1.1533
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/21 11:17:43	1.1534
@@ -1,3 +1,8 @@
+2008-09-21  Helmut Eller  <heller at common-lisp.net>
+
+	* swank.lisp (*backtrace-pprint-dispatch-table*):
+	Honor *print-escape*.
+
 2008-09-20  Ariel Badichi <abadichi at bezeqint.net>
 
 	* slime.el (slime-with-output-end-mark):
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/18 15:23:37	1.593
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/21 11:17:43	1.594
@@ -111,14 +111,16 @@
 (defvar *backtrace-pprint-dispatch-table*
   (let ((table (copy-pprint-dispatch nil)))
     (flet ((escape-string (stream string)
-             (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)))
+             (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))
+                   (t (write-string string)))))
       (set-pprint-dispatch 'string  #'escape-string 0 table)
       table)))
 



From heller at common-lisp.net  Sun Sep 21 11:17:54 2008
From: heller at common-lisp.net (heller)
Date: Sun, 21 Sep 2008 07:17:54 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080921111754.F2ABA690DD@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2063

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp: Try to remove the first few internal frames
from backtraces.
(guess-stack-top): New function.
(call-with-debugging-environment): Use it

(frame-arguments): Return a list instead of a string.  Don't quote
symbols.
(source-locations): Recognize (:internal FOO) functions.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/21 11:17:43	1.1534
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/21 11:17:49	1.1535
@@ -1,5 +1,16 @@
 2008-09-21  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-openmcl.lisp: Try to remove the first few internal frames
+	from backtraces.
+	(guess-stack-top): New function.
+	(call-with-debugging-environment): Use it
+
+	(frame-arguments): Return a list instead of a string.  Don't quote
+	symbols.
+	(source-locations): Recognize (:internal FOO) functions.
+
+2008-09-21  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (*backtrace-pprint-dispatch-table*):
 	Honor *print-escape*.
 
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/20 22:04:01	1.139
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/09/21 11:17:51	1.140
@@ -426,7 +426,7 @@
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (let* (;;(*debugger-hook* nil)
          (*sldb-stack-top* (or *sldb-stack-top-hint*
-                               (ccl::%get-frame-ptr)))
+                               (guess-stack-top 2)))
          (*sldb-stack-top-hint* nil)
          ;; don't let error while printing error take us down
          (ccl::*signal-printing-errors* nil))
@@ -440,6 +440,24 @@
 (defun backtrace-context ()
   nil)
 
+(labels ((error-entry? (frame)
+           (let ((fun (ccl::cfp-lfun frame)))
+             (or (eq fun #'ccl::%error)
+                 (eq fun #'ccl::%pascal-functions%)))))
+
+  (defun guess-stack-top (offset)
+    ;; search the beginning of the stack for some well known functions
+    (do ((ctx (backtrace-context))
+         (result (ccl::%get-frame-ptr))
+         (i 0 (1+ i))
+         (frame (ccl::%get-frame-ptr) (ccl::parent-frame frame ctx))
+         (last nil frame))
+        (nil)
+      (cond ((or (not frame) (or (> i (+ offset 7))))
+             (return result))
+            ((or (= i offset) (and last (error-entry? last)))
+             (setq result frame))))))
+
 (defun map-backtrace (function &optional
                       (start-frame-number 0)
                       (end-frame-number most-positive-fixnum))
@@ -458,35 +476,16 @@
               (funcall function frame-number p context lfun pc))
           (incf frame-number))))))
 
-;; May 13, 2004 alanr: use prin1 instead of princ so I see " around strings. Write ' in front of symbol names and lists.
-;; Sept  6, 2004 alanr: use builtin ccl::frame-supplied-args
-
 (defun frame-arguments (p context lfun pc)
-  "Returns a string representing the arguments of a frame."
+  "Returns a list representing the arguments of a frame."
   (multiple-value-bind (args types names)
       (ccl::frame-supplied-args p lfun pc nil context)
-    (let ((result nil))
-      (loop named loop
-         for var = (cond
-                     ((null args)
-                      (return-from loop))
-                     ((atom args)
-                      (prog1
-                          args
-                        (setf args nil)))
-                     (t (pop args)))
+    (loop for value in args
           for type in types
           for name in names
-          do
-          (when (or (symbolp var) (listp var)) (setq var (list 'quote var)))
-          (cond ((equal type "keyword")
-                 (push (format nil "~S ~A" 
-                               (intern (symbol-name name) "KEYWORD")
-                               (prin1-to-string var))
-                       result))
-                (t   (push (prin1-to-string var) result))))
-      (format nil "~{ ~A~}" (nreverse result)))))
-
+          append (cond ((equal type "keyword")
+                        (list (intern (symbol-name name) "KEYWORD") value))
+                       (t (list value))))))
 
 (defimplementation compute-backtrace (start-frame-number end-frame-number)
   (let (result)
@@ -502,10 +501,8 @@
   (let ((frame (swank-frame.%frame swank-frame)))
     (assert (eq (first frame) :openmcl-frame))
     (destructuring-bind (p context lfun pc) (rest frame)
-      (format stream "(~A~A)"
-              (if (ccl::function-name lfun)
-                  (ccl::%lfun-name-string lfun)
-                  lfun)
+      (format stream "(~S~{ ~S~})"
+              (or (ccl::function-name lfun) lfun)
               (frame-arguments p context lfun pc)))))
 
 (defimplementation frame-locals (index)
@@ -609,36 +606,44 @@
 ;; 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)
-           (assert (or (null file) (stringp file) (pathnamep file)))
            (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))))))))
-  
+                (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)
-      (let ((locs '())  (names '()))
-        (loop for (type . file) in files do
-              (etypecase type
-                ((member function macro variable compiler-macro 
-                         ccl:defcallback ccl::x8664-vinsn)
-                 (push (src-loc file (list :function-name (str name))) 
-                       locs)
-                 (push (list type name) names))
-                (method
-                 (let* ((m type)
-                        (name (ccl::method-name m))
-                        (specs (ccl::method-specializers m))
-                        (specs (mapcar #'specializer-name specs))
-                        (quals (ccl::method-qualifiers m)))
-                   (push (src-loc file (list :method (str name) (str* specs) 
-                                             (str* quals)))
-                         locs)
-                   (push `(method ,name ,quals ,specs) names)))))
-        (values (nreverse locs) (nreverse names))))))
+      (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 ,quals ,specs))))))))))
 
 (defimplementation frame-source-location-for-emacs (index)
   "Return to Emacs the location of the source code for the



From heller at common-lisp.net  Sun Sep 21 11:18:00 2008
From: heller at common-lisp.net (heller)
Date: Sun, 21 Sep 2008 07:18:00 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080921111800.DB3C049024@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv2117

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-eol-conversion-fixup): Return 0 (not nil) for
anyting other than CRLF conventions.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/21 11:17:49	1.1535
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/21 11:18:00	1.1536
@@ -1,5 +1,10 @@
 2008-09-21  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-eol-conversion-fixup): Return 0 (not nil) for
+	anyting other than CRLF conventions.
+
+2008-09-21  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-openmcl.lisp: Try to remove the first few internal frames
 	from backtraces.
 	(guess-stack-top): New function.
--- /project/slime/cvsroot/slime/slime.el	2008/09/20 21:46:30	1.1036
+++ /project/slime/cvsroot/slime/slime.el	2008/09/21 11:18:00	1.1037
@@ -4667,14 +4667,15 @@
   ;; moving N chars forward.  N is the number of chars but \r\n are
   ;; counted as 2 separate chars.
   (case (coding-system-eol-type buffer-file-coding-system)
-    ((0 2) 0)
     ((1) 
      (save-excursion 
        (do ((pos (+ (point) n))
             (count 0 (1+ count)))
            ((>= (point) pos) (1- count))
          (forward-line)
-         (decf pos))))))
+         (decf pos))))
+    (t 0)))
+
 
 (defun slime-search-method-location (name specializers qualifiers)
   ;; Look for a sequence of words (def<something> method name



From heller at common-lisp.net  Mon Sep 22 17:49:42 2008
From: heller at common-lisp.net (heller)
Date: Mon, 22 Sep 2008 13:49:42 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080922174942.54D5E4E019@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17070

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-repl-input-end-mark): Deleted. It was always at
the end of buffer. Use point-max instead.
(slime-repl-eol): Removed.  The usual end-of-line does the same.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/21 11:18:00	1.1536
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/22 17:49:41	1.1537
@@ -1,5 +1,11 @@
 2008-09-21  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-repl-input-end-mark): Deleted. It was always at
+	the end of buffer. Use point-max instead.
+	(slime-repl-eol): Removed.  The usual end-of-line does the same.
+
+2008-09-21  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-eol-conversion-fixup): Return 0 (not nil) for
 	anyting other than CRLF conventions.
 
--- /project/slime/cvsroot/slime/slime.el	2008/09/21 11:18:00	1.1037
+++ /project/slime/cvsroot/slime/slime.el	2008/09/22 17:49:41	1.1038
@@ -2733,14 +2733,14 @@
 ;; 
 ;;    ... output ...    ... result ...    prompt> ... input ...
 ;;    ^            ^                      ^       ^           ^
-;;    output-start output-end  prompt-start       input-start input-end  
+;;    output-start output-end  prompt-start       input-start point-max
 ;;
-;; output-start and input-start are right inserting markers;
-;; output-end and input-end left inserting.
+;; input-start is a right inserting markers marker, because
+;; we want it to say behind when the user inserts text.
 ;;
 ;; We maintain the following invariant:
 ;;
-;;  output-start <= output-end <= input-start <= input-end.
+;;  output-start <= output-end <= input-start.
 ;;
 ;; This invariant is important, because we must be prepared for
 ;; asynchronous output and asynchronous reads.  ("Asynchronous" means,
@@ -2748,29 +2748,22 @@
 ;;
 ;; All output is inserted at the output-end marker.  Some care must be
 ;; taken when output-end and input-start are at the same position: if
-;; we blindly insert at that point, we break the invariant stated
-;; above, because the output-end marker is left inserting.  The macro
-;; `slime-with-output-end-mark' handles this complication by moving
-;; the input-start marker to an appropriate place.  The macro also
-;; updates window-point if necessary, and tries to keep the prompt in
-;; the first column by inserting a newline.
+;; we insert at that point, we must move the right markers.  We should
+;; also not leave (window-)point in the middle of the new output.  The
+;; idiom we use is a combination to slime-save-marker,
+;; insert-before-markers, and manually updating window-point
+;; afterwards.
 ;;
 ;; A "synchronous" evaluation request proceeds as follows: the user
-;; inserts some text between input-start and input-end and then hits
-;; return.  We send the text between the input markers to Lisp, move
-;; the output and input makers to the line after the input and wait.
-;; When we receive the result, we insert it together with a prompt
-;; between the output-end and input-start mark.
-;; `slime-repl-insert-prompt' does this.
+;; inserts some text between input-start and point-max and then hits
+;; return.  We send that region to Lisp, move the output and input
+;; makers to the line after the input and wait.  When we receive the
+;; result, we insert it together with a prompt between the output-end
+;; and input-start mark.  See `slime-repl-insert-prompt'.
 ;;
 ;; It is possible that some output for such an evaluation request
 ;; arrives after the result.  This output is inserted before the
-;; result (and before the prompt).  Output that doesn't belong the
-;; evaluation request should not be inserted before the result, but
-;; immediately before the prompt.  To achieve this, we move the
-;; output-end mark to prompt-start after a short delay (by starting a
-;; timer in `slime-repl-insert-prompt').  In summary: synchronous
-;; output should go before the result, asynchronous before the prompt.
+;; result (and before the prompt). 
 ;;
 ;; If we are in "reading" state, e.g., during a call to Y-OR-N-P,
 ;; there is no prompt between output-end and input-start.
@@ -2789,7 +2782,6 @@
 
  (defvar slime-repl-prompt-start-mark)
  (defvar slime-repl-input-start-mark)
- (defvar slime-repl-input-end-mark)
  (defvar slime-repl-old-input-counter 0
    "Counter used to generate unique `slime-repl-old-input' properties.
 This property value must be unique to avoid having adjacent inputs be
@@ -2799,12 +2791,9 @@
   (dolist (markname '(slime-output-start
                       slime-output-end
                       slime-repl-prompt-start-mark
-                      slime-repl-input-start-mark
-                      slime-repl-input-end-mark))
+                      slime-repl-input-start-mark))
     (set markname (make-marker))
-    (set-marker (symbol-value markname) (point)))
-  (set-marker-insertion-type slime-repl-input-end-mark t)
-  (set-marker-insertion-type slime-repl-prompt-start-mark t))
+    (set-marker (symbol-value markname) (point))))
 
 ;;;;; REPL mode setup
 
@@ -2828,7 +2817,6 @@
   ([(control return)] 'slime-repl-closing-return)
   ("\C-a" 'slime-repl-bol)
   ([home] 'slime-repl-bol)
-  ("\C-e" 'slime-repl-eol)
   ("\M-p" 'slime-repl-previous-input)
   ((kbd "C-<up>") 'slime-repl-backward-input)
   ("\M-n" 'slime-repl-next-input)
@@ -2944,7 +2932,6 @@
   "Insert the prompt (before markers!).
 Set point after the prompt.  
 Return the position of the prompt beginning."
-  (assert (= slime-repl-input-end-mark (point-max)))
   (goto-char slime-repl-input-start-mark)
   (slime-save-marker slime-output-start
     (slime-save-marker slime-output-end
@@ -2981,9 +2968,9 @@
                                         until-point-p)
       (buffer-substring-no-properties
        slime-repl-input-start-mark 
-       (if (and until-point-p (<= (point) slime-repl-input-end-mark))
-           (point)
-         slime-repl-input-end-mark))))
+       (if until-point-p 
+           (point) 
+         (point-max)))))
 
 (defun slime-property-position (text-property &optional object)
   "Return the first position of TEXT-PROPERTY, or nil."
@@ -2992,8 +2979,7 @@
     (next-single-property-change 0 text-property object)))
   
 (defun slime-mark-input-start ()
-  (set-marker slime-repl-input-start-mark (point) (current-buffer))
-  (set-marker slime-repl-input-end-mark (point) (current-buffer)))
+  (set-marker slime-repl-input-start-mark (point) (current-buffer)))
 
 (defun slime-mark-output-start ()
   (set-marker slime-output-start (point))
@@ -3015,23 +3001,13 @@
         (t (beginning-of-line 1)))
   (slime-preserve-zmacs-region))
 
-(defun slime-repl-eol ()
-  "Go to the end of line or the prompt."
-  (interactive)
-  (if (and (<= (point) slime-repl-input-end-mark)
-           (slime-same-line-p (point) slime-repl-input-end-mark))
-      (goto-char slime-repl-input-end-mark)
-    (end-of-line 1))
-  (slime-preserve-zmacs-region))
-
 (defun slime-preserve-zmacs-region ()
   "In XEmacs, ensure that the zmacs-region stays active after this command."
   (when (boundp 'zmacs-region-stays)
     (set 'zmacs-region-stays t)))
 
 (defun slime-repl-in-input-area-p ()
-   (and (<= slime-repl-input-start-mark (point))
-        (<= (point) slime-repl-input-end-mark)))
+   (<= slime-repl-input-start-mark (point)))
 
 (defun slime-repl-at-prompt-start-p ()
   ;; This will not work on non-current prompts.
@@ -3050,13 +3026,14 @@
     (beginning-of-defun))
   t)
 
+;; FIXME: this looks very strange
 (defun slime-repl-end-of-defun ()
   "Move to next of defun."
   (interactive)
   ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN.
-  (if (and (not (= (point) slime-repl-input-end-mark)) 
+  (if (and (not (= (point) (point-max))) 
            (slime-repl-in-input-area-p))
-      (goto-char slime-repl-input-end-mark)
+      (goto-char (point-max))
     (end-of-defun))
   t)
 
@@ -3100,7 +3077,6 @@
 balanced."
   (interactive "P")
   (slime-check-connected)
-  (assert (<= (point) slime-repl-input-end-mark))
   (cond (end-of-input
          (slime-repl-send-input))
         (slime-repl-read-mode ; bad style?
@@ -3110,26 +3086,25 @@
          (slime-repl-grab-old-input end-of-input)
          (slime-repl-recenter-if-needed))
         ((run-hook-with-args-until-success 'slime-repl-return-hooks))
-        ((slime-input-complete-p slime-repl-input-start-mark
-                                 slime-repl-input-end-mark)
+        ((slime-input-complete-p slime-repl-input-start-mark (point-max))
          (slime-repl-send-input t))
         (t 
          (slime-repl-newline-and-indent)
          (message "[input not complete]"))))
 
 (defun slime-repl-recenter-if-needed ()
-  "Make sure that slime-repl-input-end-mark is visible."
-  (unless (pos-visible-in-window-p slime-repl-input-end-mark)
+  "Make sure that (point) is visible."
+  (unless (pos-visible-in-window-p (point-max))
     (save-excursion
-      (goto-char slime-repl-input-end-mark)
+      (goto-char (point-max))
       (recenter -1))))
 
 (defun slime-repl-send-input (&optional newline)
   "Goto to the end of the input and send the current input.
 If NEWLINE is true then add a newline at the end of the input."
-  (when (< (point) slime-repl-input-start-mark)
+  (unless (slime-repl-in-input-area-p)
     (error "No input at point."))
-  (goto-char slime-repl-input-end-mark)
+  (goto-char (point-max))
   (let ((end (point))) ; end of input, without the newline
     (slime-repl-add-to-input-history 
      (buffer-substring slime-repl-input-start-mark end))
@@ -3147,7 +3122,7 @@
       (overlay-put overlay 'read-only t)
       (overlay-put overlay 'face 'slime-repl-input-face)))
   (let ((input (slime-repl-current-input)))
-    (goto-char slime-repl-input-end-mark)
+    (goto-char (point-max))
     (slime-mark-input-start)
     (slime-mark-output-start)
     (slime-repl-send-string input)))
@@ -3163,10 +3138,10 @@
           (offset (- (point) beg)))
       ;; Append the old input or replace the current input
       (cond (replace (goto-char slime-repl-input-start-mark))
-            (t (goto-char slime-repl-input-end-mark)
+            (t (goto-char (point-max))
                (unless (eq (char-before) ?\ )
                  (insert " "))))
-      (delete-region (point) slime-repl-input-end-mark)
+      (delete-region (point) (point-max))
       (save-excursion 
         (insert old-input)
         (when (equal (char-before) ?\n) 
@@ -3219,7 +3194,7 @@
           (t t))))
 
 (defun slime-repl-delete-current-input ()
-  (delete-region slime-repl-input-start-mark slime-repl-input-end-mark))
+  (delete-region slime-repl-input-start-mark (point-max)))
 
 (defun slime-repl-kill-input ()
   "Kill all text from the prompt to point."
@@ -4676,7 +4651,6 @@
          (decf pos))))
     (t 0)))
 
-
 (defun slime-search-method-location (name specializers qualifiers)
   ;; Look for a sequence of words (def<something> method name
   ;; qualifers specializers don't look for "T" since it isn't requires
@@ -5438,7 +5412,6 @@
   (with-current-buffer (slime-output-buffer)
     (save-excursion
       (goto-char slime-repl-input-start-mark)
-      (assert (= (point-max) slime-repl-input-end-mark))
       (unless (bolp) (insert-before-markers "\n"))
       (slime-propertize-region '(slime-transcript-delimiter t)
         (insert-before-markers
@@ -9217,8 +9190,8 @@
 
 (defun slime-check-buffer-contents (msg expected)
   (let* ((marks '((point . ?*) 
-                  (output-start . ?{) (output-end . ?}) 
-                  (repl-input-start-mark . ?\[) (repl-input-end-mark . ?\])))
+                  (slime-output-start . ?{) (slime-output-end . ?}) 
+                  (slimerepl-input-start-mark . ?\[) (point-max . ?\])))
          (marks (remove-if-not (lambda (m) (position (cdr m) expected))
                                marks))
          (marks (sort (copy-sequence marks) 
@@ -9231,22 +9204,22 @@
                                         result))
                      (m marks (cdr m))
                      (s expected (remove* (cdar m) s)))
-                    ((null m) (reverse result)))))
+                    ((null m) (reverse result))))
+         (point (point))
+         (point-max (point-max)))
     (slime-test-expect (concat msg " [content]") content (buffer-string))
-    (slime-test-expect (concat msg " [point]") 
-                       (cdr (assoc 'point marks))
-                       (point))
     (macrolet ((test-mark 
                 (mark)
                 `(when (assoc ',mark marks)
                    (slime-test-expect (format "%s [%s]" msg ',mark)
                                       (cdr (assoc ',mark marks))
-                                      ,(intern (format "slime-%s" mark))
+                                      ,mark
                                       #'=))))
-      (test-mark output-end)
-      (test-mark output-start)
-      (test-mark repl-input-end-mark)
-      (test-mark repl-input-start-mark))))
+      (test-mark point)
+      (test-mark slime-output-end)
+      (test-mark slime-output-start)
+      (test-mark slime-repl-input-start-mark)
+      (test-mark point-max))))
 
 (def-slime-test repl-return 
     (before after result-contents)



From heller at common-lisp.net  Mon Sep 22 17:49:42 2008
From: heller at common-lisp.net (heller)
Date: Mon, 22 Sep 2008 13:49:42 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080922174942.9401B4E022@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv17070/contrib

Modified Files:
	slime-editing-commands.el slime-presentations.el 
Log Message:
* slime.el (slime-repl-input-end-mark): Deleted. It was always at
the end of buffer. Use point-max instead.
(slime-repl-eol): Removed.  The usual end-of-line does the same.

--- /project/slime/cvsroot/slime/contrib/slime-editing-commands.el	2008/01/10 15:32:08	1.6
+++ /project/slime/cvsroot/slime/contrib/slime-editing-commands.el	2008/09/22 17:49:42	1.7
@@ -25,8 +25,7 @@
 
 (defun slime-end-of-defun ()
   (interactive)
-  (if (and (boundp 'slime-repl-input-end-mark)
-           slime-repl-input-end-mark)
+  (if (eq major 'slime-repl-mode)
       (slime-repl-end-of-defun)
       (end-of-defun)))
 
@@ -187,3 +186,4 @@
   (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun))
 
 (provide 'slime-editing-commands)
+(defun
\ No newline at end of file
--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/08/18 09:20:20	1.17
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/09/22 17:49:42	1.18
@@ -671,10 +671,10 @@
     (let ((old-output (buffer-substring beg end))) ;;keep properties
       ;; Append the old input or replace the current input
       (cond (replace (goto-char slime-repl-input-start-mark))
-            (t (goto-char slime-repl-input-end-mark)
+            (t (goto-char (point-max))
                (unless (eq (char-before) ?\ )
                  (insert " "))))
-      (delete-region (point) slime-repl-input-end-mark)
+      (delete-region (point) (point-max))
       (let ((inhibit-read-only t))
         (insert old-output)))))
 
@@ -793,10 +793,8 @@
 The input is the region from after the last prompt to the end of
 buffer. Presentations of old results are expanded into code."
   (slime-buffer-substring-with-reified-output  slime-repl-input-start-mark
-                                               (if (and until-point-p
-                                                        (<= (point) slime-repl-input-end-mark))
-                                                   (point)
-                                                   slime-repl-input-end-mark)))    
+					       (point-max)))
+
 (defun slime-presentation-on-return-pressed ()
   (cond ((and (car (slime-presentation-around-or-before-point (point)))
 	      (< (point) slime-repl-input-start-mark))



From heller at common-lisp.net  Mon Sep 22 17:49:49 2008
From: heller at common-lisp.net (heller)
Date: Mon, 22 Sep 2008 13:49:49 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080922174949.2E9F34E03E@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17118

Modified Files:
	slime.el 
Log Message:
(slime-batch-test): Use let* to bind slime-randomize-test-order.

--- /project/slime/cvsroot/slime/slime.el	2008/09/22 17:49:41	1.1038
+++ /project/slime/cvsroot/slime/slime.el	2008/09/22 17:49:45	1.1039
@@ -1099,7 +1099,7 @@
 (defvar slime-lisp-implementations nil
   "*A list of known Lisp implementations.
 The list should have the form: 
-  ((NAME (PROGRAM PROGRAM-ARGS...) &key INIT CODING-SYSTEM) ...)
+  ((NAME (PROGRAM PROGRAM-ARGS...) &key INIT CODING-SYSTEM ENV) ...)
 
 NAME is a symbol for the implementation.
 PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process.
@@ -1108,6 +1108,7 @@
   arguments.  INIT defaults to `slime-init-command'. 
 CODING-SYSTEM a symbol for the coding system. The default is 
   slime-net-coding-system
+ENV environment variables for the subprocess (see `process-environment').
 
 Here's an example: 
  ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init slime-init-command)
@@ -2735,8 +2736,8 @@
 ;;    ^            ^                      ^       ^           ^
 ;;    output-start output-end  prompt-start       input-start point-max
 ;;
-;; input-start is a right inserting markers marker, because
-;; we want it to say behind when the user inserts text.
+;; input-start is a right inserting marker, because
+;; we want it to stay behind when the user inserts text.
 ;;
 ;; We maintain the following invariant:
 ;;
@@ -8604,9 +8605,9 @@
           (kill-emacs 252))))
     (slime-sync-to-top-level 5)
     (switch-to-buffer "*scratch*")
-    (let ((slime-randomize-test-order (when randomize (random t) t))
-          (failed-tests (cond (test-name (slime-run-one-test test-name))
-                              (t (slime-run-tests)))))
+    (let* ((slime-randomize-test-order (when randomize (random t) t))
+           (failed-tests (cond (test-name (slime-run-one-test test-name))
+                               (t (slime-run-tests)))))
       (with-current-buffer slime-test-buffer-name
         (slime-delete-hidden-outline-text)
         (goto-char (point-min))



From heller at common-lisp.net  Mon Sep 22 17:49:53 2008
From: heller at common-lisp.net (heller)
Date: Mon, 22 Sep 2008 13:49:53 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080922174953.8CD057E0B1@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv17153

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (wait-for-input): Implement this in backend,
since read-char-no-hang doesn't work in fd-handlers.
(install-sigint-handler): Go through invoke-interruption and
with-interrupts to support nested interrupts.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/22 17:49:41	1.1537
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/22 17:49:53	1.1538
@@ -1,3 +1,13 @@
+2008-09-22  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-sbcl.lisp (wait-for-input): Implement this in backend,
+	since read-char-no-hang doesn't work in fd-handlers.
+	(install-sigint-handler): Go through invoke-interruption and
+	with-interrupts to support nested interrupts.
+
+	* slime.el (slime-lisp-implementations): Mention :env keyword
+	in docstring.
+
 2008-09-21  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-repl-input-end-mark): Deleted. It was always at
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/09/17 17:48:08	1.220
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/09/22 17:49:53	1.221
@@ -117,7 +117,10 @@
   (sb-sys:enable-interrupt sb-unix:sigint 
                            (lambda (&rest args)
                              (declare (ignore args))
-                             (funcall function))))
+                             (sb-sys:invoke-interruption 
+                              (lambda ()
+                                (sb-sys:with-interrupts 
+                                  (funcall function)))))))
 
 (defvar *sigio-handlers* '()
   "List of (key . fn) pairs to be called on SIGIO.")
@@ -165,6 +168,35 @@
     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
     (file-stream (sb-sys:fd-stream-fd socket))))
 
+(defvar *wait-for-input-called*)
+
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (when (boundp '*wait-for-input-called*)
+    (setq *wait-for-input-called* t))
+  (let ((*wait-for-input-called* nil))
+    (loop
+     (let ((ready (remove-if-not #'listen streams)))
+       (when ready (return ready)))
+     (when timeout (return nil))
+     (when (check-slime-interrupts) (return :interrupt))
+     (when *wait-for-input-called* (return :interrupt))
+     (let* ((f (constantly t))
+            (handlers (loop for s in streams
+                            collect (add-one-shot-handler s f))))
+       (unwind-protect
+            (sb-sys:serve-event 0.2)
+         (mapc #'sb-sys:remove-fd-handler handlers))))))
+
+(defun add-one-shot-handler (stream function)
+  (let (handler)
+    (setq handler 
+          (sb-sys:add-fd-handler (sb-sys:fd-stream-fd stream) :input
+                                 (lambda (fd)
+                                   (declare (ignore fd))
+                                   (sb-sys:remove-fd-handler handler)
+                                   (funcall function stream))))))
+
 (defvar *external-format-to-coding-system*
   '((:iso-8859-1 
      "latin-1" "latin-1-unix" "iso-latin-1-unix" 



From heller at common-lisp.net  Mon Sep 22 20:34:25 2008
From: heller at common-lisp.net (heller)
Date: Mon, 22 Sep 2008 16:34:25 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080922203425.BC2EA5F06F@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv28218/contrib

Modified Files:
	slime-editing-commands.el 
Log Message:
Delete garbage at the eof.

--- /project/slime/cvsroot/slime/contrib/slime-editing-commands.el	2008/09/22 17:49:42	1.7
+++ /project/slime/cvsroot/slime/contrib/slime-editing-commands.el	2008/09/22 20:34:25	1.8
@@ -186,4 +186,3 @@
   (define-key slime-mode-map "\C-c\M-q" 'slime-reindent-defun))
 
 (provide 'slime-editing-commands)
-(defun
\ No newline at end of file



From nsiivola at common-lisp.net  Mon Sep 22 22:56:18 2008
From: nsiivola at common-lisp.net (nsiivola)
Date: Mon, 22 Sep 2008 18:56:18 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080922225618.9632C1F011@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv784

Modified Files:
	ChangeLog swank.lisp 
Log Message:
swank.lisp (guess-package): Return NIL if string designator is NIL

  Makes files without IN-PACKAGE forms more *BREAK-ON-SIGNALS friendly.



--- /project/slime/cvsroot/slime/ChangeLog	2008/09/22 17:49:53	1.1538
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/22 22:56:18	1.1539
@@ -1,3 +1,9 @@
+2008-09-22  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* swank.lisp (guess-package): Return NIL if string designator is
+	NIL: makes files without IN-PACKAGE forms more *BREAK-ON-SIGNALS*
+	friendly.
+
 2008-09-22  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-sbcl.lisp (wait-for-input): Implement this in backend,
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/21 11:17:43	1.594
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/22 22:56:18	1.595
@@ -1823,10 +1823,11 @@
 (defun guess-package (string)
   "Guess which package corresponds to STRING.
 Return nil if no package matches."
-  (or (find-package string)
-      (parse-package string)
-      (if (find #\! string) ; for SBCL
-          (guess-package (substitute #\- #\! string)))))
+  (when string
+    (or (find-package string)
+        (parse-package string)
+        (if (find #\! string)           ; for SBCL
+            (guess-package (substitute #\- #\! string))))))
 
 (defvar *readtable-alist* (default-readtable-alist)
   "An alist mapping package names to readtables.")



From dcrosher at common-lisp.net  Tue Sep 23 04:57:52 2008
From: dcrosher at common-lisp.net (dcrosher)
Date: Tue, 23 Sep 2008 00:57:52 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080923045752.3CE677E011@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv20249

Modified Files:
	ChangeLog swank-scl.lisp swank.lisp 
Log Message:
* Update for the Scieneer CL 1.3.8 release.


--- /project/slime/cvsroot/slime/ChangeLog	2008/09/22 22:56:18	1.1539
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/23 04:57:51	1.1540
@@ -1,3 +1,11 @@
+2008-09-23  Douglas Crosher <dcrosher at common-lisp.net>
+
+	* swank-scl.lisp: update for Scieneer CL 1.3.8.
+
+	* swank.lisp (ed-in-emacs): customize for the SCL.
+
+	* swank.lisp (signal-interrupt): fix typo.
+
 2008-09-22  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* swank.lisp (guess-package): Return NIL if string designator is
--- /project/slime/cvsroot/slime/swank-scl.lisp	2008/09/17 06:19:49	1.25
+++ /project/slime/cvsroot/slime/swank-scl.lisp	2008/09/23 04:57:51	1.26
@@ -217,6 +217,9 @@
 
 (defclass slime-output-stream (ext:character-output-stream)
   ((output-fn :initarg :output-fn :type function)
+   (output-buffer :initarg :output-buffer :type simple-string)
+   (buffer-tail :initarg :buffer-tail :initform 0 :type kernel:index)
+   (last-write :initarg :last-write)
    (column :initform 0 :type kernel:index)
    (interactive :initform nil :type (member nil t))
    (position :initform 0 :type integer)))
@@ -225,8 +228,11 @@
   (declare (function output-fn))
   (make-instance 'slime-output-stream
 		 :in-buffer ""
-		 :out-buffer (make-string 256)
-                 :output-fn output-fn))
+		 :out-buffer ""
+		 :output-buffer (make-string 256)
+                 :output-fn output-fn
+                 :last-write (get-internal-real-time)
+                 ))
   
 (defmethod print-object ((s slime-output-stream) stream)
   (print-unreadable-object (s stream :type t)))
@@ -241,18 +247,31 @@
     (unless abort
       (finish-output stream))
     (setf (ext:stream-open-p stream) nil)
-    (setf (ext:stream-out-buffer stream) " ")
+    (setf (slot-value stream 'output-buffer) "")
     t))
 
 ;;; No 'stream-clear-input method.
 
 (defmethod ext:stream-finish-output ((stream slime-output-stream))
+  (let ((buffer-tail (slot-value stream 'buffer-tail)))
+    (declare (type kernel:index buffer-tail))
+    (when (> buffer-tail 0)
+      (let ((output-fn (slot-value stream 'output-fn))
+            (output-buffer (slot-value stream 'output-buffer)))
+        (declare (function output-fn)
+                 (simple-string output-buffer))
+        (funcall output-fn (subseq output-buffer 0 buffer-tail))
+        (setf (slot-value stream 'buffer-tail) 0))
+      (setf (slot-value stream 'last-write) (get-internal-real-time))))
   nil)
 
 (defmethod ext:stream-force-output ((stream slime-output-stream))
+  (ext:stream-finish-output stream)
   nil)
 
 (defmethod ext:stream-clear-output ((stream slime-output-stream))
+  (decf (slot-value stream 'position) (slot-value stream 'buffer-tail))
+  (setf (slot-value stream 'buffer-tail) 0)
   nil)
 
 ;;; Use default 'stream-element-type method for 'character-stream which
@@ -280,12 +299,14 @@
 	   (cond ((= target-position current-position)
                   t)
                  ((> target-position current-position)
+                  (ext:stream-finish-output stream)
                   (let ((output-fn (slot-value stream 'output-fn))
                         (fill-size (- target-position current-position)))
                     (declare (function output-fn))
                     (funcall output-fn (make-string fill-size
                                                     :initial-element #\space))
                     (setf (slot-value stream 'position) target-position))
+                  (setf (slot-value stream 'last-write) (get-internal-real-time))
                   t)
                  (t
                   nil))))
@@ -297,12 +318,58 @@
 
 ;;; Use the default 'character-output-stream 'file-string-length method.
 
-;;; stream-write-chars
+;;; stream-write-char -- internal
 ;;;
-;;; The stream out-buffer is typically large enough that there is little point
-;;; growing the stream output 'string large than the total size.  For typical
-;;; usage this reduces consing.  As the string grows larger then grow to
-;;; reduce the cost of copying strings around.
+(defmethod ext:stream-write-char ((stream slime-output-stream) character)
+  (declare (type character character)
+	   (optimize (speed 3)))
+  (unless (ext:stream-open-p stream)
+    (error 'kernel:simple-stream-error
+	   :stream stream
+	   :format-control "Stream closed."))
+  ;;
+  ;; Fill the output buffer.
+  (let* ((buffer-tail (slot-value stream 'buffer-tail))
+         (output-buffer (slot-value stream 'output-buffer))
+         (buffer-length (length output-buffer)))
+    (declare (type kernel:index buffer-tail)
+             (simple-string output-buffer))
+    (when (>= buffer-tail buffer-length)
+      ;; Flush the output buffer to make room.
+      (let ((output-fn (slot-value stream 'output-fn)))
+        (declare (function output-fn))
+        (funcall output-fn output-buffer)
+        (setf buffer-tail 0)
+        (setf (slot-value stream 'last-write) (get-internal-real-time))))
+    (setf (aref output-buffer buffer-tail) character)
+    (incf buffer-tail)
+    (setf (slot-value stream 'buffer-tail) buffer-tail)
+    ;;
+    (let ((newline (char= character #\newline)))
+      (when (or newline
+                (let ((last-write (slot-value stream 'last-write)))
+                  (declare (type integer last-write))
+                  (> (get-internal-real-time)
+                     (+ last-write (* 5 internal-time-units-per-second)))))
+        ;; Flush the output buffer.
+        (let ((output-fn (slot-value stream 'output-fn)))
+          (declare (function output-fn))
+          (funcall output-fn (subseq output-buffer 0 buffer-tail))
+          (setf buffer-tail 0)
+          (setf (slot-value stream 'buffer-tail) buffer-tail)
+          (setf (slot-value stream 'last-write) (get-internal-real-time))))
+      ;;
+      (setf (slot-value stream 'column)
+	    (if newline
+		0
+		(let ((line-column (slot-value stream 'column)))
+		  (declare (type kernel:index line-column))
+		  (+ line-column 1))))
+      (incf (slot-value stream 'position))
+      ))
+  character)
+
+;;; stream-write-chars
 ;;;
 (defmethod ext:stream-write-chars ((stream slime-output-stream)
                                    string start end waitp)
@@ -334,7 +401,8 @@
                   (- end last-newline 1)
                   (let ((column (slot-value stream 'column)))
                     (declare (type kernel:index column))
-                    (+ column (- end start))))))))
+                    (+ column (- end start))))))
+      (incf (slot-value stream 'position) length)))
   (- end start))
 
 ;;;
@@ -1163,35 +1231,9 @@
 ;;;;; Argument lists
 
 (defimplementation arglist (fun)
-  (etypecase fun
-    (function (function-arglist fun))
-    (symbol (function-arglist (or (macro-function fun)
-                                  (symbol-function fun))))))
-
-(defun function-arglist (fun)
-  (flet ((compiled-function-arglist (x)
-           (let ((args (kernel:%function-arglist x)))
-             (if args
-                 (read-arglist x)
-                 :not-available))))
-    (case (kernel:get-type fun)
-      (#.vm:closure-header-type
-       (compiled-function-arglist
-        (kernel:%closure-function fun)))
-      ((#.vm:function-header-type #.vm:closure-function-header-type)
-       (compiled-function-arglist fun))
-      (#.vm:funcallable-instance-header-type
-       (typecase fun
-         (kernel:byte-function
-          :not-available)
-         (kernel:byte-closure
-          :not-available)
-         (eval:interpreted-function
-          (eval:interpreted-function-arglist fun))
-         (otherwise
-          (clos::generic-function-lambda-list fun))))
-      (t
-       :non-available))))
+  (multiple-value-bind (args winp)
+      (ext:function-arglist fun)
+    (if winp args :not-available)))
 
 (defimplementation function-name (function)
   (cond ((eval:interpreted-function-p function)
@@ -1202,20 +1244,6 @@
          (c::byte-function-name function))
         (t (kernel:%function-name (kernel:%function-self function)))))
 
-;;; A simple case: the arglist is available as a string that we can
-;;; `read'.
-
-(defun read-arglist (fn)
-  "Parse the arglist-string of the function object FN."
-  (let ((string (kernel:%function-arglist
-                 (kernel:%function-self fn)))
-        (package (find-package
-                  (c::compiled-debug-info-package
-                   (kernel:%code-debug-info
-                    (vm::find-code-object fn))))))
-    (with-standard-io-syntax
-      (let ((*package* (or package *package*)))
-        (read-from-string string)))))
 
 ;;; A harder case: an approximate arglist is derived from available
 ;;; debugging information.
@@ -1262,54 +1290,6 @@
     (values (debug-function-arglist (di::function-debug-function fn))
             (kernel:%function-arglist (kernel:%function-self fn)))))
 
-;;; Deriving arglists for byte-compiled functions:
-;;;
-(defun byte-code-function-arglist (fn)
-  ;; There doesn't seem to be much arglist information around for
-  ;; byte-code functions.  Use the arg-count and return something like
-  ;; (arg0 arg1 ...)
-  (etypecase fn
-    (c::simple-byte-function 
-     (loop for i from 0 below (c::simple-byte-function-num-args fn)
-           collect (make-arg-symbol i)))
-    (c::hairy-byte-function 
-     (hairy-byte-function-arglist fn))
-    (c::byte-closure
-     (byte-code-function-arglist (c::byte-closure-function fn)))))
-
-(defun make-arg-symbol (i)
-  (make-symbol (format nil "~A~D" (string 'arg) i)))
-
-;;; A "hairy" byte-function is one that takes a variable number of
-;;; arguments. `hairy-byte-function' is a type from the bytecode
-;;; interpreter.
-;;;
-(defun hairy-byte-function-arglist (fn)
-  (let ((counter -1))
-    (flet ((next-arg () (make-arg-symbol (incf counter))))
-      (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
-                                            keywords-p keywords) fn
-        (let ((arglist '())
-              (optional (- max-args min-args)))
-          ;; XXX isn't there a better way to write this?
-          ;; (Looks fine to me. -luke)
-          (dotimes (i min-args)
-            (push (next-arg) arglist))
-          (when (plusp optional)
-            (push '&optional arglist)
-            (dotimes (i optional)
-              (push (next-arg) arglist)))
-          (when rest-arg-p
-            (push '&rest arglist)
-            (push (next-arg) arglist))
-          (when keywords-p
-            (push '&key arglist)
-            (loop for (key _ __) in keywords
-                  do (push key arglist))
-            (when (eq keywords-p :allow-others)
-              (push '&allow-other-keys arglist)))
-          (nreverse arglist))))))
-
 
 ;;;; Miscellaneous.
 
@@ -1941,7 +1921,7 @@
 (defimplementation thread-alive-p (thread)
   (not (zerop (thread::thread-dynamic-values thread))))
 
-(defvar *mailbox-lock* (thread:make-lock "Mailbox lock"))
+(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil))
   
 (defstruct (mailbox)
   (lock (thread:make-lock "Thread mailbox" :type :error-check
@@ -1951,32 +1931,38 @@
 
 (defun mailbox (thread)
   "Return 'thread's mailbox."
-  (thread:with-lock-held (*mailbox-lock*)
-    (or (getf (thread:thread-plist thread) 'mailbox)
-        (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox)))))
+  (sys:without-interrupts
+    (thread:with-lock-held (*mailbox-lock*)
+      (or (getf (thread:thread-plist thread) 'mailbox)
+          (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox))))))
   
 (defimplementation send (thread message)
   (let* ((mbox (mailbox thread))
          (lock (mailbox-lock mbox)))
-    (thread:with-lock-held (lock "Mailbox Send")
-      (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
-                                        (list message))))
+    (sys:without-interrupts
+      (thread:with-lock-held (lock "Mailbox Send")
+        (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+                                          (list message)))))
     (mp:process-wakeup thread)))
 
+#+nil
 (defimplementation receive ()
   (receive-if (constantly t)))
 
-(defimplementation receive-if (test)
+(defimplementation receive-if (test &optional timeout)
   (let ((mbox (mailbox thread:*thread*)))
+    (assert (or (not timeout) (eq timeout t)))
     (loop
      (check-slime-interrupts)
-     (mp:with-lock-held ((mailbox-lock mbox))
-       (let* ((q (mailbox-queue mbox))
-              (tail (member-if test q)))
-         (when tail
-           (setf (mailbox-queue mbox) 
-                 (nconc (ldiff q tail) (cdr tail)))
-           (return (car tail)))))
+     (sys:without-interrupts
+       (mp:with-lock-held ((mailbox-lock mbox))
+         (let* ((q (mailbox-queue mbox))
+                (tail (member-if test q)))
+           (when tail
+             (setf (mailbox-queue mbox) 
+                   (nconc (ldiff q tail) (cdr tail)))
+             (return (car tail))))))
+     (when (eq timeout t) (return (values nil t)))
      (mp:process-wait-with-timeout
       "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
 
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/22 22:56:18	1.595
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/23 04:57:51	1.596
@@ -1121,7 +1121,7 @@
         (t (dispatch-event event))))
 
 (defun signal-interrupt (thread interrupt)  
-  (log-event "singal-interrupt~%")
+  (log-event "signal-interrupt~%")
   (cond ((use-threads-p) (interrupt-thread thread interrupt))
         (t (funcall interrupt))))
 
@@ -2088,7 +2088,9 @@
   (flet ((pathname-or-string-p (thing)
            (or (pathnamep thing) (typep thing 'string)))
          (canonicalize-filename (filename)
-           (namestring (or (probe-file filename) filename))))
+           (let ((file-name (or (probe-file filename) filename)))
+             #-scl (namestring file-name)
+             #+scl (ext:unix-namestring file-name nil))))
     (let ((target
            (cond ((and (listp what) (pathname-or-string-p (first what)))
                   (cons (canonicalize-filename (car what)) (cdr what)))



From heller at common-lisp.net  Wed Sep 24 09:12:07 2008
From: heller at common-lisp.net (heller)
Date: Wed, 24 Sep 2008 05:12:07 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080924091207.4E2F84610B@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv13564

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-prefix-map): New keymap.
(slime-define-key): Use it.  Also drop unused :inferior arg.
(slime-inspector-mode-map): Bind C-c to slime-prefix-map.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/23 04:57:51	1.1540
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/24 09:10:34	1.1541
@@ -1,3 +1,9 @@
+2008-09-24  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-prefix-map): New keymap.
+	(slime-define-key): Use it.  Also drop unused :inferior arg.
+	(slime-inspector-mode-map): Bind C-c to slime-prefix-map.
+
 2008-09-23  Douglas Crosher <dcrosher at common-lisp.net>
 
 	* swank-scl.lisp: update for Scieneer CL 1.3.8.
--- /project/slime/cvsroot/slime/slime.el	2008/09/22 17:49:45	1.1039
+++ /project/slime/cvsroot/slime/slime.el	2008/09/24 09:11:02	1.1040
@@ -612,16 +612,20 @@
 (defvar slime-prefix-key "\C-c"
   "The prefix key to use in SLIME keybinding sequences.")
 
-(defun* slime-define-key (key command &key prefixed inferior)
+(defvar slime-prefix-map (make-sparse-keymap)
+  "Keymap for prefixed with `slime-prefix-key'.")
+
+(defun* slime-define-key (key command &key prefixed)
   "Define a keybinding of KEY for COMMAND.
 If PREFIXED is non-nil, `slime-prefix-key' is prepended to KEY."
-  (when prefixed
-    (setq key (concat slime-prefix-key key)))
-  (define-key slime-mode-map key command))
+  (cond (prefixed (define-key slime-prefix-map key command))
+        (t (define-key slime-mode-map key command))))
 
 (defun slime-init-keymaps ()
   "(Re)initialize the keymaps for `slime-mode'."
   (interactive)
+  (setq slime-prefix-map (make-sparse-keymap))
+  (define-key slime-mode-map slime-prefix-key slime-prefix-map)
   (loop for (key command . keys) in slime-keys
         do (apply #'slime-define-key key command :allow-other-keys t keys))
   ;; Documentation
@@ -634,7 +638,7 @@
                (let ((modified (slime-control-modified-char key)))
                  (define-key slime-doc-map (vector modified) command)))))
   ;; C-c C-d is the prefix for the doc map.
-  (slime-define-key "\C-d" slime-doc-map :prefixed t :inferior t)
+  (slime-define-key "\C-d" slime-doc-map :prefixed t)
   ;; Who-xref
   (setq slime-who-map (make-sparse-keymap))
   (loop for (key command) in slime-who-bindings
@@ -644,7 +648,7 @@
              (let ((modified (slime-control-modified-char key)))
                  (define-key slime-who-map (vector modified) command))))
   ;; C-c C-w is the prefix for the who-xref map.
-  (slime-define-key "\C-w" slime-who-map :prefixed t :inferior t))
+  (slime-define-key "\C-w" slime-who-map :prefixed t))
 
 (defun slime-control-modified-char (char)
   "Return the control-modified version of CHAR."
@@ -7988,7 +7992,8 @@
   ([(shift tab)] 'slime-inspector-previous-inspectable-object) ; Emacs translates S-TAB
   ([backtab]     'slime-inspector-previous-inspectable-object) ; to BACKTAB on X.
   ("\M-." 'slime-edit-definition)
-  ("." 'slime-inspector-show-source))
+  ("." 'slime-inspector-show-source)
+  (slime-prefix-key slime-prefix-map))
 
 
 ;;;; Buffer selector



From heller at common-lisp.net  Wed Sep 24 09:12:48 2008
From: heller at common-lisp.net (heller)
Date: Wed, 24 Sep 2008 05:12:48 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080924091248.B859D46181@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv13564/contrib

Modified Files:
	slime-presentations.el 
Log Message:
* slime.el (slime-prefix-map): New keymap.
(slime-define-key): Use it.  Also drop unused :inferior arg.
(slime-inspector-mode-map): Bind C-c to slime-prefix-map.

--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/09/22 17:49:42	1.18
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/09/24 09:12:19	1.19
@@ -702,7 +702,7 @@
 	       (define-key slime-presentation-command-map (vector modified) command))))
   (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
   ;; C-c C-v is the prefix for the presentation-command map.
-  (slime-define-key "\C-v" slime-presentation-command-map :prefixed t :inferior t)
+  (slime-define-key "\C-v" slime-presentation-command-map :prefixed t)
   (define-key slime-repl-mode-map "\C-c\C-v" slime-presentation-command-map)
   (define-key sldb-mode-map "\C-c\C-v" slime-presentation-command-map)
   (define-key slime-inspector-mode-map "\C-c\C-v" slime-presentation-command-map))



From heller at common-lisp.net  Wed Sep 24 09:13:18 2008
From: heller at common-lisp.net (heller)
Date: Wed, 24 Sep 2008 05:13:18 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080924091318.527432105F@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv14225

Modified Files:
	slime.el 
Log Message:
(slime-prefix-map): Fix docstring.

--- /project/slime/cvsroot/slime/slime.el	2008/09/24 09:11:02	1.1040
+++ /project/slime/cvsroot/slime/slime.el	2008/09/24 09:12:59	1.1041
@@ -613,7 +613,7 @@
   "The prefix key to use in SLIME keybinding sequences.")
 
 (defvar slime-prefix-map (make-sparse-keymap)
-  "Keymap for prefixed with `slime-prefix-key'.")
+  "Keymap for commands prefixed with `slime-prefix-key'.")
 
 (defun* slime-define-key (key command &key prefixed)
   "Define a keybinding of KEY for COMMAND.



From heller at common-lisp.net  Wed Sep 24 09:13:57 2008
From: heller at common-lisp.net (heller)
Date: Wed, 24 Sep 2008 05:13:57 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080924091357.DDFA36B6BC@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv14301

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-define-both-key-bindings): New function.  Factor of
slime-init-keymaps.
(slime-init-keymaps): Use it.
(slime-control-modified-char): Deleted.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/24 09:10:34	1.1541
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/24 09:13:30	1.1542
@@ -3,6 +3,10 @@
 	* slime.el (slime-prefix-map): New keymap.
 	(slime-define-key): Use it.  Also drop unused :inferior arg.
 	(slime-inspector-mode-map): Bind C-c to slime-prefix-map.
+	(slime-define-both-key-bindings): New function.  Factor of
+	slime-init-keymaps.
+	(slime-init-keymaps): Use it.
+	(slime-control-modified-char): Deleted.
 
 2008-09-23  Douglas Crosher <dcrosher at common-lisp.net>
 
--- /project/slime/cvsroot/slime/slime.el	2008/09/24 09:12:59	1.1041
+++ /project/slime/cvsroot/slime/slime.el	2008/09/24 09:13:38	1.1042
@@ -630,30 +630,21 @@
         do (apply #'slime-define-key key command :allow-other-keys t keys))
   ;; Documentation
   (setq slime-doc-map (make-sparse-keymap))
-  (loop for (key command) in slime-doc-bindings
-        do (progn
-             ;; We bind both unmodified and with control.
-             (define-key slime-doc-map (vector key) command)
-             (unless (equal key ?h)     ; But don't bind C-h
-               (let ((modified (slime-control-modified-char key)))
-                 (define-key slime-doc-map (vector modified) command)))))
+  (slime-define-both-key-bindings slime-doc-map slime-doc-bindings)
   ;; C-c C-d is the prefix for the doc map.
   (slime-define-key "\C-d" slime-doc-map :prefixed t)
   ;; Who-xref
   (setq slime-who-map (make-sparse-keymap))
-  (loop for (key command) in slime-who-bindings
-        do (progn
-             ;; We bind both unmodified and with control.
-             (define-key slime-who-map (vector key) command)
-             (let ((modified (slime-control-modified-char key)))
-                 (define-key slime-who-map (vector modified) command))))
+  (slime-define-both-key-bindings slime-who-map slime-who-bindings)
   ;; C-c C-w is the prefix for the who-xref map.
   (slime-define-key "\C-w" slime-who-map :prefixed t))
 
-(defun slime-control-modified-char (char)
-  "Return the control-modified version of CHAR."
-  ;; Maybe better to just bitmask it?
-  (read (format "?\\C-%c" char)))
+(defun slime-define-both-key-bindings (keymap bindings)
+  (loop for (char command) in bindings do
+        ;; We bind both unmodified and with control.
+        (define-key keymap `[,char] command)
+        (unless (equal char ?h)     ; But don't bind C-h
+          (define-key keymap `[(control ,char)] command))))
 
 (slime-init-keymaps)
 



From heller at common-lisp.net  Wed Sep 24 09:14:07 2008
From: heller at common-lisp.net (heller)
Date: Wed, 24 Sep 2008 05:14:07 -0400 (EDT)
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <20080924091407.8F2691A0EE@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv14301/contrib

Modified Files:
	slime-presentations.el 
Log Message:
* slime.el (slime-define-both-key-bindings): New function.  Factor of
slime-init-keymaps.
(slime-init-keymaps): Use it.
(slime-control-modified-char): Deleted.

--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/09/24 09:12:19	1.19
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2008/09/24 09:14:02	1.20
@@ -690,16 +690,12 @@
     (?r slime-copy-presentation-at-point-to-repl)
     (?p slime-previous-presentation)
     (?n slime-next-presentation)
-    (?  slime-mark-presentation)))
+    (?\  slime-mark-presentation)))
 
 (defun slime-presentation-init-keymaps ()
   (setq slime-presentation-command-map (make-sparse-keymap))
-  (loop for (key command) in slime-presentation-bindings
-        do (progn
-             ;; We bind both unmodified and with control.
-             (define-key slime-presentation-command-map (vector key) command)
-             (let ((modified (slime-control-modified-char key)))
-	       (define-key slime-presentation-command-map (vector modified) command))))
+  (slime-define-both-key-bindings slime-presentation-command-map 
+				  slime-presentation-bindings)
   (define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
   ;; C-c C-v is the prefix for the presentation-command map.
   (slime-define-key "\C-v" slime-presentation-command-map :prefixed t)



From heller at common-lisp.net  Wed Sep 24 09:14:27 2008
From: heller at common-lisp.net (heller)
Date: Wed, 24 Sep 2008 05:14:27 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080924091427.04636662D6@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv14456

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-cycle-connections): New command.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/24 09:13:30	1.1542
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/24 09:14:13	1.1543
@@ -1,3 +1,7 @@
+2008-09-24  Knut Olav B?hmer <knut-olav.bohmer at telenor.com>
+
+	* slime.el (slime-cycle-connections): New command.
+
 2008-09-24  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (slime-prefix-map): New keymap.
--- /project/slime/cvsroot/slime/slime.el	2008/09/24 09:13:38	1.1042
+++ /project/slime/cvsroot/slime/slime.el	2008/09/24 09:14:15	1.1043
@@ -1854,6 +1854,17 @@
   "Make PROCESS the default connection."
   (setq slime-default-connection process))
 
+(defun slime-cycle-connections ()
+  "Change current slime connection, and make it buffer local."
+  (interactive)
+  (let* ((tail (or (cdr (member (slime-current-connection)
+                                slime-net-processes))
+                   slime-net-processes))
+         (p (car tail)))
+    (slime-select-connection p)
+    (setq slime-buffer-connection p)
+    (message "Lisp: %s %s" (slime-connection-name p) (process-contact p))))
+
 (defmacro* slime-with-connection-buffer ((&optional process) &rest body)
   "Execute BODY in the process-buffer of PROCESS.
 If PROCESS is not specified, `slime-connection' is used.



From trittweiler at common-lisp.net  Fri Sep 26 12:24:54 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 26 Sep 2008 08:24:54 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080926122454.966A9471BC@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv7422

Modified Files:
	slime.el ChangeLog 
Log Message:

* slime.el (slime-cycle-connections): Do not make the new
  connection buffer-local if we're currently in a REPL buffer.


--- /project/slime/cvsroot/slime/slime.el	2008/09/24 09:14:15	1.1043
+++ /project/slime/cvsroot/slime/slime.el	2008/09/26 12:24:53	1.1044
@@ -1862,7 +1862,8 @@
                    slime-net-processes))
          (p (car tail)))
     (slime-select-connection p)
-    (setq slime-buffer-connection p)
+    (unless (eq major-mode 'slime-repl-mode)
+      (setq slime-buffer-connection p))
     (message "Lisp: %s %s" (slime-connection-name p) (process-contact p))))
 
 (defmacro* slime-with-connection-buffer ((&optional process) &rest body)
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/24 09:14:13	1.1543
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/26 12:24:54	1.1544
@@ -1,3 +1,8 @@
+2008-09-25  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-cycle-connections): Do not make the new
+	connection buffer-local if we're currently in a REPL buffer.
+
 2008-09-24  Knut Olav B?hmer <knut-olav.bohmer at telenor.com>
 
 	* slime.el (slime-cycle-connections): New command.



From trittweiler at common-lisp.net  Fri Sep 26 23:14:10 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Fri, 26 Sep 2008 19:14:10 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080926231410.AA602751B7@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv28231

Modified Files:
	swank-ecl.lisp ChangeLog 
Log Message:

Improve ECL's arglist support somewhat.

* swank-ecl.lisp (grovel-docstring-for-arglist): New function.
  (arglist): Use it. Now also try to find an arglist for special
  operators, and macros.


--- /project/slime/cvsroot/slime/swank-ecl.lisp	2008/09/18 10:08:34	1.31
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2008/09/26 23:14:10	1.32
@@ -170,31 +170,45 @@
 
 ;;;; Documentation
 
+(defun grovel-docstring-for-arglist (name type)
+  (flet ((compute-arglist-offset (docstring)
+           (when docstring
+             (let ((pos1 (search "Args: " docstring)))
+               (if pos1
+                   (+ pos1 6)
+                   (let ((pos2 (search "Syntax: " docstring)))
+                     (when pos2
+                       (+ pos2 8))))))))
+    (let* ((docstring (si::get-documentation name type))
+           (pos (compute-arglist-offset docstring)))
+      (if pos
+          (multiple-value-bind (arglist errorp)
+              (ignore-errors
+                (values (read-from-string docstring t nil :start pos)))
+            (if errorp :not-available (cdr arglist)))
+          :not-available ))))
+
 (defimplementation arglist (name)
-  (or (functionp name) (setf name (symbol-function name)))
-  (if (functionp name)
-      (typecase name 
-        (generic-function
-         (clos::generic-function-lambda-list name))
-        (compiled-function
-         ; most of the compiled functions have an Args: line in their docs
-         (with-input-from-string (s (or
-                                     (si::get-documentation
-                                      (si:compiled-function-name name) 'function)
-                                     ""))
-           (do ((line (read-line s nil) (read-line s nil)))
-               ((not line) :not-available)
-             (ignore-errors
-               (if (string= (subseq line 0 6) "Args: ")
-                   (return-from nil
-                     (read-from-string (subseq line 6))))))))
-         ;
-        (function
-         (let ((fle (function-lambda-expression name)))
-           (case (car fle)
-             (si:lambda-block (caddr fle))
-             (t               :not-available)))))
-      :not-available))
+  (cond ((special-operator-p name)
+         (grovel-docstring-for-arglist name 'function))
+        ((macro-function name)
+         (grovel-docstring-for-arglist name 'function))
+        ((or (functionp name) (fboundp name))
+         (multiple-value-bind (name fndef)
+             (if (functionp name)
+                 (values (function-name name) name)
+                 (values name (fdefinition name)))
+           (typecase fndef
+             (generic-function
+              (clos::generic-function-lambda-list fndef))
+             (compiled-function
+              (grovel-docstring-for-arglist name 'function))
+             (function
+              (let ((fle (function-lambda-expression fndef)))
+                (case (car fle)
+                  (si:lambda-block (caddr fle))
+                  (t               :not-available)))))))
+        (t :not-available)))
 
 (defimplementation function-name (f)
   (si:compiled-function-name f))
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/26 12:24:54	1.1544
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/26 23:14:10	1.1545
@@ -1,4 +1,12 @@
-2008-09-25  Tobias C. Rittweiler  <tcr at freebits.de>
+2008-09-27  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Improve ECL's arglist support somewhat.
+
+	* swank-ecl.lisp (grovel-docstring-for-arglist): New function.
+	(arglist): Use it. Now also try to find an arglist for special
+	operators, and macros.
+
+2008-09-26  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime.el (slime-cycle-connections): Do not make the new
 	connection buffer-local if we're currently in a REPL buffer.



From heller at common-lisp.net  Sun Sep 28 09:39:32 2008
From: heller at common-lisp.net (heller)
Date: Sun, 28 Sep 2008 05:39:32 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080928093932.72D722E1D8@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16851

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Stop handling events in worker threads after sldb-quit.

* swank.lisp (with-top-level-restart): New macro.
(handle-requests, spawn-worker-thread): Use it.
(process-requests): Drop the just-one argument.
(handle-or-process-requests): Deleted. Call handle-requests
directly.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/26 23:14:10	1.1545
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/28 09:39:31	1.1546
@@ -1,3 +1,13 @@
+2008-09-28  Helmut Eller  <heller at common-lisp.net>
+
+	Stop handling events in worker threads after sldb-quit.
+
+	* swank.lisp (with-top-level-restart): New macro.
+	(handle-requests, spawn-worker-thread): Use it.
+	(process-requests): Drop the just-one argument.
+	(handle-or-process-requests): Deleted. Call handle-requests
+	directly.
+
 2008-09-27  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Improve ECL's arglist support somewhat.
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/23 04:57:51	1.596
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/28 09:39:31	1.597
@@ -934,31 +934,42 @@
       (when socket
         (close-socket socket)))))
 
-(defvar *sldb-quit-restart* 'abort
-  "What restart should swank attempt to invoke when the user sldb-quits.")
+;; The restart that will be invoked when the user calls sldb-quit.
+;; This restart will be named "abort" because many people press "a"
+;; instead of "q" in the debugger.
+(defvar *sldb-quit-restart*)
+
+;; Establish a top-level restart and execute BODY.
+;; Execute K if the restart is invoked.
+(defmacro with-top-level-restart ((connection k) &body body)
+  `(with-connection (,connection)
+     (restart-case 
+         (let ((*sldb-quit-restart* (find-restart 'abort)))
+           . ,body)
+       (abort (&optional v)
+         :report "Return to SLIME's top level."
+         (declare (ignore v))
+         (force-user-output)
+         ,k))))
 
-(defun handle-requests (connection &optional timeout just-one)
-  "Read and process requests.  
+(defun handle-requests (connection &optional timeout)
+  "Read and process :emacs-rex requests.
 The processing is done in the extent of the toplevel restart."
-  (assert (null *swank-state-stack*))
-  (let ((*swank-state-stack* '(:handle-request)))
-    (with-connection (connection)
-      (loop 
-       (with-simple-restart (abort "Return to SLIME's top level.")
-         (let* ((*sldb-quit-restart* (find-restart 'abort))
-                (timeout? (process-requests timeout just-one)))
-           (when (or just-one timeout?) 
-             (return))))
-       (force-user-output)))))
+  (cond ((boundp '*sldb-quit-restart*)
+         (process-requests timeout))
+        (t 
+         (tagbody
+            start
+            (with-top-level-restart (connection (go start))
+              (process-requests timeout))))))
 
-(defun process-requests (timeout just-one)
+(defun process-requests (timeout)
   "Read and process requests from Emacs."
   (loop
    (multiple-value-bind (event timeout?)
        (wait-for-event `(:emacs-rex . _) timeout)
-     (when timeout? (return t))
-     (apply #'eval-for-emacs (cdr event))
-     (when just-one (return nil)))))
+    (when timeout? (return))
+    (apply #'eval-for-emacs (cdr event)))))
 
 (defun current-socket-io ()
   (connection.socket-io *emacs-connection*))
@@ -1061,7 +1072,9 @@
 (defun spawn-worker-thread (connection)
   (spawn (lambda () 
            (with-bindings *default-worker-thread-bindings*
-             (handle-requests connection nil t)))
+             (with-top-level-restart (connection nil)
+               (apply #'eval-for-emacs 
+                      (cdr (wait-for-event `(:emacs-rex . _)))))))
          :name "worker"))
 
 (defun spawn-repl-thread (connection name)
@@ -1204,7 +1217,7 @@
 (defun install-sigio-handler (connection)
   (add-sigio-handler (connection.socket-io connection) 
                      (lambda () (process-io-interrupt connection)))
-  (handle-or-process-requests connection))
+  (handle-requests connection t))
 
 (defvar *io-interupt-level* 0)
 
@@ -1212,16 +1225,9 @@
   (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
   (let ((*io-interupt-level* (1+ *io-interupt-level*)))
     (invoke-or-queue-interrupt
-     (lambda () (handle-or-process-requests connection))))
+     (lambda () (handle-requests connection t))))
   (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
 
-(defun handle-or-process-requests (connection)
-  (log-event "handle-or-process-requests: ~a~%" *swank-state-stack*)
-  (cond ((null *swank-state-stack*)
-         (handle-requests connection t))
-        ((eq (car *swank-state-stack*) :read-next-form))
-        (t (process-requests t nil))))
-
 (defun deinstall-sigio-handler (connection)
   (log-event "deinstall-sigio-handler...~%")
   (remove-sigio-handlers (connection.socket-io connection))
@@ -1231,7 +1237,7 @@
 
 (defun install-fd-handler (connection)
   (add-fd-handler (connection.socket-io connection)
-                  (lambda () (handle-or-process-requests connection)))
+                  (lambda () (handle-requests connection t)))
   (setf (connection.saved-sigint-handler connection)
         (install-sigint-handler 
          (lambda () 
@@ -1239,7 +1245,7 @@
             (lambda () 
               (with-connection (connection)
                 (dispatch-interrupt-event)))))))
-  (handle-or-process-requests connection))
+  (handle-requests connection t))
 
 (defun dispatch-interrupt-event ()
   (dispatch-event `(:emacs-interrupt ,(current-thread-id))))



From trittweiler at common-lisp.net  Sun Sep 28 12:14:44 2008
From: trittweiler at common-lisp.net (trittweiler)
Date: Sun, 28 Sep 2008 08:14:44 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20080928121444.A907D3E057@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv1453

Modified Files:
	slime.el ChangeLog 
Log Message:

* slime.el (slime-list-compiler-notes): Revert change from
  2008-08-15 which introduced automatic shrinkage of the
  compiler-notes buffer. This turned out to be more annoying than
  worthwhile. On the cases where it's desired, the user can just use
  `C-x -' himself to shrink the notes buffer.


--- /project/slime/cvsroot/slime/slime.el	2008/09/26 12:24:53	1.1044
+++ /project/slime/cvsroot/slime/slime.el	2008/09/28 12:14:44	1.1045
@@ -4153,8 +4153,6 @@
           (when (slime-tree.collapsed-p tree) (setf collapsed-p t))
           (slime-tree-insert tree "")
           (insert "\n"))
-        (unless collapsed-p
-          (shrink-window-if-larger-than-buffer))
         (goto-char (point-min))))))
 
 (defun slime-alistify (list key test)
--- /project/slime/cvsroot/slime/ChangeLog	2008/09/28 09:39:31	1.1546
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/28 12:14:44	1.1547
@@ -1,3 +1,11 @@
+2008-09-28  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime.el (slime-list-compiler-notes): Revert change from
+	2008-08-15 which introduced automatic shrinkage of the
+	compiler-notes buffer. This turned out to be more annoying than
+	worthwhile. On the cases where it's desired, the user can just use
+	`C-x -' himself to shrink the notes buffer.
+
 2008-09-28  Helmut Eller  <heller at common-lisp.net>
 
 	Stop handling events in worker threads after sldb-quit.