From heller at common-lisp.net  Thu Dec  1 16:48:21 2011
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 01 Dec 2011 08:48:21 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RW9o5-0005Sg-T8@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (do-symbols*, classify-symbol)
(symbol-classification-string): Moved to contrib/swank-util.lisp.

--- /project/slime/cvsroot/slime/ChangeLog	2011/11/29 19:50:15	1.2251
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/01 16:48:21	1.2252
@@ -1,9 +1,15 @@
 2011-11-29  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (do-symbols*, classify-symbol)
+	(symbol-classification-string): Moved to contrib/swank-util.lisp.
+
+2011-11-29  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (to-line): Increase default limit to 512.
 	(frame-locals-for-emacs): Let *print-right-margin* override
 	default line width.
 
+
 2011-11-27  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (create-server): Add a :backlog argument.
--- /project/slime/cvsroot/slime/swank.lisp	2011/11/29 19:50:16	1.765
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/01 16:48:21	1.766
@@ -540,15 +540,6 @@
                       `(,getter ,',var))))
          , at body))))
 
-(defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
-  "Just like do-symbols, but makes sure a symbol is visited only once."
-  (let ((seen-ht (gensym "SEEN-HT")))
-    `(let ((,seen-ht (make-hash-table :test #'eq)))
-      (do-symbols (,var ,package ,result-form)
-        (unless (gethash ,var ,seen-ht)
-          (setf (gethash ,var ,seen-ht) t)
-          (tagbody , at body))))))
-
 (defmacro define-special (name doc)
   "Define a special variable NAME with doc string DOC.
 This is like defvar, but NAME will not be initialized."
@@ -650,57 +641,6 @@
 If PACKAGE is not specified, the home package of SYMBOL is used."
   (eq (symbol-status symbol package) :external))
 
-
-(defun classify-symbol (symbol)
-  "Returns a list of classifiers that classify SYMBOL according to its
-underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
-variable.) The list may contain the following classification
-keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
-:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
-  (check-type symbol symbol)
-  (flet ((type-specifier-p (s)
-           (or (documentation s 'type)
-               (not (eq (type-specifier-arglist s) :not-available)))))
-    (let (result)
-      (when (boundp symbol)             (push (if (constantp symbol)
-                                                  :constant :boundp) result))
-      (when (fboundp symbol)            (push :fboundp result))
-      (when (type-specifier-p symbol)   (push :typespec result))
-      (when (find-class symbol nil)     (push :class result))
-      (when (macro-function symbol)     (push :macro result))
-      (when (special-operator-p symbol) (push :special-operator result))
-      (when (find-package symbol)       (push :package result))
-      (when (and (fboundp symbol)
-                 (typep (ignore-errors (fdefinition symbol))
-                        'generic-function))
-        (push :generic-function result))
-
-      result)))
-
-(defun symbol-classification-string (symbol)
-  "Return a string in the form -f-c---- where each letter stands for
-boundp fboundp generic-function class macro special-operator package"
-  (let ((letters "bfgctmsp")
-        (result (copy-seq "--------")))
-    (flet ((type-specifier-p (s)
-             (or (documentation s 'type)
-                 (not (eq (type-specifier-arglist s) :not-available))))
-           (flip (letter)
-             (setf (char result (position letter letters))
-                   letter)))
-      (when (boundp symbol) (flip #\b))
-      (when (fboundp symbol)
-        (flip #\f)
-        (when (typep (ignore-errors (fdefinition symbol))
-                     'generic-function)
-          (flip #\g)))
-      (when (type-specifier-p symbol) (flip #\t))
-      (when (find-class symbol nil)   (flip #\c) )
-      (when (macro-function symbol)   (flip #\m))
-      (when (special-operator-p symbol) (flip #\s))
-      (when (find-package symbol)       (flip #\p))
-      result)))
-
 
 ;;;; TCP Server
 
@@ -1862,7 +1802,8 @@
        ,(cond ((and stream object)
                (let ((gstream (gensym "STREAM+")))
                  `(let ((,gstream ,stream))
-                    (print-unreadable-object (,object ,gstream :type t :identity t)
+                    (print-unreadable-object (,object ,gstream :type t 
+                                                      :identity t)
                       (write-string ,msg ,gstream)))))
               (stream
                `(write-string ,msg ,stream))
@@ -2675,7 +2616,7 @@
 
 (defun frame-locals-for-emacs (index)
   (with-bindings *backtrace-printer-bindings*
-    (loop for var in (frame-locals index) collect 
+    (loop for var in (frame-locals index) collect
           (destructuring-bind (&key name id value) var
             (list :name (prin1-to-string name)
                   :id id
@@ -2703,7 +2644,8 @@
             (setq *sldb-stepping-p* t)
             (continue))
            (t
-            (error "Not currently single-stepping, and no continue restart available.")))))
+            (error "Not currently single-stepping, ~
+and no continue restart available.")))))
 
 (define-stepper-function sldb-step sldb-step-into)
 (define-stepper-function sldb-next sldb-step-next)




From heller at common-lisp.net  Thu Dec  1 16:48:22 2011
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 01 Dec 2011 08:48:22 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RW9o6-0005Sx-4s@common-lisp.net>

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

Modified Files:
	ChangeLog swank-c-p-c.lisp swank-fancy-inspector.lisp 
	swank-fuzzy.lisp 
Log Message:
* swank.lisp (do-symbols*, classify-symbol)
(symbol-classification-string): Moved to contrib/swank-util.lisp.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/11/28 18:38:34	1.511
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/01 16:48:21	1.512
@@ -1,3 +1,10 @@
+2011-11-29  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-util.lisp: New file.
+	* swank-c-p-c.lisp: Use it.
+	* swank-fancy-inspector.lisp:
+	* swank-fuzzy.lisp:
+
 2011-11-28  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* slime-cl-indent.el (common-lisp-trailing-comment): New function.
--- /project/slime/cvsroot/slime/contrib/swank-c-p-c.lisp	2010/09/09 08:28:21	1.7
+++ /project/slime/cvsroot/slime/contrib/swank-c-p-c.lisp	2011/12/01 16:48:22	1.8
@@ -12,6 +12,9 @@
 
 (in-package :swank)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-util))
+
 (defslimefun completions (string default-package-name)
   "Return a list of completions for a symbol designator STRING.  
 
--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2011/11/12 14:43:02	1.31
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2011/12/01 16:48:22	1.32
@@ -6,6 +6,9 @@
 
 (in-package :swank)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-util))
+
 (defmethod emacs-inspect ((symbol symbol))
   (let ((package (symbol-package symbol)))
     (multiple-value-bind (_symbol status) 
--- /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp	2010/10/15 16:09:07	1.12
+++ /project/slime/cvsroot/slime/contrib/swank-fuzzy.lisp	2011/12/01 16:48:22	1.13
@@ -11,6 +11,7 @@
 (in-package :swank)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (swank-require :swank-util)
   (swank-require :swank-c-p-c))
 
 ;;; For nomenclature of the fuzzy completion section, please read




From heller at common-lisp.net  Thu Dec  1 16:51:30 2011
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 01 Dec 2011 08:51:30 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RW9r8-0005k7-1O@common-lisp.net>

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

Added Files:
	swank-util.lisp 
Log Message:
actually add the file


--- /project/slime/cvsroot/slime/contrib/swank-util.lisp	2011/12/01 16:51:30	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-util.lisp	2011/12/01 16:51:30	1.1
;;; swank-util.lisp --- stuff of questionable utility
;;
;; License: public domain

(in-package :swank)

(defmacro do-symbols* ((var &optional (package '*package*) result-form)
                       &body body)
  "Just like do-symbols, but makes sure a symbol is visited only once."
  (let ((seen-ht (gensym "SEEN-HT")))
    `(let ((,seen-ht (make-hash-table :test #'eq)))
       (do-symbols (,var ,package ,result-form)
         (unless (gethash ,var ,seen-ht)
           (setf (gethash ,var ,seen-ht) t)
           (tagbody , at body))))))

(defun classify-symbol (symbol)
  "Returns a list of classifiers that classify SYMBOL according to its
underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
variable.) The list may contain the following classification
keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
  (check-type symbol symbol)
  (flet ((type-specifier-p (s)
           (or (documentation s 'type)
               (not (eq (type-specifier-arglist s) :not-available)))))
    (let (result)
      (when (boundp symbol)             (push (if (constantp symbol)
                                                  :constant :boundp) result))
      (when (fboundp symbol)            (push :fboundp result))
      (when (type-specifier-p symbol)   (push :typespec result))
      (when (find-class symbol nil)     (push :class result))
      (when (macro-function symbol)     (push :macro result))
      (when (special-operator-p symbol) (push :special-operator result))
      (when (find-package symbol)       (push :package result))
      (when (and (fboundp symbol)
                 (typep (ignore-errors (fdefinition symbol))
                        'generic-function))
        (push :generic-function result))
      result)))

(defun symbol-classification-string (symbol)
  "Return a string in the form -f-c---- where each letter stands for
boundp fboundp generic-function class macro special-operator package"
  (let ((letters "bfgctmsp")
        (result (copy-seq "--------")))
    (flet ((type-specifier-p (s)
             (or (documentation s 'type)
                 (not (eq (type-specifier-arglist s) :not-available))))
           (flip (letter)
             (setf (char result (position letter letters))
                   letter)))
      (when (boundp symbol) (flip #\b))
      (when (fboundp symbol)
        (flip #\f)
        (when (typep (ignore-errors (fdefinition symbol))
                     'generic-function)
          (flip #\g)))
      (when (type-specifier-p symbol) (flip #\t))
      (when (find-class symbol nil)   (flip #\c) )
      (when (macro-function symbol)   (flip #\m))
      (when (special-operator-p symbol) (flip #\s))
      (when (find-package symbol)       (flip #\p))
      result)))



From heller at common-lisp.net  Thu Dec  1 16:54:52 2011
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 01 Dec 2011 08:54:52 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RW9uO-00069B-A5@common-lisp.net>

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

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
* swank-cmucl.lisp (method-location): Special case accessors.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/01 16:48:21	1.2252
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/01 16:54:51	1.2253
@@ -1,3 +1,7 @@
+2011-12-01  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-cmucl.lisp (method-location): Special case accessors.
+
 2011-11-29  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (do-symbols*, classify-symbol)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2011/11/27 21:47:15	1.239
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2011/12/01 16:54:52	1.240
@@ -1075,10 +1075,19 @@
          (qualifiers (pcl:method-qualifiers method)))
     `(method ,name , at qualifiers ,(pcl::unparse-specializers specializers))))
 
-;; XXX maybe special case setters/getters
 (defun method-location (method)
-  (function-location (or (pcl::method-fast-function method)
-                         (pcl:method-function method))))
+  (typecase method
+    (pcl::standard-accessor-method
+     (definition-source-location
+         (cond ((pcl::definition-source method) 
+                method)
+               (t
+                (pcl::slot-definition-class
+                 (pcl::accessor-method-slot-definition method))))
+         (pcl::accessor-method-slot-name method)))
+    (t
+     (function-location (or (pcl::method-fast-function method)
+                            (pcl:method-function method))))))
 
 (defun genericp (fn)
   (typep fn 'generic-function))




From heller at common-lisp.net  Thu Dec  1 16:55:02 2011
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 01 Dec 2011 08:55:02 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RW9uY-0006AG-VO@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp (*contribs*): Add swank-util.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/01 16:54:51	1.2253
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/01 16:55:02	1.2254
@@ -1,5 +1,9 @@
 2011-12-01  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-loader.lisp (*contribs*): Add swank-util.
+
+2011-12-01  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-cmucl.lisp (method-location): Special case accessors.
 
 2011-11-29  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/11/07 19:48:14	1.110
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/01 16:55:02	1.111
@@ -214,7 +214,8 @@
   `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
 
 (defvar *contribs*
-  '(swank-c-p-c swank-arglists swank-fuzzy
+  '(swank-util 
+    swank-c-p-c swank-arglists swank-fuzzy
     swank-fancy-inspector
     swank-presentations swank-presentation-streams
     #+(or asdf sbcl ecl) swank-asdf




From heller at common-lisp.net  Thu Dec  1 22:34:29 2011
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 01 Dec 2011 14:34:29 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWFD3-0005qz-EX@common-lisp.net>

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

Modified Files:
	ChangeLog swank-kawa.scm 
Log Message:
* swank-kawa.scm (mangled-name): Try to deal unnamed lambdas.
(inspect): Split up into inspect-array-ref and inspect-obj-ref.
(inspect-array-ref): New.
(inspect-obj-ref): New. Include methods in result.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/01 16:48:21	1.512
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/01 22:34:29	1.513
@@ -1,3 +1,10 @@
+2011-12-01  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-kawa.scm (mangled-name): Try to deal unnamed lambdas.
+	(inspect): Split up into inspect-array-ref and inspect-obj-ref.
+	(inspect-array-ref): New.
+	(inspect-obj-ref): New. Include methods in result.
+
 2011-11-29  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-util.lisp: New file.
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2010/10/17 10:17:31	1.24
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2011/12/01 22:34:29	1.25
@@ -920,7 +920,9 @@
     (as <meth-ref> (1st (! methods-by-name module name)))))
 
 (df mangled-name ((f <gnu.expr.ModuleMethod>))
-  (let ((name (gnu.expr.Compilation:mangleName (! get-name f))))
+  (let* ((name0 (! get-name f))
+         (name (cond ((nul? name0) (format "lambda~d" (@ selector f)))
+                     (#t (gnu.expr.Compilation:mangleName name0)))))
     (if (= (! maxArgs f) -1)
         (cat name "$V")
         name)))
@@ -1163,29 +1165,44 @@
                            (content-range  c 0 (len c)))))))
 
 (df inspect (obj vm)
-  (let* ((obj (as <obj-ref> (vm-mirror vm obj))))
-    (packing (pack)
-      (typecase obj
-        (<array-ref>
-         (let ((i 0))
-           (iter (! getValues obj)
-                 (fun ((v <value>))
-                   (pack (format "~d: " i))
-                   (set i (1+ i))
-                   (pack `(:value ,(vm-demirror vm v)))
-                   (pack "\n")))))
-        (<obj-ref>
-         (let* ((type (! referenceType obj))
-                (fields (! allFields type))
-                (values (! getValues obj fields)))
-           (iter fields 
-                 (fun ((f <field>))
-                   (let ((val (as <value> (! get values f))))
-                     (when (! is-static f)
-                       (pack "static "))
-                     (pack (! name f)) (pack ": ") 
-                     (pack `(:value ,(vm-demirror vm val)))
-                     (pack "\n"))))))))))
+  (let ((obj (as <obj-ref> (vm-mirror vm obj))))
+    (typecase obj 
+      (<array-ref> (inspect-array-ref vm obj))
+      (<obj-ref> (inspect-obj-ref vm obj)))))
+
+(df inspect-array-ref ((vm <vm>) (obj <array-ref>))
+  (packing (pack)
+    (let ((i 0))
+      (iter (! getValues obj)
+            (fun ((v <value>))
+              (pack (format "~d: " i))
+              (pack `(:value ,(vm-demirror vm v)))
+              (pack "\n")
+              (set i (1+ i)))))))
+
+(df inspect-obj-ref ((vm <vm>) (obj <obj-ref>))
+  (let* ((type (! referenceType obj))
+         (fields (! allFields type))
+         (values (! getValues obj fields))
+         (ifields '()) (sfields '()) (imeths '()) (smeths '())
+         (frob (lambda (lists) (apply append (reverse lists)))))
+    (iter fields 
+          (fun ((f <field>))
+            (let* ((val (as <value> (! get values f)))
+                   (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n")))
+              (if (! is-static f) 
+                  (pushf l sfields)
+                  (pushf l ifields)))))
+    (iter (! allMethods type)
+          (fun ((m <meth-ref>))
+            (let ((l `(,(! name m) ,(! signature m) "\n")))
+              (if (! is-static m)
+                  (pushf l smeths)
+                  (pushf l imeths)))))
+    `(,@(frob ifields) 
+      "--- static fields ---\n" ,@(frob sfields)
+      "--- methods ---\n" ,@(frob imeths)
+      "--- static methods ---\n" ,@(frob smeths))))
 
 (df inspector-content (content (state <inspector-state>))
   (map (fun (part)




From heller at common-lisp.net  Thu Dec  1 22:34:41 2011
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 01 Dec 2011 14:34:41 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWFDF-0005ry-NN@common-lisp.net>

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

Modified Files:
	ChangeLog swank-backend.lisp swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (wait-for-input): Call poll(2).
* swank-backend.lisp (wait-for-streams, wait-for-one-stream):
Deleted. Wouldn't work on binary streams.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/01 16:55:02	1.2254
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/01 22:34:41	1.2255
@@ -1,5 +1,11 @@
 2011-12-01  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-sbcl.lisp (wait-for-input): Call poll(2).
+	* swank-backend.lisp (wait-for-streams, wait-for-one-stream):
+	Deleted. Wouldn't work on binary streams.
+
+2011-12-01  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-loader.lisp (*contribs*): Add swank-util.
 
 2011-12-01  Helmut Eller  <heller at common-lisp.net>
@@ -17,7 +23,6 @@
 	(frame-locals-for-emacs): Let *print-right-margin* override
 	default line width.
 
-
 2011-11-27  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (create-server): Add a :backlog argument.
--- /project/slime/cvsroot/slime/swank-backend.lisp	2011/11/27 21:47:15	1.213
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2011/12/01 22:34:41	1.214
@@ -1377,34 +1377,6 @@
 
 Return :interrupt if an interrupt occurs while waiting.")
 
-(defun wait-for-streams (streams timeout)
-  (loop
-   (when (check-slime-interrupts) (return :interrupt))
-   (let ((ready (remove-if-not #'stream-readable-p streams)))
-     (when ready (return ready)))
-   (when timeout (return nil))
-   (sleep 0.1)))
-
-;; Note: Usually we can't interrupt PEEK-CHAR cleanly.
-(defun wait-for-one-stream (stream timeout)
-  (ecase timeout
-    ((nil)
-     (cond ((check-slime-interrupts) :interrupt)
-           (t (peek-char nil stream nil nil) 
-              (list stream))))
-    ((t) 
-     (let ((c (read-char-no-hang stream nil nil)))
-       (cond (c 
-              (unread-char c stream) 
-              (list stream))
-             (t '()))))))
-
-(defun stream-readable-p (stream)
-  (let ((c (read-char-no-hang stream nil :eof)))
-    (cond ((not c) nil)
-          ((eq c :eof) t)
-          (t (unread-char c stream) t))))
-
 (definterface toggle-trace (spec)
   "Toggle tracing of the function(s) given with SPEC.
 SPEC can be:
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/11/27 21:47:15	1.294
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/01 22:34:41	1.295
@@ -187,28 +187,83 @@
     (loop
      (let ((ready (remove-if-not #'input-ready-p streams)))
        (when ready (return ready)))
-     (when timeout (return nil))
      (when (check-slime-interrupts) (return :interrupt))
-            (when *wait-for-input-called* (return :interrupt))
-     (sleep 0.2))))
+     (when *wait-for-input-called* (return :interrupt))
+     #-win32
+     (progn
+       (let ((readable (poll streams () (ecase timeout 
+                                          ((nil) nil)
+                                          ((t) 0)))))
+         (when readable (return readable))
+         (when timeout (return nil))))
+     #+win32
+     (progn
+       (when timeout (return nil))
+       (sleep 0.1)))))
+
+(defun fd-stream-input-buffer-empty-p (stream)
+  (let ((buffer (sb-impl::fd-stream-ibuf stream)))
+    (or (not buffer)
+        (= (sb-impl::buffer-head buffer)
+           (sb-impl::buffer-tail buffer)))))
 
 #-win32
-(defun input-ready-p (stream)
-  (sb-sys:wait-until-fd-usable (sb-impl::fd-stream-fd stream)
-                               :input 
-                               0))
+(progn
+  (defun input-ready-p (stream)
+    (not (fd-stream-input-buffer-empty-p stream)))
+
+  (sb-alien:define-alien-type pollfd (sb-alien:struct sb-unix::pollfd))
+  (sb-alien:define-alien-routine ("poll" poll%) sb-alien:int
+    (descs (sb-alien:* pollfd)) (ndescs sb-alien:int) (millis sb-alien:int))
+
+  (defun poll (read-streams write-streams milliseconds)
+    (let* ((rlen (length read-streams))
+           (wlen (length write-streams))
+           (len (+ rlen wlen)))
+      (assert (< len 10))
+      (sb-alien:with-alien ((pollfds (sb-alien:array pollfd 10)))
+        (flet ((set-events (i stream flags)
+                 (symbol-macrolet ((pfd (sb-alien:deref pollfds i)))
+                   (setf (sb-alien:slot pfd 'sb-unix::fd)
+                         (sb-impl::fd-stream-fd stream))
+                   (setf (sb-alien:slot pfd 'sb-unix::events) flags)
+                   (setf (sb-alien:slot pfd 'sb-unix::revents) 0)))
+               (revents? (i)
+                 (let ((revents (sb-alien:slot (sb-alien:deref pollfds i)
+                                               'sb-unix::revents)))
+                   (not (zerop revents)))))
+          (declare (inline set-events revents?))
+          (loop with rflags = (logior sb-unix::pollin
+                                      #+linux #x2000 #|POLLRDHUP|#)
+                for i below rlen  for s in read-streams 
+                do (set-events i s rflags))
+          (loop for i from rlen below len  for s in write-streams 
+                do (set-events i s sb-unix::pollout))
+          (let* ((timeout (etypecase milliseconds
+                            (null -1)
+                            (integer milliseconds)))
+                 (code (poll% (sb-alien:addr (sb-alien:deref pollfds 0))
+                              len timeout))
+                 (errno (sb-alien:get-errno)))
+            (cond ((zerop code)
+                   (values () ()))
+                  ((plusp code)
+                   (values 
+                    (loop for i below rlen  for s in read-streams
+                          if (revents? i) collect s)
+                    (loop for i from rlen below len for s in write-streams
+                          if (revents? i) collect s)))
+                  ((= errno sb-posix:eintr)
+                   :interrupt)
+                  (t
+                   (error "~a" (sb-int:strerror errno)))))))))
 
+  )
 #+win32
 (progn
   (defun input-ready-p (stream)
-    (or (has-buffered-input-p stream)
-        (handle-listen (sockint::fd->handle 
-                        (sb-impl::fd-stream-fd stream)))))
-
-  (defun has-buffered-input-p (stream)
-    (let ((ibuf (sb-impl::fd-stream-ibuf stream)))
-      (/= (sb-impl::buffer-head ibuf)
-          (sb-impl::buffer-tail ibuf))))
+    (or (not (fd-stream-input-buffer-empty-p stream))
+        (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
 
   (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
       sb-win32:handle)




From heller at common-lisp.net  Fri Dec  2 18:09:28 2011
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 02 Dec 2011 10:09:28 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWXY8-0007wY-79@common-lisp.net>

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

Added Files:
	swank-mrepl.lisp 
Log Message:
swank-mrepl.lisp: New file.


--- /project/slime/cvsroot/slime/contrib/swank-mrepl.lisp	2011/12/02 18:09:28	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-mrepl.lisp	2011/12/02 18:09:28	1.1
;;; swank-mrepl.lisp
;;
;; Licence: public domain

(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((api '(
	       *emacs-connection*
	       channel 
	       channel-id
	       define-channel-method
	       defslimefun 
	       destructure-case
	       log-event
	       process-requests
	       send-to-remote-channel
	       use-threads-p
	       wait-for-event
	       with-bindings
	       with-connection
	       with-top-level-restart
	       with-slime-interrupts
	       )))
    (eval `(defpackage #:swank-api
	     (:use)
	     (:import-from #:swank . ,api)
	     (:export . ,api)))))

(defpackage :swank-mrepl
  (:use :cl :swank-api)
  (:export #:create-listener))

(in-package :swank-mrepl)

(defclass listener-channel (channel)
  ((remote :initarg :remote)
   (env :initarg :env)
   (mode :initform :eval)
   (tag :initform nil)))

(defun package-prompt (package)
  (reduce (lambda (x y) (if (< (length x) (length y)) x y))
	  (cons (package-name package) (package-nicknames package))))

(defslimefun create-mrepl (remote)
  (let* ((pkg *package*)
         (conn *emacs-connection*)
	 (thread (if (use-threads-p)
		     (spawn-listener-thread conn)
		     nil))
         (ch (make-instance 'listener-channel :remote remote :thread thread)))
    (setf (slot-value ch 'env) (initial-listener-env ch))
    (when thread
      (swank-backend:send thread `(:serve-channel ,ch)))
    (list (channel-id ch)
	  (swank-backend:thread-id (or thread (swank-backend:current-thread)))
	  (package-name pkg)
	  (package-prompt pkg))))

(defun initial-listener-env (listener)
  `((*package* . ,*package*)
    (*standard-output* . ,(make-listener-output-stream listener))
    (*standard-input* . ,(make-listener-input-stream listener))))

(defun spawn-listener-thread (connection)
  (swank-backend:spawn 
   (lambda ()
     (with-connection (connection)
       (destructure-case (swank-backend:receive)
	 ((:serve-channel c)
	  (loop
	   (with-top-level-restart (connection (drop-unprocessed-events c))
	     (process-requests nil)))))))
   :name "mrepl thread"))

(defun drop-unprocessed-events (channel)
  (with-slots (mode) channel
    (let ((old-mode mode))
      (setf mode :drop)
      (unwind-protect
	   (process-requests t)
	(setf mode old-mode)))
    (send-prompt channel)))

(define-channel-method :process ((c listener-channel) string)
  (log-event ":process ~s~%" string)
  (with-slots (mode remote) c
    (ecase mode
      (:eval (mrepl-eval c string))
      (:read (mrepl-read c string))
      (:drop))))

(defun mrepl-eval (channel string)
  (with-slots (remote env) channel
    (let ((aborted t))
      (with-bindings env
	(unwind-protect 
	     (let ((result (with-slime-interrupts (read-eval-print string))))
	       (send-to-remote-channel remote `(:write-result ,result))
	       (setq aborted nil))
	  (setf env (loop for (sym) in env
			  collect (cons sym (symbol-value sym))))
	  (cond (aborted
		 (send-to-remote-channel remote `(:evaluation-aborted)))
		(t
		 (send-prompt channel))))))))

(defun send-prompt (channel)
  (with-slots (env remote) channel
    (let ((pkg (cdr (or (assoc '*package* env) *package*)))
	  (out (cdr (assoc '*standard-output* env)))
	  (in (cdr (assoc '*standard-input* env))))
      (when out (force-output out))
      (when in (clear-input in))
      (send-to-remote-channel remote `(:prompt ,(package-name pkg)
					       ,(package-prompt pkg))))))
  
(defun mrepl-read (channel string)
  (with-slots (tag) channel
    (assert tag)
    (throw tag string)))

(defun read-eval-print (string)
  (with-input-from-string (in string)
    (setq / ())
    (loop
       (let* ((form (read in nil in)))
	 (cond ((eq form in) (return))
	       (t (setq / (multiple-value-list (eval (setq + form))))))))
    (force-output)
    (if /
	(format nil "~{~s~%~}" /) 
	"; No values")))

(defun make-listener-output-stream (channel)
  (let ((remote (slot-value channel 'remote)))
    (swank-backend:make-output-stream 
     (lambda (string)
       (send-to-remote-channel remote `(:write-string ,string))))))

(defun make-listener-input-stream (channel)
  (swank-backend:make-input-stream (lambda () (read-input channel))))

(defun set-mode (channel new-mode)
  (with-slots (mode remote) channel
    (unless (eq mode new-mode)
      (send-to-remote-channel remote `(:set-read-mode ,new-mode)))
    (setf mode new-mode)))

(defun read-input (channel)
  (with-slots (mode tag remote) channel
    (force-output)
    (let ((old-mode mode)
	  (old-tag tag))
      (setf tag (cons nil nil))
      (set-mode channel :read)
      (unwind-protect 
	   (catch tag (process-requests nil))
	(setf tag old-tag)
	(set-mode channel old-mode)))))



From heller at common-lisp.net  Fri Dec  2 18:17:54 2011
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 02 Dec 2011 10:17:54 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWXgI-0000PO-OH@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (listener-channel): Moved to contrib/swank-mrepl.lisp
(create-listener, initial-listener-bindings, spawn-listener-thread).

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/01 22:34:41	1.2255
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/02 18:17:54	1.2256
@@ -1,3 +1,8 @@
+2011-12-02  Helmut Eller  <heller at common-lisp.net>
+
+	* swank.lisp (listener-channel): Moved to contrib/swank-mrepl.lisp
+	(create-listener, initial-listener-bindings, spawn-listener-thread).
+
 2011-12-01  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-sbcl.lisp (wait-for-input): Call poll(2).
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/01 16:48:21	1.766
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/02 18:17:54	1.767
@@ -1533,83 +1533,6 @@
 (defun send-to-remote-channel (channel-id msg)
   (send-to-emacs `(:channel-send ,channel-id ,msg)))
 
-(defclass listener-channel (channel)
-  ((remote :initarg :remote)
-   (env :initarg :env)))
-
-(defslimefun create-listener (remote)
-  (let* ((pkg *package*)
-         (conn *emacs-connection*)
-         (ch (make-instance 'listener-channel
-                            :remote remote
-                            :env (initial-listener-bindings remote))))
-
-    (with-slots (thread id) ch
-      (when (use-threads-p)
-        (setf thread (spawn-listener-thread ch conn)))
-      (list id
-            (thread-id thread)
-            (package-name pkg)
-            (package-string-for-prompt pkg)))))
-
-(defun initial-listener-bindings (remote)
-  `((*package* . ,*package*)
-    (*standard-output* 
-     . ,(make-listener-output-stream remote))
-    (*standard-input*
-     . ,(make-listener-input-stream remote))))
-
-(defun spawn-listener-thread (channel connection)
-  (spawn (lambda ()
-           (with-connection (connection)
-             (loop 
-              (destructure-case (wait-for-event `(:emacs-channel-send . _))
-                ((:emacs-channel-send c (selector &rest args))
-                 (assert (eq c channel))
-                 (channel-send channel selector args))))))
-         :name "swank-listener-thread"))
-
-(define-channel-method :eval ((c listener-channel) string)
-  (with-slots (remote env) c
-    (let ((aborted t))
-      (with-bindings env
-        (unwind-protect 
-             (let* ((form (read-from-string string))
-                    (value (eval form)))
-               (send-to-remote-channel remote 
-                                       `(:write-result
-                                         ,(prin1-to-string value)))
-               (setq aborted nil))
-          (force-output)
-          (setf env (loop for (sym) in env 
-                          collect (cons sym (symbol-value sym))))
-          (let ((pkg (package-name *package*))
-                (prompt (package-string-for-prompt *package*)))
-            (send-to-remote-channel remote 
-                                    (if aborted 
-                                        `(:evaluation-aborted ,pkg ,prompt)
-                                        `(:prompt ,pkg ,prompt)))))))))
-
-(defun make-listener-output-stream (remote)
-  (make-output-stream (lambda (string)
-                        (send-to-remote-channel remote
-                                                `(:write-string ,string)))))
-
-(defun make-listener-input-stream (remote)
-  (make-input-stream 
-   (lambda ()
-     (force-output)
-     (let ((tag (make-tag)))
-       (send-to-remote-channel remote 
-                               `(:read-string ,(current-thread-id) ,tag))
-       (let ((ok nil))
-         (unwind-protect
-              (prog1 (caddr (wait-for-event
-                             `(:emacs-return-string ,tag value)))
-                (setq ok t))
-           (unless ok
-             (send-to-remote-channel remote `(:read-aborted ,tag)))))))))
-
 
 
 (defun input-available-p (stream)




From heller at common-lisp.net  Fri Dec  2 18:18:02 2011
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 02 Dec 2011 10:18:02 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWXgQ-0000QC-EY@common-lisp.net>

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

Modified Files:
	ChangeLog slime-mrepl.el 
Log Message:
* slime-mrepl.el: Drop dependency on slime-repl. Use comint
instead.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/01 22:34:29	1.513
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/02 18:18:02	1.514
@@ -1,3 +1,12 @@
+2011-12-02  Helmut Eller  <heller at common-lisp.net>
+
+	* slime-mrepl.el: Drop dependency on slime-repl. Use comint
+	instead.
+
+2011-12-02  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-mrepl.lisp: New file.
+
 2011-12-01  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-kawa.scm (mangled-name): Try to deal unnamed lambdas.
--- /project/slime/cvsroot/slime/contrib/slime-mrepl.el	2010/05/28 19:13:17	1.6
+++ /project/slime/cvsroot/slime/contrib/slime-mrepl.el	2011/12/02 18:18:02	1.7
@@ -2,130 +2,147 @@
 ;; single Slime socket.  M-x slime-open-listener creates a new REPL
 ;; buffer.
 ;;
-;; Some copy&pasting from slime-repl.el
 
 (define-slime-contrib slime-mrepl
   "Multiple REPLs."
   (:authors "Helmut Eller <heller at common-lisp.net>")
   (:license "GPL")
-  (:slime-dependencies slime-repl))
+  (:swank-dependencies swank-mrepl))
+
+(require 'comint)
+
+(defvar slime-mrepl-remote-channel nil)
+(defvar slime-mrepl-expect-sexp nil)
+
+(define-derived-mode slime-mrepl-mode comint-mode "mrepl"
+  ;; idea lifted from ielm
+  (unless (get-buffer-process (current-buffer))
+    (let* ((process-connection-type nil)
+	   (proc (start-process "mrepl (dummy)" (current-buffer) "hexl")))
+      (set-process-query-on-exit-flag proc nil)))
+  (set (make-local-variable 'comint-use-prompt-regexp) nil)
+  (set (make-local-variable 'comint-inhibit-carriage-motion) t)
+  (set (make-local-variable 'comint-input-sender) 'slime-mrepl-input-sender)
+  (set (make-local-variable 'comint-output-filter-functions) nil)
+  (set (make-local-variable 'slime-mrepl-expect-sexp) t)
+  ;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input)
+  (set-syntax-table lisp-mode-syntax-table)
+  )
+
+(slime-define-keys slime-mrepl-mode-map
+  ((kbd "RET") 'slime-mrepl-return)
+  ([return] 'slime-mrepl-return)
+  ((kbd "TAB") 'slime-indent-and-complete-symbol)
+  ((kbd "C-c C-b") 'slime-interrupt)
+  ((kbd "C-c C-c") 'slime-interrupt))
+
+(defun slime-mrepl-process% () (get-buffer-process (current-buffer))) ;stupid
+(defun slime-mrepl-mark () (process-mark (slime-mrepl-process%)))
+
+(defun slime-mrepl-insert (string)
+  (comint-output-filter (slime-mrepl-process%) string))
 
 (slime-define-channel-type listener)
 
 (slime-define-channel-method listener :prompt (package prompt)
   (with-current-buffer (slime-channel-get self 'buffer)
-    (setf slime-buffer-package package)
-    (letf (((slime-lisp-package-prompt-string) prompt))
-      (slime-repl-insert-prompt))))
+    (slime-mrepl-prompt package prompt)))
+
+(defun slime-mrepl-prompt (package prompt)
+  (setf slime-buffer-package package)
+  (slime-mrepl-insert (format "%s%s> "
+			      (case (current-column)
+				(0 "")
+				(t "\n"))
+			      prompt))
+  (slime-mrepl-recenter))
+
+(defun slime-mrepl-recenter ()
+  (when (get-buffer-window)
+    (recenter -1)))
 
 (slime-define-channel-method listener :write-result (result)
-  (letf (((slime-connection-output-buffer) (slime-channel-get self 'buffer)))
-    (slime-repl-emit-result result t)))
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (goto-char (point-max))
+    (slime-mrepl-insert result)))
 
-(slime-define-channel-method listener :evaluation-aborted (package prompt)
+(slime-define-channel-method listener :evaluation-aborted ()
   (with-current-buffer (slime-channel-get self 'buffer)
-    (setq slime-buffer-package package)
-    (letf (((slime-connection-output-buffer) (current-buffer))
-	   ((slime-lisp-package-prompt-string) prompt))
-      (slime-repl-show-abort))))
+    (goto-char (point-max))
+    (slime-mrepl-insert "; Evaluation aborted\n")))
 
 (slime-define-channel-method listener :write-string (string)
   (slime-mrepl-write-string self string))
 
 (defun slime-mrepl-write-string (self string)
-  (letf (((slime-connection-output-buffer) (slime-channel-get self 'buffer)))
-    (slime-repl-emit string)))
-
-(byte-compile 'slime-mrepl-write-string)
-
-(slime-define-channel-method listener :read-string (thread tag)
-  (letf (((slime-connection-output-buffer) (slime-channel-get self 'buffer)))
-    (slime-repl-read-string thread tag)))
-
-(define-derived-mode slime-mrepl-mode slime-repl-mode "mrepl")
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (goto-char (slime-mrepl-mark))
+    (slime-mrepl-insert string)))
 
-(slime-define-keys slime-mrepl-mode-map
-  ((kbd "RET") 'slime-mrepl-return)
-  ([return] 'slime-mrepl-return))
+(slime-define-channel-method listener :set-read-mode (mode)
+  (with-current-buffer (slime-channel-get self 'buffer)
+    (ecase mode
+      (:read (setq slime-mrepl-expect-sexp nil)
+	     (message "[Listener is waiting for input]"))
+      (:eval (setq slime-mrepl-expect-sexp t)))))
 
 (defun slime-mrepl-return (&optional end-of-input)
-  "Evaluate the current input string, or insert a newline.  
-Send the current input ony if a whole expression has been entered,
-i.e. the parenthesis are matched. 
-
-With prefix argument send the input even if the parenthesis are not
-balanced."
   (interactive "P")
   (slime-check-connected)
-  (cond (end-of-input
-         (slime-mrepl-send-input))
-        (slime-repl-read-mode ; bad style?
-         (slime-mrepl-send-input t))
-        ((and (get-text-property (point) 'slime-repl-old-input)
-              (< (point) slime-repl-input-start-mark))
-         (slime-repl-grab-old-input end-of-input)
-         (slime-repl-recenter-if-needed))
-        ((slime-input-complete-p slime-repl-input-start-mark (point-max))
-         (slime-mrepl-send-input t))
-        (t 
-         (slime-repl-newline-and-indent)
-         (message "[input not complete]"))))
-
-(defun slime-mrepl-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."
-  (unless (slime-repl-in-input-area-p)
-    (error "No input at point."))
   (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))
-    (when newline 
-      (insert "\n")
-      (slime-repl-show-maximum-output))
-    (let ((inhibit-modification-hooks t))
-      (add-text-properties slime-repl-input-start-mark 
-                           (point)
-                           `(slime-repl-old-input
-                             ,(incf slime-repl-old-input-counter))))
-    (let ((overlay (make-overlay slime-repl-input-start-mark end)))
-      ;; These properties are on an overlay so that they won't be taken
-      ;; by kill/yank.
-      (overlay-put overlay 'read-only t)
-      (overlay-put overlay 'face 'slime-repl-input-face)))
-  (let ((input (slime-repl-current-input)))
-    (goto-char (point-max))
-    (slime-mark-input-start)
-    (slime-mark-output-start)
-    (slime-mrepl-send-string input)))
+  (cond ((and slime-mrepl-expect-sexp
+	      (or (slime-input-complete-p (slime-mrepl-mark) (point))
+		  end-of-input))
+	 (comint-send-input))
+	((not slime-mrepl-expect-sexp)
+	 (unless end-of-input
+	   (insert "\n"))
+	 (comint-send-input t))
+        (t
+	 (insert "\n")
+	 (inferior-slime-indent-line)
+         (message "[input not complete]")))
+  (slime-mrepl-recenter))
+
+(defun slime-mrepl-input-sender (proc string)
+  (slime-mrepl-send-string (substring-no-properties string)))
 
 (defun slime-mrepl-send-string (string &optional command-string)
-  (cond (slime-repl-read-mode
-         (slime-repl-return-string string))
-        (t (slime-mrepl-send `(:eval ,string)))))
+  (slime-mrepl-send `(:process ,string)))
 
 (defun slime-mrepl-send (msg)
   "Send MSG to the remote channel."
   (slime-send-to-remote-channel slime-mrepl-remote-channel msg))
 
-(defun slime-open-listener ()
+(defun slime-new-mrepl ()
   "Create a new listener window."
   (interactive)
   (let ((channel (slime-make-channel slime-listener-channel-methods)))
     (slime-eval-async
-     `(swank:create-listener ,(slime-channel.id channel))
+     `(swank-mrepl:create-mrepl ,(slime-channel.id channel))
      (slime-rcurry 
       (lambda (result channel)
 	(destructuring-bind (remote thread-id package prompt) result
-	  (pop-to-buffer (generate-new-buffer (slime-buffer-name :listener)))
+	  (pop-to-buffer (generate-new-buffer (slime-buffer-name :mrepl)))
 	  (slime-mrepl-mode)
 	  (setq slime-current-thread thread-id)
 	  (setq slime-buffer-connection (slime-connection))
 	  (set (make-local-variable 'slime-mrepl-remote-channel) remote)
 	  (slime-channel-put channel 'buffer (current-buffer))
-	  (slime-reset-repl-markers)
-	  (slime-channel-send channel `(:prompt ,package ,prompt))
-	  (slime-repl-show-maximum-output)))
+	  (slime-channel-send channel `(:prompt ,package ,prompt))))
       channel))))
 
+(defun slime-mrepl ()
+  (let ((conn (slime-connection)))
+    (find-if (lambda (x) 
+	       (with-current-buffer x 
+		 (and (eq major-mode 'slime-mrepl-mode)
+		      (eq (slime-current-connection) conn))))
+	     (buffer-list))))
+
+(def-slime-selector-method ?m
+  "First mrepl-buffer"
+  (or (slime-mrepl)
+      (error "No mrepl buffer (%s)" (slime-connection-name))))
+
 (provide 'slime-mrepl)




From heller at common-lisp.net  Fri Dec  2 18:18:11 2011
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 02 Dec 2011 10:18:11 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWXgZ-0000Ql-1J@common-lisp.net>

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

Modified Files:
	ChangeLog swank-kawa.scm 
Log Message:
* swank-kawa.scm (inspect-obj-ref): Use for instead of iter.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/02 18:18:02	1.514
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/02 18:18:10	1.515
@@ -1,5 +1,9 @@
 2011-12-02  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-kawa.scm (inspect-obj-ref): Use for instead of iter.
+
+2011-12-02  Helmut Eller  <heller at common-lisp.net>
+
 	* slime-mrepl.el: Drop dependency on slime-repl. Use comint
 	instead.
 
--- /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2011/12/01 22:34:29	1.25
+++ /project/slime/cvsroot/slime/contrib/swank-kawa.scm	2011/12/02 18:18:11	1.26
@@ -1173,12 +1173,11 @@
 (df inspect-array-ref ((vm <vm>) (obj <array-ref>))
   (packing (pack)
     (let ((i 0))
-      (iter (! getValues obj)
-            (fun ((v <value>))
-              (pack (format "~d: " i))
-              (pack `(:value ,(vm-demirror vm v)))
-              (pack "\n")
-              (set i (1+ i)))))))
+      (for (((v <value>) (! getValues obj)))
+        (pack (format "~d: " i))
+        (pack `(:value ,(vm-demirror vm v)))
+        (pack "\n")
+        (set i (1+ i))))))
 
 (df inspect-obj-ref ((vm <vm>) (obj <obj-ref>))
   (let* ((type (! referenceType obj))
@@ -1186,19 +1185,17 @@
          (values (! getValues obj fields))
          (ifields '()) (sfields '()) (imeths '()) (smeths '())
          (frob (lambda (lists) (apply append (reverse lists)))))
-    (iter fields 
-          (fun ((f <field>))
-            (let* ((val (as <value> (! get values f)))
-                   (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n")))
-              (if (! is-static f) 
-                  (pushf l sfields)
-                  (pushf l ifields)))))
-    (iter (! allMethods type)
-          (fun ((m <meth-ref>))
-            (let ((l `(,(! name m) ,(! signature m) "\n")))
-              (if (! is-static m)
-                  (pushf l smeths)
-                  (pushf l imeths)))))
+    (for (((f <field>) fields))
+      (let* ((val (as <value> (! get values f)))
+             (l `(,(! name f) ": " (:value ,(vm-demirror vm val)) "\n")))
+        (if (! is-static f) 
+            (pushf l sfields)
+            (pushf l ifields))))
+    (for (((m <meth-ref>) (! allMethods type)))
+      (let ((l `(,(! name m) ,(! signature m) "\n")))
+        (if (! is-static m)
+            (pushf l smeths)
+            (pushf l imeths))))
     `(,@(frob ifields) 
       "--- static fields ---\n" ,@(frob sfields)
       "--- methods ---\n" ,@(frob imeths)




From sboukarev at common-lisp.net  Fri Dec  2 19:52:15 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 02 Dec 2011 11:52:15 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWZ9b-0007yT-6S@common-lisp.net>

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (wait-for-input): Use poll only on #+os-provides-poll.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/02 18:17:54	1.2256
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/02 19:52:14	1.2257
@@ -1,3 +1,7 @@
+2011-12-02  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-sbcl.lisp (wait-for-input): Use poll only on #+os-provides-poll.
+
 2011-12-02  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (listener-channel): Moved to contrib/swank-mrepl.lisp
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/01 22:34:41	1.295
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/02 19:52:15	1.296
@@ -189,14 +189,14 @@
        (when ready (return ready)))
      (when (check-slime-interrupts) (return :interrupt))
      (when *wait-for-input-called* (return :interrupt))
-     #-win32
-     (progn
-       (let ((readable (poll streams () (ecase timeout 
-                                          ((nil) nil)
-                                          ((t) 0)))))
-         (when readable (return readable))
-         (when timeout (return nil))))
-     #+win32
+     #+os-provides-poll
+     (let ((readable (poll streams () (ecase timeout 
+                                        ((nil) nil)
+                                        ((t) 0)))))
+       (when readable (return readable))
+       (when timeout (return nil)))
+
+     #-os-provides-poll
      (progn
        (when timeout (return nil))
        (sleep 0.1)))))
@@ -207,7 +207,7 @@
         (= (sb-impl::buffer-head buffer)
            (sb-impl::buffer-tail buffer)))))
 
-#-win32
+#+os-provides-poll
 (progn
   (defun input-ready-p (stream)
     (not (fd-stream-input-buffer-empty-p stream)))
@@ -259,7 +259,7 @@
                    (error "~a" (sb-int:strerror errno)))))))))
 
   )
-#+win32
+#-os-provides-poll
 (progn
   (defun input-ready-p (stream)
     (or (not (fd-stream-input-buffer-empty-p stream))




From sboukarev at common-lisp.net  Fri Dec  2 20:24:03 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 02 Dec 2011 12:24:03 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWZeN-0001Ba-E3@common-lisp.net>

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (wait-for-input): Define only if
#+os-provides-poll or #+win32.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/02 19:52:14	1.2257
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/02 20:24:03	1.2258
@@ -1,6 +1,7 @@
 2011-12-02  Stas Boukarev  <stassats at gmail.com>
 
-	* swank-sbcl.lisp (wait-for-input): Use poll only on #+os-provides-poll.
+	* swank-sbcl.lisp (wait-for-input): Define only if
+	#+os-provides-poll or #+win32.
 
 2011-12-02  Helmut Eller  <heller at common-lisp.net>
 
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/02 19:52:15	1.296
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/02 20:24:03	1.297
@@ -179,6 +179,7 @@
 
 (defvar *wait-for-input-called*)
 
+#+(or win32 os-provides-poll)
 (defimplementation wait-for-input (streams &optional timeout)
   (assert (member timeout '(nil t)))
   (when (boundp '*wait-for-input-called*)
@@ -257,9 +258,9 @@
                    :interrupt)
                   (t
                    (error "~a" (sb-int:strerror errno)))))))))
-
   )
-#-os-provides-poll
+
+#+win32
 (progn
   (defun input-ready-p (stream)
     (or (not (fd-stream-input-buffer-empty-p stream))




From sboukarev at common-lisp.net  Fri Dec  2 22:12:09 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 02 Dec 2011 14:12:09 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWbKz-0004qS-2q@common-lisp.net>

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

Modified Files:
	ChangeLog slime-repl.el 
Log Message:
* slime-repl.el (slime-repl-send-input): Don't put `read-only'
property on an overlay, overlays don't support it.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/02 18:18:10	1.515
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/02 22:12:08	1.516
@@ -1,3 +1,8 @@
+2011-12-02  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-repl.el (slime-repl-send-input): Don't put `read-only'
+	property on an overlay, overlays don't support it.
+
 2011-12-02  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-kawa.scm (inspect-obj-ref): Use for instead of iter.
--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2011/11/27 19:24:34	1.60
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2011/12/02 22:12:09	1.61
@@ -754,7 +754,6 @@
     (let ((overlay (make-overlay slime-repl-input-start-mark end)))
       ;; These properties are on an overlay so that they won't be taken
       ;; by kill/yank.
-      (overlay-put overlay 'read-only t)
       (overlay-put overlay 'face 'slime-repl-input-face)))
   (let ((input (slime-repl-current-input)))
     (goto-char (point-max))




From heller at common-lisp.net  Sat Dec  3 12:03:27 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 03 Dec 2011 04:03:27 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWoJT-0002mk-0X@common-lisp.net>

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

Modified Files:
	ChangeLog swank-clisp.lisp 
Log Message:
* swank-mrepl.lisp (package-prompt): Use <= instead of < to give
package-name priority over nicknames.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/02 20:24:03	1.2258
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/03 12:03:26	1.2259
@@ -1,3 +1,7 @@
+2011-12-03  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-clisp.lisp (wait-for-input): Add a version for windows.
+
 2011-12-02  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-sbcl.lisp (wait-for-input): Define only if
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2011/11/27 21:47:15	1.98
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2011/12/03 12:03:26	1.99
@@ -187,6 +187,41 @@
                                if x collect s)))
               (when ready (return ready))))))))
 
+#+win32
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (loop
+   (cond ((check-slime-interrupts) (return :interrupt))
+         (t 
+          (let ((ready (remove-if-not #'input-available-p streams)))
+            (when ready (return ready)))
+          (when timeout (return nil))
+          (sleep 0.1)))))
+
+#+win32
+;; Some facts to remember (for the next time we need to debug this):
+;;  - interactive-sream-p returns t for socket-streams
+;;  - listen returns nil for socket-streams
+;;  - (type-of <socket-stream>) is 'stream
+;;  - (type-of *terminal-io*) is 'two-way-stream
+;;  - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
+;;  - calling socket:socket-status on non sockets signals an error,
+;;    but seems to mess up something internally.
+;;  - calling read-char-no-hang on sockets does not signal an error,
+;;    but seems to mess up something internally.
+(defun input-available-p (stream)
+  (case (stream-element-type stream)
+    (character
+     (let ((c (read-char-no-hang stream nil nil)))
+       (cond ((not c)
+              nil)
+             (t
+              (unread-char c stream)
+              t))))
+    (t
+     (eq (socket:socket-status (cons stream :input) 0 0)
+         :input))))
+
 ;;;; Coding systems
 
 (defvar *external-format-to-coding-system*




From heller at common-lisp.net  Sat Dec  3 12:03:37 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 03 Dec 2011 04:03:37 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWoJd-0002nS-VT@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (set-default-initial-binding): In 9.0 alpha,
*CL-DEFAULT-SPECIAL-BINDINGS* is [soon to be] deprecated.  It's
otherwise the same EXCL:*REQUIRED-TOP-LEVEL-BINDINGS* (i.e. no
change in behavior).

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/03 12:03:26	1.2259
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/03 12:03:37	1.2260
@@ -1,3 +1,10 @@
+2011-12-03  G?bor Melis  <mega at retes.hu>
+
+	* swank-allegro.lisp (set-default-initial-binding): In 9.0 alpha,
+	*CL-DEFAULT-SPECIAL-BINDINGS* is [soon to be] deprecated.  It's
+	otherwise the same EXCL:*REQUIRED-TOP-LEVEL-BINDINGS* (i.e. no
+	change in behavior).
+
 2011-12-03  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-clisp.lisp (wait-for-input): Add a version for windows.
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2011/11/27 21:47:15	1.148
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2011/12/03 12:03:37	1.149
@@ -832,8 +832,11 @@
                                    #'mp:gate-open-p (mailbox.gate mbox)))))
 
 (defimplementation set-default-initial-binding (var form)
-  (setq excl:*cl-default-special-bindings*
-        (acons var form excl:*cl-default-special-bindings*)))
+  (push (cons var form)
+        #+(version>= 9 0)
+        excl:*required-thread-bindings*
+        #-(version>= 9 0)
+        excl::required-thread-bindings))
 
 (defimplementation quit-lisp ()
   (excl:exit 0 :quiet t))




From heller at common-lisp.net  Sat Dec  3 12:03:43 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 03 Dec 2011 04:03:43 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWoJj-0002oC-Bk@common-lisp.net>

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

Modified Files:
	ChangeLog swank-mrepl.lisp 
Log Message:
* swank-mrepl.lisp (package-prompt): Use <= instead of < to give
package-name priority over nicknames.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/02 22:12:08	1.516
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/03 12:03:43	1.517
@@ -1,3 +1,8 @@
+2011-12-03  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-mrepl.lisp (package-prompt): Use <= instead of < to give
+	package-name priority over nicknames.
+
 2011-12-02  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-repl.el (slime-repl-send-input): Don't put `read-only'
--- /project/slime/cvsroot/slime/contrib/swank-mrepl.lisp	2011/12/02 18:09:28	1.1
+++ /project/slime/cvsroot/slime/contrib/swank-mrepl.lisp	2011/12/03 12:03:43	1.2
@@ -39,7 +39,7 @@
    (tag :initform nil)))
 
 (defun package-prompt (package)
-  (reduce (lambda (x y) (if (< (length x) (length y)) x y))
+  (reduce (lambda (x y) (if (<= (length x) (length y)) x y))
 	  (cons (package-name package) (package-nicknames package))))
 
 (defslimefun create-mrepl (remote)




From heller at common-lisp.net  Sat Dec  3 13:06:46 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 03 Dec 2011 05:06:46 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWpIk-0006wO-Pu@common-lisp.net>

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

Modified Files:
	NEWS 
Log Message:
Mention utf8 thing.

--- /project/slime/cvsroot/slime/NEWS	2009/01/02 21:57:13	1.11
+++ /project/slime/cvsroot/slime/NEWS	2011/12/03 13:06:46	1.12
@@ -1,6 +1,13 @@
 * SLIME News                                         -*- outline -*-
 
-* 3.0 (not released yet)
+* (since 2.3)
+
+** UTF8 encoding
+SLIME now uses only UTF8 to encode strings on the wire.  Customization
+variables like slime-net-coding-system or swank:*coding-system* are
+now useless.
+
+* 2.3 (October 2011)
 
 ** REPL no longer loaded by default
 SLIME has a REPL which communicates exclusively over SLIME's socket.
@@ -24,6 +31,8 @@
       "--core" "/home/me/sbcl-cvs/output/sbcl.core")
      :env ("SBCL_HOME=/home/me/sbcl-cvs/contrib/"))
 
+* 2.1
+
 ** Removed Features
 Some of the more esoteric features, like presentations or fuzzy
 completion, are no longer enabled by default.  A new directory




From heller at common-lisp.net  Sat Dec  3 13:06:50 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 03 Dec 2011 05:06:50 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWpIo-0006wp-5B@common-lisp.net>

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

Modified Files:
	PROBLEMS 
Log Message:
Mention problem with CLISP Windows filenames.

--- /project/slime/cvsroot/slime/PROBLEMS	2005/11/20 23:31:56	1.8
+++ /project/slime/cvsroot/slime/PROBLEMS	2011/12/03 13:06:50	1.9
@@ -3,6 +3,7 @@
 * Common to all backends
 
 ** Caution: network security
+
 The `M-x slime' command has Lisp listen on a TCP socket and wait for
 Emacs to connect, which typically takes on the order of one second. If
 someone else were to connect to this socket then they could use the
@@ -38,14 +39,6 @@
 lower and SBCL itself is compiled at a lower setting. Thus only
 defun-granularity is available with default policies.
 
-The XREF commands are not implemented.
-
-** OpenMCL
-
-We support OpenMCL 0.14.3.
-
-The XREF commands are not available.
-
 ** LispWorks
 
 On Windows, SLIME hangs when calling foreign functions or certain
@@ -61,13 +54,19 @@
 
 ** CLISP
 
-We require version 2.33.2 or higher. We also require socket support, so
+We require version 2.49 or higher. We also require socket support, so
 you may have to start CLISP with "clisp -K full".
 
 Under Windows, interrupting (with C-c C-b) doesn't work.  Emacs sends
 a SIGINT signal, but the signal is either ignored or CLISP exits
 immediately.
 
+On Windows, CLISP may refuse to parse filenames like
+"C:\\DOCUME~1\\johndoe\\LOCALS~1\\Temp\\slime.1424" when we actually
+mean C:\Documents and Settings\johndoe\Local Settings\slime.1424.  As
+a workaround, you could set slime-to-lisp-filename-function to some
+function that returns a string that is accepted by CLISP.
+
 Function arguments and local variables aren't displayed properly in
 the backtrace.  Changes to CLISP's C code are needed to fix this
 problem.  Interpreted code is usually easer to debug.




From nsiivola at common-lisp.net  Sat Dec  3 15:31:08 2011
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Sat, 03 Dec 2011 07:31:08 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWrYS-00019M-Dg@common-lisp.net>

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
sbcl: another run at WAIT-FOR-INPUT

  This is still disturbingly under-the-hood stuff, but at least we're using
  fewer internal symbols: drop poll() based solution, use SYSREAD-MAY-BLOCK-P
  in INPUT-READ-P instead.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/03 12:03:37	1.2260
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/03 15:31:08	1.2261
@@ -1,3 +1,9 @@
+2011-12-03  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* swank-sbcl.lisp (wait-for-input): Another go at this. Rip out POLL,
+	build on top of just INPUT-READY-P.
+	(input-ready-p): Outside Windows, use SYSREAD-MAY-BLOCK-P to check.
+
 2011-12-03  G?bor Melis  <mega at retes.hu>
 
 	* swank-allegro.lisp (set-default-initial-binding): In 9.0 alpha,
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/02 20:24:03	1.297
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/03 15:31:08	1.298
@@ -179,86 +179,30 @@
 
 (defvar *wait-for-input-called*)
 
-#+(or win32 os-provides-poll)
 (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 #'input-ready-p streams)))
-       (when ready (return ready)))
-     (when (check-slime-interrupts) (return :interrupt))
-     (when *wait-for-input-called* (return :interrupt))
-     #+os-provides-poll
-     (let ((readable (poll streams () (ecase timeout 
-                                        ((nil) nil)
-                                        ((t) 0)))))
-       (when readable (return readable))
-       (when timeout (return nil)))
-
-     #-os-provides-poll
-     (progn
-       (when timeout (return nil))
-       (sleep 0.1)))))
-
-(defun fd-stream-input-buffer-empty-p (stream)
-  (let ((buffer (sb-impl::fd-stream-ibuf stream)))
-    (or (not buffer)
-        (= (sb-impl::buffer-head buffer)
-           (sb-impl::buffer-tail buffer)))))
-
-#+os-provides-poll
-(progn
-  (defun input-ready-p (stream)
-    (not (fd-stream-input-buffer-empty-p stream)))
-
-  (sb-alien:define-alien-type pollfd (sb-alien:struct sb-unix::pollfd))
-  (sb-alien:define-alien-routine ("poll" poll%) sb-alien:int
-    (descs (sb-alien:* pollfd)) (ndescs sb-alien:int) (millis sb-alien:int))
-
-  (defun poll (read-streams write-streams milliseconds)
-    (let* ((rlen (length read-streams))
-           (wlen (length write-streams))
-           (len (+ rlen wlen)))
-      (assert (< len 10))
-      (sb-alien:with-alien ((pollfds (sb-alien:array pollfd 10)))
-        (flet ((set-events (i stream flags)
-                 (symbol-macrolet ((pfd (sb-alien:deref pollfds i)))
-                   (setf (sb-alien:slot pfd 'sb-unix::fd)
-                         (sb-impl::fd-stream-fd stream))
-                   (setf (sb-alien:slot pfd 'sb-unix::events) flags)
-                   (setf (sb-alien:slot pfd 'sb-unix::revents) 0)))
-               (revents? (i)
-                 (let ((revents (sb-alien:slot (sb-alien:deref pollfds i)
-                                               'sb-unix::revents)))
-                   (not (zerop revents)))))
-          (declare (inline set-events revents?))
-          (loop with rflags = (logior sb-unix::pollin
-                                      #+linux #x2000 #|POLLRDHUP|#)
-                for i below rlen  for s in read-streams 
-                do (set-events i s rflags))
-          (loop for i from rlen below len  for s in write-streams 
-                do (set-events i s sb-unix::pollout))
-          (let* ((timeout (etypecase milliseconds
-                            (null -1)
-                            (integer milliseconds)))
-                 (code (poll% (sb-alien:addr (sb-alien:deref pollfds 0))
-                              len timeout))
-                 (errno (sb-alien:get-errno)))
-            (cond ((zerop code)
-                   (values () ()))
-                  ((plusp code)
-                   (values 
-                    (loop for i below rlen  for s in read-streams
-                          if (revents? i) collect s)
-                    (loop for i from rlen below len for s in write-streams
-                          if (revents? i) collect s)))
-                  ((= errno sb-posix:eintr)
-                   :interrupt)
-                  (t
-                   (error "~a" (sb-int:strerror errno)))))))))
-  )
+      (let ((ready (remove-if-not #'input-ready-p streams)))
+        (when ready (return ready)))
+      (when (check-slime-interrupts)
+        (return :interrupt))
+      (when *wait-for-input-called*
+        (return :interrupt))
+      (when timeout
+        (return nil))
+      (sleep 0.1))))
+
+#-win32
+(defun input-ready-p (stream)
+  (or (let ((buffer (sb-impl::fd-stream-ibuf stream)))
+        (when buffer
+          (= (sb-impl::buffer-head buffer)
+             (sb-impl::buffer-tail buffer))))
+      (eq :regular (sb-impl::fd-stream-fd-type stream))
+      (not (sb-impl::sysread-may-block-p stream))))
 
 #+win32
 (progn




From nsiivola at common-lisp.net  Sat Dec  3 15:33:36 2011
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Sat, 03 Dec 2011 07:33:36 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWraq-0001H1-Kq@common-lisp.net>

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

Modified Files:
	ChangeLog slime-cl-indent.el 
Log Message:
slime-indentation: XEmacs compatibility

  Patch from Didier Verna.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/03 12:03:43	1.517
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/03 15:33:36	1.518
@@ -1,3 +1,10 @@
+2011-12-03  Didier Verna  <didier at xemacs.org>
+
+       * slime-cl-indent.el (lisp-indent-lambda-list-keywords-regexp):
+       Match empty string after a word consitituent (\>) instead of a
+       symbol constituent (\_>) because XEmacs doesn't have that syntax,
+       and here, it doesn't hurt anyway.
+
 2011-12-03  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-mrepl.lisp (package-prompt): Use <= instead of < to give
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/11/28 18:38:34	1.57
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/03 15:33:36	1.58
@@ -960,7 +960,7 @@
 (defvar lisp-indent-lambda-list-keywords-regexp
   "&\\(\
 optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|environment\\|more\
-\\)\\_>"
+\\)\\>"
   "Regular expression matching lambda-list keywords.")
 
 (defun lisp-indent-lambda-list




From nsiivola at common-lisp.net  Sat Dec  3 15:38:19 2011
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Sat, 03 Dec 2011 07:38:19 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RWrfP-0001eS-7k@common-lisp.net>

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

Modified Files:
	ChangeLog slime-cl-indent-test.txt slime-cl-indent.el 
Log Message:
slime-indentation: recognize :foo and #:foo style loop keywords

  Patch from Didier Verna.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/03 15:33:36	1.518
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/03 15:38:19	1.519
@@ -1,5 +1,18 @@
 2011-12-03  Didier Verna  <didier at xemacs.org>
 
+       * slime-cl-indent.el (common-lisp-loop-type)
+       (common-lisp-loop-part-indentation)
+       (common-lisp-indent-body-introducing-loop-macro-keyword)
+       (common-lisp-indent-prefix-loop-macro-keyword)
+       (common-lisp-indent-clause-joining-loop-macro-keyword)
+       (common-lisp-indent-indented-loop-macro-keyword)
+       (common-lisp-indent-indenting-loop-macro-keyword)
+       (common-lisp-indent-loop-macro-else-keyword)
+       (common-lisp-indent-loop-macro-1): Match not only KEYWORD but also
+       :KEYWORD and #:KEYWORD in the LOOP macro.
+
+2011-12-03  Didier Verna  <didier at xemacs.org>
+
        * slime-cl-indent.el (lisp-indent-lambda-list-keywords-regexp):
        Match empty string after a word consitituent (\>) instead of a
        symbol constituent (\_>) because XEmacs doesn't have that syntax,
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt	2011/11/28 18:38:34	1.15
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt	2011/12/03 15:38:19	1.16
@@ -736,3 +736,30 @@
                    ;; is a beginning
         do (foo)))
 
+;;; Test: 70
+;;
+;; lisp-loop-indent-subclauses: nil
+
+(progn
+  (loop
+    :repeat 1000
+    #:do ;; This is the
+         ;; beginning
+       (foo))
+  (loop #:repeat 100 ;; This too
+                     ;; is a beginning
+        :do (foo)))
+
+;;; Test: 71
+;;
+;; lisp-loop-indent-subclauses: t
+
+(progn
+  (loop
+    #:repeat 1000
+    #:do ;; This is the
+         ;; beginning
+         (foo))
+  (loop :repeat 100 ;; This too
+                    ;; is a beginning
+        #:do (foo)))
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/03 15:33:36	1.58
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/03 15:38:19	1.59
@@ -599,13 +599,13 @@
                   (setq comment-split t))))
             (forward-sexp 1)
             (backward-sexp 1)
-            (if (looking-at "\\sw")
-                (if (or (not maybe-split) (= line (line-number-at-pos)))
-                    'extended
-                  'extended/split)
+            (if (eql (char-after) ?\()
+		(if (or (not maybe-split) (= line (line-number-at-pos)))
+		    'simple
+		    'simple/split)
               (if (or (not maybe-split) (= line (line-number-at-pos)))
-                  'simple
-                'simple/split))))
+		  'extended
+		  'extended/split))))
       (error
        (if comment-split
            'simple/split
@@ -630,7 +630,7 @@
                                  (- (current-column) 4)
                                (current-column))))
          (indent nil)
-         (re "\\(:?\\sw+\\|)\\|\n\\)"))
+         (re "\\(\\(#?:\\)?\\sw+\\|)\\|\n\\)"))
     (goto-char indent-point)
     (back-to-indentation)
     (cond ((eq type 'simple/split)
@@ -1265,32 +1265,32 @@
 
 ;; Regexps matching various varieties of loop macro keyword ...
 (defvar common-lisp-indent-body-introducing-loop-macro-keyword
-  "do\\|finally\\|initially"
+  "\\(#?:\\)?\\(do\\|finally\\|initially\\)"
   "Regexp matching loop macro keywords which introduce body-forms.")
 
 ;; This is so "and when" and "else when" get handled right
 ;; (not to mention "else do" !!!)
 (defvar common-lisp-indent-prefix-loop-macro-keyword
-  "and\\|else"
+  "\\(#?:\\)?\\(and\\|else\\)"
   "Regexp matching loop macro keywords which are prefixes.")
 
 (defvar common-lisp-indent-clause-joining-loop-macro-keyword
-  "and"
+  "\\(#?:\\)?and"
   "Regexp matching 'and', and anything else there ever comes to be like it.")
 
 ;; This is handled right, but it's incomplete ...
 ;; (It could probably get arbitrarily long if I did *every* iteration-path)
 (defvar common-lisp-indent-indented-loop-macro-keyword
-  "into\\|by\\|upto\\|downto\\|above\\|below\\|on\\|being\\|=\\|first\\|then\\|from\\|to"
+  "\\(#?:\\)?\\(into\\|by\\|upto\\|downto\\|above\\|below\\|on\\|being\\|=\\|first\\|then\\|from\\|to\\)"
   "Regexp matching keywords introducing loop subclauses.
 Always indented two.")
 
 (defvar common-lisp-indent-indenting-loop-macro-keyword
-  "when\\|unless\\|if"
+  "\\(#?:\\)?\\(when\\|unless\\|if\\)"
   "Regexp matching keywords introducing conditional clauses.
 Cause subsequent clauses to be indented.")
 
-(defvar common-lisp-indent-loop-macro-else-keyword "else")
+(defvar common-lisp-indent-loop-macro-else-keyword "\\(#?:\\)?else")
 
 ;;; Attempt to indent the loop macro ...
 
@@ -1404,7 +1404,7 @@
                           (> (point) loop-macro-first-clause))
                 (back-to-indentation)
                 (if (and (< (current-column) loop-body-indentation)
-                         (looking-at "\\sw"))
+                         (looking-at "\\(#?:\\)?\\sw"))
                     (progn
                       (if (looking-at common-lisp-indent-loop-macro-else-keyword)
                           (common-lisp-indent-loop-advance-past-keyword-on-line))
@@ -1697,6 +1697,6 @@
 ;;;   (common-lisp-run-indentation-tests t)
 ;;;
 ;;; Run specific test:
-;;;   (common-lisp-run-indentation-tests 69)
+;;;   (common-lisp-run-indentation-tests 70)
 
 ;;; cl-indent.el ends here




From nsiivola at common-lisp.net  Sat Dec  3 19:47:45 2011
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Sat, 03 Dec 2011 11:47:45 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RWvYn-0002bl-Fk@common-lisp.net>

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

Modified Files:
	swank-sbcl.lisp 
Log Message:
sbcl: fix INPUT-READY-P

  What a moronic bug. *blush*


--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/03 15:31:08	1.298
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/03 19:47:45	1.299
@@ -199,7 +199,7 @@
 (defun input-ready-p (stream)
   (or (let ((buffer (sb-impl::fd-stream-ibuf stream)))
         (when buffer
-          (= (sb-impl::buffer-head buffer)
+          (< (sb-impl::buffer-head buffer)
              (sb-impl::buffer-tail buffer))))
       (eq :regular (sb-impl::fd-stream-fd-type stream))
       (not (sb-impl::sysread-may-block-p stream))))




From heller at common-lisp.net  Sun Dec  4 14:54:35 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 06:54:35 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXDSd-0001Yl-Lq@common-lisp.net>

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

Modified Files:
	ChangeLog swank-rpc.lisp 
Log Message:
* swank-rpc.lisp (read-chunk): Signal end-of-file we had no input.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/03 15:31:08	1.2261
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/04 14:54:35	1.2262
@@ -1,3 +1,7 @@
+2011-12-04  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-rpc.lisp (read-chunk): Signal end-of-file we had no input.
+
 2011-12-03  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* swank-sbcl.lisp (wait-for-input): Another go at this. Rip out POLL,
--- /project/slime/cvsroot/slime/swank-rpc.lisp	2011/11/08 08:15:34	1.9
+++ /project/slime/cvsroot/slime/swank-rpc.lisp	2011/12/04 14:54:35	1.10
@@ -59,9 +59,14 @@
 (defun read-chunk (stream length)
   (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
          (count (read-sequence buffer stream)))
-    (assert (= count length) () "Short read: length=~D  count=~D" length count)
-    buffer))
+    (cond ((= count length)
+           buffer)
+          ((zerop count)
+           (error (make-condition 'end-of-file :stream stream)))
+          (t
+           (error "Short read: length=~D  count=~D" length count)))))
 
+;; end-of-file
 ;; FIXME: no one ever tested this and will probably not work.
 (defparameter *validate-input* nil
   "Set to true to require input that strictly conforms to the protocol")




From heller at common-lisp.net  Sun Dec  4 14:54:46 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 06:54:46 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXDSo-0001aK-32@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp (*contribs*): Add swank-mrepl.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/04 14:54:35	1.2262
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/04 14:54:45	1.2263
@@ -1,5 +1,9 @@
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-loader.lisp (*contribs*): Add swank-mrepl.
+
+2011-12-04  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-rpc.lisp (read-chunk): Signal end-of-file we had no input.
 
 2011-12-03  Nikodemus Siivola  <nikodemus at random-state.net>
--- /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/01 16:55:02	1.111
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/04 14:54:46	1.112
@@ -222,6 +222,7 @@
     swank-package-fu
     swank-hyperdoc
     #+sbcl swank-sbcl-exts
+    swank-mrepl
     )
   "List of names for contrib modules.")
 




From heller at common-lisp.net  Sun Dec  4 14:56:07 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 06:56:07 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RXDU7-0001kq-JV@common-lisp.net>

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

Modified Files:
	ChangeLog 
Added Files:
	swank-repl.lisp 
Log Message:
swank-repl.lisp: New file

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/03 15:38:19	1.519
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/04 14:56:07	1.520
@@ -1,3 +1,7 @@
+2011-12-04  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-repl.lisp: New file.
+
 2011-12-03  Didier Verna  <didier at xemacs.org>
 
        * slime-cl-indent.el (common-lisp-loop-type)

--- /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/04 14:56:07	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/04 14:56:07	1.1
;;; swank-repl.lisp --- Server side part of the Lisp listener.
;;
;; License: public domain

(in-package :swank)

(defvar *use-dedicated-output-stream* nil
  "When T swank will attempt to create a second connection to Emacs
which is used just to send output.")

(defvar *dedicated-output-stream-port* 0
  "Which port we should use for the dedicated output stream.")

(defvar *dedicated-output-stream-buffering*
  (if (eq *communication-style* :spawn) t nil)
  "The buffering scheme that should be used for the output stream.
Valid values are nil, t, :line")

(defun open-streams (connection properties)
  "Return the 5 streams for IO redirection:
DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
  (let* ((input-fn
          (lambda ()
            (with-connection (connection)
              (with-simple-restart (abort-read
                                    "Abort reading input from Emacs.")
                (read-user-input-from-emacs)))))
         (dedicated-output (if *use-dedicated-output-stream*
                               (open-dedicated-output-stream
                                connection
                                (getf properties :coding-system))))
         (in (make-input-stream input-fn))
         (out (or dedicated-output
                  (make-output-stream (make-output-function connection))))
         (io (make-two-way-stream in out))
         (repl-results (make-output-stream-for-target connection
                                                      :repl-result)))
    (when (eq (connection.communication-style connection) :spawn)
      (setf (connection.auto-flush-thread connection)
            (spawn (lambda () (auto-flush-loop out))
                   :name "auto-flush-thread")))
    (values dedicated-output in out io repl-results)))

;; 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)
        (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."
  (lambda (string)
    (with-connection (connection)
      (with-simple-restart
          (abort "Abort sending output to Emacs.")
        (send-to-emacs `(:write-string ,string ,target))))))

(defun make-output-stream-for-target (connection target)
  "Create a stream that sends output to a specific TARGET in Emacs."
  (make-output-stream (make-output-function-for-target connection target)))

(defun open-dedicated-output-stream (connection coding-system)
  "Open a dedicated output connection to the Emacs on SOCKET-IO.
Return an output stream suitable for writing program output.

This is an optimized way for Lisp to deliver output to Emacs."
  (let ((socket (create-socket *loopback-interface*
                               *dedicated-output-stream-port*))
        (ef (find-external-format-or-lose coding-system)))
    (unwind-protect
         (let ((port (local-port socket)))
           (encode-message `(:open-dedicated-output-stream ,port
                                                           ,coding-system)
                           (connection.socket-io connection))
           (let ((dedicated (accept-connection
                             socket
                             :external-format ef
                             :buffering *dedicated-output-stream-buffering*
                             :timeout 30)))
             (authenticate-client dedicated)
             (close-socket socket)
             (setf socket nil)
             dedicated))
      (when socket
        (close-socket socket)))))

(defun find-repl-thread (connection)
  (cond ((not (use-threads-p))
         (current-thread))
        (t
         (let ((thread (connection.repl-thread connection)))
           (cond ((not thread) nil)
                 ((thread-alive-p thread) thread)
                 (t
                  (setf (connection.repl-thread connection)
                        (spawn-repl-thread connection "new-repl-thread"))))))))

(defun spawn-repl-thread (connection name)
  (spawn (lambda ()
           (with-bindings *default-worker-thread-bindings*
             (repl-loop connection)))
         :name name))

(defun repl-loop (connection)
  (handle-requests connection))

;;;;; Redirection during requests
;;;
;;; We always redirect the standard streams to Emacs while evaluating
;;; an RPC. This is done with simple dynamic bindings.

(defslimefun create-repl (target &key coding-system)
  (assert (eq target nil))
  (let ((conn *emacs-connection*))
    (initialize-streams-for-connection conn `(:coding-system ,coding-system))
    (with-struct* (connection. @ conn)
      (setf (@ env)
            `((*standard-output* . ,(@ user-output))
              (*standard-input*  . ,(@ user-input))
              (*trace-output*    . ,(or (@ trace-output) (@ user-output)))
              (*error-output*    . ,(@ user-output))
              (*debug-io*        . ,(@ user-io))
              (*query-io*        . ,(@ user-io))
              (*terminal-io*     . ,(@ user-io))))
      (maybe-redirect-global-io conn)
      (when (use-threads-p)
        (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
      (list (package-name *package*)
            (package-string-for-prompt *package*)))))

(defun initialize-streams-for-connection (connection properties)
  (multiple-value-bind (dedicated in out io repl-results)
      (open-streams connection properties)
    (setf (connection.dedicated-output connection) dedicated
          (connection.user-io connection)          io
          (connection.user-output connection)      out
          (connection.user-input connection)       in
          (connection.repl-results connection)     repl-results)
    connection))

(defun read-user-input-from-emacs ()
  (let ((tag (make-tag)))
    (force-output)
    (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
    (let ((ok nil))
      (unwind-protect
           (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
             (setq ok t))
        (unless ok
          (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))

;;;;; Listener eval

(defvar *listener-eval-function* 'repl-eval)

(defslimefun listener-eval (string)
  (funcall *listener-eval-function* string))

(defvar *send-repl-results-function* 'send-repl-results-to-emacs)

(defun repl-eval (string)
  (clear-user-input)
  (with-buffer-syntax ()
    (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)

(defslimefun clear-repl-variables ()
  (let ((variables '(*** ** * /// // / +++ ++ +)))
    (loop for variable in variables
          do (setf (symbol-value variable) nil))))

(defun track-package (fun)
  (let ((p *package*))
    (unwind-protect (funcall fun)
      (unless (eq *package* p)
        (send-to-emacs (list :new-package (package-name *package*)
                             (package-string-for-prompt *package*)))))))

(defun send-repl-results-to-emacs (values)
  (finish-output)
  (if (null values)
      (send-to-emacs `(:write-string "; No value" :repl-result))
      (dolist (v values)
        (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
                                       :repl-result)))))

(defslimefun redirect-trace-output (target)
  (setf (connection.trace-output *emacs-connection*)
        (make-output-stream-for-target *emacs-connection* target))
  nil)




From heller at common-lisp.net  Sun Dec  4 15:05:41 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 07:05:41 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXDdN-0002ZB-DB@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank.lisp (create-repl): Moved to contrib/swank-repl.lisp.
(*use-dedicated-output-stream*, *dedicated-output-stream-port*
(*dedicated-output-stream-buffering*, open-streams)
(make-output-function, send-user-output)
(make-output-function-for-target, make-output-stream-for-target)
(open-dedicated-output-stream, find-repl-thread)
(spawn-repl-thread, repl-loop, initialize-streams-for-connection)
(read-user-input-from-emacs,  *listener-eval-function*)
(listener-eval, *send-repl-results-function*, repl-eval)
(clear-repl-variables, track-package, send-repl-results-to-emacs)
(redirect-trace-output);
* swank-loader.lisp (*contribs*): Add swank-repl.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/04 14:54:45	1.2263
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/04 15:05:41	1.2264
@@ -1,5 +1,20 @@
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (create-repl): Moved to contrib/swank-repl.lisp.
+	(*use-dedicated-output-stream*, *dedicated-output-stream-port*
+	(*dedicated-output-stream-buffering*, open-streams)
+	(make-output-function, send-user-output)
+	(make-output-function-for-target, make-output-stream-for-target)
+	(open-dedicated-output-stream, find-repl-thread)
+	(spawn-repl-thread, repl-loop, initialize-streams-for-connection)
+	(read-user-input-from-emacs,  *listener-eval-function*)
+	(listener-eval, *send-repl-results-function*, repl-eval)
+	(clear-repl-variables, track-package, send-repl-results-to-emacs)
+	(redirect-trace-output);
+	* swank-loader.lisp (*contribs*): Add swank-repl.
+
+2011-12-04  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-loader.lisp (*contribs*): Add swank-mrepl.
 
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/04 14:54:46	1.112
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/04 15:05:41	1.113
@@ -214,7 +214,7 @@
   `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
 
 (defvar *contribs*
-  '(swank-util 
+  '(swank-util swank-repl
     swank-c-p-c swank-arglists swank-fuzzy
     swank-fancy-inspector
     swank-presentations swank-presentation-streams




From heller at common-lisp.net  Sun Dec  4 15:05:46 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 07:05:46 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXDdS-0002Zx-BD@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
Ooops forgot this file in last commit.

--- /project/slime/cvsroot/slime/swank.lisp	2011/12/02 18:17:54	1.767
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/04 15:05:46	1.768
@@ -644,24 +644,12 @@
 
 ;;;; TCP Server
 
-(defvar *use-dedicated-output-stream* nil
-  "When T swank will attempt to create a second connection to
-  Emacs which is used just to send output.")
-
-(defvar *dedicated-output-stream-port* 0
-  "Which port we should use for the dedicated output stream.")
-
 (defvar *communication-style* (preferred-communication-style))
 
 (defvar *dont-close* nil
   "Default value of :dont-close argument to start-server and
   create-server.")
 
-(defvar *dedicated-output-stream-buffering* 
-  (if (eq *communication-style* :spawn) t nil)
-  "The buffering scheme that should be used for the output stream.
-Valid values are nil, t, :line")
-
 (defvar *listener-sockets* nil
   "A property list of lists containing style, socket pairs used 
    by swank server listeners, keyed on socket port number. They 
@@ -789,92 +777,6 @@
     (format *log-output* "~&;; Swank started at port: ~D.~%" port)
     (force-output *log-output*)))
 
-(defun open-streams (connection properties)
-  "Return the 5 streams for IO redirection:
-DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
-  (let* ((input-fn
-          (lambda () 
-            (with-connection (connection)
-              (with-simple-restart (abort-read
-                                    "Abort reading input from Emacs.")
-                (read-user-input-from-emacs)))))
-         (dedicated-output (if *use-dedicated-output-stream*
-                               (open-dedicated-output-stream 
-                                connection
-                                (getf properties :coding-system))))
-         (in (make-input-stream input-fn))
-         (out (or dedicated-output
-                  (make-output-stream (make-output-function connection))))
-         (io (make-two-way-stream in out))
-         (repl-results (make-output-stream-for-target connection
-                                                      :repl-result)))
-    (when (eq (connection.communication-style connection) :spawn)
-      (setf (connection.auto-flush-thread connection)
-            (spawn (lambda () (auto-flush-loop out))
-                   :name "auto-flush-thread")))
-    (values dedicated-output in out io repl-results)))
-
-;; 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)
-        (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."
-  (lambda (string) 
-    (with-connection (connection)
-      (with-simple-restart
-          (abort "Abort sending output to Emacs.")
-        (send-to-emacs `(:write-string ,string ,target))))))
-
-(defun make-output-stream-for-target (connection target)
-  "Create a stream that sends output to a specific TARGET in Emacs."
-  (make-output-stream (make-output-function-for-target connection target)))
-
-(defun open-dedicated-output-stream (connection coding-system)
-  "Open a dedicated output connection to the Emacs on SOCKET-IO.
-Return an output stream suitable for writing program output.
-
-This is an optimized way for Lisp to deliver output to Emacs."
-  (let ((socket (create-socket *loopback-interface*
-                               *dedicated-output-stream-port*))
-        (ef (find-external-format-or-lose coding-system)))
-    (unwind-protect
-         (let ((port (local-port socket)))
-           (encode-message `(:open-dedicated-output-stream ,port 
-                                                           ,coding-system)
-                           (connection.socket-io connection))
-           (let ((dedicated (accept-connection 
-                             socket 
-                             :external-format ef
-                             :buffering *dedicated-output-stream-buffering*
-                             :timeout 30)))
-             (authenticate-client dedicated)
-             (close-socket socket)
-             (setf socket nil)
-             dedicated))
-      (when socket
-        (close-socket socket)))))
-
 
 ;;;;; Event Decoding/Encoding
 
@@ -1003,17 +905,6 @@
      :seconds 0.1)
     (sleep *auto-flush-interval*)))
 
-(defun find-repl-thread (connection)
-  (cond ((not (use-threads-p))
-         (current-thread))
-        (t
-         (let ((thread (connection.repl-thread connection)))
-           (cond ((not thread) nil)
-                 ((thread-alive-p thread) thread)
-                 (t
-                  (setf (connection.repl-thread connection)
-                        (spawn-repl-thread connection "new-repl-thread"))))))))
-
 (defun find-worker-thread (id)
   (etypecase id
     ((member t)
@@ -1057,12 +948,6 @@
                       (cdr (wait-for-event `(:emacs-rex . _)))))))
          :name "worker"))
 
-(defun spawn-repl-thread (connection name)
-  (spawn (lambda () 
-           (with-bindings *default-worker-thread-bindings*
-             (repl-loop connection)))
-         :name name))
-
 (defun dispatch-event (event)
   "Handle an event triggered either by Emacs or within Lisp."
   (log-event "dispatch-event: ~s~%" event)
@@ -1197,9 +1082,6 @@
                  (not (equal (current-thread) thread)))
         (kill-thread thread)))))
 
-(defun repl-loop (connection)
-  (handle-requests connection))
-
 ;;;;;; Signal driven IO
 
 (defun install-sigio-handler (connection)
@@ -1463,41 +1345,6 @@
 
 (add-hook *connection-closed-hook* 'update-redirection-after-close)
 
-;;;;; Redirection during requests
-;;;
-;;; We always redirect the standard streams to Emacs while evaluating
-;;; an RPC. This is done with simple dynamic bindings.
-
-(defslimefun create-repl (target &key coding-system)
-  (assert (eq target nil))
-  (let ((conn *emacs-connection*))
-    (initialize-streams-for-connection conn `(:coding-system ,coding-system))
-    (with-struct* (connection. @ conn)
-      (setf (@ env)
-            `((*standard-output* . ,(@ user-output))
-              (*standard-input*  . ,(@ user-input))
-              (*trace-output*    . ,(or (@ trace-output) (@ user-output)))
-              (*error-output*    . ,(@ user-output))
-              (*debug-io*        . ,(@ user-io))
-              (*query-io*        . ,(@ user-io))
-              (*terminal-io*     . ,(@ user-io))))
-      (maybe-redirect-global-io conn)
-      (when (use-threads-p)
-        (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
-      (list (package-name *package*)
-            (package-string-for-prompt *package*)))))
-
-(defun initialize-streams-for-connection (connection properties)
-  (multiple-value-bind (dedicated in out io repl-results) 
-      (open-streams connection properties)
-    (setf (connection.dedicated-output connection) dedicated
-          (connection.user-io connection)          io
-          (connection.user-output connection)      out
-          (connection.user-input connection)       in
-          (connection.repl-results connection)     repl-results)
-    connection))
-
-
 ;;; Channels
 
 (defvar *channels* '())
@@ -1561,17 +1408,6 @@
 (defun make-tag () 
   (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
 
-(defun read-user-input-from-emacs ()
-  (let ((tag (make-tag)))
-    (force-output)
-    (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
-    (let ((ok nil))
-      (unwind-protect
-           (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
-             (setq ok t))
-        (unless ok 
-          (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
-
 (defun y-or-n-p-in-emacs (format-string &rest arguments)
   "Like y-or-n-p, but ask in the Emacs minibuffer."
   (let ((tag (make-tag))
@@ -2027,48 +1863,6 @@
     (setq *package* p)
     (list (package-name p) (package-string-for-prompt p))))
 
-;;;;; Listener eval
-
-(defvar *listener-eval-function* 'repl-eval)
-
-(defslimefun listener-eval (string)
-  (funcall *listener-eval-function* string))
-
-(defvar *send-repl-results-function* 'send-repl-results-to-emacs)
-
-(defun repl-eval (string)
-  (clear-user-input)
-  (with-buffer-syntax ()
-    (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)
-
-(defslimefun clear-repl-variables ()
-  (let ((variables '(*** ** * /// // / +++ ++ +)))
-    (loop for variable in variables
-          do (setf (symbol-value variable) nil))))
-
-(defun track-package (fun)
-  (let ((p *package*))
-    (unwind-protect (funcall fun)
-      (unless (eq *package* p)
-        (send-to-emacs (list :new-package (package-name *package*)
-                             (package-string-for-prompt *package*)))))))
-
-(defun send-repl-results-to-emacs (values)    
-  (finish-output)
-  (if (null values)
-      (send-to-emacs `(:write-string "; No value" :repl-result))
-      (dolist (v values)
-        (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
-                                       :repl-result)))))
-
 (defun cat (&rest strings)
   "Concatenate all arguments and make the result a string."
   (with-output-to-string (out)
@@ -3056,11 +2850,6 @@
 (defslimefun untrace-all ()
   (untrace))
 
-(defslimefun redirect-trace-output (target)
-  (setf (connection.trace-output *emacs-connection*)
-        (make-output-stream-for-target *emacs-connection* target))
-  nil)
-
 
 ;;;; Undefing
 




From heller at common-lisp.net  Sun Dec  4 15:18:42 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 07:18:42 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RXDpy-0003ve-Ny@common-lisp.net>

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

Modified Files:
	ChangeLog slime-repl.el 
Log Message:
* swank-repl.lisp: New file.
* slime-repl.el (slime-repl): Add swank-dependecy.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/04 14:56:07	1.520
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/04 15:18:42	1.521
@@ -1,6 +1,7 @@
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-repl.lisp: New file.
+	* slime-repl.el (slime-repl): Add swank-dependecy.
 
 2011-12-03  Didier Verna  <didier at xemacs.org>
 
--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2011/12/02 22:12:09	1.61
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2011/12/04 15:18:42	1.62
@@ -30,7 +30,8 @@
    (add-hook 'slime-event-hooks 'slime-repl-event-hook-function)
    (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
    (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package))
-  (:on-unload (slime-repl-remove-hooks)))
+  (:on-unload (slime-repl-remove-hooks))
+  (:swank-dependencies swank-repl))
 
 ;;;;; slime-repl
 




From heller at common-lisp.net  Sun Dec  4 15:44:08 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 07:44:08 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXEEa-0006h3-Nj@common-lisp.net>

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

Modified Files:
	ChangeLog swank-rpc.lisp swank.lisp 
Log Message:
* swank.lisp: Minor cleanups.
* swank-rpc.lisp:

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/04 15:05:41	1.2264
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/04 15:44:08	1.2265
@@ -1,5 +1,10 @@
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp: Minor cleanups.
+	* swank-rpc.lisp:
+
+2011-12-04  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (create-repl): Moved to contrib/swank-repl.lisp.
 	(*use-dedicated-output-stream*, *dedicated-output-stream-port*
 	(*dedicated-output-stream-buffering*, open-streams)
--- /project/slime/cvsroot/slime/swank-rpc.lisp	2011/12/04 14:54:35	1.10
+++ /project/slime/cvsroot/slime/swank-rpc.lisp	2011/12/04 15:44:08	1.11
@@ -66,7 +66,6 @@
           (t
            (error "Short read: length=~D  count=~D" length count)))))
 
-;; end-of-file
 ;; FIXME: no one ever tested this and will probably not work.
 (defparameter *validate-input* nil
   "Set to true to require input that strictly conforms to the protocol")
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/04 15:05:46	1.768
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/04 15:44:08	1.769
@@ -78,13 +78,6 @@
 (defconstant keyword-package (find-package :keyword)
   "The KEYWORD package.")
 
-(defvar *canonical-package-nicknames*
-  `((:common-lisp-user . :cl-user))
-  "Canonical package names to use instead of shortest name/nickname.")
-
-(defvar *auto-abbreviate-dotted-packages* t
-  "Abbreviate dotted package names to their last component if T.")
-
 (defconstant default-server-port 4005
   "The default TCP port for the server (when started manually).")
 
@@ -462,6 +455,11 @@
                '()
                `((t (error "destructure-case failed: ~S" ,tmp))))))))
 
+
+;;;; Interrupt handling 
+
+;; FIXME: should document how this is supposed to work.
+
 ;; If true execute interrupts, otherwise queue them.
 ;; Note: `with-connection' binds *pending-slime-interrupts*.
 (defvar *slime-interrupts-enabled*)
@@ -503,6 +501,7 @@
                   (funcall *interrupt-queued-handler*)))))))
 
 
+;;; FIXME: poor name?
 (defmacro with-io-redirection ((connection) &body body)
   "Execute BODY I/O redirection to CONNECTION. "
   `(with-bindings (connection.env ,connection)
@@ -519,7 +518,8 @@
            (without-slime-interrupts
              (with-swank-error-handler (connection)
                (with-io-redirection (connection)
-                 (call-with-debugger-hook #'swank-debugger-hook function))))))))
+                 (call-with-debugger-hook #'swank-debugger-hook 
+                                          function))))))))
 
 (defun call-with-retry-restart (msg thunk)
   (loop (with-simple-restart (retry "~a" msg)
@@ -563,6 +563,7 @@
 
 ;;;;; Symbols
 
+;; FIXME: this docstring is more confusing than helpful.
 (defun symbol-status (symbol &optional (package (symbol-package symbol)))
   "Returns one of 
 
@@ -905,6 +906,7 @@
      :seconds 0.1)
     (sleep *auto-flush-interval*)))
 
+;; FIXME: drop dependicy on find-repl-thread
 (defun find-worker-thread (id)
   (etypecase id
     ((member t)
@@ -914,6 +916,7 @@
     (fixnum 
      (find-thread id))))
 
+;; FIXME: drop dependicy on find-repl-thread
 (defun interrupt-worker-thread (id)
   (let ((thread (or (find-worker-thread id)
                     (find-repl-thread *emacs-connection*)
@@ -1196,6 +1199,8 @@
       (end-of-file () (error 'end-of-repl-input :stream stream)))))
 
 
+;; FIXME: would be nice if we could move this I/O stuff to swank-repl.lisp.
+
 ;;;; IO to Emacs
 ;;;
 ;;; This code handles redirection of the standard I/O streams
@@ -1347,6 +1352,7 @@
 
 ;;; Channels
 
+;; FIXME: should be per connection not global.
 (defvar *channels* '())
 (defvar *channel-counter* 0)
 
@@ -1355,9 +1361,7 @@
    (thread :initarg :thread :initform (current-thread) :reader channel-thread)
    (name :initarg :name :initform nil)))
 
-(defmethod initialize-instance ((ch channel) &rest initargs)
-  (declare (ignore initargs))
-  (call-next-method)
+(defmethod initialize-instance :after ((ch channel) &key)
   (with-slots (id) ch
     (setf id (incf *channel-counter*))
     (push (cons id ch) *channels*)))
@@ -1382,24 +1386,19 @@
 
 
 
-(defun input-available-p (stream)
-  (loop
-   (etypecase (wait-for-input (list stream) t)
-     (null (return nil))
-     (cons (return t))
-     ((member :interrupt)))))
-
 (defvar *slime-features* nil
   "The feature list that has been sent to Emacs.")
 
 (defun send-oob-to-emacs (object)
   (send-to-emacs object))
 
+;; FIXME: belongs to swank-repl.lisp
 (defun force-user-output ()
   (force-output (connection.user-io *emacs-connection*)))
 
 (add-hook *pre-reply-hook* 'force-user-output)
 
+;; FIXME: belongs to swank-repl.lisp
 (defun clear-user-input  ()
   (clear-input (connection.user-input *emacs-connection*)))
 
@@ -1934,6 +1933,19 @@
                   (t (write-char c stream)))))
     (write-char #\" stream)))
 
+
+;;;; Prompt 
+
+;; FIXME: do we really need 45 lines of code just to figure out the
+;; prompt?
+
+(defvar *canonical-package-nicknames*
+  `((:common-lisp-user . :cl-user))
+  "Canonical package names to use instead of shortest name/nickname.")
+
+(defvar *auto-abbreviate-dotted-packages* t
+  "Abbreviate dotted package names to their last component if T.")
+
 (defun package-string-for-prompt (package)
   "Return the shortest nickname (or canonical name) of PACKAGE."
   (unparse-name
@@ -1973,6 +1985,8 @@
                                    shortest)
               finally (return shortest)))
 
+
+
 (defslimefun ed-in-emacs (&optional what)
   "Edit WHAT in Emacs.
 
@@ -3109,7 +3123,7 @@
               ((:value obj &optional str) 
                (list (value-part obj str (istate.parts istate))))
               ((:label &rest strs)
-               (list (list :label (apply #'concatenate 'string (mapcar #'string strs)))))
+               (list (list :label (apply #'cat (mapcar #'string strs)))))
               ((:action label lambda &key (refreshp t)) 
                (list (action-part label lambda refreshp
                                   (istate.actions istate))))




From heller at common-lisp.net  Sun Dec  4 18:08:32 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 04 Dec 2011 10:08:32 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXGUK-0006sD-P8@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (interrupt-worker-thread): Don't use find-repl-thread
as fallback.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/04 15:44:08	1.2265
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/04 18:08:32	1.2266
@@ -1,5 +1,10 @@
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (interrupt-worker-thread): Don't use find-repl-thread
+	as fallback.
+
+2011-12-04  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp: Minor cleanups.
 	* swank-rpc.lisp:
 
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/04 15:44:08	1.769
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/04 18:08:32	1.770
@@ -916,10 +916,8 @@
     (fixnum 
      (find-thread id))))
 
-;; FIXME: drop dependicy on find-repl-thread
 (defun interrupt-worker-thread (id)
   (let ((thread (or (find-worker-thread id)
-                    (find-repl-thread *emacs-connection*)
                     ;; FIXME: to something better here
                     (spawn (lambda ()) :name "ephemeral"))))
     (log-event "interrupt-worker-thread: ~a ~a~%" id thread)




From sboukarev at common-lisp.net  Mon Dec  5 10:09:09 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 05 Dec 2011 02:09:09 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXVTx-0000Xl-7V@common-lisp.net>

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

Modified Files:
	ChangeLog start-swank.lisp 
Log Message:
* start-swank.lisp: Remove :coding-system argument.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/04 18:08:32	1.2266
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/05 10:09:09	1.2267
@@ -1,3 +1,7 @@
+2011-12-05  Stas Boukarev  <stassats at gmail.com>
+
+	* start-swank.lisp: Remove :coding-system argument.
+
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (interrupt-worker-thread): Don't use find-repl-thread
--- /project/slime/cvsroot/slime/start-swank.lisp	2010/03/21 13:45:28	1.2
+++ /project/slime/cvsroot/slime/start-swank.lisp	2011/12/05 10:09:09	1.3
@@ -17,8 +17,6 @@
  :load-contribs nil) ; load all contribs
 
 (swank:create-server :port 4005
-                     :coding-system "iso-latin-1-unix"
-
                      ;; if non-nil the connection won't be closed
                      ;; after connecting
                      :dont-close nil)




From sboukarev at common-lisp.net  Mon Dec  5 10:12:34 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 05 Dec 2011 02:12:34 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXVXG-0000af-SE@common-lisp.net>

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

Modified Files:
	start-swank.lisp 
Log Message:
Remove stale commentaries.


--- /project/slime/cvsroot/slime/start-swank.lisp	2011/12/05 10:09:09	1.3
+++ /project/slime/cvsroot/slime/start-swank.lisp	2011/12/05 10:12:34	1.4
@@ -3,8 +3,6 @@
 ;;; e.g. sbcl --load start-swank.lisp
 ;;;
 ;;; Default port is 4005
-;;; Default encoding is "iso-latin-1-unix"
-;;;  see Emacs variable `slime-net-valid-coding-systems' for possible values.
 
 ;;; For additional swank-side configurations see
 ;;; 6.2 section of the Slime user manual.




From heller at common-lisp.net  Mon Dec  5 11:29:01 2011
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 05 Dec 2011 03:29:01 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXWjF-0004Re-2D@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
Move flow control into dispatch-event.

* swank.lisp (maybe-slow-down, ping-pong): New functions.
(dispatch-event): Use it. Also require connection argument.
Update callers accordingly.
([defstruct] connection): New slots: send-counter and slowdown.
* slime.el (slime-dispatch-event): Drop thread from
:ping/:emacs-ping messages.

Use subclasses of connection.  Wasn't neccessary for flow control
but seems like a good idea for the future.

* swank.lisp (multithreaded-connection)
(singlethreaded-connection): New
(make-connection): Create multi/single threaded variant depending
on style argument.
([defstruct] serve-requests, cleanup): Delete slots.  Dispatch on
connection type instead.
(stop-serving-requests): New.
(close-connection): Use it.  Can't use
*use-dedicated-output-stream* here.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/05 10:09:09	1.2267
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/05 11:29:00	1.2268
@@ -2,6 +2,35 @@
 
 	* start-swank.lisp: Remove :coding-system argument.
 
+2011-12-05  Helmut Eller  <heller at common-lisp.net>
+
+	Move flow control into dispatch-event.
+
+	* swank.lisp (maybe-slow-down, ping-pong): New functions.
+	(dispatch-event): Use it. Also require connection argument.
+	Update callers accordingly.
+	([defstruct] connection): New slots: send-counter and slowdown.
+	* slime.el (slime-dispatch-event): Drop thread from
+	:ping/:emacs-ping messages.
+
+	Use subclasses of connection.  Wasn't neccessary for flow control
+	but seems like a good idea for the future.
+
+	* swank.lisp (multithreaded-connection)
+	(singlethreaded-connection): New
+	(make-connection): Create multi/single threaded variant depending
+	on style argument.
+	([defstruct] serve-requests, cleanup): Delete slots.  Dispatch on
+	connection type instead.
+	(stop-serving-requests): New.
+	(close-connection): Use it.  Can't use
+	*use-dedicated-output-stream* here.
+
+2011-12-05  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el ([test] arglist): swank::create-server now has an
+	optional argument.  Use swank::compute-backtrace instead.
+
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (interrupt-worker-thread): Don't use find-repl-thread
--- /project/slime/cvsroot/slime/slime.el	2011/11/27 19:24:33	1.1382
+++ /project/slime/cvsroot/slime/slime.el	2011/12/05 11:29:00	1.1383
@@ -2342,20 +2342,18 @@
            (slime-send `(:emacs-return ,thread ,tag ,value)))
           ((:ed what)
            (slime-ed what))
-          ((:inspect what wait-thread wait-tag)
-           (let ((hook (when (and wait-thread wait-tag)
-                         (lexical-let ((thread wait-thread)
-                                       (tag wait-tag))
-                           (lambda ()
-                             (slime-send `(:emacs-return ,thread ,tag nil)))))))
+          ((:inspect what thread tag)
+           (let ((hook (when (and thread tag)
+                         (slime-curry #'slime-send 
+                                      `(:emacs-return ,thread ,tag nil)))))
              (slime-open-inspector what nil hook)))
           ((:background-message message)
            (slime-background-message "%s" message))
           ((:debug-condition thread message)
            (assert thread)
            (message "%s" message))
-          ((:ping thread tag)
-           (slime-send `(:emacs-pong ,thread ,tag)))
+          ((:ping tag)
+           (slime-send `(:emacs-pong ,tag)))
           ((:reader-error packet condition)
            (slime-with-popup-buffer ((slime-buffer-name :error))
              (princ (format "Invalid protocol message:\n%s\n\n%s"
@@ -7913,7 +7911,7 @@
     "Lookup the argument list for FUNCTION-NAME.
 Confirm that EXPECTED-ARGLIST is displayed."
     '(("swank::operator-arglist" "(swank::operator-arglist name package)")
-      ("swank::create-socket" "(swank::create-socket host port)")
+      ("swank::compute-backtrace" "(swank::compute-backtrace start end)")
       ("swank::emacs-connected" "(swank::emacs-connected)")
       ("swank::compile-string-for-emacs"
        "(swank::compile-string-for-emacs string buffer position filename policy)")
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/04 18:08:32	1.770
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/05 11:29:00	1.771
@@ -210,25 +210,6 @@
   (trace-output     nil :type (or stream null))
   ;; A stream where we send REPL results.
   (repl-results     nil :type (or stream null))
-  ;; In multithreaded systems we delegate certain tasks to specific
-  ;; threads. The `reader-thread' is responsible for reading network
-  ;; requests from Emacs and sending them to the `control-thread'; the
-  ;; `control-thread' is responsible for dispatching requests to the
-  ;; threads that should handle them; the `repl-thread' is the one
-  ;; that evaluates REPL expressions. The control thread dispatches
-  ;; all REPL evaluations to the REPL thread and for other requests it
-  ;; spawns new threads.
-  reader-thread
-  control-thread
-  repl-thread
-  auto-flush-thread
-  ;; Callback functions:
-  ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
-  ;; from Emacs.
-  (serve-requests   (missing-arg) :type function)
-  ;; (CLEANUP <this-connection>) is called when the connection is
-  ;; closed.
-  (cleanup          nil :type (or null function))
   ;; Cache of macro-indentation information that has been sent to Emacs.
   ;; This is used for preparing deltas to update Emacs's knowledge.
   ;; Maps: symbol -> indentation-specification
@@ -237,14 +218,38 @@
   (indentation-cache-packages '())
   ;; The communication style used.
   (communication-style nil :type (member nil :spawn :sigio :fd-handler))
-  ;; The SIGINT handler we should restore when the connection is
-  ;; closed.
-  saved-sigint-handler)
+  ;; Used for control flow.  If non-nil we should wait a bit before
+  ;; sending something to Emacs.
+  (slowdown nil :type (or null float))
+  ;; Used for control flow.
+  (send-counter 0 :type (mod 1000))
+  )
 
 (defun print-connection (conn stream depth)
   (declare (ignore depth))
   (print-unreadable-object (conn stream :type t :identity t)))
 
+(defstruct (singlethreaded-connection (:include connection)
+                                      (:conc-name sconn.))
+  ;; The SIGINT handler we should restore when the connection is
+  ;; closed.
+  saved-sigint-handler)
+
+(defstruct (multithreaded-connection (:include connection)
+                                     (:conc-name mconn.))
+  ;; In multithreaded systems we delegate certain tasks to specific
+  ;; threads. The `reader-thread' is responsible for reading network
+  ;; requests from Emacs and sending them to the `control-thread'; the
+  ;; `control-thread' is responsible for dispatching requests to the
+  ;; threads that should handle them; the `repl-thread' is the one
+  ;; that evaluates REPL expressions. The control thread dispatches
+  ;; all REPL evaluations to the REPL thread and for other requests it
+  ;; spawns new threads.
+  reader-thread
+  control-thread
+  repl-thread
+  auto-flush-thread)
+
 (defvar *connections* '()
   "List of all active connections, with the most recent at the front.")
 
@@ -261,24 +266,17 @@
   (first *connections*))
 
 (defun make-connection (socket stream style)
-  (multiple-value-bind (serve cleanup)
-      (ecase style
-        (:spawn
-         (values #'spawn-threads-for-connection #'cleanup-connection-threads))
-        (:sigio
-         (values #'install-sigio-handler #'deinstall-sigio-handler))
-        (:fd-handler
-         (values #'install-fd-handler #'deinstall-fd-handler))
-        ((nil)
-         (values #'simple-serve-requests nil)))
-    (let ((conn (%make-connection :socket socket
-                                  :socket-io stream
-                                  :communication-style style
-                                  :serve-requests serve
-                                  :cleanup cleanup)))
-      (run-hook *new-connection-hook* conn)
-      (push conn *connections*)
-      conn)))
+  (let ((conn (funcall (ecase style
+                         (:spawn 
+                          #'make-multithreaded-connection)
+                         ((:sigio nil :fd-handler)
+                          #'make-singlethreaded-connection))
+                       :socket socket
+                       :socket-io stream
+                       :communication-style style)))
+    (run-hook *new-connection-hook* conn)
+    (push conn *connections*)
+    conn))
 
 (defslimefun ping (tag)
   tag)
@@ -763,7 +761,24 @@
 
 (defun serve-requests (connection)
   "Read and process all requests on connections."
-  (funcall (connection.serve-requests connection) connection))
+  (etypecase connection
+    (multithreaded-connection
+     (spawn-threads-for-connection connection))
+    (singlethreaded-connection
+     (ecase (connection.communication-style connection)
+       ((nil) (simple-serve-requests connection))
+       (:sigio (install-sigio-handler connection))
+       (:fd-handler (install-fd-handler connection))))))
+
+(defun stop-serving-requests (connection)
+  (etypecase connection
+    (multithreaded-connection
+     (cleanup-connection-threads connection))
+    (singlethreaded-connection
+     (ecase (connection.communication-style connection)
+       ((nil))
+       (:sigio (deinstall-sigio-handler connection))
+       (:fd-handler (deinstall-fd-handler connection))))))
 
 (defun announce-server-port (file port)
   (with-open-file (s file
@@ -850,9 +865,7 @@
     (log-event "close-connection: ~a ...~%" condition))
   (format *log-output* "~&;; swank:close-connection: ~A~%"
           (escape-non-ascii (safe-condition-message condition)))
-  (let ((cleanup (connection.cleanup c)))
-    (when cleanup
-      (funcall cleanup c)))
+  (stop-serving-requests c)
   (close (connection.socket-io c))
   (when (connection.dedicated-output c)
     (close (connection.dedicated-output c)))
@@ -867,13 +880,12 @@
                         ;; Connection to Emacs lost. [~%~
                         ;;  condition: ~A~%~
                         ;;  type: ~S~%~
-                        ;;  style: ~S dedicated: ~S]~%"
+                        ;;  style: ~S]~%"
             (loop for (i f) in backtrace collect 
                   (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f))))
             (escape-non-ascii (safe-condition-message condition) )
             (type-of condition)
-            (connection.communication-style c)
-            *use-dedicated-output-stream*))
+            (connection.communication-style c)))
   (finish-output *log-output*)
   (log-event "close-connection ~a ... done.~%" condition))
 
@@ -883,14 +895,14 @@
 
 (defun read-loop (connection)
   (let ((input-stream (connection.socket-io connection))
-        (control-thread (connection.control-thread connection)))
+        (control-thread (mconn.control-thread connection)))
     (with-swank-error-handler (connection)
       (loop (send control-thread (decode-message input-stream))))))
 
 (defun dispatch-loop (connection)
   (let ((*emacs-connection* connection))
     (with-panic-handler (connection)
-      (loop (dispatch-event (receive))))))
+      (loop (dispatch-event connection (receive))))))
 
 (defvar *auto-flush-interval* 0.2)
 
@@ -949,7 +961,7 @@
                       (cdr (wait-for-event `(:emacs-rex . _)))))))
          :name "worker"))
 
-(defun dispatch-event (event)
+(defun dispatch-event (connection event)
   "Handle an event triggered either by Emacs or within Lisp."
   (log-event "dispatch-event: ~s~%" event)
   (destructure-case event
@@ -978,8 +990,9 @@
        :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
       &rest _)
      (declare (ignore _))
-     (encode-message event (current-socket-io)))
-    (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
+     (encode-message event (current-socket-io))
+     (maybe-slow-down connection))
+    (((:emacs-return :emacs-return-string) thread-id &rest args)
      (send-event (find-thread thread-id) (cons (car event) args)))
     ((:emacs-channel-send channel-id msg)
      (let ((ch (find-channel channel-id)))
@@ -987,8 +1000,40 @@
     ((:reader-error packet condition)
      (encode-message `(:reader-error ,packet 
                                      ,(safe-condition-message condition))
-                     (current-socket-io)))))
+                     (current-socket-io)))
+    ((:emacs-pong _)
+     (declare (ignore _))
+     (assert (singlethreaded-connection-p connection))
+     (send-event (current-thread) event))))
+
+
+;;;; Flow control
 
+;; After sending N (usually 100) messages we slow down and ping Emacs
+;; to make sure that everything we have sent so far was received.
+
+(defconstant send-counter-limit 100)
+
+(defun maybe-slow-down (connection)
+  (let ((counter (incf (connection.send-counter connection))))
+    (when (< send-counter-limit counter)
+      (setf (connection.send-counter connection) 0)
+      (setf (connection.slowdown connection) 0.1)
+      (ping-pong connection)
+      (setf (connection.slowdown connection) nil))))
+
+(defun ping-pong (connection)
+  (let* ((tag (make-tag))
+         (pattern `(:emacs-pong ,tag)))
+    (encode-message `(:ping ,tag) (connection.socket-io connection))
+    (etypecase connection
+      (multithreaded-connection
+       (receive-if (lambda (e) (event-match-p e pattern)) nil))
+      (singlethreaded-connection
+       (let ((*emacs-connection* connection))
+         (wait-for-event pattern))))))
+
+
 (defvar *event-queue* '())
 (defvar *events-enqueued* 0)
 
@@ -1002,9 +1047,14 @@
 (defun send-to-emacs (event)
   "Send EVENT to Emacs."
   ;;(log-event "send-to-emacs: ~a" event)
-  (cond ((use-threads-p)
-         (send (connection.control-thread *emacs-connection*) event))
-        (t (dispatch-event event))))
+  (let ((c *emacs-connection*))
+    (etypecase c
+      (multithreaded-connection
+       (when (connection.slowdown c)
+         (sleep 0.1))
+       (send (mconn.control-thread c) event))
+      (singlethreaded-connection
+       (dispatch-event c event)))))
 
 (defun wait-for-event (pattern &optional timeout)
   "Scan the event queue for PATTERN and return the event.
@@ -1014,12 +1064,14 @@
 event was found."
   (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)))))
+    (let ((c *emacs-connection*))
+      (etypecase c
+        (multithreaded-connection
+         (receive-if (lambda (e) (event-match-p e pattern)) timeout))
+        (singlethreaded-connection
+         (wait-for-event/event-loop c pattern timeout))))))
 
-(defun wait-for-event/event-loop (pattern timeout)
+(defun wait-for-event/event-loop (connection pattern timeout)
   (assert (or (not timeout) (eq timeout t)))
   (loop 
    (check-slime-interrupts)
@@ -1035,7 +1087,8 @@
             )
            (t
             (assert (equal ready (list (current-socket-io))))
-            (dispatch-event (decode-message (current-socket-io))))))))
+            (dispatch-event connection
+                            (decode-message (current-socket-io))))))))
 
 (defun poll-for-event (pattern)
   (let ((tail (member-if (lambda (e) (event-match-p e pattern))
@@ -1060,23 +1113,24 @@
         (t (error "Invalid pattern: ~S" pattern))))
 
 (defun spawn-threads-for-connection (connection)
-  (setf (connection.control-thread connection) 
+  (setf (mconn.control-thread connection)
         (spawn (lambda () (control-thread connection))
                :name "control-thread"))
   connection)
 
 (defun control-thread (connection)
-  (with-struct* (connection. @ connection)
+  (with-struct* (mconn. @ connection)
     (setf (@ control-thread) (current-thread))
     (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) 
                                    :name "reader-thread"))
     (dispatch-loop connection)))
 
 (defun cleanup-connection-threads (connection)
-  (let ((threads (list (connection.repl-thread connection)
-                       (connection.reader-thread connection)
-                       (connection.control-thread connection)
-                       (connection.auto-flush-thread connection))))
+  (let* ((c connection)
+         (threads (list (mconn.repl-thread c)
+                        (mconn.reader-thread c)
+                        (mconn.control-thread c)
+                        (mconn.auto-flush-thread c))))
     (dolist (thread threads)
       (when (and thread 
                  (thread-alive-p thread)
@@ -1109,7 +1163,7 @@
 (defun install-fd-handler (connection)
   (add-fd-handler (connection.socket-io connection)
                   (lambda () (handle-requests connection t)))
-  (setf (connection.saved-sigint-handler connection)
+  (setf (sconn.saved-sigint-handler connection)
         (install-sigint-handler 
          (lambda () 
            (invoke-or-queue-interrupt
@@ -1120,12 +1174,12 @@
   ;; This boils down to INTERRUPT-WORKER-THREAD which uses
   ;; USE-THREADS-P which needs *EMACS-CONNECTION*.
   (with-connection (connection)
-    (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))
+    (dispatch-event connection `(:emacs-interrupt ,(current-thread-id)))))
 
 (defun deinstall-fd-handler (connection)
   (log-event "deinstall-fd-handler~%")
   (remove-fd-handlers (connection.socket-io connection))
-  (install-sigint-handler (connection.saved-sigint-handler connection)))
+  (install-sigint-handler (sconn.saved-sigint-handler connection)))
 
 ;;;;;; Simple sequential IO
 




From heller at common-lisp.net  Mon Dec  5 11:29:12 2011
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 05 Dec 2011 03:29:12 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXWjQ-0004Sd-Uc@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (background-message): Do nothing if connection.slowdown is set.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/05 11:29:00	1.2268
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/05 11:29:12	1.2269
@@ -1,7 +1,3 @@
-2011-12-05  Stas Boukarev  <stassats at gmail.com>
-
-	* start-swank.lisp: Remove :coding-system argument.
-
 2011-12-05  Helmut Eller  <heller at common-lisp.net>
 
 	Move flow control into dispatch-event.
@@ -26,11 +22,18 @@
 	(close-connection): Use it.  Can't use
 	*use-dedicated-output-stream* here.
 
+	* swank.lisp (background-message): Do nothing if
+	connection.slowdown is set.
+
 2011-12-05  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el ([test] arglist): swank::create-server now has an
 	optional argument.  Use swank::compute-backtrace instead.
 
+2011-12-05  Stas Boukarev  <stassats at gmail.com>
+
+	* start-swank.lisp: Remove :coding-system argument.
+
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (interrupt-worker-thread): Don't use find-repl-thread
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/05 11:29:00	1.771
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/05 11:29:12	1.772
@@ -2106,8 +2106,9 @@
   "Display a message in Emacs' echo area.
 
 Use this function for informative messages only.  The message may even
-be dropped, if we are too busy with other things."
-  (when *emacs-connection*
+be dropped if we are too busy with other things."
+  (when (and *emacs-connection*
+             (not (connection.slowdown *emacs-connection*)))
     (send-to-emacs `(:background-message 
                      ,(apply #'format nil format-string args)))))
 




From heller at common-lisp.net  Mon Dec  5 11:29:18 2011
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 05 Dec 2011 03:29:18 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RXWjW-0004TC-E4@common-lisp.net>

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

Modified Files:
	ChangeLog swank-repl.lisp 
Log Message:
Drop flow control from repl-output-stream.
That's now done at a lower level.

* swank-repl.lisp (make-output-function): Use :write-string directly.
(send-user-output, *maximum-pipelined-output-chunks*)
(*maximum-pipelined-output-length*): Deleted.

* swank-repl.lisp (create-repl, open-streams, find-repl-thread):
Use accessors for multithreaded-connection where needed.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/04 15:18:42	1.521
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/05 11:29:18	1.522
@@ -1,3 +1,15 @@
+2011-12-05  Helmut Eller  <heller at common-lisp.net>
+
+	Drop flow control from repl-output-stream.
+	That's now done at a lower level.
+
+	* swank-repl.lisp (make-output-function): Use :write-string directly.
+	(send-user-output, *maximum-pipelined-output-chunks*)
+	(*maximum-pipelined-output-length*): Deleted.
+
+	* swank-repl.lisp (create-repl, open-streams, find-repl-thread):
+	Use accessors for multithreaded-connection where needed.
+
 2011-12-04  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-repl.lisp: New file.
--- /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/04 14:56:07	1.1
+++ /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/05 11:29:18	1.2
@@ -35,35 +35,18 @@
          (io (make-two-way-stream in out))
          (repl-results (make-output-stream-for-target connection
                                                       :repl-result)))
-    (when (eq (connection.communication-style connection) :spawn)
-      (setf (connection.auto-flush-thread connection)
-            (spawn (lambda () (auto-flush-loop out))
-                   :name "auto-flush-thread")))
+    (typecase connection
+      (multithreaded-connection
+       (setf (mconn.auto-flush-thread connection)
+	     (spawn (lambda () (auto-flush-loop out))
+		    :name "auto-flush-thread"))))
     (values dedicated-output in out io repl-results)))
 
-;; 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)
-        (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))))
+  (lambda (string)
+    (with-connection (connection)
+      (send-to-emacs `(:write-string ,string)))))
 
 (defun make-output-function-for-target (connection target)
   "Create a function to send user output to a specific TARGET in Emacs."
@@ -106,11 +89,11 @@
   (cond ((not (use-threads-p))
          (current-thread))
         (t
-         (let ((thread (connection.repl-thread connection)))
+         (let ((thread (mconn.repl-thread connection)))
            (cond ((not thread) nil)
                  ((thread-alive-p thread) thread)
                  (t
-                  (setf (connection.repl-thread connection)
+                  (setf (mconn.repl-thread connection)
                         (spawn-repl-thread connection "new-repl-thread"))))))))
 
 (defun spawn-repl-thread (connection name)
@@ -141,8 +124,10 @@
               (*query-io*        . ,(@ user-io))
               (*terminal-io*     . ,(@ user-io))))
       (maybe-redirect-global-io conn)
-      (when (use-threads-p)
-        (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
+      (typecase conn
+	(multithreaded-connection
+	 (setf (mconn.repl-thread conn) 
+	       (spawn-repl-thread conn "repl-thread"))))
       (list (package-name *package*)
             (package-string-for-prompt *package*)))))
 




From sboukarev at common-lisp.net  Tue Dec  6 15:09:04 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 06 Dec 2011 07:09:04 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RXwdk-0006vY-I9@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-compile-region): Check connection before running
hooks, invoking slime-flash-region doesn't make much sense when
there's no connection.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/05 11:29:12	1.2269
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/06 15:09:04	1.2270
@@ -1,3 +1,9 @@
+2011-12-06  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-compile-region): Check connection before running
+	hooks, invoking slime-flash-region doesn't make much sense when
+	there's no connection.
+
 2011-12-05  Helmut Eller  <heller at common-lisp.net>
 
 	Move flow control into dispatch-event.
--- /project/slime/cvsroot/slime/slime.el	2011/12/05 11:29:00	1.1383
+++ /project/slime/cvsroot/slime/slime.el	2011/12/06 15:09:04	1.1384
@@ -2667,10 +2667,14 @@
 (defun slime-compile-region (start end)
   "Compile the region."
   (interactive "r")
-  (slime-flash-region start end)
+  ;; Check connection before running hooks
+  ;; things like slime-flash-region don't make much sense if there's no connection
+  (slime-connection) 
   (run-hook-with-args 'slime-before-compile-functions start end)
   (slime-compile-string (buffer-substring-no-properties start end) start))
 
+(add-hook 'slime-before-compile-functions 'slime-flash-region)
+
 (defun slime-flash-region (start end &optional timeout)
   "Temporarily highlight region from START to END."
   (let ((overlay (make-overlay start end))) 




From heller at common-lisp.net  Tue Dec  6 18:57:18 2011
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 06 Dec 2011 10:57:18 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RY0Cc-0007c0-L3@common-lisp.net>

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

Modified Files:
	ChangeLog slime-asdf.el 
Log Message:
* slime-asdf.el (slime-asdf): New custom group.
* slime-asdf.el (slime-asdf-collect-notes): Put this variable in.
Patch by Didier Verna.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/05 11:29:18	1.522
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/06 18:57:18	1.523
@@ -1,3 +1,8 @@
+2011-12-06  Didier Verna  <didier at xemacs.org>
+
+	* slime-asdf.el (slime-asdf): New custom group.
+	* slime-asdf.el (slime-asdf-collect-notes): Put this variable in.
+
 2011-12-05  Helmut Eller  <heller at common-lisp.net>
 
 	Drop flow control from repl-output-stream.
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2010/05/28 19:13:17	1.32
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2011/12/06 18:57:18	1.33
@@ -1,4 +1,3 @@
-
 (define-slime-contrib slime-asdf
   "ASDF support."
   (:authors "Daniel Barlow       <dan at telent.net>"
@@ -18,6 +17,11 @@
 
 ;;; Utilities
 
+(defgroup slime-asdf nil
+  "ASDF support for Slime."
+  :prefix "slime-asdf-"
+  :group 'slime)
+
 (defvar slime-system-history nil
   "History list for ASDF system names.")
 
@@ -69,7 +73,9 @@
 (defcustom slime-asdf-collect-notes t
   "Collect and display notes produced by the compiler.
 
-See also `slime-highlight-compiler-notes' and `slime-compilation-finished-hook'.")
+See also `slime-highlight-compiler-notes' and
+`slime-compilation-finished-hook'."
+  :group 'slime-asdf)
 
 (defun slime-asdf-operation-finished-function (system)
   (if slime-asdf-collect-notes




From heller at common-lisp.net  Tue Dec  6 18:57:34 2011
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 06 Dec 2011 10:57:34 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RY0Cs-0007cz-PH@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el ([xemacs]): Don't require 'un-define in XEmacs 21.5 and
later. Mule-UCS is not needed anymore because of internal Unicode
support (and conflicts with it).

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/06 15:09:04	1.2270
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/06 18:57:34	1.2271
@@ -1,3 +1,9 @@
+2011-12-05  Didier Verna  <didier at xemacs.org>
+
+	* slime.el ([xemacs]): Don't require 'un-define in XEmacs 21.5 and
+	later. Mule-UCS is not needed anymore because of internal Unicode
+	support (and conflicts with it).
+
 2011-12-06  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-compile-region): Check connection before running
--- /project/slime/cvsroot/slime/slime.el	2011/12/06 15:09:04	1.1384
+++ /project/slime/cvsroot/slime/slime.el	2011/12/06 18:57:34	1.1385
@@ -68,7 +68,10 @@
 (require 'font-lock)
 (when (featurep 'xemacs)
   (require 'overlay)
-  (require 'un-define))
+  (when (or (< emacs-major-version 21)
+            (and (= emacs-major-version 21)
+                 (< emacs-minor-version 5)))
+    (require 'un-define)))
 (require 'easymenu)
 (eval-when (compile)
   (require 'arc-mode)




From sboukarev at common-lisp.net  Wed Dec  7 15:05:53 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 07 Dec 2011 07:05:53 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYJ4D-0001wa-QW@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
* doc/.cvsignore: Add more files generated by Texinfo (.kys, .fns
and .vrs).


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/06 18:57:34	1.2271
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 15:05:53	1.2272
@@ -1,3 +1,8 @@
+2011-12-07  Didier Verna  <didier at xemacs.org>
+
+	* doc/.cvsignore: Add more files generated by Texinfo (.kys, .fns
+	and .vrs).
+
 2011-12-05  Didier Verna  <didier at xemacs.org>
 
 	* slime.el ([xemacs]): Don't require 'un-define in XEmacs 21.5 and




From sboukarev at common-lisp.net  Wed Dec  7 15:05:54 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 07 Dec 2011 07:05:54 -0800
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1RYJ4E-0001wn-1T@common-lisp.net>

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

Modified Files:
	.cvsignore 
Log Message:
* doc/.cvsignore: Add more files generated by Texinfo (.kys, .fns
and .vrs).


--- /project/slime/cvsroot/slime/doc/.cvsignore	2011/10/05 13:54:19	1.2
+++ /project/slime/cvsroot/slime/doc/.cvsignore	2011/12/07 15:05:53	1.3
@@ -3,8 +3,10 @@
 slime.cp
 slime.dvi
 slime.fn
+slime.fns
 slime.info
 slime.ky
+slime.kys
 slime.log
 slime.pdf
 slime.pg
@@ -13,5 +15,6 @@
 slime.toc
 slime.tp
 slime.vr
+slime.vrs
 slime.html
 html




From sboukarev at common-lisp.net  Wed Dec  7 15:10:11 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 07 Dec 2011 07:10:11 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYJ8N-0002MA-0Z@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
* doc/.cvsignore: Aadd html.tgz


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 15:05:53	1.2272
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 15:10:10	1.2273
@@ -1,3 +1,7 @@
+2011-12-07  Stas Boukarev  <stassats at gmail.com>
+
+	* doc/.cvsignore: Aadd html.tgz
+
 2011-12-07  Didier Verna  <didier at xemacs.org>
 
 	* doc/.cvsignore: Add more files generated by Texinfo (.kys, .fns




From sboukarev at common-lisp.net  Wed Dec  7 15:10:11 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 07 Dec 2011 07:10:11 -0800
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1RYJ8N-0002MN-8G@common-lisp.net>

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

Modified Files:
	.cvsignore 
Log Message:
* doc/.cvsignore: Aadd html.tgz


--- /project/slime/cvsroot/slime/doc/.cvsignore	2011/12/07 15:05:53	1.3
+++ /project/slime/cvsroot/slime/doc/.cvsignore	2011/12/07 15:10:11	1.4
@@ -18,3 +18,4 @@
 slime.vrs
 slime.html
 html
+html.tgz




From heller at common-lisp.net  Wed Dec  7 18:02:03 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 10:02:03 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYLoh-0000Hr-Gh@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-batch-test): Forgot to rename slime-run-one-test
to slime-run-test here.
(slime-net-connect): Remove coding-system argument.
(slime-xref-insert-recompilation-flags): Use insert-char instead
of (dotimes (i ..) (insert " " ..)) to avoid the compiler warning.
([test] break, slime-forward-sexp): Use _i in dotimes.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 15:10:10	1.2273
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:02:03	1.2274
@@ -1,3 +1,12 @@
+2011-12-07  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-batch-test): Forgot to rename slime-run-one-test
+	to slime-run-test here.
+	(slime-net-connect): Remove coding-system argument.
+	(slime-xref-insert-recompilation-flags): Use insert-char instead
+	of (dotimes (i ..) (insert " " ..)) to avoid the compiler warning.
+	([test] break, slime-forward-sexp): Use _i in dotimes.
+
 2011-12-07  Stas Boukarev  <stassats at gmail.com>
 
 	* doc/.cvsignore: Aadd html.tgz
--- /project/slime/cvsroot/slime/slime.el	2011/12/06 18:57:34	1.1385
+++ /project/slime/cvsroot/slime/slime.el	2011/12/07 18:02:03	1.1386
@@ -1202,12 +1202,9 @@
              (y-or-n-p "Close old connections first? "))
     (slime-disconnect-all))
   (message "Connecting to Swank on port %S.." port)
-  (let ((coding-system (or coding-system slime-net-coding-system)))
-    (slime-check-coding-system coding-system)
-    (message "Connecting to Swank on port %S.." port)
-    (let* ((process (slime-net-connect host port coding-system))
-           (slime-dispatching-connection process))
-      (slime-setup-connection process))))
+  (let* ((process (slime-net-connect host port))
+         (slime-dispatching-connection process))
+    (slime-setup-connection process)))
 
 ;; FIXME: seems redundant
 (defun slime-start-and-init (options fun)
@@ -1505,7 +1502,7 @@
     (file-error nil)))
 
 ;;; Interface
-(defun slime-net-connect (host port coding-system)
+(defun slime-net-connect (host port)
   "Establish a connection with a CL."
   (let* ((inhibit-quit nil)
          (proc (open-network-stream "SLIME Lisp" nil host port))
@@ -4973,9 +4970,7 @@
                                                  (slime-xref-dspec-at-point))
                      until (equal dspec-at-point dspec))
                (end-of-line) ; skip old status information.
-               (dotimes (i (- max-column (current-column)))
-                 (insert " "))
-               (insert " ")
+               (insert-char ?\  (1+ (- max-column (current-column))))
                (insert (format "[%s]"
                                (case result
                                  ((t)   :success)
@@ -7483,7 +7478,7 @@
     (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))
+           (failed-tests (cond (test-name (slime-run-test test-name))
                                (t (slime-run-tests)))))
       (with-current-buffer slime-test-buffer-name
         (slime-delete-hidden-outline-text)
@@ -8286,7 +8281,7 @@
                                    (unless (= i 0)
                                      (swank::sleep-for 1))
                                    ,exp)))))
-  (dotimes (i times)
+  (dotimes (_i times)
     (slime-wait-condition "Debugger visible" 
                           (lambda () 
                             (and (slime-sldb-level= 1)
@@ -8592,7 +8587,7 @@
 (defun slime-forward-sexp (&optional count)
   "Like `forward-sexp', but understands reader-conditionals (#- and #+),
 and skips comments."
-  (dotimes (i (or count 1))
+  (dotimes (_i (or count 1))
     (slime-forward-cruft)
     (forward-sexp)))
 




From heller at common-lisp.net  Wed Dec  7 18:02:16 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 10:02:16 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYLou-0000NT-Rh@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-update-system-indentation): Moved to
contrib/slime-indentation.el.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:02:03	1.2274
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:02:16	1.2275
@@ -1,5 +1,10 @@
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-update-system-indentation): Move to
+	contrib/slime-indentation.el.
+
+2011-12-07  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-batch-test): Forgot to rename slime-run-one-test
 	to slime-run-test here.
 	(slime-net-connect): Remove coding-system argument.
--- /project/slime/cvsroot/slime/slime.el	2011/12/07 18:02:03	1.1386
+++ /project/slime/cvsroot/slime/slime.el	2011/12/07 18:02:16	1.1387
@@ -2323,7 +2323,8 @@
           ((:emacs-channel-send id msg)
            (slime-send `(:emacs-channel-send ,id ,msg)))
           ((:read-from-minibuffer thread tag prompt initial-value)
-           (slime-read-from-minibuffer-for-swank thread tag prompt initial-value))
+           (slime-read-from-minibuffer-for-swank thread tag prompt 
+                                                 initial-value))
           ((:y-or-n-p thread tag question)
            (slime-y-or-n-p thread tag question))
           ((:emacs-return-string thread tag string)
@@ -6973,26 +6974,9 @@
         (t
          spec)))
 
-(defun slime-update-system-indentation (symbol indent packages)
-  (let ((list (gethash symbol common-lisp-system-indentation))
-        (ok nil))
-    (if (not list)
-        (puthash symbol (list (cons indent packages))
-                 common-lisp-system-indentation)
-      (dolist (spec list)
-        (cond ((equal (car spec) indent)
-               (dolist (p packages)
-                 (unless (member p (cdr spec))
-                   (push p (cdr spec))))
-               (setf ok t))
-              (t
-               (setf (cdr spec)
-                     (set-difference (cdr spec) packages :test 'equal)))))
-      (unless ok
-        (puthash symbol (cons (cons indent packages)
-                              list)
-                 common-lisp-system-indentation)))))
-
+;; FIXME: restore the old version without per-package
+;; stuff. slime-indentation.el should be able tho disable the simple
+;; version if needed.
 (defun slime-handle-indentation-update (alist)
   "Update Lisp indent information.
 




From heller at common-lisp.net  Wed Dec  7 18:02:17 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 10:02:17 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RYLov-0000Nk-3j@common-lisp.net>

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

Modified Files:
	slime-indentation.el 
Log Message:
* slime.el (slime-update-system-indentation): Moved to
contrib/slime-indentation.el.

--- /project/slime/cvsroot/slime/contrib/slime-indentation.el	2011/06/09 16:35:09	1.8
+++ /project/slime/cvsroot/slime/contrib/slime-indentation.el	2011/12/07 18:02:16	1.9
@@ -7,4 +7,24 @@
 
 (setq common-lisp-current-package-function 'slime-current-package)
 
+(defun slime-update-system-indentation (symbol indent packages)
+  (let ((list (gethash symbol common-lisp-system-indentation))
+        (ok nil))
+    (if (not list)
+        (puthash symbol (list (cons indent packages))
+                 common-lisp-system-indentation)
+      (dolist (spec list)
+        (cond ((equal (car spec) indent)
+               (dolist (p packages)
+                 (unless (member p (cdr spec))
+                   (push p (cdr spec))))
+               (setf ok t))
+              (t
+               (setf (cdr spec)
+                     (set-difference (cdr spec) packages :test 'equal)))))
+      (unless ok
+        (puthash symbol (cons (cons indent packages)
+                              list)
+                 common-lisp-system-indentation)))))
+
 (provide 'slime-indentation)




From heller at common-lisp.net  Wed Dec  7 18:02:31 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 10:02:31 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYLp9-0000QK-Tl@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
Move flow control from dispatch-event to send-to-emacs.

* swank.lisp (*send-counter*): New thread local variable.
(with-connection): Bind it.
(send-to-emacs): Call maybe-slow-down.
(maybe-slow-down, ping-pong): Go through dispatch-event instead of
writing to the socket directly.
(dispatch-event): Re-add thread arg to :ping/:emacs-pong.
Also add a :test-delay event.
(perform-indentation-update): Use with-connection to bind
*emacs-connection* and *send-counter*.
(background-message): Remove reference to connection.slowdown.
(flow-control-test): New support code for testing flow-control.
([defstruct] connection): Delete send-counter and slowdown slots.

* slime.el (slime-dispatch-event): Re-add thread arg to
:ping/:emacs-pong and :test-delay event.
([test] flow-control): New test.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:02:16	1.2275
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:02:31	1.2276
@@ -1,6 +1,27 @@
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
-	* slime.el (slime-update-system-indentation): Move to
+	Move flow control from dispatch-event to send-to-emacs.
+
+	* swank.lisp (*send-counter*): New thread local variable.
+	(with-connection): Bind it.
+	(send-to-emacs): Call maybe-slow-down.
+	(maybe-slow-down, ping-pong): Go through dispatch-event instead of
+	writing to the socket directly.
+	(dispatch-event): Re-add thread arg to :ping/:emacs-pong.
+	Also add a :test-delay event.
+	(perform-indentation-update): Use with-connection to bind
+	*emacs-connection* and *send-counter*.
+	(background-message): Remove reference to connection.slowdown.
+	(flow-control-test): New support code for testing flow-control.
+	([defstruct] connection): Delete send-counter and slowdown slots.
+
+	* slime.el (slime-dispatch-event): Re-add thread arg to
+	:ping/:emacs-pong and :test-delay event.
+	([test] flow-control): New test.
+
+2011-12-07  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-update-system-indentation): Moved to
 	contrib/slime-indentation.el.
 
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/slime.el	2011/12/07 18:02:16	1.1387
+++ /project/slime/cvsroot/slime/slime.el	2011/12/07 18:02:31	1.1388
@@ -2353,8 +2353,8 @@
           ((:debug-condition thread message)
            (assert thread)
            (message "%s" message))
-          ((:ping tag)
-           (slime-send `(:emacs-pong ,tag)))
+          ((:ping thread tag)
+           (slime-send `(:emacs-pong ,thread ,tag)))
           ((:reader-error packet condition)
            (slime-with-popup-buffer ((slime-buffer-name :error))
              (princ (format "Invalid protocol message:\n%s\n\n%s"
@@ -2366,7 +2366,8 @@
                  (remove* id (slime-rex-continuations) :key #'car))
            (error "Invalid rpc: %s" message))
           ((:emacs-skipped-packet _pkg))
-          ))))
+          ((:test-delay seconds) ; for testing only
+           (sit-for seconds))))))
 
 (defun slime-send (sexp)
   "Send SEXP directly over the wire on the current connection."
@@ -8378,6 +8379,23 @@
     (sldb-quit))
   (slime-sync-to-top-level 1))
 
+(def-slime-test flow-control 
+    (n delay interrupts)
+    "Let Lisp produce output faster than Emacs can consume it."
+    `((400 0.03 3))
+  (slime-check "No debugger" (not (sldb-get-default-buffer)))
+  (slime-eval-async `(swank:flow-control-test ,n ,delay))
+  (sleep-for 0.2)
+  (dotimes (_i interrupts)
+    (slime-interrupt)
+    (slime-wait-condition "In debugger" (lambda () (slime-sldb-level= 1)) 5)
+    (slime-check "In debugger" (slime-sldb-level= 1))
+    (with-current-buffer (sldb-get-default-buffer)
+      (sldb-continue))
+    (slime-wait-condition "No debugger" (lambda () (slime-sldb-level= nil)) 3)
+    (slime-check "Debugger closed" (slime-sldb-level= nil)))
+  (slime-sync-to-top-level 8))
+
 ;;; FIXME: reconnection is broken since the recent io-redirection changes.    
 (def-slime-test (disconnect-one-connection (:style :spawn)) ()
     "`slime-disconnect' should disconnect only the current connection"
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/05 11:29:12	1.772
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/07 18:02:31	1.773
@@ -218,11 +218,6 @@
   (indentation-cache-packages '())
   ;; The communication style used.
   (communication-style nil :type (member nil :spawn :sigio :fd-handler))
-  ;; Used for control flow.  If non-nil we should wait a bit before
-  ;; sending something to Emacs.
-  (slowdown nil :type (or null float))
-  ;; Used for control flow.
-  (send-counter 0 :type (mod 1000))
   )
 
 (defun print-connection (conn stream depth)
@@ -504,7 +499,11 @@
   "Execute BODY I/O redirection to CONNECTION. "
   `(with-bindings (connection.env ,connection)
      . ,body))
-      
+
+;; Thread local variable used for flow-control.
+;; It's bound by with-connection.
+(defvar *send-counter*)
+
 (defmacro with-connection ((connection) &body body)
   "Execute BODY in the context of CONNECTION."
   `(let ((connection ,connection)
@@ -512,7 +511,8 @@
      (if (eq *emacs-connection* connection)
          (funcall function)
          (let ((*emacs-connection* connection)
-               (*pending-slime-interrupts* '()))
+               (*pending-slime-interrupts* '())
+               (*send-counter* 0))
            (without-slime-interrupts
              (with-swank-error-handler (connection)
                (with-io-redirection (connection)
@@ -963,6 +963,7 @@
 
 (defun dispatch-event (connection event)
   "Handle an event triggered either by Emacs or within Lisp."
+  (declare (ignore connection))
   (log-event "dispatch-event: ~s~%" event)
   (destructure-case event
     ((:emacs-rex form package thread-id id)
@@ -982,17 +983,16 @@
      (encode-message `(:return , at args) (current-socket-io)))
     ((:emacs-interrupt thread-id)
      (interrupt-worker-thread thread-id))
-    (((:write-string
+    (((:write-string 
        :debug :debug-condition :debug-activate :debug-return :channel-send
        :presentation-start :presentation-end
        :new-package :new-features :ed :indentation-update
        :eval :eval-no-wait :background-message :inspect :ping
-       :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
+       :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay)
       &rest _)
      (declare (ignore _))
-     (encode-message event (current-socket-io))
-     (maybe-slow-down connection))
-    (((:emacs-return :emacs-return-string) thread-id &rest args)
+     (encode-message event (current-socket-io)))
+    (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
      (send-event (find-thread thread-id) (cons (car event) args)))
     ((:emacs-channel-send channel-id msg)
      (let ((ch (find-channel channel-id)))
@@ -1000,38 +1000,7 @@
     ((:reader-error packet condition)
      (encode-message `(:reader-error ,packet 
                                      ,(safe-condition-message condition))
-                     (current-socket-io)))
-    ((:emacs-pong _)
-     (declare (ignore _))
-     (assert (singlethreaded-connection-p connection))
-     (send-event (current-thread) event))))
-
-
-;;;; Flow control
-
-;; After sending N (usually 100) messages we slow down and ping Emacs
-;; to make sure that everything we have sent so far was received.
-
-(defconstant send-counter-limit 100)
-
-(defun maybe-slow-down (connection)
-  (let ((counter (incf (connection.send-counter connection))))
-    (when (< send-counter-limit counter)
-      (setf (connection.send-counter connection) 0)
-      (setf (connection.slowdown connection) 0.1)
-      (ping-pong connection)
-      (setf (connection.slowdown connection) nil))))
-
-(defun ping-pong (connection)
-  (let* ((tag (make-tag))
-         (pattern `(:emacs-pong ,tag)))
-    (encode-message `(:ping ,tag) (connection.socket-io connection))
-    (etypecase connection
-      (multithreaded-connection
-       (receive-if (lambda (e) (event-match-p e pattern)) nil))
-      (singlethreaded-connection
-       (let ((*emacs-connection* connection))
-         (wait-for-event pattern))))))
+                     (current-socket-io)))))
 
 
 (defvar *event-queue* '())
@@ -1050,12 +1019,32 @@
   (let ((c *emacs-connection*))
     (etypecase c
       (multithreaded-connection
-       (when (connection.slowdown c)
-         (sleep 0.1))
        (send (mconn.control-thread c) event))
       (singlethreaded-connection
-       (dispatch-event c event)))))
+       (dispatch-event c event)))
+    (maybe-slow-down)))
 
+
+;;;;;; Flow control
+
+;; After sending N (usually 100) messages we slow down and ping Emacs
+;; to make sure that everything we have sent so far was received.
+
+(defconstant send-counter-limit 100)
+
+(defun maybe-slow-down ()
+  (let ((counter (incf *send-counter*)))
+    (when (< send-counter-limit counter)
+      (setf *send-counter* 0)
+      (ping-pong))))
+
+(defun ping-pong ()
+  (let* ((tag (make-tag))
+         (pattern `(:emacs-pong ,tag)))
+    (send-to-emacs `(:ping ,(current-thread-id) ,tag))
+    (wait-for-event pattern)))
+
+
 (defun wait-for-event (pattern &optional timeout)
   "Scan the event queue for PATTERN and return the event.
 If TIMEOUT is 'nil wait until a matching event is enqued.
@@ -1112,6 +1101,8 @@
                         (event-match-p (cdr event) (cdr pattern)))))))
         (t (error "Invalid pattern: ~S" pattern))))
 
+
+
 (defun spawn-threads-for-connection (connection)
   (setf (mconn.control-thread connection)
         (spawn (lambda () (control-thread connection))
@@ -1547,21 +1538,6 @@
                :prompt ,(package-string-for-prompt *package*))
       :version ,*swank-wire-protocol-version*)))
 
-(defslimefun io-speed-test (&optional (n 1000) (m 1))
-  (let* ((s *standard-output*)
-         (*trace-output* (make-broadcast-stream s *log-output*)))
-    (time (progn
-            (dotimes (i n)
-              (format s "~D abcdefghijklm~%" i)
-              (when (zerop (mod n m))
-                (finish-output s)))
-            (finish-output s)
-            (when *emacs-connection*
-              (eval-in-emacs '(message "done.")))))
-    (terpri *trace-output*)
-    (finish-output *trace-output*)
-    nil))
-
 (defun debug-on-swank-error ()
   (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
   *debug-on-swank-protocol-error*)
@@ -2107,8 +2083,7 @@
 
 Use this function for informative messages only.  The message may even
 be dropped if we are too busy with other things."
-  (when (and *emacs-connection*
-             (not (connection.slowdown *emacs-connection*)))
+  (when *emacs-connection*
     (send-to-emacs `(:background-message 
                      ,(apply #'format nil format-string args)))))
 
@@ -3563,8 +3538,6 @@
   (let ((pkg *buffer-package*))
     (flet ((perform-it ()
              (let ((cache (connection.indentation-cache connection))
-                   ;; Rebind for spawned thread.
-                   (*emacs-connection* connection)
                    (*buffer-package* pkg))
                (multiple-value-bind (delta cache)
                    (update-indentation/delta-for-emacs cache force)
@@ -3573,9 +3546,12 @@
                  (unless (null delta)
                    (setf (connection.indentation-cache connection) cache)
                    (send-to-emacs (list :indentation-update delta)))))))
-      (if (use-threads-p)
-          (spawn #'perform-it :name "indentation-update-thread")
-          (perform-it)))))
+      (etypecase connection
+        (multithreaded-connection
+         (spawn (lambda () (with-connection (connection) (perform-it)))
+                :name "indentation-update-thread"))
+        (singlethreaded-connection
+         (perform-it))))))
 
 ;; FIXME: too complicated
 (defun update-indentation/delta-for-emacs (cache &optional force)
@@ -3692,6 +3668,38 @@
 
 (add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
 
+
+;;;; Testing 
+
+(defslimefun io-speed-test (&optional (n 1000) (m 1))
+  (let* ((s *standard-output*)
+         (*trace-output* (make-broadcast-stream s *log-output*)))
+    (time (progn
+            (dotimes (i n)
+              (format s "~D abcdefghijklm~%" i)
+              (when (zerop (mod n m))
+                (finish-output s)))
+            (finish-output s)
+            (when *emacs-connection*
+              (eval-in-emacs '(message "done.")))))
+    (terpri *trace-output*)
+    (finish-output *trace-output*)
+    nil))
+
+(defslimefun flow-control-test (n delay)
+  (let ((stream (make-output-stream 
+                 (let ((conn *emacs-connection*))
+                   (lambda (string)
+                     (declare (ignore string))
+                     (with-connection (conn)
+                       (progn ;without-slime-interrupts
+                         (send-to-emacs `(:test-delay ,delay)))))))))
+    (dotimes (i n)
+      (print i stream)
+      (force-output stream)
+      (background-message "flow-control-test: ~d" i))))
+
+
 (defun before-init (version load-path)
   (pushnew :swank *features*)
   (setq *swank-wire-protocol-version* version)




From heller at common-lisp.net  Wed Dec  7 18:27:17 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 10:27:17 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYMD7-0003Gg-RH@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (send-to-emacs): Add a without-slime-interrupts to
protect send/receive from arbitrary interrupts.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:02:31	1.2276
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:27:17	1.2277
@@ -1,5 +1,10 @@
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (send-to-emacs): Add a without-slime-interrupts to
+	protect send/receive from arbitrary interrupts.
+
+2011-12-07  Helmut Eller  <heller at common-lisp.net>
+
 	Move flow control from dispatch-event to send-to-emacs.
 
 	* swank.lisp (*send-counter*): New thread local variable.
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/07 18:02:31	1.773
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/07 18:27:17	1.774
@@ -1016,14 +1016,15 @@
 (defun send-to-emacs (event)
   "Send EVENT to Emacs."
   ;;(log-event "send-to-emacs: ~a" event)
-  (let ((c *emacs-connection*))
-    (etypecase c
-      (multithreaded-connection
-       (send (mconn.control-thread c) event))
-      (singlethreaded-connection
-       (dispatch-event c event)))
-    (maybe-slow-down)))
-
+  (without-slime-interrupts
+    (let ((c *emacs-connection*))
+      (etypecase c
+        (multithreaded-connection
+         (send (mconn.control-thread c) event))
+        (singlethreaded-connection
+         (dispatch-event c event)))
+      (maybe-slow-down))))
+  
 
 ;;;;;; Flow control
 
@@ -2084,7 +2085,7 @@
 Use this function for informative messages only.  The message may even
 be dropped if we are too busy with other things."
   (when *emacs-connection*
-    (send-to-emacs `(:background-message 
+    (send-to-emacs `(:background-message
                      ,(apply #'format nil format-string args)))))
 
 ;; This is only used by the test suite.
@@ -3692,8 +3693,7 @@
                    (lambda (string)
                      (declare (ignore string))
                      (with-connection (conn)
-                       (progn ;without-slime-interrupts
-                         (send-to-emacs `(:test-delay ,delay)))))))))
+                       (send-to-emacs `(:test-delay ,delay))))))))
     (dotimes (i n)
       (print i stream)
       (force-output stream)




From heller at common-lisp.net  Wed Dec  7 19:23:45 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 11:23:45 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYN5l-0000N9-2R@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el ([xemacs]): Use (find-coding-system 'utf-8-unix)
instead of checking the XEmacs version to decide when 'un-define
is required.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 18:27:17	1.2277
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 19:23:44	1.2278
@@ -1,5 +1,11 @@
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el ([xemacs]): Use (find-coding-system 'utf-8-unix)
+	instead of checking the XEmacs version to decide when 'un-define
+	is required.
+
+2011-12-07  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (send-to-emacs): Add a without-slime-interrupts to
 	protect send/receive from arbitrary interrupts.
 
--- /project/slime/cvsroot/slime/slime.el	2011/12/07 18:02:31	1.1388
+++ /project/slime/cvsroot/slime/slime.el	2011/12/07 19:23:44	1.1389
@@ -68,9 +68,7 @@
 (require 'font-lock)
 (when (featurep 'xemacs)
   (require 'overlay)
-  (when (or (< emacs-major-version 21)
-            (and (= emacs-major-version 21)
-                 (< emacs-minor-version 5)))
+  (unless (find-coding-system 'utf-8-unix)
     (require 'un-define)))
 (require 'easymenu)
 (eval-when (compile)




From heller at common-lisp.net  Wed Dec  7 21:06:30 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 13:06:30 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYOhC-0002Ze-Av@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Make *event-queue* and *events-enqueued* slots of the connection struct.

* swank.lisp (*event-queue*, *events-enqueued*): Deleted
([struct] singlethreaded-connection): New slots event-queue and
events-enqueued.
(poll-for-event, send-event, wait-for-event/event-loop): Update
accordingly.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 19:23:44	1.2278
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 21:06:30	1.2279
@@ -1,5 +1,16 @@
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
+	Make *event-queue* and *events-enqueued* slots of the connection
+	struct.
+
+	* swank.lisp (*event-queue*, *events-enqueued*): Deleted
+	([struct] singlethreaded-connection): New slots event-queue and
+	events-enqueued.
+	(poll-for-event, send-event, wait-for-event/event-loop): Update
+	accordingly.
+
+2011-12-07  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el ([xemacs]): Use (find-coding-system 'utf-8-unix)
 	instead of checking the XEmacs version to decide when 'un-define
 	is required.
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/07 18:27:17	1.774
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/07 21:06:30	1.775
@@ -228,7 +228,14 @@
                                       (:conc-name sconn.))
   ;; The SIGINT handler we should restore when the connection is
   ;; closed.
-  saved-sigint-handler)
+  saved-sigint-handler
+  ;; A queue of events.  Not all events can be processed in order and
+  ;; we need a place to stored them.
+  (event-queue '() :type list)
+  ;; A counter that is incremented whenever an event is added to the
+  ;; queue.  This is used to detected modifications to the event queue
+  ;; by interrupts.  The counter wraps around.
+  (events-enqueued 0 :type fixnum))
 
 (defstruct (multithreaded-connection (:include connection)
                                      (:conc-name mconn.))
@@ -1008,10 +1015,14 @@
 
 (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)))
-           (setf *events-enqueued* (mod (1+ *events-enqueued*)
-                                        most-positive-fixnum)))))
+  (let ((c *emacs-connection*))
+    (etypecase c
+      (multithreaded-connection 
+       (send thread event))
+      (singlethreaded-connection 
+       (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event)))
+       (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c))
+                                            most-positive-fixnum))))))
 
 (defun send-to-emacs (event)
   "Send EVENT to Emacs."
@@ -1065,13 +1076,13 @@
   (assert (or (not timeout) (eq timeout t)))
   (loop 
    (check-slime-interrupts)
-   (let ((event (poll-for-event pattern)))
+   (let ((event (poll-for-event connection pattern)))
      (when event (return (car event))))
-   (let ((events-enqueued *events-enqueued*)
+   (let ((events-enqueued (sconn.events-enqueued connection))
          (ready (wait-for-input (list (current-socket-io)) timeout)))
      (cond ((and timeout (not ready))
             (return (values nil t)))
-           ((or (/= events-enqueued *events-enqueued*)
+           ((or (/= events-enqueued (sconn.events-enqueued connection))
                 (eq ready :interrupt))
             ;; rescan event queue, interrupts may enqueue new events 
             )
@@ -1080,12 +1091,13 @@
             (dispatch-event connection
                             (decode-message (current-socket-io))))))))
 
-(defun poll-for-event (pattern)
-  (let ((tail (member-if (lambda (e) (event-match-p e pattern))
-                         *event-queue*)))
+(defun poll-for-event (connection pattern)
+  (let* ((c connection)
+         (tail (member-if (lambda (e) (event-match-p e pattern))
+                          (sconn.event-queue c))))
     (when tail 
-      (setq *event-queue* (nconc (ldiff *event-queue* tail)
-                                 (cdr tail)))
+      (setf (sconn.event-queue c) 
+            (nconc (ldiff (sconn.event-queue c) tail) (cdr tail)))
       tail)))
 
 ;;; FIXME: Make this use SWANK-MATCH.




From heller at common-lisp.net  Wed Dec  7 22:04:37 2011
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 07 Dec 2011 14:04:37 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYPbR-0008CE-B1@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (*slime-interrupts-enabled*): Describe the idea
behind the interrupt handlig code a bit.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 21:06:30	1.2279
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/07 22:04:37	1.2280
@@ -1,5 +1,10 @@
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (*slime-interrupts-enabled*): Describe the idea
+	behind the interrupt handlig code a bit.
+
+2011-12-07  Helmut Eller  <heller at common-lisp.net>
+
 	Make *event-queue* and *events-enqueued* slots of the connection
 	struct.
 
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/07 21:06:30	1.775
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/07 22:04:37	1.776
@@ -458,7 +458,28 @@
 
 ;;;; Interrupt handling 
 
-;; FIXME: should document how this is supposed to work.
+;; Usually we'd like to enter the debugger when an interrupt happens.
+;; But for some operations, in particular send&receive, it's crucial
+;; that those are not interrupted when the mailbox is in an
+;; inconsistent/locked state. Obviously, if send&receive don't work we
+;; can't communicate and the debugger will not work.  To solve that
+;; problem, we try to handle interrupts only at certain safe-points.
+;;
+;; Whenever an interrupt happens we call the function
+;; INVOKE-OR-QUEUE-INTERRUPT.  Usually this simply invokes the
+;; debugger, but if interrupts are disabled the interrupt is put in a
+;; queue for later processing.  At safe-points, we call
+;; CHECK-SLIME-INTERRUPTS which looks at the queue and invokes the
+;; debugger if needed.
+;;
+;; The queue for interrupts is stored in a thread local variable.
+;; WITH-CONNECTION sets it up.  WITH-SLIME-INTERRUPTS allows
+;; interrupts, i.e. the debugger is entered immediately.  When we call
+;; "user code" or non-problematic code we allow interrupts.  When
+;; inside WITHOUT-SLIME-INTERRUPTS, interrupts are queued.  When we
+;; switch from "user code" to more delicate operations we need to
+;; disable interrupts.  In particular, interrupts should be disabled
+;; for SEND and RECEIVE-IF.
 
 ;; If true execute interrupts, otherwise queue them.
 ;; Note: `with-connection' binds *pending-slime-interrupts*.
@@ -508,7 +529,7 @@
      . ,body))
 
 ;; Thread local variable used for flow-control.
-;; It's bound by with-connection.
+;; It's bound by `with-connection'.
 (defvar *send-counter*)
 
 (defmacro with-connection ((connection) &body body)




From nsiivola at common-lisp.net  Thu Dec  8 13:40:55 2011
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Thu, 08 Dec 2011 05:40:55 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RYeDX-0004C1-F3@common-lisp.net>

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

Modified Files:
	ChangeLog slime-cl-indent.el 
Log Message:
slime-indentation: wrap initialization into a function


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/06 18:57:18	1.523
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/08 13:40:55	1.524
@@ -1,3 +1,8 @@
+2011-12-08  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* slime-cl-indent.el (common-lisp-init-standard-indentation): New function,
+	wraps initialization of the common-lisp-indent-function properties.
+
 2011-12-06  Didier Verna  <didier at xemacs.org>
 
 	* slime-asdf.el (slime-asdf): New custom group.
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/03 15:38:19	1.59
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/08 13:40:55	1.60
@@ -1506,103 +1506,105 @@
 
 
 ;;;; Indentation specs for standard symbols, and a few semistandard ones.
-(let ((l '((block 1)
-           (case        (4 &rest (&whole 2 &rest 1)))
-           (ccase       (as case))
-           (ecase       (as case))
-           (typecase    (as case))
-           (etypecase   (as case))
-           (ctypecase   (as case))
-           (catch 1)
-           (cond        (&rest (&whole 2 &rest nil)))
-           ;; for DEFSTRUCT
-           (:constructor (4 &lambda))
-           (defvar      (4 2 2))
-           (defclass    (6 (&whole 4 &rest 1) (&whole 2 &rest 1) (&whole 2 &rest 1)))
-           (defconstant (as defvar))
-           (defcustom   (4 2 2 2))
-           (defparameter     (as defvar))
-           (defconst         (as defcustom))
-           (define-condition (as defclass))
-           (define-modify-macro (4 &lambda &body))
-           (defsetf      lisp-indent-defsetf)
-           (defun       (4 &lambda &body))
-           (defgeneric  (4 &lambda &body))
-           (define-setf-method   (as defun))
-           (define-setf-expander (as defun))
-           (defmacro     (as defun))
-           (defsubst     (as defun))
-           (deftype      (as defun))
-           (defmethod   lisp-indent-defmethod)
-           (defpackage  (4 2))
-           (defstruct   ((&whole 4 &rest (&whole 2 &rest 1))
-                         &rest (&whole 2 &rest 1)))
-           (destructuring-bind (&lambda 4 &body))
-           (do          lisp-indent-do)
-           (do*         (as do))
-           (dolist      ((&whole 4 2 1) &body))
-           (dotimes     (as dolist))
-           (eval-when   1)
-           (flet        ((&whole 4 &rest (&whole 1 &lambda &body)) &body))
-           (labels         (as flet))
-           (macrolet       (as flet))
-           (generic-flet   (as flet))
-           (generic-labels (as flet))
-           (handler-case (4 &rest (&whole 2 &lambda &body)))
-           (restart-case (as handler-case))
-           ;; single-else style (then and else equally indented)
-           (if          (&rest nil))
-           (if*         common-lisp-indent-if*)
-           (lambda      (&lambda &rest lisp-indent-function-lambda-hack))
-           (let         ((&whole 4 &rest (&whole 1 1 2)) &body))
-           (let*         (as let))
-           (compiler-let (as let))
-           (handler-bind (as let))
-           (restart-bind (as let))
-           (locally 1)
-           (loop           lisp-indent-loop)
-           (:method        lisp-indent-defmethod) ; in `defgeneric'
-           (multiple-value-bind ((&whole 6 &rest 1) 4 &body))
-           (multiple-value-call (4 &body))
-           (multiple-value-prog1 1)
-           (multiple-value-setq (4 2))
-           (multiple-value-setf (as multiple-value-setq))
-           (named-lambda (4 &lambda &rest lisp-indent-function-lambda-hack))
-           (pprint-logical-block (4 2))
-           (print-unreadable-object ((&whole 4 1 &rest 1) &body))
-           ;; Combines the worst features of BLOCK, LET and TAGBODY
-           (prog        (&lambda &rest lisp-indent-tagbody))
-           (prog* (as prog))
-           (prog1 1)
-           (prog2 2)
-           (progn 0)
-           (progv       (4 4 &body))
-           (return 0)
-           (return-from (nil &body))
-           (symbol-macrolet (as let))
-           (tagbody     lisp-indent-tagbody)
-           (throw 1)
-           (unless 1)
-           (unwind-protect (5 &body))
-           (when 1)
-           (with-accessors          (as multiple-value-bind))
-           (with-compilation-unit   ((&whole 4 &rest 1) &body))
-           (with-condition-restarts (as multiple-value-bind))
-           (with-output-to-string (4 2))
-           (with-slots              (as multiple-value-bind))
-           (with-standard-io-syntax (2)))))
-  (dolist (el l)
-    (let* ((name (car el))
-           (spec (cdr el))
-           (indentation
-            (if (symbolp spec)
-                (error "Old style indirect indentation spec: %s" el)
-              (when (cdr spec)
-                (error "Malformed indentation specification: %s" el))
-              (car spec))))
-      (unless (symbolp name)
-        (error "Cannot set Common Lisp indentation of a non-symbol: %s" name))
-      (put name 'common-lisp-indent-function indentation))))
+(defun common-lisp-init-standard-indentation ()
+  (let ((l '((block 1)
+             (case        (4 &rest (&whole 2 &rest 1)))
+             (ccase       (as case))
+             (ecase       (as case))
+             (typecase    (as case))
+             (etypecase   (as case))
+             (ctypecase   (as case))
+             (catch 1)
+             (cond        (&rest (&whole 2 &rest nil)))
+             ;; for DEFSTRUCT
+             (:constructor (4 &lambda))
+             (defvar      (4 2 2))
+             (defclass    (6 (&whole 4 &rest 1) (&whole 2 &rest 1) (&whole 2 &rest 1)))
+             (defconstant (as defvar))
+             (defcustom   (4 2 2 2))
+             (defparameter     (as defvar))
+             (defconst         (as defcustom))
+             (define-condition (as defclass))
+             (define-modify-macro (4 &lambda &body))
+             (defsetf      lisp-indent-defsetf)
+             (defun       (4 &lambda &body))
+             (defgeneric  (4 &lambda &body))
+             (define-setf-method   (as defun))
+             (define-setf-expander (as defun))
+             (defmacro     (as defun))
+             (defsubst     (as defun))
+             (deftype      (as defun))
+             (defmethod   lisp-indent-defmethod)
+             (defpackage  (4 2))
+             (defstruct   ((&whole 4 &rest (&whole 2 &rest 1))
+                           &rest (&whole 2 &rest 1)))
+             (destructuring-bind (&lambda 4 &body))
+             (do          lisp-indent-do)
+             (do*         (as do))
+             (dolist      ((&whole 4 2 1) &body))
+             (dotimes     (as dolist))
+             (eval-when   1)
+             (flet        ((&whole 4 &rest (&whole 1 &lambda &body)) &body))
+             (labels         (as flet))
+             (macrolet       (as flet))
+             (generic-flet   (as flet))
+             (generic-labels (as flet))
+             (handler-case (4 &rest (&whole 2 &lambda &body)))
+             (restart-case (as handler-case))
+             ;; single-else style (then and else equally indented)
+             (if          (&rest nil))
+             (if*         common-lisp-indent-if*)
+             (lambda      (&lambda &rest lisp-indent-function-lambda-hack))
+             (let         ((&whole 4 &rest (&whole 1 1 2)) &body))
+             (let*         (as let))
+             (compiler-let (as let))
+             (handler-bind (as let))
+             (restart-bind (as let))
+             (locally 1)
+             (loop           lisp-indent-loop)
+             (:method        lisp-indent-defmethod) ; in `defgeneric'
+             (multiple-value-bind ((&whole 6 &rest 1) 4 &body))
+             (multiple-value-call (4 &body))
+             (multiple-value-prog1 1)
+             (multiple-value-setq (4 2))
+             (multiple-value-setf (as multiple-value-setq))
+             (named-lambda (4 &lambda &rest lisp-indent-function-lambda-hack))
+             (pprint-logical-block (4 2))
+             (print-unreadable-object ((&whole 4 1 &rest 1) &body))
+             ;; Combines the worst features of BLOCK, LET and TAGBODY
+             (prog        (&lambda &rest lisp-indent-tagbody))
+             (prog* (as prog))
+             (prog1 1)
+             (prog2 2)
+             (progn 0)
+             (progv       (4 4 &body))
+             (return 0)
+             (return-from (nil &body))
+             (symbol-macrolet (as let))
+             (tagbody     lisp-indent-tagbody)
+             (throw 1)
+             (unless 1)
+             (unwind-protect (5 &body))
+             (when 1)
+             (with-accessors          (as multiple-value-bind))
+             (with-compilation-unit   ((&whole 4 &rest 1) &body))
+             (with-condition-restarts (as multiple-value-bind))
+             (with-output-to-string (4 2))
+             (with-slots              (as multiple-value-bind))
+             (with-standard-io-syntax (2)))))
+    (dolist (el l)
+      (let* ((name (car el))
+             (spec (cdr el))
+             (indentation
+              (if (symbolp spec)
+                  (error "Old style indirect indentation spec: %s" el)
+                (when (cdr spec)
+                  (error "Malformed indentation specification: %s" el))
+                (car spec))))
+        (unless (symbolp name)
+          (error "Cannot set Common Lisp indentation of a non-symbol: %s" name))
+        (put name 'common-lisp-indent-function indentation)))))
+(common-lisp-init-standard-indentation)
 
 (defun common-lisp-indent-test (name bindings test)
   (with-temp-buffer




From nsiivola at common-lisp.net  Thu Dec  8 13:54:19 2011
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Thu, 08 Dec 2011 05:54:19 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RYeQV-0004eB-He@common-lisp.net>

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

Modified Files:
	ChangeLog slime-cl-indent-test.txt slime-cl-indent.el 
Log Message:
slime-indentation: fix local function lambda-list indentation


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/08 13:40:55	1.524
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/08 13:54:19	1.525
@@ -1,5 +1,16 @@
 2011-12-08  Nikodemus Siivola  <nikodemus at random-state.net>
 
+	* slime-cl-indent.el (lisp-indent-maximum-backtracking)
+	("basic"): Increase default backtracking level to 6, so that at
+	least mildly nested macrolet-lambda lists can be identified as
+	such.
+
+	* slime-cl-indent.el (common-lisp-init-standard-indentation): Fix
+	FLET indentation spec, which caused local function lambda-lists to
+	be indented as part of the body.
+
+	* slime-cl-indent-test.txt (tests 72-76): New tests.
+
 	* slime-cl-indent.el (common-lisp-init-standard-indentation): New function,
 	wraps initialization of the common-lisp-indent-function properties.
 
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt	2011/12/03 15:38:19	1.16
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt	2011/12/08 13:54:19	1.17
@@ -763,3 +763,67 @@
   (loop :repeat 100 ;; This too
                     ;; is a beginning
         #:do (foo)))
+
+;;; Test: 72
+;;
+;; lisp-lambda-list-keyword-parameter-alignment: nil
+;; lisp-lambda-list-keyword-alignment: nil
+
+(flet ((foo (foo &optional opt1
+                   opt2
+             &rest rest)
+         (list foo opt1 opt2
+               rest)))
+  ...)
+
+;;; Test: 73
+;;
+;; lisp-lambda-list-keyword-parameter-alignment: t
+;; lisp-lambda-list-keyword-alignment: nil
+
+(flet ((foo (foo &optional opt1
+                           opt2
+             &rest rest)
+         (list foo opt1 opt2
+               rest)))
+  ...)
+
+;;; Test: 74
+;;
+;; lisp-lambda-list-keyword-parameter-alignment: nil
+;; lisp-lambda-list-keyword-alignment: t
+
+(flet ((foo (foo &optional opt1
+                   opt2
+                 &rest rest)
+         (list foo opt1 opt2
+               rest)))
+  ...)
+
+;;; Test: 75
+;;
+;; lisp-lambda-list-keyword-parameter-alignment: t
+;; lisp-lambda-list-keyword-alignment: t
+
+(flet ((foo (foo &optional opt1
+                           opt2
+                 &rest rest)
+         (list foo opt1 opt2
+               rest)))
+  ...)
+
+;;; Test: 76
+;;
+;; lisp-lambda-list-keyword-parameter-alignment: t
+;; lisp-lambda-list-keyword-alignment: t
+
+(macrolet ((foo
+               (foo (&optional xopt1
+                               xopt2
+                     &rest xrest)
+                &optional opt1
+                          opt2
+                &rest rest)
+             (list foo opt1 opt2
+                   rest)))
+  ...)
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/08 13:40:55	1.60
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/08 13:54:19	1.61
@@ -37,10 +37,10 @@
   "Indentation in Lisp."
   :group 'lisp)
 
-(defcustom lisp-indent-maximum-backtracking 3
+(defcustom lisp-indent-maximum-backtracking 6
   "Maximum depth to backtrack out from a sublist for structured indentation.
 If this variable is 0, no backtracking will occur and forms such as `flet'
-may not be correctly indented."
+may not be correctly indented if this value is less than 4."
   :type 'integer
   :group 'lisp-indent)
 
@@ -419,7 +419,7 @@
    customizations. It also adjusts comment indentation from default.
    All other predefined modes inherit from basic."
   (:variables
-   (lisp-indent-maximum-backtracking 3)
+   (lisp-indent-maximum-backtracking 6)
    (lisp-tag-indentation 1)
    (lisp-tag-body-indentation 3)
    (lisp-backquote-indentation t)
@@ -1544,7 +1544,7 @@
              (dolist      ((&whole 4 2 1) &body))
              (dotimes     (as dolist))
              (eval-when   1)
-             (flet        ((&whole 4 &rest (&whole 1 &lambda &body)) &body))
+             (flet        ((&whole 4 &rest (&whole 1 4 &lambda &body)) &body))
              (labels         (as flet))
              (macrolet       (as flet))
              (generic-flet   (as flet))




From heller at common-lisp.net  Fri Dec  9 11:02:09 2011
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 09 Dec 2011 03:02:09 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RYyDR-0003aw-6q@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Create an extra thread for the indentation cache.

* swank.lisp (indentation-cache-loop): New.
([struct] multithreaded-connection): New slot
indentation-cache-thread.
(control-thread, cleanup-connection-threads): Create/kill it.
(send-to-indentation-cache): New function.
(update-indentation-information, sync-indentation-to-emacs): Use
it.
(perform-indentation-update, update-indentation/delta-for-emacs):
Add package as argument; that used to be *buffer-package.  Can
again be simpler as the indentation-cache-thread doesn't share the
cache with others.
(handle-indentation-cache-request, symbol-packages): New helpers.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/07 22:04:37	1.2280
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/09 11:02:03	1.2281
@@ -1,3 +1,20 @@
+2011-12-09  Helmut Eller  <heller at common-lisp.net>
+
+	Create an extra thread for the indentation cache.
+
+	* swank.lisp (indentation-cache-loop): New.
+	([struct] multithreaded-connection): New slot
+	indentation-cache-thread.
+	(control-thread, cleanup-connection-threads): Create/kill it.
+	(send-to-indentation-cache): New function.
+	(update-indentation-information, sync-indentation-to-emacs): Use
+	it.
+	(perform-indentation-update, update-indentation/delta-for-emacs):
+	Add package as argument; that used to be *buffer-package.  Can
+	again be simpler as the indentation-cache-thread doesn't share the
+	cache with others.
+	(handle-indentation-cache-request, symbol-packages): New helpers.
+
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (*slime-interrupts-enabled*): Describe the idea
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/07 22:04:37	1.776
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/09 11:02:05	1.777
@@ -250,7 +250,9 @@
   reader-thread
   control-thread
   repl-thread
-  auto-flush-thread)
+  auto-flush-thread
+  indentation-cache-thread
+  )
 
 (defvar *connections* '()
   "List of all active connections, with the most recent at the front.")
@@ -1148,6 +1150,9 @@
     (setf (@ control-thread) (current-thread))
     (setf (@ reader-thread) (spawn (lambda () (read-loop connection)) 
                                    :name "reader-thread"))
+    (setf (@ indentation-cache-thread)
+          (spawn (lambda () (indentation-cache-loop connection))
+                 :name "swank-indentation-cache-thread"))
     (dispatch-loop connection)))
 
 (defun cleanup-connection-threads (connection)
@@ -1155,9 +1160,10 @@
          (threads (list (mconn.repl-thread c)
                         (mconn.reader-thread c)
                         (mconn.control-thread c)
-                        (mconn.auto-flush-thread c))))
+                        (mconn.auto-flush-thread c)
+                        (mconn.indentation-cache-thread c))))
     (dolist (thread threads)
-      (when (and thread 
+      (when (and thread
                  (thread-alive-p thread)
                  (not (equal (current-thread) thread)))
         (kill-thread thread)))))
@@ -3549,15 +3555,39 @@
 after each command.")
 
 (defslimefun update-indentation-information ()
-  (perform-indentation-update *emacs-connection* t)
+  (send-to-indentation-cache `(:update-indentation-information))
   nil)
 
 ;; This function is for *PRE-REPLY-HOOK*.
 (defun sync-indentation-to-emacs ()
   "Send any indentation updates to Emacs via CONNECTION."
   (when *configure-emacs-indentation*
-    (let ((fullp (need-full-indentation-update-p *emacs-connection*)))
-      (perform-indentation-update *emacs-connection* fullp))))
+    (send-to-indentation-cache `(:sync-indentation ,*buffer-package*))))
+
+;; Send REQUEST to the cache.  If we are single threaded perform the
+;; request right away, otherwise delegate the request to the
+;; indentation-cache-thread.
+(defun send-to-indentation-cache (request)
+  (let ((c *emacs-connection*))
+    (etypecase c
+      (singlethreaded-connection 
+       (handle-indentation-cache-request c request))
+      (multithreaded-connection
+       (without-slime-interrupts
+         (send (mconn.indentation-cache-thread c) request))))))
+
+(defun indentation-cache-loop (connection)
+  (with-connection (connection)
+    (loop
+     (handle-indentation-cache-request connection (receive)))))
+
+(defun handle-indentation-cache-request (connection request)
+  (destructure-case request
+    ((:sync-indentation package)
+     (let ((fullp (need-full-indentation-update-p connection)))
+       (perform-indentation-update connection fullp package)))
+    ((:update-indentation-information)
+     (perform-indentation-update connection t nil))))
 
 (defun need-full-indentation-update-p (connection)
   "Return true if the whole indentation cache should be updated.
@@ -3566,73 +3596,52 @@
   (set-difference (list-all-packages)
                   (connection.indentation-cache-packages connection)))
 
-(defun perform-indentation-update (connection force)
+(defun perform-indentation-update (connection force package)
   "Update the indentation cache in CONNECTION and update Emacs.
 If FORCE is true then start again without considering the old cache."
-  (let ((pkg *buffer-package*))
-    (flet ((perform-it ()
-             (let ((cache (connection.indentation-cache connection))
-                   (*buffer-package* pkg))
-               (multiple-value-bind (delta cache)
-                   (update-indentation/delta-for-emacs cache force)
-                 (setf (connection.indentation-cache-packages connection)
-                       (list-all-packages))
-                 (unless (null delta)
-                   (setf (connection.indentation-cache connection) cache)
-                   (send-to-emacs (list :indentation-update delta)))))))
-      (etypecase connection
-        (multithreaded-connection
-         (spawn (lambda () (with-connection (connection) (perform-it)))
-                :name "indentation-update-thread"))
-        (singlethreaded-connection
-         (perform-it))))))
+  (let ((cache (connection.indentation-cache connection)))
+    (when force (clrhash cache))
+    (let ((delta (update-indentation/delta-for-emacs cache force package)))
+      (setf (connection.indentation-cache-packages connection)
+            (list-all-packages))
+      (unless (null delta)
+        (setf (connection.indentation-cache connection) cache)
+        (send-to-emacs (list :indentation-update delta))))))
 
-;; FIXME: too complicated
-(defun update-indentation/delta-for-emacs (cache &optional force)
+(defun update-indentation/delta-for-emacs (cache force package)
   "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list.
 If FORCE is true then check all symbols, otherwise only check symbols
-belonging to the buffer package."
-  (let ((alist '())
-        (must-copy (use-threads-p)))
-    ;; The hash-table copying hair here is to ensure no two threads ever
-    ;; operate on the same hash-table -- except in the worst case with
-    ;; parallel readers. (Hash-tables aren't guaranteed to be thread-safe at
-    ;; all, but we make the hopefully-portable assumption that parallel
-    ;; readers are OK.)
+belonging to PACKAGE."
+  (let ((alist '()))
     (flet ((consider (symbol)
              (let ((indent (symbol-indentation symbol)))
                (when indent
                  (unless (equal (gethash symbol cache) indent)
-                   (when must-copy
-                     (setf cache (let ((new (make-hash-table :test #'eq)))
-                                   (maphash (lambda (k v)
-                                              (setf (gethash k new) v))
-                                            cache)
-                                   new)
-                           must-copy nil))
                    (setf (gethash symbol cache) indent)
-                   (let ((pkgs (loop for p in (list-all-packages)
-                                     when (eq symbol (find-symbol (string symbol) p))
-                                     collect (package-name p)))
+                   (let ((pkgs (mapcar #'package-name 
+                                       (symbol-packages symbol)))
                          (name (string-downcase symbol)))
                      (push (list name indent pkgs) alist)))))))
       (cond (force
-             (setf cache (make-hash-table :test 'eq)
-                   must-copy nil)
              (do-all-symbols (symbol)
                (consider symbol)))
             (t
-             (do-symbols (symbol *buffer-package*)
-               ;; We're really just interested in the symbols of *BUFFER-PACKAGE*,
-               ;; and *not* all symbols that are _present_ (cf. SYMBOL-STATUS.)
-               (when (eq (symbol-package symbol) *buffer-package*)
+             (do-symbols (symbol package)
+               (when (eq (symbol-package symbol) package)
                  (consider symbol)))))
-      (values alist cache))))
+      alist)))
 
 (defun package-names (package)
   "Return the name and all nicknames of PACKAGE in a fresh list."
   (cons (package-name package) (copy-list (package-nicknames package))))
 
+(defun symbol-packages (symbol)
+  "Return the  packages where SYMBOL can be found."
+  (let ((string (string symbol)))
+    (loop for p in (list-all-packages)
+          when (eq symbol (find-symbol string p))
+          collect p)))
+
 (defun cl-symbol-p (symbol)
   "Is SYMBOL a symbol in the COMMON-LISP package?"
   (eq (symbol-package symbol) cl-package))




From heller at common-lisp.net  Sat Dec 10 12:33:28 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 10 Dec 2011 04:33:28 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RZM7M-0007h4-Rm@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp (delete-stale-contrib-fasl-files): New.
(compile-contribs): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/09 11:02:03	1.2281
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:33:28	1.2282
@@ -1,3 +1,8 @@
+2011-12-10  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-loader.lisp (delete-stale-contrib-fasl-files): New.
+	(compile-contribs): Use it.
+
 2011-12-09  Helmut Eller  <heller at common-lisp.net>
 
 	Create an extra thread for the indentation cache.
--- /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/04 15:05:41	1.113
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2011/12/10 12:33:28	1.114
@@ -10,13 +10,12 @@
 
 ;; If you want customize the source- or fasl-directory you can set
 ;; swank-loader:*source-directory* resp. swank-loader:*fasl-directory*
-;; before loading this files. (you also need to create the
-;; swank-loader package.)
+;; before loading this files. 
 ;; E.g.:
 ;;
-;;   (make-package :swank-loader)
-;;   (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
 ;;   (load ".../swank-loader.lisp")
+;;   (setq swank-loader::*fasl-directory* "/tmp/fasl/")
+;;   (swank-loader:init)
 
 (cl:defpackage :swank-loader
   (:use :cl)
@@ -242,11 +241,24 @@
            (list (contrib-dir fasl-dir)
                  (contrib-dir src-dir))))
 
+(defun delete-stale-contrib-fasl-files (swank-files contrib-files fasl-dir)
+  (let ((newest (reduce #'max (mapcar #'file-write-date swank-files))))
+    (dolist (src contrib-files)
+      (let ((fasl (binary-pathname src fasl-dir)))
+        (when (and (probe-file fasl)
+                   (<= (file-write-date fasl) newest))
+          (delete-file fasl))))))
+
 (defun compile-contribs (&key (src-dir (contrib-dir *source-directory*))
-                         (fasl-dir (contrib-dir *fasl-directory*))
-                         load)
-  (compile-files (src-files *contribs* src-dir) fasl-dir load))
-  
+                           (fasl-dir (contrib-dir *fasl-directory*))
+                           (swank-src-dir *source-directory*)
+                           load)
+  (let* ((swank-src-files (src-files *swank-files* swank-src-dir))
+         (contrib-src-files (src-files *contribs* src-dir)))
+    (delete-stale-contrib-fasl-files swank-src-files contrib-src-files 
+                                     fasl-dir)
+    (compile-files contrib-src-files fasl-dir load)))
+
 (defun loadup ()
   (load-swank)
   (compile-contribs :load t))




From heller at common-lisp.net  Sat Dec 10 12:33:40 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 10 Dec 2011 04:33:40 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RZM7Y-0007he-EW@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Make *active-threads* a slot of the connection struct.

* swank.lisp (*active-threads*): Deleted
([struct] multithreaded-connection): New slot active-threads.
(find-worker-thread, interrupt-worker-thread)
(thread-for-evaluation): Update accordingly.
(add-active-thread, remove-active-thread): New helpers.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:33:28	1.2282
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:33:40	1.2283
@@ -1,5 +1,15 @@
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
 
+	Make *active-threads* a slot of the connection struct.
+
+	* swank.lisp (*active-threads*): Deleted
+	([struct] multithreaded-connection): New slot active-threads.
+	(find-worker-thread, interrupt-worker-thread)
+	(thread-for-evaluation): Update accordingly.
+	(add-active-thread, remove-active-thread): New helpers.
+
+2011-12-10  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-loader.lisp (delete-stale-contrib-fasl-files): New.
 	(compile-contribs): Use it.
 
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/09 11:02:05	1.777
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/10 12:33:40	1.778
@@ -252,6 +252,11 @@
   repl-thread
   auto-flush-thread
   indentation-cache-thread
+  ;; List of threads that are currently processing requests.  We use
+  ;; this to find the newest/current thread for an interrupt.  In the
+  ;; future we may store here (thread . request-tag) pairs so that we
+  ;; can interrupt specific requests.
+  (active-threads '() :type list)
   )
 
 (defvar *connections* '()
@@ -921,8 +926,6 @@
 
 ;;;;;; Thread based communication
 
-(defvar *active-threads* '())
-
 (defun read-loop (connection)
   (let ((input-stream (connection.socket-io connection))
         (control-thread (mconn.control-thread connection)))
@@ -948,40 +951,44 @@
      :seconds 0.1)
     (sleep *auto-flush-interval*)))
 
-;; FIXME: drop dependicy on find-repl-thread
-(defun find-worker-thread (id)
+;; FIXME: drop dependency on find-repl-thread
+(defun find-worker-thread (connection id)
   (etypecase id
     ((member t)
-     (car *active-threads*))
+     (etypecase connection
+       (multithreaded-connection (car (mconn.active-threads connection)))
+       (singlethreaded-connection (current-thread))))
     ((member :repl-thread) 
-     (find-repl-thread *emacs-connection*))
+     (find-repl-thread connection))
     (fixnum 
      (find-thread id))))
 
-(defun interrupt-worker-thread (id)
-  (let ((thread (or (find-worker-thread id)
+(defun interrupt-worker-thread (connection id)
+  (let ((thread (or (find-worker-thread connection id)
                     ;; FIXME: to something better here
                     (spawn (lambda ()) :name "ephemeral"))))
     (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
     (assert thread)
-    (cond ((use-threads-p)
-           (interrupt-thread thread
-                             (lambda ()
-                               ;; safely interrupt THREAD
-                               (invoke-or-queue-interrupt #'simple-break))))
-          (t (simple-break)))))
+    (etypecase connection
+      (multithreaded-connection
+       (interrupt-thread thread
+                         (lambda ()
+                           ;; safely interrupt THREAD
+                           (invoke-or-queue-interrupt #'simple-break))))
+      (singlethreaded-connection
+       (simple-break)))))
 
-(defun thread-for-evaluation (id)
+(defun thread-for-evaluation (connection id)
   "Find or create a thread to evaluate the next request."
-  (let ((c *emacs-connection*))
-    (etypecase id
-      ((member t)
-       (cond ((use-threads-p) (spawn-worker-thread c))
-             (t (current-thread))))
-      ((member :repl-thread)
-       (find-repl-thread c))
-      (fixnum
-       (find-thread id)))))
+  (etypecase id
+    ((member t)
+     (etypecase connection
+       (multithreaded-connection (spawn-worker-thread connection))
+       (singlethreaded-connection (current-thread))))
+    ((member :repl-thread)
+     (find-repl-thread connection))
+    (fixnum
+     (find-thread id))))
 
 (defun spawn-worker-thread (connection)
   (spawn (lambda () 
@@ -991,15 +998,27 @@
                       (cdr (wait-for-event `(:emacs-rex . _)))))))
          :name "worker"))
 
+(defun add-active-thread (connection thread)
+  (etypecase connection
+    (multithreaded-connection 
+     (push thread (mconn.active-threads connection)))
+    (singlethreaded-connection)))
+
+(defun remove-active-thread (connection thread)
+  (etypecase connection
+    (multithreaded-connection
+     (setf (mconn.active-threads connection)
+           (delete thread (mconn.active-threads connection) :count 1)))
+    (singlethreaded-connection)))
+
 (defun dispatch-event (connection event)
   "Handle an event triggered either by Emacs or within Lisp."
-  (declare (ignore connection))
   (log-event "dispatch-event: ~s~%" event)
   (destructure-case event
     ((:emacs-rex form package thread-id id)
-     (let ((thread (thread-for-evaluation thread-id)))
-       (cond (thread 
-              (push thread *active-threads*)
+     (let ((thread (thread-for-evaluation connection thread-id)))
+       (cond (thread
+              (add-active-thread connection thread)
               (send-event thread `(:emacs-rex ,form ,package ,id)))
              (t
               (encode-message 
@@ -1007,12 +1026,10 @@
                      (format nil "Thread not found: ~s" thread-id))
                (current-socket-io))))))
     ((:return thread &rest args)
-     (let ((tail (member thread *active-threads*)))
-       (setq *active-threads* (nconc (ldiff *active-threads* tail)
-				     (cdr tail))))
+     (remove-active-thread connection thread)
      (encode-message `(:return , at args) (current-socket-io)))
     ((:emacs-interrupt thread-id)
-     (interrupt-worker-thread thread-id))
+     (interrupt-worker-thread connection thread-id))
     (((:write-string 
        :debug :debug-condition :debug-activate :debug-return :channel-send
        :presentation-start :presentation-end
@@ -1033,9 +1050,6 @@
                      (current-socket-io)))))
 
 
-(defvar *event-queue* '())
-(defvar *events-enqueued* 0)
-
 (defun send-event (thread event)
   (log-event "send-event: ~s ~s~%" thread event)
   (let ((c *emacs-connection*))
@@ -1202,8 +1216,6 @@
   (handle-requests connection t))
 
 (defun dispatch-interrupt-event (connection)
-  ;; This boils down to INTERRUPT-WORKER-THREAD which uses
-  ;; USE-THREADS-P which needs *EMACS-CONNECTION*.
   (with-connection (connection)
     (dispatch-event connection `(:emacs-interrupt ,(current-thread-id)))))
 




From heller at common-lisp.net  Sat Dec 10 12:33:52 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 10 Dec 2011 04:33:52 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RZM7k-0007iF-NQ@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp: Move global io-redirection contrib/slime-repl.lisp.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:33:40	1.2283
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:33:52	1.2284
@@ -1,5 +1,9 @@
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp: Move global io-redirection contrib/slime-repl.lisp.
+
+2011-12-10  Helmut Eller  <heller at common-lisp.net>
+
 	Make *active-threads* a slot of the connection struct.
 
 	* swank.lisp (*active-threads*): Deleted
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/10 12:33:40	1.778
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/10 12:33:52	1.779
@@ -205,7 +205,7 @@
   (user-output      nil :type (or stream null))
   (user-io          nil :type (or stream null))
   ;; Bindings used for this connection (usually streams)
-  env
+  (env '() :type list)
   ;; A stream that we use for *trace-output*; if nil, we user user-output.
   (trace-output     nil :type (or stream null))
   ;; A stream where we send REPL results.
@@ -1294,157 +1294,6 @@
       (end-of-file () (error 'end-of-repl-input :stream stream)))))
 
 
-;; FIXME: would be nice if we could move this I/O stuff to swank-repl.lisp.
-
-;;;; IO to Emacs
-;;;
-;;; This code handles redirection of the standard I/O streams
-;;; (`*standard-output*', etc) into Emacs. The `connection' structure
-;;; contains the appropriate streams, so all we have to do is make the
-;;; right bindings.
-
-;;;;; Global I/O redirection framework
-;;;
-;;; Optionally, the top-level global bindings of the standard streams
-;;; can be assigned to be redirected to Emacs. When Emacs connects we
-;;; redirect the streams into the connection, and they keep going into
-;;; that connection even if more are established. If the connection
-;;; handling the streams closes then another is chosen, or if there
-;;; are no connections then we revert to the original (real) streams.
-;;;
-;;; It is slightly tricky to assign the global values of standard
-;;; streams because they are often shadowed by dynamic bindings. We
-;;; solve this problem by introducing an extra indirection via synonym
-;;; streams, so that *STANDARD-INPUT* is a synonym stream to
-;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
-;;; variables, so they can always be assigned to affect a global
-;;; change.
-
-(defvar *globally-redirect-io* nil
-  "When non-nil globally redirect all standard streams to Emacs.")
-
-;;;;; Global redirection setup
-
-(defvar *saved-global-streams* '()
-  "A plist to save and restore redirected stream objects.
-E.g. the value for '*standard-output* holds the stream object
-for *standard-output* before we install our redirection.")
-
-(defun setup-stream-indirection (stream-var &optional stream)
-  "Setup redirection scaffolding for a global stream variable.
-Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
-
-1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
-
-2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
-*STANDARD-INPUT*.
-
-3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
-*CURRENT-STANDARD-INPUT*.
-
-This has the effect of making *CURRENT-STANDARD-INPUT* contain the
-effective global value for *STANDARD-INPUT*. This way we can assign
-the effective global value even when *STANDARD-INPUT* is shadowed by a
-dynamic binding."
-  (let ((current-stream-var (prefixed-var '#:current stream-var))
-        (stream (or stream (symbol-value stream-var))))
-    ;; Save the real stream value for the future.
-    (setf (getf *saved-global-streams* stream-var) stream)
-    ;; Define a new variable for the effective stream.
-    ;; This can be reassigned.
-    (proclaim `(special ,current-stream-var))
-    (set current-stream-var stream)
-    ;; Assign the real binding as a synonym for the current one.
-    (let ((stream (make-synonym-stream current-stream-var)))
-      (set stream-var stream)
-      (set-default-initial-binding stream-var `(quote ,stream)))))
-
-(defun prefixed-var (prefix variable-symbol)
-  "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
-  (let ((basename (subseq (symbol-name variable-symbol) 1)))
-    (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
-
-(defvar *standard-output-streams*
-  '(*standard-output* *error-output* *trace-output*)
-  "The symbols naming standard output streams.")
-
-(defvar *standard-input-streams*
-  '(*standard-input*)
-  "The symbols naming standard input streams.")
-
-(defvar *standard-io-streams*
-  '(*debug-io* *query-io* *terminal-io*)
-  "The symbols naming standard io streams.")
-
-(defun init-global-stream-redirection ()
-  (when *globally-redirect-io*
-    (cond (*saved-global-streams*
-           (warn "Streams already redirected."))
-          (t
-           (mapc #'setup-stream-indirection
-                 (append *standard-output-streams*
-                         *standard-input-streams*
-                         *standard-io-streams*))))))
-
-(add-hook *after-init-hook* 'init-global-stream-redirection)
-
-(defun globally-redirect-io-to-connection (connection)
-  "Set the standard I/O streams to redirect to CONNECTION.
-Assigns *CURRENT-<STREAM>* for all standard streams."
-  (dolist (o *standard-output-streams*)
-    (set (prefixed-var '#:current o)
-         (connection.user-output connection)))
-  ;; FIXME: If we redirect standard input to Emacs then we get the
-  ;; regular Lisp top-level trying to read from our REPL.
-  ;;
-  ;; Perhaps the ideal would be for the real top-level to run in a
-  ;; thread with local bindings for all the standard streams. Failing
-  ;; that we probably would like to inhibit it from reading while
-  ;; Emacs is connected.
-  ;;
-  ;; Meanwhile we just leave *standard-input* alone.
-  #+NIL
-  (dolist (i *standard-input-streams*)
-    (set (prefixed-var '#:current i)
-         (connection.user-input connection)))
-  (dolist (io *standard-io-streams*)
-    (set (prefixed-var '#:current io)
-         (connection.user-io connection))))
-
-(defun revert-global-io-redirection ()
-  "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
-  (dolist (stream-var (append *standard-output-streams*
-                              *standard-input-streams*
-                              *standard-io-streams*))
-    (set (prefixed-var '#:current stream-var)
-         (getf *saved-global-streams* stream-var))))
-
-;;;;; Global redirection hooks
-
-(defvar *global-stdio-connection* nil
-  "The connection to which standard I/O streams are globally redirected.
-NIL if streams are not globally redirected.")
-
-(defun maybe-redirect-global-io (connection)
-  "Consider globally redirecting to CONNECTION."
-  (when (and *globally-redirect-io* (null *global-stdio-connection*)
-             (connection.user-io connection))
-    (setq *global-stdio-connection* connection)
-    (globally-redirect-io-to-connection connection)))
-
-(defun update-redirection-after-close (closed-connection)
-  "Update redirection after a connection closes."
-  (check-type closed-connection connection)
-  (when (eq *global-stdio-connection* closed-connection)
-    (if (and (default-connection) *globally-redirect-io*)
-        ;; Redirect to another connection.
-        (globally-redirect-io-to-connection (default-connection))
-        ;; No more connections, revert to the real streams.
-        (progn (revert-global-io-redirection)
-               (setq *global-stdio-connection* nil)))))
-
-(add-hook *connection-closed-hook* 'update-redirection-after-close)
-
 ;;; Channels
 
 ;; FIXME: should be per connection not global.




From heller at common-lisp.net  Sat Dec 10 12:33:52 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 10 Dec 2011 04:33:52 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RZM7k-0007iW-Ur@common-lisp.net>

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

Modified Files:
	swank-repl.lisp 
Log Message:
* swank.lisp: Move global io-redirection contrib/slime-repl.lisp.

--- /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/05 11:29:18	1.2
+++ /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/10 12:33:52	1.3
@@ -199,3 +199,153 @@
         (make-output-stream-for-target *emacs-connection* target))
   nil)
 
+
+
+;;;; IO to Emacs
+;;;
+;;; This code handles redirection of the standard I/O streams
+;;; (`*standard-output*', etc) into Emacs. The `connection' structure
+;;; contains the appropriate streams, so all we have to do is make the
+;;; right bindings.
+
+;;;;; Global I/O redirection framework
+;;;
+;;; Optionally, the top-level global bindings of the standard streams
+;;; can be assigned to be redirected to Emacs. When Emacs connects we
+;;; redirect the streams into the connection, and they keep going into
+;;; that connection even if more are established. If the connection
+;;; handling the streams closes then another is chosen, or if there
+;;; are no connections then we revert to the original (real) streams.
+;;;
+;;; It is slightly tricky to assign the global values of standard
+;;; streams because they are often shadowed by dynamic bindings. We
+;;; solve this problem by introducing an extra indirection via synonym
+;;; streams, so that *STANDARD-INPUT* is a synonym stream to
+;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
+;;; variables, so they can always be assigned to affect a global
+;;; change.
+
+(defvar *globally-redirect-io* nil
+  "When non-nil globally redirect all standard streams to Emacs.")
+
+;;;;; Global redirection setup
+
+(defvar *saved-global-streams* '()
+  "A plist to save and restore redirected stream objects.
+E.g. the value for '*standard-output* holds the stream object
+for *standard-output* before we install our redirection.")
+
+(defun setup-stream-indirection (stream-var &optional stream)
+  "Setup redirection scaffolding for a global stream variable.
+Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
+
+1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
+
+2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
+*STANDARD-INPUT*.
+
+3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
+*CURRENT-STANDARD-INPUT*.
+
+This has the effect of making *CURRENT-STANDARD-INPUT* contain the
+effective global value for *STANDARD-INPUT*. This way we can assign
+the effective global value even when *STANDARD-INPUT* is shadowed by a
+dynamic binding."
+  (let ((current-stream-var (prefixed-var '#:current stream-var))
+        (stream (or stream (symbol-value stream-var))))
+    ;; Save the real stream value for the future.
+    (setf (getf *saved-global-streams* stream-var) stream)
+    ;; Define a new variable for the effective stream.
+    ;; This can be reassigned.
+    (proclaim `(special ,current-stream-var))
+    (set current-stream-var stream)
+    ;; Assign the real binding as a synonym for the current one.
+    (let ((stream (make-synonym-stream current-stream-var)))
+      (set stream-var stream)
+      (set-default-initial-binding stream-var `(quote ,stream)))))
+
+(defun prefixed-var (prefix variable-symbol)
+  "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
+  (let ((basename (subseq (symbol-name variable-symbol) 1)))
+    (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
+
+(defvar *standard-output-streams*
+  '(*standard-output* *error-output* *trace-output*)
+  "The symbols naming standard output streams.")
+
+(defvar *standard-input-streams*
+  '(*standard-input*)
+  "The symbols naming standard input streams.")
+
+(defvar *standard-io-streams*
+  '(*debug-io* *query-io* *terminal-io*)
+  "The symbols naming standard io streams.")
+
+(defun init-global-stream-redirection ()
+  (when *globally-redirect-io*
+    (cond (*saved-global-streams*
+           (warn "Streams already redirected."))
+          (t
+           (mapc #'setup-stream-indirection
+                 (append *standard-output-streams*
+                         *standard-input-streams*
+                         *standard-io-streams*))))))
+
+(add-hook *after-init-hook* 'init-global-stream-redirection)
+
+(defun globally-redirect-io-to-connection (connection)
+  "Set the standard I/O streams to redirect to CONNECTION.
+Assigns *CURRENT-<STREAM>* for all standard streams."
+  (dolist (o *standard-output-streams*)
+    (set (prefixed-var '#:current o)
+         (connection.user-output connection)))
+  ;; FIXME: If we redirect standard input to Emacs then we get the
+  ;; regular Lisp top-level trying to read from our REPL.
+  ;;
+  ;; Perhaps the ideal would be for the real top-level to run in a
+  ;; thread with local bindings for all the standard streams. Failing
+  ;; that we probably would like to inhibit it from reading while
+  ;; Emacs is connected.
+  ;;
+  ;; Meanwhile we just leave *standard-input* alone.
+  #+NIL
+  (dolist (i *standard-input-streams*)
+    (set (prefixed-var '#:current i)
+         (connection.user-input connection)))
+  (dolist (io *standard-io-streams*)
+    (set (prefixed-var '#:current io)
+         (connection.user-io connection))))
+
+(defun revert-global-io-redirection ()
+  "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
+  (dolist (stream-var (append *standard-output-streams*
+                              *standard-input-streams*
+                              *standard-io-streams*))
+    (set (prefixed-var '#:current stream-var)
+         (getf *saved-global-streams* stream-var))))
+
+;;;;; Global redirection hooks
+
+(defvar *global-stdio-connection* nil
+  "The connection to which standard I/O streams are globally redirected.
+NIL if streams are not globally redirected.")
+
+(defun maybe-redirect-global-io (connection)
+  "Consider globally redirecting to CONNECTION."
+  (when (and *globally-redirect-io* (null *global-stdio-connection*)
+             (connection.user-io connection))
+    (setq *global-stdio-connection* connection)
+    (globally-redirect-io-to-connection connection)))
+
+(defun update-redirection-after-close (closed-connection)
+  "Update redirection after a connection closes."
+  (check-type closed-connection connection)
+  (when (eq *global-stdio-connection* closed-connection)
+    (if (and (default-connection) *globally-redirect-io*)
+        ;; Redirect to another connection.
+        (globally-redirect-io-to-connection (default-connection))
+        ;; No more connections, revert to the real streams.
+        (progn (revert-global-io-redirection)
+               (setq *global-stdio-connection* nil)))))
+
+(add-hook *connection-closed-hook* 'update-redirection-after-close)




From heller at common-lisp.net  Sat Dec 10 12:33:57 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 10 Dec 2011 04:33:57 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1RZM7p-0007jA-Ql@common-lisp.net>

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

Modified Files:
	ChangeLog swank-repl.lisp 
Log Message:
Don't call init-global-stream-redirection in *after-init-hook*.
*after-init-hook* may be called before the contrib was loaded.

* swank-repl.lisp (maybe-redirect-global-io): Call
init-global-stream-redirection here instead.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/08 13:54:19	1.525
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/10 12:33:57	1.526
@@ -1,3 +1,11 @@
+2011-12-10  Helmut Eller  <heller at common-lisp.net>
+
+	Don't call init-global-stream-redirection in *after-init-hook*.
+	*after-init-hook* may be called before the contrib was loaded.
+
+	* swank-repl.lisp (maybe-redirect-global-io): Call
+	init-global-stream-redirection here instead.
+
 2011-12-08  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* slime-cl-indent.el (lisp-indent-maximum-backtracking)
--- /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/10 12:33:52	1.3
+++ /project/slime/cvsroot/slime/contrib/swank-repl.lisp	2011/12/10 12:33:57	1.4
@@ -291,8 +291,6 @@
                          *standard-input-streams*
                          *standard-io-streams*))))))
 
-(add-hook *after-init-hook* 'init-global-stream-redirection)
-
 (defun globally-redirect-io-to-connection (connection)
   "Set the standard I/O streams to redirect to CONNECTION.
 Assigns *CURRENT-<STREAM>* for all standard streams."
@@ -334,6 +332,8 @@
   "Consider globally redirecting to CONNECTION."
   (when (and *globally-redirect-io* (null *global-stdio-connection*)
              (connection.user-io connection))
+    (unless *saved-global-streams*
+      (init-global-stream-redirection))
     (setq *global-stdio-connection* connection)
     (globally-redirect-io-to-connection connection)))
 




From heller at common-lisp.net  Sat Dec 10 12:34:09 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 10 Dec 2011 04:34:09 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RZM81-0007jo-NH@common-lisp.net>

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

Modified Files:
	ChangeLog swank-backend.lisp swank.lisp 
Log Message:
* swank.lisp (auto-flush-loop): Don't use call-with-io-timeout.
Removing it had no effect on the number of failed tests.  If you
want it back, first create a test case to demonstrate the problem.
* swank-backend.lisp: Mention that locks should only be used in
swank-gray.lisp.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:33:52	1.2284
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:34:09	1.2285
@@ -1,5 +1,13 @@
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (auto-flush-loop): Don't use call-with-io-timeout.
+	Removing it had no effect on the number of failed tests.  If you
+	want it back, first create a test case to demonstrate the problem.
+	* swank-backend.lisp: Mention that locks should only be used in
+	swank-gray.lisp.
+
+2011-12-10  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp: Move global io-redirection contrib/slime-repl.lisp.
 
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/swank-backend.lisp	2011/12/01 22:34:41	1.214
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2011/12/10 12:34:09	1.215
@@ -430,6 +430,16 @@
   "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
   (default-utf8-to-string octets))
 
+;;; Codepoint length
+
+;; we don't need this anymore.
+(definterface codepoint-length (string)
+  "Return the number of codepoints in STRING.
+With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
+units, but other Lisps return the number of codepoints. The slime
+protocol wants string lengths in terms of codepoints."
+  (length string))
+
 
 ;;;; TCP server
 
@@ -1086,9 +1096,10 @@
   (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
                         this implementation."))
 
-
 (definterface buffer-first-change (filename)
-  "Called for effect the first time FILENAME's buffer is modified."
+  "Called for effect the first time FILENAME's buffer is modified.
+CMUCL/SBCL use this to cache the unmodified file and use the
+unmodified text to improve the precision of source locations."
   (declare (ignore filename))
   nil)
 
@@ -1191,6 +1202,19 @@
 themselves, that is, their dispatch functions, are left alone.")
 
 
+;;;; Trace
+
+(definterface toggle-trace (spec)
+  "Toggle tracing of the function(s) given with SPEC.
+SPEC can be:
+ (setf NAME)                            ; a setf function
+ (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
+ (:defgeneric NAME)                     ; a generic function with all methods
+ (:call CALLER CALLEE)                  ; trace calls from CALLER to CALLEE.
+ (:labels TOPLEVEL LOCAL) 
+ (:flet TOPLEVEL LOCAL) ")
+
+
 ;;;; Inspector
 
 (defgeneric emacs-inspect (object)
@@ -1293,19 +1317,6 @@
   (declare (ignore thread))
   '())
 
-(definterface make-lock (&key name)
-   "Make a lock for thread synchronization.
-Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
-but that thread may hold it more than once."
-   (declare (ignore name))
-   :null-lock)
-
-(definterface call-with-lock-held (lock function)
-   "Call FUNCTION with LOCK held, queueing if necessary."
-   (declare (ignore lock)
-            (type function function))
-   (funcall function))
-
 (definterface current-thread ()
   "Return the currently executing thread."
   0)
@@ -1377,15 +1388,30 @@
 
 Return :interrupt if an interrupt occurs while waiting.")
 
-(definterface toggle-trace (spec)
-  "Toggle tracing of the function(s) given with SPEC.
-SPEC can be:
- (setf NAME)                            ; a setf function
- (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
- (:defgeneric NAME)                     ; a generic function with all methods
- (:call CALLER CALLEE)                  ; trace calls from CALLER to CALLEE.
- (:labels TOPLEVEL LOCAL) 
- (:flet TOPLEVEL LOCAL) ")
+
+;;;;  Locks 
+
+;; Please use locks only in swank-gray.lisp.  Locks are too low-level
+;; for our taste.
+
+(definterface make-lock (&key name)
+   "Make a lock for thread synchronization.
+Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
+but that thread may hold it more than once."
+   (declare (ignore name))
+   :null-lock)
+
+(definterface call-with-lock-held (lock function)
+   "Call FUNCTION with LOCK held, queueing if necessary."
+   (declare (ignore lock)
+            (type function function))
+   (funcall function))
+
+;; Same here: don't use this outside of swank-gray.lisp.
+(definterface call-with-io-timeout (function &key seconds)
+  "Calls function with the specified IO timeout."
+  (declare (ignore seconds))
+  (funcall function))
 
 
 ;;;; Weak datastructures
@@ -1460,19 +1486,3 @@
   "Request saving a heap image to the file FILENAME.
 RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
 COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
-
-;;; Codepoint length
-
-(definterface codepoint-length (string)
-  "Return the number of codepoints in STRING.
-With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
-units, but other Lisps return the number of codepoints. The slime
-protocol wants string lengths in terms of codepoints."
-  (length string))
-
-;;; Timeouts
-
-(definterface call-with-io-timeout (function &key seconds)
-  "Calls function with the specified IO timeout."
-  (declare (ignore seconds))
-  (funcall function))
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/10 12:33:52	1.779
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/10 12:34:09	1.780
@@ -941,15 +941,11 @@
 
 (defun auto-flush-loop (stream)
   (loop
-    (when (not (and (open-stream-p stream) 
-                    (output-stream-p stream)))
-      (return nil))
-    ;; Use an IO timeout to avoid deadlocks
-    ;; on the stream we're flushing.
-    (call-with-io-timeout
-     (lambda () (finish-output stream))
-     :seconds 0.1)
-    (sleep *auto-flush-interval*)))
+   (when (not (and (open-stream-p stream)
+                   (output-stream-p stream)))
+     (return nil))
+   (force-output stream)
+   (sleep *auto-flush-interval*)))
 
 ;; FIXME: drop dependency on find-repl-thread
 (defun find-worker-thread (connection id)




From heller at common-lisp.net  Sat Dec 10 12:58:42 2011
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 10 Dec 2011 04:58:42 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RZMVm-0008SR-NE@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Fix some typos.

--- /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:34:09	1.2285
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:58:42	1.2286
@@ -8,7 +8,7 @@
 
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
 
-	* swank.lisp: Move global io-redirection contrib/slime-repl.lisp.
+	* swank.lisp: Move io-redirection to contrib/swank-repl.lisp.
 
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
 
@@ -45,7 +45,7 @@
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (*slime-interrupts-enabled*): Describe the idea
-	behind the interrupt handlig code a bit.
+	behind the interrupt handling code a bit.
 
 2011-12-07  Helmut Eller  <heller at common-lisp.net>
 
@@ -106,7 +106,7 @@
 
 2011-12-07  Stas Boukarev  <stassats at gmail.com>
 
-	* doc/.cvsignore: Aadd html.tgz
+	* doc/.cvsignore: Add html.tgz
 
 2011-12-07  Didier Verna  <didier at xemacs.org>
 




From sboukarev at common-lisp.net  Mon Dec 12 06:59:26 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 11 Dec 2011 22:59:26 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RZzrC-0000Pi-Vs@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-compile-region): Run slime-flash-region
directly, not from `slime-before-compile-functions', which is run
also for C-c C-k.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/10 12:58:42	1.2286
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/12 06:59:26	1.2287
@@ -1,3 +1,9 @@
+2011-12-12  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-compile-region): Run slime-flash-region
+	directly, not from `slime-before-compile-functions', which is run
+	also for C-c C-k.
+
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (auto-flush-loop): Don't use call-with-io-timeout.
--- /project/slime/cvsroot/slime/slime.el	2011/12/07 19:23:44	1.1389
+++ /project/slime/cvsroot/slime/slime.el	2011/12/12 06:59:26	1.1390
@@ -2669,12 +2669,11 @@
   (interactive "r")
   ;; Check connection before running hooks
   ;; things like slime-flash-region don't make much sense if there's no connection
-  (slime-connection) 
+  (slime-connection)
+  (slime-flash-region start end)
   (run-hook-with-args 'slime-before-compile-functions start end)
   (slime-compile-string (buffer-substring-no-properties start end) start))
 
-(add-hook 'slime-before-compile-functions 'slime-flash-region)
-
 (defun slime-flash-region (start end &optional timeout)
   "Temporarily highlight region from START to END."
   (let ((overlay (make-overlay start end))) 




From sboukarev at common-lisp.net  Wed Dec 21 16:19:52 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 21 Dec 2011 08:19:52 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1RdOtU-0004Hw-4S@common-lisp.net>

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (input-ready-p): Don't use
sb-impl::fd-stream-fd-type if it's not present.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/12 06:59:26	1.2287
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/21 16:19:51	1.2288
@@ -1,3 +1,8 @@
+2011-12-21  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-sbcl.lisp (input-ready-p): Don't use
+	sb-impl::fd-stream-fd-type if it's not present.
+
 2011-12-12  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-compile-region): Run slime-flash-region
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/03 19:47:45	1.299
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/21 16:19:52	1.300
@@ -201,6 +201,7 @@
         (when buffer
           (< (sb-impl::buffer-head buffer)
              (sb-impl::buffer-tail buffer))))
+      #+#.(swank-backend:with-symbol 'fd-stream-fd-type 'sb-impl)
       (eq :regular (sb-impl::fd-stream-fd-type stream))
       (not (sb-impl::sysread-may-block-p stream))))
 




From sboukarev at common-lisp.net  Fri Dec 23 20:03:15 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 23 Dec 2011 12:03:15 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1ReBKl-000327-Jt@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-cycle-connections): Add
`slime-cycle-connections-hook', to be used by slime-repl.

* contrib/slime-repl.el (slime-change-repl-to-default-connection): New
function.
Changes the current REPL to the REPL of the default connection. If
the current buffer is not a REPL, don't do anything.
Put it into `slime-cycle-connections-hook', so that when
connections are cycled through it will change the currently
displayed REPL.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/21 16:19:51	1.2288
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/23 20:03:15	1.2289
@@ -1,3 +1,8 @@
+2011-12-23  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-cycle-connections): Add
+	`slime-cycle-connections-hook', to be used by slime-repl.
+
 2011-12-21  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-sbcl.lisp (input-ready-p): Don't use
--- /project/slime/cvsroot/slime/slime.el	2011/12/12 06:59:26	1.1390
+++ /project/slime/cvsroot/slime/slime.el	2011/12/23 20:03:15	1.1391
@@ -1811,6 +1811,8 @@
   "Make PROCESS the default connection."
   (setq slime-default-connection process))
 
+(defvar slime-cycle-connections-hook nil)
+
 (defun slime-cycle-connections ()
   "Change current slime connection, cycling through all connections."
   (interactive)
@@ -1819,6 +1821,7 @@
                    slime-net-processes))
          (p (car tail)))
     (slime-select-connection p)
+    (run-hooks 'slime-cycle-connections-hook)
     (message "Lisp: %s %s" (slime-connection-name p) (process-contact p))))
 
 (defmacro* slime-with-connection-buffer ((&optional process) &rest body)




From sboukarev at common-lisp.net  Fri Dec 23 20:03:15 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 23 Dec 2011 12:03:15 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1ReBKl-00032O-T2@common-lisp.net>

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

Modified Files:
	ChangeLog slime-repl.el 
Log Message:
* slime.el (slime-cycle-connections): Add
`slime-cycle-connections-hook', to be used by slime-repl.

* contrib/slime-repl.el (slime-change-repl-to-default-connection): New
function.
Changes the current REPL to the REPL of the default connection. If
the current buffer is not a REPL, don't do anything.
Put it into `slime-cycle-connections-hook', so that when
connections are cycled through it will change the currently
displayed REPL.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/10 12:33:57	1.526
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/23 20:03:15	1.527
@@ -1,3 +1,13 @@
+2011-12-23  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-repl.el (slime-change-repl-to-default-connection): New
+	function.
+	Changes the current REPL to the REPL of the default connection. If
+	the current buffer is not a REPL, don't do anything.
+	Put it into `slime-cycle-connections-hook', so that when
+	connections are cycled through it will change the currently
+	displayed REPL.
+
 2011-12-10  Helmut Eller  <heller at common-lisp.net>
 
 	Don't call init-global-stream-redirection in *after-init-hook*.
--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2011/12/04 15:18:42	1.62
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2011/12/23 20:03:15	1.63
@@ -27,8 +27,7 @@
   (:authors "too many to mention")
   (:license "GPL")
   (:on-load
-   (add-hook 'slime-event-hooks 'slime-repl-event-hook-function)
-   (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
+   (slime-repl-add-hooks) 
    (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package))
   (:on-unload (slime-repl-remove-hooks))
   (:swank-dependencies swank-repl))
@@ -1704,13 +1703,26 @@
      t)
     (t nil)))
 
+(defun slime-change-repl-to-default-connection ()
+  "Change current REPL to the REPL of the default connection.
+If the current buffer is not a REPL, don't do anything."
+  (when (equal major-mode 'slime-repl-mode)
+    (let ((slime-buffer-connection slime-default-connection))
+      (pop-to-buffer-same-window (slime-connection-output-buffer)))))
+
 (defun slime-repl-find-buffer-package ()
   (or (slime-search-buffer-package)
       (slime-lisp-package)))
 
+(defun slime-repl-add-hooks ()
+  (add-hook 'slime-event-hooks 'slime-repl-event-hook-function)
+  (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
+  (add-hook 'slime-cycle-connections-hook 'slime-change-repl-to-default-connection))
+
 (defun slime-repl-remove-hooks ()
   (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function)
-  (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function))
+  (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
+  (remove-hook 'slime-cycle-connections-hook 'slime-change-repl-to-default-connection))
 
 (let ((byte-compile-warnings '()))
   (mapc #'byte-compile




From sboukarev at common-lisp.net  Sat Dec 24 05:01:25 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 23 Dec 2011 21:01:25 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1ReJjZ-0003W0-Gc@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (throw-to-toplevel): If *sldb-quit-restart* is not
found, try to invoke the last restart, which usually is a
top-level abort restart. This is useful when the debugger is
invoked from a non-slime thread.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/23 20:03:15	1.2289
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/24 05:01:25	1.2290
@@ -1,3 +1,10 @@
+2011-12-24  Stas Boukarev  <stassats at gmail.com>
+
+	* swank.lisp (throw-to-toplevel): If *sldb-quit-restart* is not
+	found, try to invoke the last restart, which usually is a
+	top-level abort restart. This is useful when the debugger is
+	invoked from a non-slime thread.
+
 2011-12-23  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-cycle-connections): Add
--- /project/slime/cvsroot/slime/swank.lisp	2011/12/10 12:34:09	1.780
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/24 05:01:25	1.781
@@ -2231,7 +2231,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 (and *sldb-quit-restart* (find-restart *sldb-quit-restart*))))
+  (let ((restart (or (and *sldb-quit-restart* (find-restart *sldb-quit-restart*))
+                     (car (last (compute-restarts))))))
     (cond (restart (invoke-restart restart))
           (t (format nil "Restart not active [~s]" *sldb-quit-restart*)))))
 




From sboukarev at common-lisp.net  Sat Dec 24 17:45:24 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 24 Dec 2011 09:45:24 -0800
Subject: [slime-cvs] CVS slime
Message-ID: <E1ReVeu-0007NZ-3z@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-init-command): Don't call
`slime-to-lisp-filename', the lisp is not yet connected and if
there's another connection it will use the wrong translation.

* contrib/slime-tramp.el (slime-find-filename-translators): Don't signal
an error if there's no translators for a hostname, just use 'identity.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/24 05:01:25	1.2290
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/24 17:45:23	1.2291
@@ -1,5 +1,11 @@
 2011-12-24  Stas Boukarev  <stassats at gmail.com>
 
+	* slime.el (slime-init-command): Don't call
+	`slime-to-lisp-filename', the lisp is not yet connected and if
+	there's another connection it will use the wrong translation.
+
+2011-12-24  Stas Boukarev  <stassats at gmail.com>
+
 	* swank.lisp (throw-to-toplevel): If *sldb-quit-restart* is not
 	found, try to invoke the last restart, which usually is a
 	top-level abort restart. This is useful when the debugger is
--- /project/slime/cvsroot/slime/slime.el	2011/12/23 20:03:15	1.1391
+++ /project/slime/cvsroot/slime/slime.el	2011/12/24 17:45:23	1.1392
@@ -1345,11 +1345,11 @@
     ;; Return a single form to avoid problems with buffered input.
     (format "%S\n\n"
             `(progn
-               (load ,(slime-to-lisp-filename (expand-file-name loader)) 
+               (load ,(expand-file-name loader) 
                      :verbose t)
                (funcall (read-from-string "swank-loader:init"))
                (funcall (read-from-string "swank:start-server")
-                        ,(slime-to-lisp-filename port-filename))))))
+                        ,port-filename)))))
 
 (defun slime-swank-port-file ()
   "Filename where the SWANK server writes its TCP port number."




From sboukarev at common-lisp.net  Sat Dec 24 17:45:24 2011
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 24 Dec 2011 09:45:24 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1ReVeu-0007Nq-DH@common-lisp.net>

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

Modified Files:
	ChangeLog slime-tramp.el 
Log Message:
* slime.el (slime-init-command): Don't call
`slime-to-lisp-filename', the lisp is not yet connected and if
there's another connection it will use the wrong translation.

* contrib/slime-tramp.el (slime-find-filename-translators): Don't signal
an error if there's no translators for a hostname, just use 'identity.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/23 20:03:15	1.527
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/24 17:45:24	1.528
@@ -1,3 +1,8 @@
+2011-12-24  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-tramp.el (slime-find-filename-translators): Don't signal
+	an error if there's no translators for a hostname, just use 'identity.
+
 2011-12-23  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-repl.el (slime-change-repl-to-default-connection): New
--- /project/slime/cvsroot/slime/contrib/slime-tramp.el	2010/05/28 19:13:17	1.6
+++ /project/slime/cvsroot/slime/contrib/slime-tramp.el	2011/12/24 17:45:24	1.7
@@ -48,10 +48,8 @@
   :group 'slime-lisp)
 
 (defun slime-find-filename-translators (hostname)
-  (cond ((and hostname slime-filename-translations)
-         (or (cdr (assoc-if (lambda (regexp) (string-match regexp hostname))
-                            slime-filename-translations))
-             (error "No filename-translations for hostname: %s" hostname)))
+  (cond ((cdr (assoc-if (lambda (regexp) (string-match regexp hostname))
+                            slime-filename-translations)))
         (t (list #'identity #'identity))))
 
 (defun slime-make-tramp-file-name (username remote-host lisp-filename)




From nsiivola at common-lisp.net  Fri Dec 30 17:10:13 2011
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Fri, 30 Dec 2011 09:10:13 -0800
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Rgfy9-00055f-TJ@common-lisp.net>

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

Modified Files:
	ChangeLog slime-cl-indent-test.txt slime-cl-indent.el 
Log Message:
slime-indentation: better treatment of feature expressions

  Particularly interaction with keyword arguments.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/24 17:45:24	1.528
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2011/12/30 17:10:13	1.529
@@ -1,3 +1,22 @@
+2011-12-30  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* slime-cl-indent.el (common-lisp-looking-at-keyword): New function. Looks
+	past #+foo expressions.
+	(common-lisp-backward-keyword-argument): New function. Semi-aware
+	of #+foo expressions.
+	(common-lisp-indent-function-1):
+	1. Use `common-lisp-indent-parse-state-start'.
+	2. Move #+/- cleavernes outside the cond: it is always a default, and shouldn't
+	trump other indentation logic. Also make it use the column of the first feature
+	expression, not the last.
+	3. Make keyword alignment somewhat feature-expression aware.
+	4. Make heuristics not force remaining forms to be indented at the same line.
+	(common-lisp-indent-test): Leave one leading whitespace on comment lines
+	when messing up indentation.
+
+	* slime-cl-indent-test.txt (tests 77-83): Tests for feature-expression
+	and keyword alignment interaction.
+
 2011-12-24  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-tramp.el (slime-find-filename-translators): Don't signal
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt	2011/12/08 13:54:19	1.17
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent-test.txt	2011/12/30 17:10:13	1.18
@@ -827,3 +827,66 @@
              (list foo opt1 opt2
                    rest)))
   ...)
+
+;;; Test: 77
+;;
+;; lisp-align-keywords-in-calls: t
+
+(foo *foo*
+     :bar t
+     :quux #+quux t
+           #-quux nil
+     :zot t)
+
+;;; Test: 78
+;;
+;; lisp-align-keywords-in-calls: t
+
+(foo *foo* :fii t
+           :bar t
+           :quux #+quux t
+                 #+zot nil
+           :zot t)
+
+;;; Test: 79
+
+(foo #+quux :quux #+quux t
+     #-quux :zoo #-quux t)
+
+;;; Test: 80
+;;
+;; lisp-align-keywords-in-calls: t
+
+(foo *foo* :fii t
+           :bar t
+           #+quux :quux #+quux t
+           :zot t)
+
+;;; Test: 81
+;;
+;; lisp-align-keywords-in-calls: t
+
+(foo *foo* :fii t
+           :bar t
+           #+quux #+quux :quux t
+           :zot t)
+
+;;; Test: 82
+;;
+;; lisp-align-keywords-in-calls: t
+
+(foo *foo* :fii t
+           :bar t
+           #+quux
+           :quux #+quux t
+           :zot t)
+
+;;; Test: 83
+;;
+;; lisp-align-keywords-in-calls: t
+
+(foo *foo* :fii t
+           :bar t
+           #+quux #+quux
+           :quux t
+           :zot t)
--- /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/08 13:54:19	1.61
+++ /project/slime/cvsroot/slime/contrib/slime-cl-indent.el	2011/12/30 17:10:13	1.62
@@ -743,6 +743,34 @@
       (unless (eql (elt string (- len i 1)) (char-before (- (point) i)))
         (return nil)))))
 
+(defvar common-lisp-feature-expression-regexp "#!?\\(+\\|-\\)")
+
+;;; Semi-feature-expression aware keyword check.
+(defun common-lisp-looking-at-keyword ()
+  (or (looking-at ":")
+      (and (looking-at common-lisp-feature-expression-regexp)
+           (save-excursion
+             (forward-sexp)
+             (skip-chars-forward " \t\n")
+             (common-lisp-looking-at-keyword)))))
+
+;;; Semi-feature-expression aware backwards movement for keyword argument pairs.
+(defun common-lisp-backward-keyword-argument ()
+  (ignore-errors
+    (backward-sexp 2)
+    (when (looking-at common-lisp-feature-expression-regexp)
+      (cond ((ignore-errors
+               (save-excursion
+                 (backward-sexp 2)
+                 (looking-at common-lisp-feature-expression-regexp)))
+             (common-lisp-backward-keyword-argument))
+            ((ignore-errors
+               (save-excursion
+                 (backward-sexp 1)
+                 (looking-at ":")))
+             (backward-sexp))))
+    t))
+
 (defun common-lisp-indent-function-1 (indent-point state)
   ;; If we're looking at a splice, move to the first comma.
   (when (or (common-lisp-looking-back ",") (common-lisp-looking-back ",@"))
@@ -763,7 +791,7 @@
           tentative-calculated
           (last-point indent-point)
           ;; the position of the open-paren of the innermost containing list
-          (containing-form-start (elt state 1))
+          (containing-form-start (common-lisp-indent-parse-state-start state))
           ;; the column of the above
           sexp-column)
       ;; Move to start of innermost containing list
@@ -829,21 +857,32 @@
                       function)
                      (setq method '(&lambda &body)))))
 
+            ;; #+ and #- cleverness.
+            (save-excursion
+              (goto-char indent-point)
+              (backward-sexp)
+              (let ((indent (current-column)))
+                (when (or (looking-at common-lisp-feature-expression-regexp)
+                          (ignore-errors
+                            (backward-sexp)
+                            (when (looking-at common-lisp-feature-expression-regexp)
+                              (setq indent (current-column))
+                              (let ((line (line-number-at-pos)))
+                                (while (ignore-errors
+                                         (backward-sexp 2)
+                                         (and
+                                          (= line (line-number-at-pos))
+                                          (looking-at common-lisp-feature-expression-regexp)))
+                                  (setq indent (current-column))))
+                              t)))
+                  (setq calculated (list indent containing-form-start)))))
+
             (cond ((and (or (eq (char-after (1- containing-sexp)) ?\')
                             (and (not lisp-backquote-indentation)
                                  (eq (char-after (1- containing-sexp)) ?\`)))
                         (not (eq (char-after (- containing-sexp 2)) ?\#)))
                    ;; No indentation for "'(...)" elements
                    (setq calculated (1+ sexp-column)))
-                  ((save-excursion
-                     (goto-char indent-point)
-                     (backward-sexp)
-                     (let ((re "#!?\\(+\\|-\\)"))
-                       (if (or (looking-at re)
-                               (ignore-errors
-                                 (backward-sexp)
-                                 (looking-at re)))
-                         (setq calculated (current-column))))))
                   ((eq (char-after (1- containing-sexp)) ?\#)
                    ;; "#(...)"
                    (setq calculated (1+ sexp-column)))
@@ -875,10 +914,11 @@
                        (save-excursion
                          (goto-char indent-point)
                          (back-to-indentation)
-                         (when (looking-at ":")
-                           (while (ignore-errors (backward-sexp 2) t)
-                             (when (looking-at ":")
-                               (setq calculated (current-column)))))))))
+                         (when (common-lisp-looking-at-keyword)
+                           (while (common-lisp-backward-keyword-argument)
+                             (when (common-lisp-looking-at-keyword)
+                               (setq calculated (list (current-column)
+                                                      containing-form-start)))))))))
                   ((integerp method)
                    ;; convenient top-level hack.
                    ;;  (also compatible with lisp-indent-function)
@@ -926,11 +966,11 @@
                 (let ((one (current-column)))
                   (skip-chars-forward " \t")
                   (if (or (eolp) (looking-at ";"))
-                      one
+                      (list one containing-form-start)
                     (forward-sexp 2)
                     (backward-sexp)
                     (unless (= p (point))
-                      (current-column)))))))))))
+                      (list (current-column) containing-form-start)))))))))))
 
 
 (defun common-lisp-indent-call-method (function method path state indent-point
@@ -1624,8 +1664,9 @@
         (unless (looking-at "^$")
           (case (random 2)
             (0
-             ;; Delete all leading whitespace.
-             (while (looking-at " ") (delete-char 1)))
+             ;; Delete all leading whitespace -- except for comment lines.
+             (while (and (looking-at " ") (not (looking-at " ;")))
+               (delete-char 1)))
             (1
              ;; Insert whitespace random.
              (let ((n (1+ (random 24))))
@@ -1699,6 +1740,6 @@
 ;;;   (common-lisp-run-indentation-tests t)
 ;;;
 ;;; Run specific test:
-;;;   (common-lisp-run-indentation-tests 70)
+;;;   (common-lisp-run-indentation-tests 77)
 
 ;;; cl-indent.el ends here