From sboukarev at common-lisp.net  Mon Feb  1 14:51:26 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 01 Feb 2010 09:51:26 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nbxcc-0007I6-0H@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el: Added missing pieces to make `slime-cycle-connections'
available from keystrokes.
(slime-prefix-bindings): Added "\C-xn" entry.
(slime-cycle-connections): Corrected grammar in doc string.
(def-slime-selector-method): Added menu item `n' to SLIME selector
menu.

* doc/slime.texi: Added a description for the new key sequence for
`slime-cycle-connections' and for the new menu item in the SLIME
selector menu.
Node slime-selector: Added menu item `n' and cross-references to
"Multiple Connections" node.
Node Multiple connections: Added C-c C-x n description.  Added
cross-references to `slime-selector' node.


--- /project/slime/cvsroot/slime/ChangeLog	2010/01/31 19:07:54	1.1976
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/01 14:51:25	1.1977
@@ -1,3 +1,20 @@
+2010-02-01  Mark Harig <idirectscm at aim.com>
+
+	* slime.el: Added missing pieces to make `slime-cycle-connections'
+	available from keystrokes.
+	(slime-prefix-bindings): Added "\C-xn" entry.
+	(slime-cycle-connections): Corrected grammar in doc string.
+	(def-slime-selector-method): Added menu item `n' to SLIME selector
+	menu.
+
+	* doc/slime.texi: Added a description for the new key sequence for
+	`slime-cycle-connections' and for the new menu item in the SLIME
+	selector menu.
+	Node slime-selector: Added menu item `n' and cross-references to
+	"Multiple Connections" node.
+	Node Multiple connections: Added C-c C-x n description.  Added
+	cross-references to `slime-selector' node.
+
 2010-01-31  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* hyperspec.el: When using C-c C-d ~ TAB, previously there were
--- /project/slime/cvsroot/slime/slime.el	2010/01/30 15:59:52	1.1266
+++ /project/slime/cvsroot/slime/slime.el	2010/02/01 14:51:25	1.1267
@@ -506,6 +506,7 @@
     ("\C-t"  slime-toggle-trace-fdefinition)
     ("I"     slime-inspect)
     ("\C-xt" slime-list-threads)
+    ("\C-xn" slime-cycle-connections)
     ("\C-xc" slime-list-connections)
     ("<"     slime-list-callers)
     (">"     slime-list-callees)
@@ -1822,7 +1823,7 @@
   (setq slime-default-connection process))
 
 (defun slime-cycle-connections ()
-  "Change current slime connection cycling through all connection."
+  "Change current slime connection, cycling through all connections."
   (interactive)
   (let* ((tail (or (cdr (member (slime-current-connection)
                                 slime-net-processes))
@@ -6807,6 +6808,13 @@
   (slime-list-connections)
   slime-connections-buffer-name)
 
+(def-slime-selector-method ?n
+  "Cycle to the next Lisp connection."
+  (slime-cycle-connections)
+  (concat "*slime-repl "
+          (slime-connection-name (slime-current-connection))
+          "*"))
+
 (def-slime-selector-method ?t
   "SLIME threads buffer."
   (slime-list-threads)




From sboukarev at common-lisp.net  Mon Feb  1 14:51:26 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 01 Feb 2010 09:51:26 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1Nbxcc-0007IJ-9V@common-lisp.net>

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

Modified Files:
	slime.texi 
Log Message:
* slime.el: Added missing pieces to make `slime-cycle-connections'
available from keystrokes.
(slime-prefix-bindings): Added "\C-xn" entry.
(slime-cycle-connections): Corrected grammar in doc string.
(def-slime-selector-method): Added menu item `n' to SLIME selector
menu.

* doc/slime.texi: Added a description for the new key sequence for
`slime-cycle-connections' and for the new menu item in the SLIME
selector menu.
Node slime-selector: Added menu item `n' and cross-references to
"Multiple Connections" node.
Node Multiple connections: Added C-c C-x n description.  Added
cross-references to `slime-selector' node.


--- /project/slime/cvsroot/slime/doc/slime.texi	2010/01/30 15:59:52	1.95
+++ /project/slime/cvsroot/slime/doc/slime.texi	2010/02/01 14:51:26	1.96
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2010/01/30 15:59:52 $}
+ at set UPDATED @code{$Date: 2010/02/01 14:51:26 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -1516,8 +1516,10 @@
 The @code{*slime-scratch*} buffer (@pxref{slime-scratch}).
 @item c
 SLIME connections buffer (@pxref{Multiple connections}).
+ at item n
+Cycle to the next Lisp connection (@pxref{Multiple connections}).
 @item t
-SLIME threads buffer.
+SLIME threads buffer (@pxref{Multiple connections}).
 @end table
 
 @code{slime-selector} doesn't have a key binding by default but we
@@ -1588,13 +1590,18 @@
 
 @table @kbd
 @kbditem{C-c C-x c, slime-list-connections}
-Pop up a buffer listing the established connections.
-It's also avaiable from (@pxref{slime-selector}) by the key @kbd{c}
- at kbditem{, slime-cycle-connections}
-Change current slime connection cycling through all connection.
- at kbditem{C-c C-x t, slime-list-threads}
-Pop up a buffer listing the current threads.
+Pop up a buffer listing the established connections.  It is also
+available by the typing @kbd{c} from the SLIME selector
+(@ref{slime-selector}).
+
+ at kbditem{C-c C-x n, slime-cycle-connections}
+Change current Lisp connection by cycling through all connections.  It
+is also available by the typing @kbd{n} from the SLIME selector
+(@ref{slime-selector}).
 
+ at kbditem{C-c C-x t, slime-list-threads}
+Pop up a buffer listing the current threads.  It is also available by
+the typing @kbd{t} from the SLIME selector (@ref{slime-selector}).
 @end table
 
 The buffer displayed by @code{slime-list-connections} gives a one-line




From trittweiler at common-lisp.net  Sun Feb  7 11:44:41 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 07 Feb 2010 06:44:41 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Ne5ZB-0006Vg-P7@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (xref-doit): Declare eql-specializing parameter
	ignorable, as some implementations complain about them not being
	used.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/01 14:51:25	1.1977
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/07 11:44:41	1.1978
@@ -1,3 +1,9 @@
+2010-02-07  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp (xref-doit): Declare eql-specializing parameter
+	ignorable, as some implementations complain about them not being
+	used.
+
 2010-02-01  Mark Harig <idirectscm at aim.com>
 
 	* slime.el: Added missing pieces to make `slime-cycle-connections'
--- /project/slime/cvsroot/slime/swank.lisp	2010/01/30 15:44:50	1.687
+++ /project/slime/cvsroot/slime/swank.lisp	2010/02/07 11:44:41	1.688
@@ -1989,7 +1989,7 @@
            (check-type *buffer-package* package)
            (check-type *buffer-readtable* readtable)
            ;; APPLY would be cleaner than EVAL. 
-           ;;(setq result (apply (car form) (cdr form)))
+           ;; (setq result (apply (car form) (cdr form)))
            (setq result (with-slime-interrupts (eval form)))
            (run-hook *pre-reply-hook*)
            (setq ok t))
@@ -3114,28 +3114,25 @@
     (unless error
       (mapcar #'xref>elisp (find-definitions sexp)))))
 
+;;; Generic function so contribs can extend it.
 (defgeneric xref-doit (type thing)
-  (:method ((type (eql :calls)) thing)
-    (who-calls thing))
-  (:method ((type (eql :calls-who)) thing)
-    (calls-who thing))
-  (:method ((type (eql :references)) thing)
-    (who-references thing))
-  (:method ((type (eql :binds)) thing)
-    (who-binds thing))
-  (:method ((type (eql :sets)) thing)
-    (who-sets thing))
-  (:method ((type (eql :macroexpands)) thing)
-    (who-macroexpands thing))
-  (:method ((type (eql :specializes)) thing)
-    (who-specializes thing))
-  (:method ((type (eql :callers)) thing)
-    (list-callers thing))
-  (:method ((type (eql :callees)) thing)
-    (list-callees thing))
   (:method (type thing)
+    (declare (ignore type thing))
     :not-implemented))
 
+(macrolet ((define-xref-action (xref-type handler)
+             `(defmethod xref-doit ((type (eql ,xref-type)) thing)
+                (declare (ignorable type))
+                (funcall ,handler thing))))
+  (define-xref-action :calls        #'who-calls)
+  (define-xref-action :calls-who    #'calls-who)
+  (define-xref-action :references   #'who-references)
+  (define-xref-action :binds        #'who-binds)
+  (define-xref-action :macroexpands #'who-macroexpands)
+  (define-xref-action :specializes  #'who-specializes)
+  (define-xref-action :callers      #'list-callers)
+  (define-xref-action :callees      #'list-callees))
+
 (defslimefun xref (type name)
   (multiple-value-bind (sexp error) (ignore-errors (from-string name))
     (unless error




From trittweiler at common-lisp.net  Sun Feb  7 22:33:54 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 07 Feb 2010 17:33:54 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NeFhS-0004vl-6Q@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	* swank-ecl.lisp: Update threading code. ECL doesn't still work
	with :spawn, though. Work in progress.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/07 11:44:41	1.1978
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/07 22:33:53	1.1979
@@ -1,5 +1,10 @@
 2010-02-07  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-ecl.lisp: Update threading code. ECL doesn't still work
+	with :spawn, though. Work in progress.
+
+2010-02-07  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (xref-doit): Declare eql-specializing parameter
 	ignorable, as some implementations complain about them not being
 	used.
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2009/12/19 14:56:06	1.50
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/07 22:33:53	1.51
@@ -532,13 +532,34 @@
   (declare (ignore callers methods))
   (eval `(profile:profile ,(package-name (find-package package)))))
 
+;;;; Communication-Styles
 
-;;;; Threads
+;;; :SPAWN
 
 #+threads
 (progn
-  (defvar *thread-id-counter* 0)
+  
+  ;;; THREAD-PLIST  
+  (defvar *thread-plists* (make-hash-table))
+  (defvar *thread-plists-lock*
+    (mp:make-lock :name "thread plists lock"))
+
+  (defun thread-plist (thread)
+    (mp:with-lock (*thread-plists-lock*)
+      ;; FIXME: Do we have to synchronize reads here?
+      (gethash thread *thread-plists*)))
+
+  (defun remove-thread-plist (thread)
+    (mp:with-lock (*thread-plists-lock*)
+      (remhash thread *thread-plists*)))
+
+  (defun put-thread-property (thread property value)
+    (mp:with-lock (*thread-plists-lock*)
+      (setf (getf (gethash thread *thread-plists*) property) value))
+    value)
 
+  ;;; THREAD-ID
+  (defvar *thread-id-counter* 0)
   (defvar *thread-id-counter-lock*
     (mp:make-lock :name "thread id counter lock"))
 
@@ -546,49 +567,34 @@
     (mp:with-lock (*thread-id-counter-lock*)
       (incf *thread-id-counter*)))
 
-  (defparameter *thread-id-map* (make-hash-table))
-  (defparameter *id-thread-map* (make-hash-table))
-
-  (defvar *thread-id-map-lock*
-    (mp:make-lock :name "thread id map lock"))
-
-  ; ecl doesn't have weak pointers
   (defimplementation spawn (fn &key name)
-    (let ((thread (mp:make-process :name name))
-	  (id (next-thread-id)))
+    (let ((thread (mp:make-process :name name)))
+      (put-thread-property thread 'thread-id (next-thread-id))
       (mp:process-preset
-	thread
-	#'(lambda ()
-	    (unwind-protect
-	      (mp:with-lock (*thread-id-map-lock*)
-	        (setf (gethash id *thread-id-map*) thread)
-                (setf (gethash thread *id-thread-map*) id))
-	      (funcall fn)
-	      (mp:with-lock (*thread-id-map-lock*)
-                (remhash thread *id-thread-map*)
-                (remhash id *thread-id-map*)))))
+       thread
+       #'(lambda ()
+           ;; ecl doesn't have weak pointers
+           (unwind-protect (funcall fn)
+             (remove-thread-plist thread))))
       (mp:process-enable thread)))
 
   (defimplementation thread-id (thread)
-    (block thread-id
-      (mp:with-lock (*thread-id-map-lock*)
-        (or (gethash thread *id-thread-map*)
-            (let ((id (next-thread-id)))
-              (setf (gethash id *thread-id-map*) thread)
-              (setf (gethash thread *id-thread-map*) id)
-              id)))))
+    (or (getf (thread-plist thread) 'thread-id)
+        (put-thread-property thread 'thread-id  (next-thread-id))))
 
   (defimplementation find-thread (id)
-    (mp:with-lock (*thread-id-map-lock*)
-      (gethash id *thread-id-map*)))
+    (find id (mp:all-processes)
+          :key #'(lambda (thread)
+                   (getf (thread-plist thread) 'thread-id))))
 
   (defimplementation thread-name (thread)
     (mp:process-name thread))
 
   (defimplementation thread-status (thread)
-    (if (mp:process-active-p thread)
-        "RUNNING"
-        "STOPPED"))
+    (let ((whostate (process-whostate thread)))
+      (cond (whostate (princ-to-string whostate))
+            ((mp:process-active-p thread) "RUNNING")
+            (t "STOPPED"))))
 
   (defimplementation make-lock (&key name)
     (mp:make-lock :name name))
@@ -612,43 +618,38 @@
   (defimplementation thread-alive-p (thread)
     (mp:process-active-p thread))
 
-  (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
-
   (defstruct (mailbox (:conc-name mailbox.))
-    (mutex (mp:make-lock :name "process mailbox"))
+    (lock (mp:make-lock :name "mailbox lock"))
+    (cvar (mp:make-condition-variable))
     (queue '() :type list))
 
   (defun mailbox (thread)
     "Return THREAD's mailbox."
-    (mp:with-lock (*mailbox-lock*)
-      (or (find thread *mailboxes* :key #'mailbox.thread)
-          (let ((mb (make-mailbox :thread thread)))
-            (push mb *mailboxes*)
-            mb))))
+    (or (getf (thread-plist thread) 'mailbox)
+        (put-thread-property thread 'mailbox (make-mailbox))))
 
   (defimplementation send (thread message)
-    (let* ((mbox (mailbox thread))
-           (mutex (mailbox.mutex mbox)))
-      (mp:interrupt-process
-	thread
-	(lambda ()
-	  (mp:with-lock (mutex)
-            (setf (mailbox.queue mbox)
-              (nconc (mailbox.queue mbox) (list message))))))))
-
-  (defimplementation receive ()
-    (block got-mail
-      (let* ((mbox (mailbox mp:*current-process*))
-             (mutex (mailbox.mutex mbox)))
-        (loop
-	  (mp:with-lock (mutex)
-            (if (mailbox.queue mbox)
-	      (return-from got-mail (pop (mailbox.queue mbox)))))
-          ;interrupt-process will halt this if it takes longer than 1sec
-          (sleep 1)))))
-
-  (defmethod stream-finish-output ((stream stream))
-    (finish-output stream))
-
-  )
+    (let ((mbox (mailbox thread)))
+      (mp:with-lock ((mailbox.lock mbox))
+        (setf (mailbox.queue mbox)
+              (nconc (mailbox.queue mbox) (list message)))
+        (mp:condition-variable-broadcast (mailbox.cvar mbox)))))
+
+  (defimplementation receive-if (test &optional timeout)
+    (let ((mbox (mailbox mp:*current-process*)))
+      (assert (or (not timeout) (eq timeout t)))
+      (loop
+        (check-slime-interrupts)
+        (mp:with-lock ((mailbox.lock mbox))
+          (let* ((q (mailbox.queue mbox))
+                 (tail (member-if test q)))
+            (when tail 
+              (setf (mailbox.queue mbox) 
+                    (nconc (ldiff q tail) (cdr tail)))
+              (return (car tail))))
+          (when (eq timeout t) (return (values nil t)))
+          (mp:condition-variable-timedwait (mailbox.cvar mbox)
+                                           (mailbox.lock mbox)
+                                           0.2)))))
+) ; #+thread (progn ...
 




From trittweiler at common-lisp.net  Sat Feb 13 11:34:38 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 13 Feb 2010 06:34:38 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NgGGk-00089c-Lm@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-attempt-connection): Do not keep on trying to
	connect if inferior process died.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/07 22:33:53	1.1979
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/13 11:34:38	1.1980
@@ -1,3 +1,8 @@
+2010-02-13  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (slime-attempt-connection): Do not keep on trying to
+	connect if inferior process died.
+
 2010-02-07  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-ecl.lisp: Update threading code. ECL doesn't still work
--- /project/slime/cvsroot/slime/slime.el	2010/02/01 14:51:25	1.1267
+++ /project/slime/cvsroot/slime/slime.el	2010/02/13 11:34:38	1.1268
@@ -1420,7 +1420,10 @@
                (slime-set-inferior-process c process))))
           ((and retries (zerop retries))
            (slime-cancel-connect-retry-timer)
-           (message "Failed to connect to Swank."))
+           (message "Gave up connecting to Swank after ~D attempts." attempt))
+          ((eq (process-status process) 'exit)
+           (slime-cancel-connect-retry-timer)
+           (message "Failed to connect to Swank: inferior process exited."))
           (t
            (when (and (file-exists-p file) 
                       (zerop (nth 7 (file-attributes file))))




From trittweiler at common-lisp.net  Sun Feb 14 18:26:01 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 14 Feb 2010 13:26:01 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NgjAP-0007FO-Ex@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-attempt-connection): Fix typo. Thanks to Mark
	Harig for spotting it.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/13 11:34:38	1.1980
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/14 18:26:01	1.1981
@@ -1,3 +1,8 @@
+2010-02-14  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (slime-attempt-connection): Fix typo. Thanks to Mark
+	Harig for spotting it.
+
 2010-02-13  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-attempt-connection): Do not keep on trying to
--- /project/slime/cvsroot/slime/slime.el	2010/02/13 11:34:38	1.1268
+++ /project/slime/cvsroot/slime/slime.el	2010/02/14 18:26:01	1.1269
@@ -1420,7 +1420,7 @@
                (slime-set-inferior-process c process))))
           ((and retries (zerop retries))
            (slime-cancel-connect-retry-timer)
-           (message "Gave up connecting to Swank after ~D attempts." attempt))
+           (message "Gave up connecting to Swank after %d attempts." attempt))
           ((eq (process-status process) 'exit)
            (slime-cancel-connect-retry-timer)
            (message "Failed to connect to Swank: inferior process exited."))




From trittweiler at common-lisp.net  Mon Feb 15 21:42:37 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 15 Feb 2010 16:42:37 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nh8iD-0000o3-G3@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-load-contribs): Do not call SWANK-REQUIRE
	asynchronously, if host Lisp uses :SPAWN that may result in the
	attempt to load in code concurrently -- the host Lisp may not
	support that.

	* slime-asdf.el, slime-autodoc.el, slime-c-p-c.el,
	slime-clipboard.el, slime-fancy-inspector.el, slime-fuzzy,el,
	slime-indentation.el, slime-motd.el,
	slime-presentation-streams.el, slime-presentations.el,
	slime-sbcl-exts, slime-snapshot.el, slime-sprof.el:

	Make sure that contrib code does not try to load in swank code
	asynchronously but use `slime-require' instead; also make sure to
	move the `slime-require' into the contribs' init function.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/14 18:26:01	1.1981
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/15 21:42:37	1.1982
@@ -1,3 +1,10 @@
+2010-02-15  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (slime-load-contribs): Do not call SWANK-REQUIRE
+	asynchronously, if host Lisp uses :SPAWN that may result in the
+	attempt to load in code concurrently -- the host Lisp may not
+	support that.
+
 2010-02-14  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-attempt-connection): Fix typo. Thanks to Mark
--- /project/slime/cvsroot/slime/slime.el	2010/02/14 18:26:01	1.1269
+++ /project/slime/cvsroot/slime/slime.el	2010/02/15 21:42:37	1.1270
@@ -6876,9 +6876,11 @@
                                      (mapcar #'downcase (slime-lisp-modules))))
                            slime-required-modules)))
     (when needed
-      (slime-eval-async `(swank:swank-require ',needed)
-                        (lambda (new-modules)
-                          (setf (slime-lisp-modules) new-modules))))))
+      ;; No asynchronous request because with :SPAWN that could result
+      ;; in the attempt to load modules concurrently which may not be
+      ;; supported by the host Lisp.
+      (setf (slime-lisp-modules) 
+            (slime-eval `(swank:swank-require ',needed))))))
 
 
 ;;;;; Pull-down menu




From trittweiler at common-lisp.net  Mon Feb 15 21:42:37 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 15 Feb 2010 16:42:37 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Nh8iD-0000oK-Uc@common-lisp.net>

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

Modified Files:
	ChangeLog slime-asdf.el slime-autodoc.el slime-c-p-c.el 
	slime-clipboard.el slime-fancy-inspector.el slime-fuzzy.el 
	slime-indentation.el slime-motd.el 
	slime-presentation-streams.el slime-presentations.el 
	slime-sbcl-exts.el slime-snapshot.el slime-sprof.el 
Log Message:
	* slime.el (slime-load-contribs): Do not call SWANK-REQUIRE
	asynchronously, if host Lisp uses :SPAWN that may result in the
	attempt to load in code concurrently -- the host Lisp may not
	support that.

	* slime-asdf.el, slime-autodoc.el, slime-c-p-c.el,
	slime-clipboard.el, slime-fancy-inspector.el, slime-fuzzy,el,
	slime-indentation.el, slime-motd.el,
	slime-presentation-streams.el, slime-presentations.el,
	slime-sbcl-exts, slime-snapshot.el, slime-sprof.el:

	Make sure that contrib code does not try to load in swank code
	asynchronously but use `slime-require' instead; also make sure to
	move the `slime-require' into the contribs' init function.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/01/31 20:17:27	1.342
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/15 21:42:37	1.343
@@ -1,3 +1,15 @@
+2010-02-15  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-asdf.el, slime-autodoc.el, slime-c-p-c.el,
+	slime-clipboard.el, slime-fancy-inspector.el, slime-fuzzy,el,
+	slime-indentation.el, slime-motd.el,
+	slime-presentation-streams.el, slime-presentations.el,
+	slime-sbcl-exts, slime-snapshot.el, slime-sprof.el:
+
+	Make sure that contrib code does not try to load in swank code
+	asynchronously but use `slime-require' instead; also make sure to
+	move the `slime-require' into the contribs' init function.
+
 2010-01-31  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-repl.el (slime-repl-mode): Don't do
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2010/01/05 19:58:57	1.27
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2010/02/15 21:42:37	1.28
@@ -287,11 +287,8 @@
 
 ;;; Initialization
 
-(defun slime-asdf-on-connect ()
-  (slime-eval-async '(swank:swank-require :swank-asdf)))
-
 (defun slime-asdf-init ()
-  (add-hook 'slime-connected-hook 'slime-asdf-on-connect)
+  (slime-require :swank-asdf)
   (add-to-list 'slime-edit-uses-xrefs :depends-on t)
   (define-key slime-who-map [?d] 'slime-who-depends-on))
 
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/01/06 18:23:44	1.34
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/02/15 21:42:37	1.35
@@ -215,6 +215,7 @@
 ;;;; Initialization
 
 (defun slime-autodoc-init ()
+  (slime-require :swank-arglists)
   (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
     (add-hook h 'slime-autodoc-maybe-enable)))
 
@@ -233,8 +234,6 @@
   (dolist (h '(slime-mode-hook slime-repl-mode-hook sldb-mode-hook))
     (remove-hook h 'slime-autodoc-maybe-enable)))
 
-(slime-require :swank-arglists)
-
 ;;;; Test cases
 
 (defun slime-check-autodoc-at-point (arglist)
--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2009/12/30 10:30:13	1.20
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2010/02/15 21:42:37	1.21
@@ -170,6 +170,7 @@
 (defvar slime-c-p-c-init-undo-stack nil)
 
 (defun slime-c-p-c-init ()
+  (slime-require :swank-c-p-c)
   ;; save current state for unload
   (push 
    `(progn
--- /project/slime/cvsroot/slime/contrib/slime-clipboard.el	2008/08/12 17:54:30	1.2
+++ /project/slime/cvsroot/slime/contrib/slime-clipboard.el	2010/02/15 21:42:37	1.3
@@ -17,7 +17,6 @@
 ;;
 
 (require 'slime)
-(slime-require :swank-clipboard)
 
 (define-derived-mode slime-clipboard-mode fundamental-mode
   "Slime-Clipboard"
@@ -166,4 +165,7 @@
    `(:sldb ,(sldb-frame-number-at-point) 
 	   ,(sldb-var-number-at-point))))
 
+(defun slime-clipboard-init ()
+  (slime-require :swank-clipboard))
+
 (provide 'slime-clipboard)
--- /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el	2008/02/10 08:31:21	1.3
+++ /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el	2010/02/15 21:42:37	1.4
@@ -4,6 +4,7 @@
 ;; License: GNU GPL (same license as Emacs)
 ;;
 
-(slime-require :swank-fancy-inspector)
+(defun slime-fancy-inspector-init ()
+  (slime-require :swank-fancy-inspector))
 
 (provide 'slime-fancy-inspector)
\ No newline at end of file
--- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2009/12/11 06:35:20	1.14
+++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2010/02/15 21:42:37	1.15
@@ -593,12 +593,11 @@
 ;;; Initialization 
 
 (defun slime-fuzzy-init ()
-  (slime-fuzzy-bind-keys))
+  (slime-fuzzy-bind-keys)
+  (slime-require :swank-fuzzy))
 
 (defun slime-fuzzy-bind-keys ()
   (define-key slime-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)
   (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol))
 
-(slime-require :swank-fuzzy)
-
 (provide 'slime-fuzzy)
--- /project/slime/cvsroot/slime/contrib/slime-indentation.el	2008/08/20 11:42:47	1.3
+++ /project/slime/cvsroot/slime/contrib/slime-indentation.el	2010/02/15 21:42:37	1.4
@@ -1,10 +1,7 @@
 ;;;; slime-indentation.el - cl-indent.el as a slime-contrib module
 
-(defun slime-indentation-install ()
-  (slime-eval-async '(swank:swank-require :swank-indentation)))
-
 (defun slime-indentation-init ()
-  (add-hook 'slime-connected-hook 'slime-indentation-install))
+  (slime-require :swank-indentation))
 
 ;; redefine this for cl-indent:method
 (defun slime-handle-indentation-update (alist)
--- /project/slime/cvsroot/slime/contrib/slime-motd.el	2008/02/03 18:39:23	1.1
+++ /project/slime/cvsroot/slime/contrib/slime-motd.el	2010/02/15 21:42:37	1.2
@@ -11,19 +11,18 @@
 (require 'slime-banner)
 
 (defcustom slime-motd-pathname nil
-  "The local pathnamethe motd is read from."
+  "The local pathname the motd is read from."
   :group 'slime-mode
   :type '(file :must-match t))
 
 (defun slime-insert-motd ()
-  (slime-eval-async `(cl:progn
-                      (swank:swank-require :swank-motd)
-                      (swank::read-motd ,slime-motd-pathname))
+  (slime-eval-async `(swank::read-motd ,slime-motd-pathname)
                     (lambda (motd)
                       (when motd
                         (slime-repl-insert-result (list :values motd))))))
 
 (defun slime-motd-init ()
+  (swank:swank-require :swank-motd)
   (add-hook 'slime-connected-hook 'slime-insert-motd))
 
 (provide 'slime-motd)
--- /project/slime/cvsroot/slime/contrib/slime-presentation-streams.el	2007/08/28 08:25:12	1.2
+++ /project/slime/cvsroot/slime/contrib/slime-presentation-streams.el	2010/02/15 21:42:37	1.3
@@ -20,10 +20,8 @@
 
 (require 'slime-presentations)
 
-(add-hook 'slime-connected-hook 'slime-install-presentation-streams)
-
-(defun slime-install-presentation-streams ()
-  (slime-eval-async '(swank:swank-require :swank-presentation-streams)))
+(defun slime-presentation-streams-init ()
+  (slime-require :swank-presentation-streams))
 
 (provide 'slime-presentation-streams)
 
--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2009/12/12 18:43:04	1.27
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2010/02/15 21:42:37	1.28
@@ -761,12 +761,11 @@
      (with-current-buffer (slime-output-buffer)
        (let ((marker (slime-output-target-marker target)))
          (goto-char marker)
-         (let ((result-start (point)))
-	   (slime-propertize-region `(face slime-repl-result-face
-					   rear-nonsticky (face))
-	     (insert string))
-           ;; Move the input-start marker after the REPL result.
-           (set-marker marker (point))))))
+         (slime-propertize-region `(face slime-repl-result-face
+                                         rear-nonsticky (face))
+           (insert string))
+         ;; Move the input-start marker after the REPL result.
+         (set-marker marker (point)))))
     (t
      (let* ((marker (slime-output-target-marker target))
             (buffer (and marker (marker-buffer marker))))
@@ -843,6 +842,7 @@
 ;;; Initialization
 
 (defun slime-presentations-init ()
+  (slime-require :swank-presentations)
   (add-hook 'slime-repl-mode-hook
 	    (lambda ()
 	      ;; Respect the syntax text properties of presentation.
@@ -855,7 +855,6 @@
   (add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input)
   (add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
   (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
-  (add-hook 'slime-connected-hook 'slime-install-presentations)
   (add-hook 'slime-edit-definition-hooks 'slime-edit-presentation)
   (setq slime-inspector-insert-ispec-function 'slime-presentation-inspector-insert-ispec)
   (setq sldb-insert-frame-variable-value-function 
@@ -863,9 +862,4 @@
   (slime-presentation-init-keymaps)
   (slime-presentation-add-easy-menu))
 
-(defun slime-install-presentations ()
-  (slime-eval-async '(swank:swank-require :swank-presentations)))
-
-(slime-presentations-init)
-
 (provide 'slime-presentations)
--- /project/slime/cvsroot/slime/contrib/slime-sbcl-exts.el	2009/12/21 16:03:41	1.4
+++ /project/slime/cvsroot/slime/contrib/slime-sbcl-exts.el	2010/02/15 21:42:37	1.5
@@ -30,8 +30,7 @@
   (browse-url (format "http://bugs.launchpad.net/sbcl/+bug/%s" 
                       (substring bug 1))))
 
-(defun slime-sbcl-exts-init ())
-
-(slime-require :swank-sbcl-exts)
+(defun slime-sbcl-exts-init ()
+  (slime-require :swank-sbcl-exts))
 
 (provide 'slime-sbcl-exts)
\ No newline at end of file
--- /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2009/12/22 09:31:15	1.1
+++ /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2010/02/15 21:42:37	1.2
@@ -1,7 +1,5 @@
 ;; slime-snapshot.el --- Save&restore memory images without disconnecting
 
-(slime-require :swank-snapshot)
-
 (defun slime-snapshot (filename)
   "Save a memory image to the file FILENAME."
   (interactive (list (read-file-name "Image file: ")))
@@ -16,3 +14,6 @@
 				,(expand-file-name filename))
 			       nil t nil)
 		  (slime-connection)))
+
+(defun slime-snapshot-init ()
+  (slime-require :swank-snapshot))
\ No newline at end of file
--- /project/slime/cvsroot/slime/contrib/slime-sprof.el	2009/10/14 17:29:15	1.4
+++ /project/slime/cvsroot/slime/contrib/slime-sprof.el	2010/02/15 21:42:37	1.5
@@ -10,8 +10,6 @@
 ;;
 ;;   (slime-setup '(... slime-sprof))
 
-(slime-require :swank-sprof)
-
 (defvar slime-sprof-exclude-swank nil
   "*Display swank functions in the report.")
 
@@ -217,6 +215,7 @@
 ;;; Menu
 
 (defun slime-sprof-init ()
+  (slime-require :swank-sprof)
   (let ((C '(and (slime-connected-p)
              (equal (slime-lisp-implementation-type) "SBCL"))))
     (setf (cdr (last (assoc "Profiling" slime-easy-menu)))




From trittweiler at common-lisp.net  Tue Feb 16 11:08:01 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 16 Feb 2010 06:08:01 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhLHd-0005NT-Ji@common-lisp.net>

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

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

	* swank-ecl.lisp: We depend on ECL 10.2.1 which is not released
	yet -- you need git/cvs HEAD. Added :spawn, and :fd-handler as
	communication-style (Thanks to Ram Krishnan), improve compilation
	hooks so highligting of warnings works, + various cleanup.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/15 21:42:37	1.1982
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/16 11:08:01	1.1983
@@ -1,3 +1,12 @@
+2010-02-16  Tobias C. Rittweiler <tcr at freebits.de>
+
+	Pimp my swank.
+
+	* swank-ecl.lisp: We depend on ECL 10.2.1 which is not released
+	yet -- you need git/cvs HEAD. Added :spawn, and :fd-handler as
+	communication-style (Thanks to Ram Krishnan), improve compilation
+	hooks so highligting of warnings works, + various cleanup.
+
 2010-02-15  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-load-contribs): Do not call SWANK-REQUIRE
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/07 22:33:53	1.51
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/16 11:08:01	1.52
@@ -10,25 +10,33 @@
 
 (in-package :swank-backend)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
+    (when (or (not version) (< (symbol-value version) 100201))
+      (error "~&IMPORTANT:~%  ~
+              The version of ECL you're using (~A) is too old.~%  ~
+              Please upgrade to at least 10.2.1.~%  ~
+              Sorry for the inconvenience.~%~%"
+             (lisp-implementation-version)))))
+
 (declaim (optimize (debug 3)))
 
-(defvar *tmp*)
+;;; Swank-mop
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (if (find-package :gray)
-      (import-from :gray *gray-stream-symbols* :swank-backend)
-      (import-from :ext *gray-stream-symbols* :swank-backend))
+  (import-from :gray *gray-stream-symbols* :swank-backend)
 
-  (swank-backend::import-swank-mop-symbols :clos
+  (import-swank-mop-symbols :clos
     '(:eql-specializer
       :eql-specializer-object
       :generic-function-declarations
       :specializer-direct-methods
       :compute-applicable-methods-using-classes)))
 
-(defun swank-mop:compute-applicable-methods-using-classes (gf classes)
-  (declare (ignore gf classes))
-  (values nil nil))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (probe-file "sys:serve-event.fas")
+    (require :serve-event)
+    (pushnew :serve-event *features*)))
 
 
 ;;;; TCP Server
@@ -53,20 +61,18 @@
   (nth-value 1 (sb-bsd-sockets:socket-name socket)))
 
 (defimplementation close-socket (socket)
+  (when (eq (preferred-communication-style) :fd-handler)
+    (remove-fd-handlers socket))
   (sb-bsd-sockets:socket-close socket))
 
 (defimplementation accept-connection (socket
                                       &key external-format
                                       buffering timeout)
   (declare (ignore buffering timeout external-format))
-  (make-socket-io-stream (accept socket)))
-
-(defun make-socket-io-stream (socket)
-  (sb-bsd-sockets:socket-make-stream socket
+  (sb-bsd-sockets:socket-make-stream (accept socket)
                                      :output t
                                      :input t
                                      :element-type 'base-char))
-
 (defun accept (socket)
   "Like socket-accept, but retry on EAGAIN."
   (loop (handler-case
@@ -74,7 +80,10 @@
           (sb-bsd-sockets:interrupted-error ()))))
 
 (defimplementation preferred-communication-style ()
-  (values nil))
+  ;; ECL on Windows does not provide condition-variables
+  (or #+ (and threads (not win32) (not win64)) :spawn
+      #+serve-event :fd-handler
+      nil))
 
 (defvar *external-format-to-coding-system*
   '((:iso-8859-1
@@ -89,30 +98,28 @@
 
 ;;;; Unix signals
 
+(defvar *original-sigint-handler* #'si:terminal-interrupt)
+
 (defimplementation install-sigint-handler (handler)
+  (declare (function handler))
   (let ((old-handler (symbol-function 'si:terminal-interrupt)))
     (setf (symbol-function 'si:terminal-interrupt)
-          (if (consp handler)
-              (car handler)
+          (if (eq handler *original-sigint-handler*)
+              handler
               (lambda (&rest args)
                 (declare (ignore args))
                 (funcall handler)
                 (continue))))
-    (list old-handler)))
+    old-handler))
 
 
 (defimplementation getpid ()
   (si:getpid))
 
-#+nil
 (defimplementation set-default-directory (directory)
-  (ext::chdir (namestring directory))
-  ;; Setting *default-pathname-defaults* to an absolute directory
-  ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
-  (setf *default-pathname-defaults* (ext::getcwd))
+  (ext:chdir (namestring directory))  ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
   (default-directory))
 
-#+nil
 (defimplementation default-directory ()
   (namestring (ext:getcwd)))
 
@@ -120,55 +127,101 @@
   (ext:quit))
 
 
+;;;; Serve Event Handlers
+
+;;; FIXME: verify this is correct implementation
+
+#+serve-event
+(progn
+  
+(defun socket-fd (socket)
+  (etypecase socket
+    (fixnum socket)
+    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+    (file-stream (si:file-stream-fd socket))))
+
+(defvar *descriptor-handlers* (make-hash-table :test 'eql))
+
+(defimplementation add-fd-handler (socket fun)
+  (let* ((fd (socket-fd socket))
+         (handler (gethash fd *descriptor-handlers*)))
+    (when handler
+      (serve-event:remove-fd-handler handler))
+    (setf (gethash fd *descriptor-handlers*)
+          (serve-event:add-fd-handler fd :input #'(lambda (x)
+                                                    (declare (ignore x))
+                                                    (funcall fun))))
+    (serve-event:serve-event)))
+
+(defimplementation remove-fd-handlers (socket)
+  (let ((handler (gethash (socket-fd socket) *descriptor-handlers*)))
+    (when handler
+      (serve-event:remove-fd-handler handler))))
+
+(defimplementation wait-for-input (streams &optional timeout)
+  (assert (member timeout '(nil t)))
+  (loop
+     (let ((ready (remove-if-not #'listen streams)))
+       (when ready (return ready)))
+     ;; (when timeout (return nil))
+     (when (check-slime-interrupts) (return :interrupt))
+     (serve-event:serve-event)))
+
+) ; #+serve-event (progn ...
+
+
 ;;;; Compilation
 
 (defvar *buffer-name* nil)
 (defvar *buffer-start-position*)
-(defvar *buffer-string*)
-(defvar *compile-filename*)
 
 (defun signal-compiler-condition (&rest args)
   (signal (apply #'make-condition 'compiler-condition args)))
 
-(defun handle-compiler-warning (condition)
-  (signal-compiler-condition
-   :original-condition condition
-   :message (format nil "~A" condition)
-   :severity :warning
-   :location
-   (if *buffer-name*
-       (make-location (list :buffer *buffer-name*)
-                      (list :offset *buffer-start-position* 0))
-       ;; ;; compiler::*current-form*
-       ;; (if compiler::*current-function*
-       ;;     (make-location (list :file *compile-filename*)
-       ;;                    (list :function-name   
-       ;;                          (symbol-name
-       ;;                           (slot-value compiler::*current-function*
-       ;;                                       'compiler::name))))
-       (list :error "No location found.")
-           ;; )
-       )))
+(defun handle-compiler-message (condition)
+  ;; ECL emits lots of noise in compiler-notes, like "Invoking
+  ;; external command".
+  (unless (typep condition 'c::compiler-note)
+    (signal-compiler-condition
+     :original-condition condition
+     :message (format nil "~A" condition)
+     :severity (etypecase condition
+                 (c:compiler-fatal-error :error)
+                 (c:compiler-error :error)
+                 (error            :error)
+                 (style-warning    :style-warning)
+                 (warning          :warning))
+     :location (condition-location condition))))
+
+(defun condition-location (condition)
+  (let ((file     (c:compiler-message-file condition))
+        (position (c:compiler-message-file-position condition)))
+    (if (and position (not (minusp position)))
+        (if *buffer-name*
+            (make-location `(:buffer ,*buffer-name*)
+                           `(:offset ,*buffer-start-position* ,position)
+                           `(:align t))
+            (make-location `(:file ,(namestring file))
+                           `(:position ,(1+ position))
+                           `(:align t)))
+        (make-error-location "No location found."))))
 
 (defimplementation call-with-compilation-hooks (function)
-  (handler-bind ((warning #'handle-compiler-warning))
+  (handler-bind ((c:compiler-message #'handle-compiler-message))
     (funcall function)))
 
 (defimplementation swank-compile-file (input-file output-file
                                        load-p external-format)
   (declare (ignore external-format))
   (with-compilation-hooks ()
-    (let ((*buffer-name* nil)
-          (*compile-filename* input-file))
-      (compile-file input-file :output-file output-file :load t))))
+    (compile-file input-file :output-file output-file :load load-p)))
 
 (defimplementation swank-compile-string (string &key buffer position filename
                                          policy)
   (declare (ignore filename policy))
   (with-compilation-hooks ()
     (let ((*buffer-name* buffer)
-          (*buffer-start-position* position)
-          (*buffer-string* string))
+          (*buffer-start-position* position))
       (with-input-from-string (s string)
         (not (nth-value 2 (compile-from-stream s :load t)))))))
 
@@ -236,9 +289,8 @@
     (generic-function (clos:generic-function-name f))
     (function (si:compiled-function-name f))))
 
-(defimplementation macroexpand-all (form)
-  ;;; FIXME! This is not the same as a recursive macroexpansion!
-  (macroexpand form))
+;; FIXME
+;; (defimplementation macroexpand-all (form))
 
 (defimplementation describe-symbol-for-emacs (symbol)
   (let ((result '()))
@@ -276,6 +328,24 @@
      si::set-current-ihs
      si::tpl-commands)))
 
+(defun make-invoke-debugger-hook (hook)
+  (when hook
+    #'(lambda (condition old-hook)
+        ;; Regard *debugger-hook* if set by user.
+        (if *debugger-hook*
+            nil         ; decline, *DEBUGGER-HOOK* will be tried next.
+            (funcall hook condition old-hook)))))
+
+(defimplementation install-debugger-globally (function)
+  (setq *debugger-hook* function)
+  (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
+
+(defimplementation call-with-debugger-hook (hook fun)
+  (let ((*debugger-hook* hook)
+        (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
+        (*ihs-base* (ihs-top)))
+    (funcall fun)))
+
 (defvar *backtrace* '())
 
 (defun in-swank-package-p (x)
@@ -305,20 +375,10 @@
      (declare (ignore position))
      (if file (is-swank-source-p file)))))
 
-#+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
-(defmacro find-ihs-top (x)
-  (if (< ext:+ecl-version-number+ 90601)
-      `(si::ihs-top ,x)
-      '(si::ihs-top)))
-
-#-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
-(defmacro find-ihs-top (x) 
-  `(si::ihs-top ,x))
-
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
   (let* ((*tpl-commands* si::tpl-commands)
-         (*ihs-top* (find-ihs-top 'call-with-debugging-environment))
+         (*ihs-top* (ihs-top))
          (*ihs-current* *ihs-top*)
          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
          (*frs-top* (frs-top))
@@ -337,17 +397,11 @@
                    (unless (si::fixnump name)
                      (push name (third x)))))))
     (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
-    (setf *tmp* *backtrace*)
     (set-break-env)
     (set-current-ihs)
     (let ((*ihs-base* *ihs-top*))
       (funcall debugger-loop-fn))))
 
-(defimplementation call-with-debugger-hook (hook fun)
-  (let ((*debugger-hook* hook)
-        (*ihs-base* (find-ihs-top 'call-with-debugger-hook)))
-    (funcall fun)))
-
 (defimplementation compute-backtrace (start end)
   (when (numberp end)
     (setf end (min end (length *backtrace*))))
@@ -379,12 +433,7 @@
   (let ((functions '())
         (blocks '())
         (variables '()))
-    #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
-    #.(if (< ext:+ecl-version-number+ 90601)
-        '(setf frame (second frame))
-        '(setf frame (si::decode-ihs-env (second frame))))
-    #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
-    '(setf frame (second frame))
+    (setf frame (si::decode-ihs-env (second frame)))
     (dolist (record frame)
       (let* ((record0 (car record))
 	     (record1 (cdr record)))
@@ -460,11 +509,11 @@
                        ("Input stream" (two-way-stream-input-stream o))))
        (ignore-errors (label-value-line*
                        ("Output stream" (two-way-stream-output-stream o)))))))
-    (t
+    ((si:instancep o)
      (let* ((cl (si:instance-class o))
             (slots (clos:class-slots cl)))
        (list* (format nil "~S is an instance of class ~A~%"
-                       o (clos::class-name cl))
+                      o (clos::class-name cl))
                (loop for x in slots append
                     (let* ((name (clos:slot-definition-name x))
                            (value (clos::slot-value o name)))
@@ -481,7 +530,6 @@
         `(((defun ,name) ,tmp)))))
 
 (defimplementation find-source-location (obj)
-  (setf *tmp* obj)
   (or
    (typecase obj
      (function
@@ -492,19 +540,16 @@
               `(:position ,pos)
               `(:snippet
                 ,(with-open-file (s file)
-
-                                 #+#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
-                                 (if (< ext:+ecl-version-number+ 90601)
-                                     (skip-toplevel-forms pos s)
-                                     (file-position s pos))
-                                 #-#.(swank-backend:with-symbol '+ECL-VERSION-NUMBER+ 'EXT)
-                                 (skip-toplevel-forms pos s)
-                                 (skip-comments-and-whitespace s)
-                                 (read-snippet s))))))))
+                   (file-position s pos)
+                   (skip-comments-and-whitespace s)
+                   (read-snippet s))))))))
    `(:error ,(format nil "Source definition of ~S not found" obj))))
 
 ;;;; Profiling
 
+#+profile
+(progn
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (require 'profile))
 
@@ -531,70 +576,54 @@
 (defimplementation profile-package (package callers methods)
   (declare (ignore callers methods))
   (eval `(profile:profile ,(package-name (find-package package)))))
+)                                       ; progn
 
-;;;; Communication-Styles
-
-;;; :SPAWN
+;;;; Threads
 
 #+threads
 (progn
-  

[158 lines skipped]




From trittweiler at common-lisp.net  Tue Feb 16 11:28:19 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 16 Feb 2010 06:28:19 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhLbH-0006VP-68@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
	* swank-loader.lisp: Compile files on ECL, too.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/16 11:08:01	1.1983
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/16 11:28:18	1.1984
@@ -1,5 +1,9 @@
 2010-02-16  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-loader.lisp: Compile files on ECL, too.
+
+2010-02-16  Tobias C. Rittweiler <tcr at freebits.de>
+
 	Pimp my swank.
 
 	* swank-ecl.lisp: We depend on ECL 10.2.1 which is not released
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/01/19 19:41:00	1.98
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/16 11:28:19	1.99
@@ -43,7 +43,8 @@
   #+clisp '(xref metering swank-clisp swank-gray)
   #+armedbear '(swank-abcl)
   #+cormanlisp '(swank-corman swank-gray)
-  #+ecl '(swank-source-path-parser swank-source-file-cache swank-ecl swank-gray))
+  #+ecl '(swank-source-path-parser swank-source-file-cache
+          swank-ecl swank-gray))
 
 (defparameter *implementation-features*
   '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp
@@ -156,9 +157,9 @@
           (serious-condition (c)
             (handle-loadtime-error c dest)))))))
 
-#+(or cormanlisp ecl)
+#+(or cormanlisp)
 (defun compile-files (files fasl-dir load)
-  "Corman Lisp and ECL have trouble with compiled files."
+  "Corman Lisp has trouble with compiled files."
   (declare (ignore fasl-dir))
   (when load
     (dolist (file files)
@@ -182,16 +183,18 @@
                            :defaults src-dir))
           names))
 
-(defvar *swank-files* `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
+(defvar *swank-files*
+  `(swank-backend ,@*sysdep-files* swank-match swank-rpc swank))
 
-(defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
-                     swank-fancy-inspector
-                     swank-presentations swank-presentation-streams
-                     #+(or asdf sbcl) swank-asdf
-                     swank-package-fu
-                     swank-hyperdoc
-                     swank-sbcl-exts
-                     )
+(defvar *contribs*
+  '(swank-c-p-c swank-arglists swank-fuzzy
+    swank-fancy-inspector
+    swank-presentations swank-presentation-streams
+    #+(or asdf sbcl ecl) swank-asdf
+    swank-package-fu
+    swank-hyperdoc
+    swank-sbcl-exts
+    )
   "List of names for contrib modules.")
 
 (defvar *fasl-directory* (default-fasl-dir)




From heller at common-lisp.net  Wed Feb 17 17:04:00 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:00 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnJg-00043M-3y@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
Test suite hangs for CCL and CMUCL.

* slime.el ([test] compile-defun): Remove those compile-time read
errors for which some implementations invoke the debugger.

--- /project/slime/cvsroot/slime/slime.el	2010/02/15 21:42:37	1.1270
+++ /project/slime/cvsroot/slime/slime.el	2010/02/17 17:03:59	1.1271
@@ -7746,13 +7746,8 @@
        (cl-user::bar))
       ("(defun foo ()
           #+#.'(:and) (/ 1 0))"
-       (/ 1 0)) 
-      ("(defun foo () pkg-does-not-exist:symbol)" 
-       pkg-does-not-exist:symbol)
-      ("(defun foo () swank:symbol-does-not-exist)"
-       swank:symbol-does-not-exist)
-      ("(defun foo (x) ,x)" \,x)
-      ("(defun foo () #@foo)" @foo))
+       (/ 1 0))
+      )
   (slime-check-top-level)    
   (with-temp-buffer
     (lisp-mode)




From heller at common-lisp.net  Wed Feb 17 17:04:06 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:06 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnJm-00043p-4x@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
slime.el (sexp-at-point.1): Remove failing tests.

--- /project/slime/cvsroot/slime/slime.el	2010/02/17 17:03:59	1.1271
+++ /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:05	1.1272
@@ -7546,10 +7546,7 @@
   '(("foo")
     ("#:foo")
     ("#'foo")
-    ("#'(lambda (x) x)")
-    ("#\\space")
-    ("#\\(")
-    ("#\\)"))
+    ("#'(lambda (x) x)"))
   (with-temp-buffer
     (lisp-mode)
     (insert string)
@@ -7560,7 +7557,6 @@
                        (slime-sexp-at-point)
                        #'equal)))
 
-
 (def-slime-test narrowing ()
     "Check that narrowing is properly sustained."
     '()




From heller at common-lisp.net  Wed Feb 17 17:04:13 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:13 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnJt-00044I-6N@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
Get rid or snapshots.

* slime.el (slime-narrowing-configuration, slime-emacs-snapshot)
(slime-current-narrowing-configuration)
(slime-set-narrowing-configuration, slime-current-emacs-snapshot)
(slime-set-emacs-snapshot)
(slime-current-emacs-snapshot-fingerprint, slime-frame-windows):
Deleted.  Update call-sites accordingly.

--- /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:05	1.1272
+++ /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:13	1.1273
@@ -836,78 +836,6 @@
   `(lambda (&rest more) (apply ',fun (append more ',args))))
 
 
-;; FIXME: Get rid or snapshots.
-;;;;; Snapshots of current Emacs state
-
-;;; Window configurations do not save (and hence not restore)
-;;; any narrowing that could be applied to a buffer.
-;;;
-;;; For this purpose, we introduce a superset of a window
-;;; configuration that does include the necessary information to
-;;; properly restore narrowing.
-;;;
-;;; We call this superset an Emacs Snapshot.
-
-(defstruct (slime-narrowing-configuration
-             (:conc-name slime-narrowing-configuration.))
-  narrowedp beg end)
-
-(defstruct (slime-emacs-snapshot (:conc-name slime-emacs-snapshot.))
-  ;; We explicitly store the value of point even though it's implicitly
-  ;; stored in the window-configuration because Emacs provides no
-  ;; way to access the things stored in a window configuration.
-  window-configuration narrowing-configuration point-marker)
-
-(defun slime-current-narrowing-configuration (&optional buffer)
-  (with-current-buffer (or buffer (current-buffer))
-    (make-slime-narrowing-configuration :narrowedp (slime-buffer-narrowed-p)
-                                        :beg (point-min-marker)
-                                        :end (point-max-marker))))
-
-(defun slime-set-narrowing-configuration (narrowing-cfg)
-  (when (slime-narrowing-configuration.narrowedp narrowing-cfg)
-    (narrow-to-region (slime-narrowing-configuration.beg narrowing-cfg)
-                      (slime-narrowing-configuration.end narrowing-cfg))))
-
-(defun slime-current-emacs-snapshot (&optional frame)
-  "Returns a snapshot of the current state of FRAME, or the
-currently active frame if FRAME is not given respectively."
-  (with-current-buffer
-      (if frame
-          (window-buffer (frame-selected-window (selected-frame)))
-          (current-buffer))
-    (make-slime-emacs-snapshot
-     :window-configuration    (current-window-configuration frame)
-     :narrowing-configuration (slime-current-narrowing-configuration)
-     :point-marker            (point-marker))))
-
-(defun slime-set-emacs-snapshot (snapshot)
-  "Restores the state of Emacs according to the information saved
-in SNAPSHOT."
-  (let ((window-cfg    (slime-emacs-snapshot.window-configuration snapshot))
-        (narrowing-cfg (slime-emacs-snapshot.narrowing-configuration snapshot))
-        (marker        (slime-emacs-snapshot.point-marker snapshot)))
-    (set-window-configuration window-cfg) ; restores previously current buffer.
-    (slime-set-narrowing-configuration narrowing-cfg)
-    (goto-char (marker-position marker))))
-
-(defun slime-current-emacs-snapshot-fingerprint (&optional frame)
-  "Return a fingerprint of the current emacs snapshot.
-Fingerprints are `equalp' if and only if they represent window
-configurations that are very similar (same windows and buffers.)
-
-Unlike real window-configuration objects, fingerprints are not
-sensitive to the point moving and they can't be restored."
-  (mapcar (lambda (window) (list window (window-buffer window)))
-          (slime-frame-windows frame)))
-
-(defun slime-frame-windows (&optional frame)
-  "Return the list of windows in FRAME."
-  (loop with last-window = (previous-window (frame-first-window frame))
-        for window = (frame-first-window frame) then (next-window window)
-        collect window
-        until (eq window last-window)))
-
 ;;;;; Temporary popup buffers
 
 (defvar slime-popup-restore-data nil
@@ -928,8 +856,7 @@
 (defvar slime-buffer-connection)
 
 ;; Interface
-(defmacro* slime-with-popup-buffer ((name &optional package connection select
-                                          emacs-snapshot)
+(defmacro* slime-with-popup-buffer ((name &optional package connection select)
                                     &body body)
   "Similar to `with-output-to-temp-buffer'.
 Bind standard-output and initialize some buffer-local variables.
@@ -940,14 +867,9 @@
 CONNECTION is the value for `slime-buffer-connection'.
 If nil, no explicit connection is associated with
 the buffer.  If t, the current connection is taken.
-
-If EMACS-SNAPSHOT is non-NIL, it's used to restore the previous
-state of Emacs after closing the temporary buffer. Otherwise, the
-current state will be saved and later restored."
+"
   `(let* ((vars% (list ,(if (eq package t) '(slime-current-package) package)
-                       ,(if (eq connection t) '(slime-connection) connection)
-                       ;; Defer the decision for NILness until runtime.
-                       (or ,emacs-snapshot (slime-current-emacs-snapshot))))
+                       ,(if (eq connection t) '(slime-connection) connection)))
           (standard-output (slime-make-popup-buffer ,name vars%)))
      (with-current-buffer standard-output
        (prog1 (progn , at body)
@@ -3888,19 +3810,18 @@
   (interactive (list (slime-read-symbol-name "Edit Uses of: ")))
   (slime-xrefs slime-edit-uses-xrefs
                symbol
-               #'(lambda (xrefs type symbol package snapshot)
-                   (cond
-                     ((null xrefs)
-                      (message "No xref information found for %s." symbol))
-                     ((and (slime-length= xrefs 1)          ; one group
-                           (slime-length= (cdar  xrefs) 1)) ; one ref in group
-                      (destructuring-bind (_ (_ loc)) (first xrefs)
-                        (slime-push-definition-stack)
-                        (slime-pop-to-location loc)))
-                     (t
-                      (slime-push-definition-stack)
-                      (slime-show-xref-buffer xrefs type symbol
-                                              package snapshot))))))
+               (lambda (xrefs type symbol package)
+                 (cond
+                  ((null xrefs)
+                   (message "No xref information found for %s." symbol))
+                  ((and (slime-length= xrefs 1)          ; one group
+                        (slime-length= (cdar  xrefs) 1)) ; one ref in group
+                   (destructuring-bind (_ (_ loc)) (first xrefs)
+                     (slime-push-definition-stack)
+                     (slime-pop-to-location loc)))
+                  (t
+                   (slime-push-definition-stack)
+                   (slime-show-xref-buffer xrefs type symbol package))))))
 
 (defun slime-analyze-xrefs (xrefs)
   "Find common filenames in XREFS.
@@ -4692,8 +4613,6 @@
 ;;;; XREF: cross-referencing
 
 (defvar slime-xref-mode-map)
-(defvar slime-xref-saved-emacs-snapshot nil
-  "Buffer local variable in xref windows.")
 
 (define-derived-mode slime-xref-mode lisp-mode "Xref"
   "slime-xref-mode: Major mode for cross-referencing.
@@ -4734,13 +4653,12 @@
 ;; to move through the xref buffer implicitly from the source
 ;; buffer by using C-M-. and C-M-,.
 ;; FIXME: the claim about ergonomics is very weak
-(defmacro* slime-with-xref-buffer ((xref-type symbol &optional package 
-                                              emacs-snapshot)
+(defmacro* slime-with-xref-buffer ((xref-type symbol &optional package)
                                    &body body)
   "Execute BODY in a xref buffer, then show that buffer."
   `(let ((xref-buffer-name% (format "*slime xref[%s: %s]*" 
                                     ,xref-type ,symbol)))
-     (slime-with-popup-buffer (xref-buffer-name% ,package t nil ,emacs-snapshot)
+     (slime-with-popup-buffer (xref-buffer-name% ,package t nil)
        (slime-xref-mode)
        (slime-set-truncate-lines)
        (erase-buffer)
@@ -4762,8 +4680,8 @@
   ;; Remove the final newline to prevent accidental window-scrolling
   (backward-delete-char 1))
 
-(defun slime-show-xref-buffer (xrefs type symbol package emacs-snapshot)
-  (slime-with-xref-buffer (type symbol package emacs-snapshot)
+(defun slime-show-xref-buffer (xrefs type symbol package)
+  (slime-with-xref-buffer (type symbol package)
     (slime-insert-xrefs xrefs)
     (goto-char (point-min))
     (setq slime-next-location-function 'slime-goto-next-xref)
@@ -4780,11 +4698,11 @@
   "The most recent XREF results buffer.
 This is used by `slime-goto-next-xref'")
 
-(defun slime-show-xrefs (xrefs type symbol package &optional emacs-snapshot)
+(defun slime-show-xrefs (xrefs type symbol package)
   "Show the results of an XREF query."
   (if (null xrefs)
       (message "No references found for %s." symbol)
-      (slime-show-xref-buffer xrefs type symbol package emacs-snapshot)))
+      (slime-show-xref-buffer xrefs type symbol package)))
 
 
 ;;;;; XREF commands
@@ -4838,15 +4756,14 @@
   "Make an XREF request to Lisp."
   (slime-eval-async
    `(swank:xref ',type ',symbol)
-   (slime-rcurry (lambda (result type symbol package snapshot cont)
+   (slime-rcurry (lambda (result type symbol package cont)
                    (slime-check-xref-implemented type result)
                    (let ((file-alist (cadr (slime-analyze-xrefs result))))
                      (funcall (or cont 'slime-show-xrefs)
-                              file-alist type symbol package snapshot)))
+                              file-alist type symbol package)))
                  type 
                  symbol 
                  (slime-current-package)
-                 (slime-current-emacs-snapshot)
                  continuation)))
 
 (defun slime-check-xref-implemented (type xrefs)
@@ -4862,16 +4779,15 @@
   "Make multiple XREF requests at once."
   (slime-eval-async
    `(swank:xrefs ',types ',symbol)
-   (slime-rcurry (lambda (result types symbol package snapshot cont)
+   (slime-rcurry (lambda (result types symbol package cont)
                    (funcall (or cont 'slime-show-xrefs)
                             (slime-map-alist #'slime-xref-type 
                                              #'identity 
                                              result)
-                            types symbol package snapshot))
+                            types symbol package))
                  types 
                  symbol 
                  (slime-current-package)
-                 (slime-current-emacs-snapshot)
                  continuation)))
 
 




From heller at common-lisp.net  Wed Feb 17 17:04:20 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:20 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnK0-00044q-J1@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
Select the xref buffer.
I never could get used to the next/prev cycling.

* slime.el (slime-with-xref-buffer): Select the buffer.
(slime-insert-xrefs): Add point-entered hook to automatically
display the current location.
(slime-xref-entered): New function.
(slime-show-buffer-position): Don't use reposition-window which
seems very slow and doesn't even do a particularly good job.  The
new heuristic is much cruder but faster.
(slime-xref-mode-map): Remove apparently redundant bindings for
RET.

--- /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:13	1.1273
+++ /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:20	1.1274
@@ -4631,10 +4631,8 @@
 
 (slime-define-keys slime-xref-mode-map 
   ((kbd "RET") 'slime-show-xref)
-  ([return] 'slime-show-xref)
-  ("\C-m" 'slime-show-xref)
   (" " 'slime-goto-xref)
-  ("n" 'slime-next-line/not-add-newlines)
+  ("n" 'forward-line)
   ("p" 'previous-line)
   ("\C-c\C-c" 'slime-recompile-xref)
   ("\C-c\C-k" 'slime-recompile-all-xrefs)
@@ -4648,17 +4646,12 @@
 
 ;;;;; XREF results buffer and window management
 
-
-;; Do not select the xref buffer; it's most often more ergonomic
-;; to move through the xref buffer implicitly from the source
-;; buffer by using C-M-. and C-M-,.
-;; FIXME: the claim about ergonomics is very weak
 (defmacro* slime-with-xref-buffer ((xref-type symbol &optional package)
                                    &body body)
   "Execute BODY in a xref buffer, then show that buffer."
   `(let ((xref-buffer-name% (format "*slime xref[%s: %s]*" 
                                     ,xref-type ,symbol)))
-     (slime-with-popup-buffer (xref-buffer-name% ,package t nil)
+     (slime-with-popup-buffer (xref-buffer-name% ,package t t)
        (slime-xref-mode)
        (slime-set-truncate-lines)
        (erase-buffer)
@@ -4674,19 +4667,29 @@
   (loop for (group . refs) in xref-alist do 
         (slime-insert-propertized '(face bold) group "\n")
         (loop for (label location) in refs do
-              (slime-insert-propertized (list 'slime-location location
-                                              'face 'font-lock-keyword-face)
-                                        "  " (slime-one-line-ify label) "\n")))
+              (slime-insert-propertized 
+               (list 'slime-location location 'face 'font-lock-keyword-face
+                     'point-entered 'slime-xref-entered)
+               "  " (slime-one-line-ify label) "\n")))
   ;; Remove the final newline to prevent accidental window-scrolling
   (backward-delete-char 1))
 
+(defun slime-xref-entered (old new)
+  (let ((old (get-text-property old 'slime-location))
+        (loc (get-text-property new 'slime-location)))
+    (unless (eq old loc)
+      (ecase (car loc)
+        (:location (slime-show-source-location loc))
+        (:error (message "%s" (cadr loc)))
+        ((nil))))))
+
 (defun slime-show-xref-buffer (xrefs type symbol package)
   (slime-with-xref-buffer (type symbol package)
     (slime-insert-xrefs xrefs)
-    (goto-char (point-min))
     (setq slime-next-location-function 'slime-goto-next-xref)
     (setq slime-previous-location-function 'slime-goto-previous-xref)
-    (setq slime-xref-last-buffer (current-buffer))))
+    (setq slime-xref-last-buffer (current-buffer))
+    (goto-char (point-min))))
 
 (defvar slime-next-location-function nil
   "Function to call for going to the next location.")
@@ -5627,7 +5630,8 @@
         (center (recenter))
         ((nil)
          (unless (pos-visible-in-window-p)
-           (reposition-window)))))))
+           (cond ((= (current-column) 0) (recenter 1))
+                 (t (recenter)))))))))
 
 (defun sldb-recenter-region (start end &optional center)
   "Make the region from START to END visible.




From heller at common-lisp.net  Wed Feb 17 17:04:26 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:26 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnK6-00045M-5p@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
Point-entered hooks in xref buffer don't work so well.
Use forward/backward commands intead.

* slime.el (slime-xref-next-line, slime-xref-prev-line): New
commands.
(slime-xref-show-location): New aux function.
(slime-xref-mode-map): Remap up/down to next/prev location
commands.  Make SPC and RET do the same.

--- /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:20	1.1274
+++ /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:26	1.1275
@@ -4629,14 +4629,20 @@
   (setq delayed-mode-hooks nil)
   (slime-mode -1))
 
-(slime-define-keys slime-xref-mode-map 
-  ((kbd "RET") 'slime-show-xref)
-  (" " 'slime-goto-xref)
-  ("n" 'forward-line)
-  ("p" 'previous-line)
+(slime-define-keys slime-xref-mode-map
+  ((kbd "RET") 'slime-goto-xref)
+  ((kbd "SPC") 'slime-goto-xref)
+  ("v" 'slime-show-xref)
+  ("n" (lambda () (interactive) (next-line)))
+  ("p" (lambda () (interactive) (previous-line)))
   ("\C-c\C-c" 'slime-recompile-xref)
   ("\C-c\C-k" 'slime-recompile-all-xrefs)
-  ("\M-," 'slime-xref-retract))
+  ("\M-," 'slime-xref-retract)
+  ([remap next-line] 'slime-xref-next-line)
+  ([remap previous-line] 'slime-xref-prev-line)
+  ;; for XEmacs:
+  ([down] 'slime-xref-next-line)
+  ([up] 'slime-xref-prev-line))
 
 (defun slime-next-line/not-add-newlines ()
   (interactive)
@@ -4668,20 +4674,24 @@
         (slime-insert-propertized '(face bold) group "\n")
         (loop for (label location) in refs do
               (slime-insert-propertized 
-               (list 'slime-location location 'face 'font-lock-keyword-face
-                     'point-entered 'slime-xref-entered)
+               (list 'slime-location location 'face 'font-lock-keyword-face)
                "  " (slime-one-line-ify label) "\n")))
   ;; Remove the final newline to prevent accidental window-scrolling
   (backward-delete-char 1))
 
-(defun slime-xref-entered (old new)
-  (let ((old (get-text-property old 'slime-location))
-        (loc (get-text-property new 'slime-location)))
-    (unless (eq old loc)
-      (ecase (car loc)
-        (:location (slime-show-source-location loc))
-        (:error (message "%s" (cadr loc)))
-        ((nil))))))
+(defun slime-xref-next-line ()
+  (interactive)
+  (slime-xref-show-location (slime-search-property 'slime-location)))
+
+(defun slime-xref-prev-line ()
+  (interactive)
+  (slime-xref-show-location (slime-search-property 'slime-location t)))
+
+(defun slime-xref-show-location (loc)
+  (ecase (car loc)
+    (:location (slime-show-source-location loc t))
+    (:error (message "%s" (cadr loc)))
+    ((nil))))
 
 (defun slime-show-xref-buffer (xrefs type symbol package)
   (slime-with-xref-buffer (type symbol package)
@@ -4877,10 +4887,8 @@
              (not (or (setq prop-value (funcall prop-value-fn)) 
                       (eobp) 
                       (bobp)))))
-    (if prop-value
-        prop-value
-     (goto-char start)
-     nil)))
+    (cond (prop-value)
+          (t (goto-char start) nil))))
 
 (defun slime-next-location ()
   "Go to the next location, depending on context.




From heller at common-lisp.net  Wed Feb 17 17:04:34 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:34 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnKE-00045u-6c@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Forgotten log entry

--- /project/slime/cvsroot/slime/ChangeLog	2010/02/16 11:28:18	1.1984
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/17 17:04:33	1.1985
@@ -1,3 +1,4 @@
+
 2010-02-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-loader.lisp: Compile files on ECL, too.




From heller at common-lisp.net  Wed Feb 17 17:04:46 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:46 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnKQ-00046Q-5T@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank-backend.lisp swank-cmucl.lisp 
	swank.lisp 
Log Message:
Add a command to eval stuff in the inspector.

* slime.el (slime-inspector-eval): New command.
(slime-inspector-mode-map): Bind it to 'e'.
* swank.lisp (inspector-eval): New function.
* swank-backend.lisp (eval-context): New function.
* swank-cmucl.lisp (eval-context): Implement it.

--- /project/slime/cvsroot/slime/ChangeLog	2010/02/17 17:04:33	1.1985
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/17 17:04:45	1.1986
@@ -1,4 +1,3 @@
-
 2010-02-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-loader.lisp: Compile files on ECL, too.
--- /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:26	1.1275
+++ /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:46	1.1276
@@ -6529,6 +6529,11 @@
                          (error "No part at point"))))
   (slime-eval-describe `(swank:pprint-inspector-part ,part)))
 
+(defun slime-inspector-eval (string)
+  "Eval an expression in the context of the inspected object."
+  (interactive (list (slime-read-from-minibuffer "Inspector eval: ")))
+  (slime-eval-with-transcript `(swank:inspector-eval ,string)))
+
 (defun slime-inspector-show-source (part)
   (interactive (list (or (get-text-property (point) 'slime-part-number)
                          (error "No part at point"))))
@@ -6621,6 +6626,7 @@
   (" " 'slime-inspector-next)
   ("d" 'slime-inspector-describe)
   ("p" 'slime-inspector-pprint)
+  ("e" 'slime-inspector-eval)
   ("q" 'slime-inspector-quit)
   ("g" 'slime-inspector-reinspect)
   ("v" 'slime-inspector-toggle-verbose)
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/01/06 14:13:48	1.191
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/17 17:04:46	1.192
@@ -992,6 +992,10 @@
      (:newline) (:newline)
      ,(with-output-to-string (desc) (describe object desc))))
 
+(definterface eval-context (object)
+  "Return a list of bindings corresponding to OBJECT's slots."
+  (declare (ignore object))
+  '())
 
 ;;; Utilities for inspector methods.
 ;;; 
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/01/05 09:00:30	1.218
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/02/17 17:04:46	1.219
@@ -2141,6 +2141,19 @@
     (alien::alien-record-type (inspect-alien-record alien))
     (alien::alien-pointer-type (inspect-alien-pointer alien))
     (t (cmucl-inspect alien))))
+
+(defimplementation eval-context (obj)
+  (cond ((typep (class-of obj) 'structure-class)
+         (let* ((dd (kernel:layout-info (kernel:layout-of obj)))
+                (slots (kernel:dd-slots dd)))
+           (list* (cons '*package* 
+                        (symbol-package (if slots 
+                                            (kernel:dsd-name (car slots))
+                                            (kernel:dd-name dd))))
+                  (loop for slot in slots collect 
+                        (cons (kernel:dsd-name slot)
+                              (funcall (kernel:dsd-accessor slot) obj))))))))
+                 
 
 ;;;; Profiling
 (defimplementation profile (fname)
--- /project/slime/cvsroot/slime/swank.lisp	2010/02/07 11:44:41	1.688
+++ /project/slime/cvsroot/slime/swank.lisp	2010/02/17 17:04:46	1.689
@@ -3260,8 +3260,6 @@
         (format nil "#~D=~A" pos string)
         string)))
 
-
-
 (defun content-range (list start end)
   (typecase list
     (list (let ((len (length list)))
@@ -3314,6 +3312,18 @@
   (setf (istate.verbose *istate*) (not (istate.verbose *istate*)))
   (istate>elisp *istate*))
 
+(defslimefun inspector-eval (string)
+  (let* ((obj (istate.object *istate*))
+         (context (eval-context obj))
+         (form (with-buffer-syntax ((cdr (assoc '*package* context)))
+                 (read-from-string string)))
+         (ignorable (remove-if #'boundp (mapcar #'car context))))
+    (to-string (eval `(let ((* ',obj) (- ',form)
+                            . ,(loop for (var . val) in context collect
+                                     `(,var ',val)))
+                        (declare (ignorable . ,ignorable))
+                        ,form)))))
+
 (defslimefun quit-inspector ()
   (reset-inspector)
   nil)




From heller at common-lisp.net  Wed Feb 17 17:04:50 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:50 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NhnKU-00047A-Rc@common-lisp.net>

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

Modified Files:
	ChangeLog inferior-slime.el 
Log Message:
Fix bugs when *inferior-buffers* doesn't exist.

* inferior-slime.el (inferior-slime-start-transcript)
(inferior-slime-stop-transcript): Make sure the buffer exists.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/15 21:42:37	1.343
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/17 17:04:50	1.344
@@ -26,6 +26,13 @@
 	(slime-search-exports-in-defpackage): take #:symbol and :symbol
 	into account too.
 
+2010-02-17  Helmut Eller  <heller at common-lisp.net>
+
+	Fix bugs when *inferior-buffers* doesn't exist.
+
+	* inferior-slime.el (inferior-slime-start-transcript)
+	(inferior-slime-stop-transcript): Make sure the buffer exists.
+
 2010-01-14  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-repl.el: Revert the previous change because it
--- /project/slime/cvsroot/slime/contrib/inferior-slime.el	2010/01/05 10:03:02	1.9
+++ /project/slime/cvsroot/slime/contrib/inferior-slime.el	2010/02/17 17:04:50	1.10
@@ -101,19 +101,23 @@
   (display-buffer (process-buffer (slime-inferior-process)) t))
 
 (defun inferior-slime-start-transcript ()
-  (with-current-buffer (process-buffer (slime-inferior-process))
-    (add-hook 'comint-output-filter-functions 
-	      'inferior-slime-show-transcript
-	      nil t)))
+  (let ((proc (slime-inferior-process)))
+    (when proc
+      (with-current-buffer (process-buffer proc)
+	(add-hook 'comint-output-filter-functions 
+		  'inferior-slime-show-transcript
+		  nil t)))))
 
 (defun inferior-slime-stop-transcript ()
-  (with-current-buffer (process-buffer (slime-inferior-process))
-    (run-with-timer 0.2 nil 
-		    (lambda (buffer) 
-		      (with-current-buffer buffer
-			(remove-hook 'comint-output-filter-functions
-				     'inferior-slime-show-transcript t)))
-		    (current-buffer))))
+  (let ((proc (slime-inferior-process)))
+    (when proc
+      (with-current-buffer (process-buffer (slime-inferior-process))
+	(run-with-timer 0.2 nil 
+			(lambda (buffer) 
+			  (with-current-buffer buffer
+			    (remove-hook 'comint-output-filter-functions
+					 'inferior-slime-show-transcript t)))
+			(current-buffer))))))
 
 (defun inferior-slime-init ()
   (add-hook 'slime-inferior-process-start-hook 'inferior-slime-hook-function)




From heller at common-lisp.net  Wed Feb 17 17:04:59 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:59 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NhnKd-00047q-G4@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Fix changelogs.

--- /project/slime/cvsroot/slime/ChangeLog	2010/02/17 17:04:45	1.1986
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/17 17:04:59	1.1987
@@ -1,3 +1,58 @@
+2010-02-17  Helmut Eller  <heller at common-lisp.net>
+
+	Add a command to eval stuff in the inspector.
+
+	* slime.el (slime-inspector-eval): New command.
+	(slime-inspector-mode-map): Bind it to 'e'.
+	* swank.lisp (inspector-eval): New function.
+	* swank-backend.lisp (eval-context): New function.
+	* swank-cmucl.lisp (eval-context): Implement it.
+
+2010-02-17  Helmut Eller  <heller at common-lisp.net>
+
+	Point-entered hooks in the xref buffer don't work so well.
+	Use forward/backward commands instead.
+
+	* slime.el (slime-xref-next-line, slime-xref-prev-line): New
+	commands.
+	(slime-xref-show-location): New aux function.
+	(slime-xref-mode-map): Remap up/down to next/prev location
+	commands.  Make SPC and RET do the same.
+
+2010-02-17  Helmut Eller  <heller at common-lisp.net>
+
+	Select the xref buffer.
+	I never could get used to the next/prev cycling.
+
+	* slime.el (slime-with-xref-buffer): Select the buffer.
+	(slime-insert-xrefs): Add point-entered hook to automatically
+	display the current location.
+	(slime-xref-entered): New function.
+	(slime-show-buffer-position): Don't use reposition-window which
+	seems very slow and doesn't even do a particularly good job.  The
+	new heuristic is much cruder but faster.
+	(slime-xref-mode-map): Remove apparently redundant bindings for
+	RET.
+
+2010-02-17  Helmut Eller  <heller at common-lisp.net>
+
+	Get rid or snapshots.
+
+	* slime.el (slime-narrowing-configuration, slime-emacs-snapshot)
+	(slime-current-narrowing-configuration)
+	(slime-set-narrowing-configuration, slime-current-emacs-snapshot)
+	(slime-set-emacs-snapshot)
+	(slime-current-emacs-snapshot-fingerprint, slime-frame-windows):
+	Deleted.  Update call-sites accordingly.
+
+2010-02-17  Helmut Eller  <heller at common-lisp.net>
+
+	Test suite hangs for CCL and CMUCL.
+
+	* slime.el ([test] compile-defun): Remove those compile-time read
+	errors for which some implementations invoke the debugger.
+	(sexp-at-point.1): Remove failing tests
+
 2010-02-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-loader.lisp: Compile files on ECL, too.




From heller at common-lisp.net  Wed Feb 17 17:04:59 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 17 Feb 2010 12:04:59 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NhnKd-000482-Mr@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Fix changelogs.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/17 17:04:50	1.344
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/17 17:04:59	1.345
@@ -1,3 +1,10 @@
+2010-02-17  Helmut Eller  <heller at common-lisp.net>
+
+	Fix bugs when *inferior-buffers* doesn't exist.
+
+	* inferior-slime.el (inferior-slime-start-transcript)
+	(inferior-slime-stop-transcript): Make sure the buffer exists.
+
 2010-02-15  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-asdf.el, slime-autodoc.el, slime-c-p-c.el,




From heller at common-lisp.net  Thu Feb 18 18:46:02 2010
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 18 Feb 2010 13:46:02 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NiBNy-00050K-MX@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
The compiler warns about various stuff. Fix some of it.

* slime.el (slime-add-local-hook): Remove support for Emacs 20.
(sldb-recenter-region): Use forward-line; not next-line.

Patch by Mark Harig.

--- /project/slime/cvsroot/slime/ChangeLog	2010/02/17 17:04:59	1.1987
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/18 18:46:02	1.1988
@@ -1,3 +1,10 @@
+2010-02-18  Mark Harig <idirectscm at aim.com>
+
+	The compiler warns about various stuff. Fix some of it.
+
+	* slime.el (slime-add-local-hook): Remove support for Emacs 20.
+	(sldb-recenter-region): Use forward-line; not next-line.
+
 2010-02-17  Helmut Eller  <heller at common-lisp.net>
 
 	Add a command to eval stuff in the inspector.
--- /project/slime/cvsroot/slime/slime.el	2010/02/17 17:04:46	1.1276
+++ /project/slime/cvsroot/slime/slime.el	2010/02/18 18:46:02	1.1277
@@ -5665,7 +5665,7 @@
                  (t
                   (goto-char start)
                   (unless noninteractive ; for running the test suite
-                    (next-line (- (window-height) 2)))))))))
+                    (forward-line (- (window-height) 2)))))))))
 
 ;; not sure yet, whether this is a good idea.
 (defmacro slime-save-coordinates (origin &rest body)
@@ -8540,9 +8540,6 @@
 
 (defun slime-add-local-hook (hook function &optional append)
   (cond ((featurep 'xemacs) (add-local-hook hook function append))
-        ((< emacs-major-version 21)
-         (make-local-hook hook)
-         (add-hook hook function append t))
         (t (add-hook hook function append t))))
 
 (defun slime-run-mode-hooks (&rest hooks)




From heller at common-lisp.net  Thu Feb 18 18:46:07 2010
From: heller at common-lisp.net (CVS User heller)
Date: Thu, 18 Feb 2010 13:46:07 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NiBO3-00054S-CE@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Remove duplicated entry.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/17 17:04:59	1.345
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/18 18:46:07	1.346
@@ -33,13 +33,6 @@
 	(slime-search-exports-in-defpackage): take #:symbol and :symbol
 	into account too.
 
-2010-02-17  Helmut Eller  <heller at common-lisp.net>
-
-	Fix bugs when *inferior-buffers* doesn't exist.
-
-	* inferior-slime.el (inferior-slime-start-transcript)
-	(inferior-slime-stop-transcript): Make sure the buffer exists.
-
 2010-01-14  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-repl.el: Revert the previous change because it




From sboukarev at common-lisp.net  Fri Feb 19 10:38:07 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 19 Feb 2010 05:38:07 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NiQFL-0002bC-H2@common-lisp.net>

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

Modified Files:
	ChangeLog slime-fuzzy.el 
Log Message:
* contrib/slime-fuzzy.el (slime-fuzzy-choices-buffer): Make connection buffer-local, otherwise
`swank:fuzzy-completion-selected' will be sent to the default connection.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/18 18:46:07	1.346
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/19 10:38:07	1.347
@@ -1,3 +1,8 @@
+2010-02-19  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-fuzzy.el (slime-fuzzy-choices-buffer): Make connection buffer-local, otherwise
+	`swank:fuzzy-completion-selected' will be sent to the default connection.
+
 2010-02-17  Helmut Eller  <heller at common-lisp.net>
 
 	Fix bugs when *inferior-buffers* doesn't exist.
--- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2010/02/15 21:42:37	1.15
+++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2010/02/19 10:38:07	1.16
@@ -346,7 +346,8 @@
 `end'.  This saves the window configuration before popping the
 buffer so that it can possibly be restored when the user is
 done."
-  (let ((new-completion-buffer (not slime-fuzzy-target-buffer)))
+  (let ((new-completion-buffer (not slime-fuzzy-target-buffer))
+        (connection (slime-connection)))
     (when new-completion-buffer
       (setq slime-fuzzy-saved-window-configuration
             (current-window-configuration)))
@@ -359,6 +360,7 @@
     (setq slime-fuzzy-text slime-fuzzy-original-text)
     (slime-fuzzy-fill-completions-buffer completions interrupted-p)
     (pop-to-buffer (slime-get-fuzzy-buffer))
+    (setq slime-buffer-connection connection)
     (when new-completion-buffer
       ;; Hook to nullify window-config restoration if the user changes
       ;; the window configuration himself.




From sboukarev at common-lisp.net  Sat Feb 20 14:37:32 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 20 Feb 2010 09:37:32 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NiqSa-0007h0-G0@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el: In minor-mode-alist for slime-popup-buffer-mode,
run slime-modeline-string only if slime-mode isn't active, because
slime-mode runs slime-modeline-string from minor-mode-alist too
resulting in duplicate modeline strings.
Reported by Leo Liu.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/18 18:46:02	1.1988
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/20 14:37:32	1.1989
@@ -1,3 +1,11 @@
+2010-02-20  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el: In minor-mode-alist for slime-popup-buffer-mode,
+	run slime-modeline-string only if slime-mode isn't active, because
+	slime-mode runs slime-modeline-string from minor-mode-alist too
+	resulting in duplicate modeline strings.
+	Reported by Leo Liu.
+
 2010-02-18  Mark Harig <idirectscm at aim.com>
 
 	The compiler warns about various stuff. Fix some of it.
--- /project/slime/cvsroot/slime/slime.el	2010/02/18 18:46:02	1.1277
+++ /project/slime/cvsroot/slime/slime.el	2010/02/20 14:37:32	1.1278
@@ -955,7 +955,8 @@
              `(slime-popup-buffer-mode
                ,(if (featurep 'xemacs)
                     'slime-modeline-string
-                  '(:eval (slime-modeline-string)))))
+                    '(:eval (unless slime-mode
+                              (slime-modeline-string))))))
 
 (set-keymap-parent slime-popup-buffer-mode-map slime-parent-map)
 




From sboukarev at common-lisp.net  Sat Feb 20 15:12:19 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 20 Feb 2010 10:12:19 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nir0F-0002P9-Qc@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
* swank-ccl.lisp: Remove outdated comment at the beginning
since it may be misleading.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/20 14:37:32	1.1989
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/20 15:12:19	1.1990
@@ -1,5 +1,8 @@
 2010-02-20  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-ccl.lisp: Remove outdated comment at the beginning
+	since it may be misleading.
+
 	* slime.el: In minor-mode-alist for slime-popup-buffer-mode,
 	run slime-modeline-string only if slime-mode isn't active, because
 	slime-mode runs slime-modeline-string from minor-mode-alist too
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2010/01/21 23:21:26	1.14
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2010/02/20 15:12:19	1.15
@@ -13,43 +13,6 @@
 ;;; The LLGPL is also available online at
 ;;; http://opensource.franz.com/preamble.html
 
-;;;
-;;; This is the beginning of a Slime backend for OpenMCL.  It has been
-;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would
-;;; be interested in hearing the results with other versions.
-;;;
-;;; Additionally, reporting the positions of warnings accurately requires
-;;; a small patch to the OpenMCL file compiler, which may be found at:
-;;;
-;;;   http://www.jamesjb.com/slime/openmcl-warning-position.diff
-;;;
-;;; Things that work:
-;;;
-;;; * Evaluation of forms with C-M-x.
-;;; * Compilation of defuns with C-c C-c.
-;;; * File compilation with C-c C-k.
-;;; * Most of the debugger functionality, except EVAL-IN-FRAME,
-;;;   FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS.
-;;; * Macroexpanding with C-c RET.
-;;; * Disassembling the symbol at point with C-c M-d.
-;;; * Describing symbol at point with C-c C-d.
-;;; * Compiler warnings are trapped and sent to Emacs using the buffer
-;;;   position of the offending top level form.
-;;; * Symbol completion and apropos.
-;;;
-;;; Things that sort of work:
-;;;
-;;; * WHO-CALLS is implemented but is only able to return the file a
-;;;   caller is defined in---source location information is not
-;;;   available.
-;;;
-;;; Things that aren't done yet:
-;;;
-;;; * Cross-referencing.
-;;; * Due to unimplementation functionality the test suite does not
-;;;   run correctly (it hangs upon entering the debugger).
-;;;
-
 (in-package :swank-backend)
 
 (eval-when (:compile-toplevel :execute :load-toplevel)




From trittweiler at common-lisp.net  Sat Feb 20 18:20:46 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 20 Feb 2010 13:20:46 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nitwc-0007rG-R9@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
	* swank-loader.lisp (*architecture-features*): Add :PENTIUM3 and
	:PENTIUM4; they're used by ECL.
	(handle-swank-load-error): Renamed from HANDLE-LOADTIME-ERROR. Use
	*FASL-DIRECTORY* rather than (DEFAULT-FASL-DIR). Parametrize
	context to differentiate b/w compilation/loading.
	(compile-files): Adapted accordingly. Also make sure that an error
	is signaled in case COMPILE-FILE returns NIL as primary result.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/20 15:12:19	1.1990
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/20 18:20:46	1.1991
@@ -1,3 +1,13 @@
+2010-02-20  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-loader.lisp (*architecture-features*): Add :PENTIUM3 and
+	:PENTIUM4; they're used by ECL.
+	(handle-swank-load-error): Renamed from HANDLE-LOADTIME-ERROR. Use
+	*FASL-DIRECTORY* rather than (DEFAULT-FASL-DIR). Parametrize
+	context to differentiate b/w compilation/loading.
+	(compile-files): Adapted accordingly. Also make sure that an error
+	is signaled in case COMPILE-FILE returns NIL as primary result.
+
 2010-02-20  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-ccl.lisp: Remove outdated comment at the beginning
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/16 11:28:19	1.99
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/20 18:20:46	1.100
@@ -56,7 +56,8 @@
 
 (defparameter *architecture-features*
   '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386
-    :sparc64 :sparc :hppa64 :hppa))
+    :sparc64 :sparc :hppa64 :hppa
+    :pentium3 :pentium4))
 
 (defun lisp-version-string ()
   #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
@@ -117,6 +118,9 @@
                  ,(unique-dir-name)))
    (user-homedir-pathname)))
 
+(defvar *fasl-directory* (default-fasl-dir)
+  "The directory where fasl files should be placed.")
+
 (defun binary-pathname (src-pathname binary-dir)
   "Return the pathname where SRC-PATHNAME's binary should be compiled."
   (let ((cfp (compile-file-pathname src-pathname)))
@@ -124,21 +128,23 @@
                                     :type (pathname-type cfp))
                      binary-dir)))
 
-(defun handle-loadtime-error (condition binary-pathname)
+(defun handle-swank-load-error (condition context pathname)
+  (fresh-line *error-output*)
   (pprint-logical-block (*error-output* () :per-line-prefix ";; ")
     (format *error-output*
-            "~%Error while loading: ~A~%Condition: ~A~%Aborting.~%"
-            binary-pathname condition))
-  (when (equal (directory-namestring binary-pathname)
-               (directory-namestring (default-fasl-dir)))
-    (ignore-errors (delete-file binary-pathname)))
+            "~%Error while ~A ~A:~%  ~A~%Aborting.~%"
+            context pathname condition))
+  (when (equal (directory-namestring pathname)
+               (directory-namestring *fasl-directory*))
+    (ignore-errors (delete-file pathname)))
   (abort))
 
 (defun compile-files (files fasl-dir load)
   "Compile each file in FILES if the source is newer than its
 corresponding binary, or the file preceding it was recompiled.
 If LOAD is true, load the fasl file."
-  (let ((needs-recompile nil))
+  (let ((needs-recompile nil)
+        (state :unknown))
     (dolist (src files)
       (let ((dest (binary-pathname src fasl-dir)))
         (handler-case
@@ -146,16 +152,24 @@
               (when (or needs-recompile
                         (not (probe-file dest))
                         (file-newer-p src dest))
-                ;; need a to recompile src-pathname, so we'll
-                ;; need to recompile everything after this too.
-                (setq needs-recompile t)
                 (ensure-directories-exist dest)
-                (compile-file src :output-file dest :print nil :verbose t))
+                ;; need to recompile SRC, so we'll need to recompile
+                ;; everything after this too.
+                (setq needs-recompile t)
+                (setq state :compile)
+                (or (compile-file src :output-file dest :print nil :verbose t)
+                    ;; An implementation may not necessarily signal a
+                    ;; condition itself when COMPILE-FILE fails (e.g. ECL)
+                    (error "COMPILE-FILE returned NIL.")))
               (when load
+                (setq state :load)
                 (load dest :verbose t)))
           ;; Fail as early as possible
           (serious-condition (c)
-            (handle-loadtime-error c dest)))))))
+            (ecase state
+              (:compile (handle-swank-load-error c "compiling" src))
+              (:load    (handle-swank-load-error c "loading" dest))
+              (:unknown (handle-swank-load-error c "???ing" src)))))))))
 
 #+(or cormanlisp)
 (defun compile-files (files fasl-dir load)
@@ -197,9 +211,6 @@
     )
   "List of names for contrib modules.")
 
-(defvar *fasl-directory* (default-fasl-dir)
-  "The directory where fasl files should be placed.")
-
 (defun append-dir (absolute name)
   (merge-pathnames 
    (make-pathname :directory `(:relative ,name) :defaults absolute)
@@ -211,7 +222,7 @@
 (defun q (s) (read-from-string s))
 
 (defun load-swank (&key (src-dir *source-directory*)
-                   (fasl-dir *fasl-directory*))
+                        (fasl-dir *fasl-directory*))
   (compile-files (src-files *swank-files* src-dir) fasl-dir t)
   (funcall (q "swank::before-init")
            (slime-version-string)




From trittweiler at common-lisp.net  Sat Feb 20 18:46:24 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 20 Feb 2010 13:46:24 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NiuLQ-00010P-5k@common-lisp.net>

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

Modified Files:
	ChangeLog slime-fancy.el 
Log Message:
	* slime-fancy.el: Call init function for fancy
	inspector. Necessary due to 2010-02-15.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/19 10:38:07	1.347
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/20 18:46:24	1.348
@@ -1,3 +1,8 @@
+2010-02-20  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* slime-fancy.el: Call init function for fancy
+	inspector. Necessary due to 2010-02-15.
+
 2010-02-19  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-fuzzy.el (slime-fuzzy-choices-buffer): Make connection buffer-local, otherwise
--- /project/slime/cvsroot/slime/contrib/slime-fancy.el	2009/12/21 16:03:41	1.10
+++ /project/slime/cvsroot/slime/contrib/slime-fancy.el	2010/02/20 18:46:24	1.11
@@ -37,6 +37,7 @@
 
 ;; Makes the inspector fancier.  (Once loaded, can't be turned off.)
 (require 'slime-fancy-inspector)
+(slime-fancy-inspector-init)
 
 ;; Just adds the command C-c M-i.  We do not make fuzzy completion the
 ;; default completion invoked by TAB. --mkoeppe




From trittweiler at common-lisp.net  Sat Feb 20 19:15:59 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sat, 20 Feb 2010 14:15:59 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Niuo3-0002S9-Jf@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	More work on ECL's swank-backend.

	* swank-ecl.lisp (accept-connection): Handle :buffering, and
	:external-format.
	(external-format): New helper.
	(find-external-format): Make sure to only return :default in case
	ECL was built with --disable-unicode; it'll barf on anything else.
	(socket-fd): Add two-way-stream case due to recent changes in ECL.
	(make-file-location, make-buffer-location): New helpers.
	(condition-location): Use them.
	(swank-compile-file): Handle :external-format.
	(compile-from-stream): Deleted. Slurped into swank-compile-string.
	(swank-compile-string): Call SI:MKSTEMP correctly. Make sure to
	also remove fasl file, not just source file.
	(grovel-docstring-for-arglist): Do not look at "Syntax:" entry in
	docstring because that was a kludge. Upstream ECL should be
	modified instead.
	(in-swank-package-p, is-swank-source-p, is-ignorable-fun-p):
	Commented out. They make debugging ECL's swank-backend harder.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/20 18:20:46	1.1991
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/20 19:15:59	1.1992
@@ -1,5 +1,27 @@
 2010-02-20  Tobias C. Rittweiler <tcr at freebits.de>
 
+	More work on ECL's swank-backend.
+
+	* swank-ecl.lisp (accept-connection): Handle :buffering, and
+	:external-format.
+	(external-format): New helper.
+	(find-external-format): Make sure to only return :default in case
+	ECL was built with --disable-unicode; it'll barf on anything else.
+	(socket-fd): Add two-way-stream case due to recent changes in ECL.
+	(make-file-location, make-buffer-location): New helpers.
+	(condition-location): Use them.
+	(swank-compile-file): Handle :external-format.
+	(compile-from-stream): Deleted. Slurped into swank-compile-string.
+	(swank-compile-string): Call SI:MKSTEMP correctly. Make sure to
+	also remove fasl file, not just source file.
+	(grovel-docstring-for-arglist): Do not look at "Syntax:" entry in
+	docstring because that was a kludge. Upstream ECL should be
+	modified instead.
+	(in-swank-package-p, is-swank-source-p, is-ignorable-fun-p):
+	Commented out. They make debugging ECL's swank-backend harder.
+
+2010-02-20  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank-loader.lisp (*architecture-features*): Add :PENTIUM3 and
 	:PENTIUM4; they're used by ECL.
 	(handle-swank-load-error): Renamed from HANDLE-LOADTIME-ERROR. Use
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/16 11:08:01	1.52
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/20 19:15:59	1.53
@@ -19,6 +19,19 @@
               Sorry for the inconvenience.~%~%"
              (lisp-implementation-version)))))
 
+;; Hard dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'sockets))
+
+;; Soft dependencies.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (probe-file "sys:profile.fas")
+    (require :profile)
+    (pushnew :profile *features*))
+  (when (probe-file "sys:serve-event.fas")
+    (require :serve-event)
+    (pushnew :serve-event *features*)))
+
 (declaim (optimize (debug 3)))
 
 ;;; Swank-mop
@@ -33,17 +46,9 @@
       :specializer-direct-methods
       :compute-applicable-methods-using-classes)))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (when (probe-file "sys:serve-event.fas")
-    (require :serve-event)
-    (pushnew :serve-event *features*)))
-
 
 ;;;; TCP Server
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (require 'sockets))
-
 (defun resolve-hostname (name)
   (car (sb-bsd-sockets:host-ent-addresses
         (sb-bsd-sockets:get-host-by-name name))))
@@ -68,11 +73,12 @@
 (defimplementation accept-connection (socket
                                       &key external-format
                                       buffering timeout)
-  (declare (ignore buffering timeout external-format))
+  (declare (ignore timeout))
   (sb-bsd-sockets:socket-make-stream (accept socket)
                                      :output t
                                      :input t
-                                     :element-type 'base-char))
+                                     :buffering buffering
+                                     :external-format external-format))
 (defun accept (socket)
   "Like socket-accept, but retry on EAGAIN."
   (loop (handler-case
@@ -81,22 +87,34 @@
 
 (defimplementation preferred-communication-style ()
   ;; ECL on Windows does not provide condition-variables
-  (or #+ (and threads (not win32) (not win64)) :spawn
+  (or #+(and threads (not windows)) :spawn
       #+serve-event :fd-handler
       nil))
 
 (defvar *external-format-to-coding-system*
-  '((:iso-8859-1
+  '((:latin-1
      "latin-1" "latin-1-unix" "iso-latin-1-unix" 
      "iso-8859-1" "iso-8859-1-unix")
     (:utf-8 "utf-8" "utf-8-unix")))
 
+(defun external-format (coding-system)
+  (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+                      *external-format-to-coding-system*))
+      (find coding-system (ext:all-encodings) :test #'string-equal)))
+
 (defimplementation find-external-format (coding-system)
-  (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
-                  *external-format-to-coding-system*)))
+  #+unicode (external-format coding-system)
+  ;; Without unicode support, ECL uses the one-byte encoding of the
+  ;; underlying OS, and will barf on anything except :DEFAULT.  We
+  ;; return NIL here for known multibyte encodings, so
+  ;; SWANK:CREATE-SERVER will barf.
+  #-unicode (let ((xf (external-format coding-system)))
+              (if (member xf '(:utf-8))
+                  nil
+                  :default)))
 
 
-;;;; Unix signals
+;;;; Unix Integration
 
 (defvar *original-sigint-handler* #'si:terminal-interrupt)
 
@@ -112,7 +130,6 @@
                 (continue))))
     old-handler))
 
-
 (defimplementation getpid ()
   (si:getpid))
 
@@ -137,6 +154,7 @@
 (defun socket-fd (socket)
   (etypecase socket
     (fixnum socket)
+    (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
     (file-stream (si:file-stream-fd socket))))
 
@@ -184,26 +202,34 @@
   (unless (typep condition 'c::compiler-note)
     (signal-compiler-condition
      :original-condition condition
-     :message (format nil "~A" condition)
+     :message (princ-to-string condition)
      :severity (etypecase condition
                  (c:compiler-fatal-error :error)
-                 (c:compiler-error :error)
-                 (error            :error)
-                 (style-warning    :style-warning)
-                 (warning          :warning))
+                 (c:compiler-error       :error)
+                 (error                  :error)
+                 (style-warning          :style-warning)
+                 (warning                :warning))
      :location (condition-location condition))))
 
+(defun make-file-location (file file-position)
+  ;; File positions in CL start at 0, but Emacs' buffer positions
+  ;; start at 1.
+  (make-location `(:file ,(namestring file))
+                 `(:position ,(1+ file-position))
+                 `(:align t)))
+
+(defun make-buffer-location (buffer-name start-position offset)
+  (make-location `(:buffer ,buffer-name)
+                 `(:offset ,start-position ,offset)
+                 `(:align t)))
+
 (defun condition-location (condition)
   (let ((file     (c:compiler-message-file condition))
         (position (c:compiler-message-file-position condition)))
     (if (and position (not (minusp position)))
         (if *buffer-name*
-            (make-location `(:buffer ,*buffer-name*)
-                           `(:offset ,*buffer-start-position* ,position)
-                           `(:align t))
-            (make-location `(:file ,(namestring file))
-                           `(:position ,(1+ position))
-                           `(:align t)))
+            (make-buffer-location *buffer-name* *buffer-start-position* position)
+            (make-file-location file position))
         (make-error-location "No location found."))))
 
 (defimplementation call-with-compilation-hooks (function)
@@ -212,29 +238,26 @@
 
 (defimplementation swank-compile-file (input-file output-file
                                        load-p external-format)
-  (declare (ignore external-format))
   (with-compilation-hooks ()
-    (compile-file input-file :output-file output-file :load load-p)))
+    (compile-file input-file :output-file output-file
+                  :load load-p
+                  :external-format external-format)))
 
 (defimplementation swank-compile-string (string &key buffer position filename
-                                         policy)
+                                                policy)
   (declare (ignore filename policy))
   (with-compilation-hooks ()
-    (let ((*buffer-name* buffer)
+    (let ((*buffer-name* buffer)        ; for compilation hooks
           (*buffer-start-position* position))
-      (with-input-from-string (s string)
-        (not (nth-value 2 (compile-from-stream s :load t)))))))
-
-(defun compile-from-stream (stream &rest args)
-  (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
-    (with-open-file (s file :direction :output :if-exists :overwrite)
-      (do ((line (read-line stream nil) (read-line stream nil)))
-	  ((not line))
-	(write-line line s)))
-    (unwind-protect
-         (apply #'compile-file file args)
-      (delete-file file))))
-
+      (let ((file (si:mkstemp "TMP:ECL-SWANK-")))
+        (unwind-protect
+             (with-open-file (file-stream file :direction :output
+                                               :if-exists :supersede)
+               (write-string string file-stream)
+               (finish-output file-stream)
+               (not (nth-value 2 (compile-file file :load t))))
+          (delete-file file)
+          (delete-file (compile-file-pathname file)))))))
 
 ;;;; Documentation
 
@@ -242,11 +265,7 @@
   (flet ((compute-arglist-offset (docstring)
            (when docstring
              (let ((pos1 (search "Args: " docstring)))
-               (if pos1
-                   (+ pos1 6)
-                   (let ((pos2 (search "Syntax: " docstring)))
-                     (when pos2
-                       (+ pos2 8))))))))
+               (and pos1 (+ pos1 6))))))
     (let* ((docstring (si::get-documentation name type))
            (pos (compute-arglist-offset docstring)))
       (if pos
@@ -342,38 +361,42 @@
 
 (defimplementation call-with-debugger-hook (hook fun)
   (let ((*debugger-hook* hook)
-        (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
-        (*ihs-base* (ihs-top)))
+        (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
     (funcall fun)))
 
 (defvar *backtrace* '())
 
-(defun in-swank-package-p (x)
-  (and
-   (symbolp x)
-   (member (symbol-package x)
-           (list #.(find-package :swank)
-                 #.(find-package :swank-backend)
-                 #.(ignore-errors (find-package :swank-mop))
-                 #.(ignore-errors (find-package :swank-loader))))
-   t))
-
-(defun is-swank-source-p (name)
-  (setf name (pathname name))
-  (pathname-match-p
-   name
-   (make-pathname :defaults swank-loader::*source-directory*
-                  :name (pathname-name name)
-                  :type (pathname-type name)
-                  :version (pathname-version name))))
-
-(defun is-ignorable-fun-p (x)
-  (or
-   (in-swank-package-p (frame-name x))
-   (multiple-value-bind (file position)
-       (ignore-errors (si::bc-file (car x)))
-     (declare (ignore position))
-     (if file (is-swank-source-p file)))))
+;;; Commented out; it's not clear this is a good way of doing it. In
+;;; particular because it makes errors stemming from this file harder
+;;; to debug, and given the "young" age of ECL's swank backend, that's
+;;; a bad idea.
+
+;; (defun in-swank-package-p (x)
+;;   (and
+;;    (symbolp x)
+;;    (member (symbol-package x)
+;;            (list #.(find-package :swank)
+;;                  #.(find-package :swank-backend)
+;;                  #.(ignore-errors (find-package :swank-mop))
+;;                  #.(ignore-errors (find-package :swank-loader))))
+;;    t))
+
+;; (defun is-swank-source-p (name)
+;;   (setf name (pathname name))
+;;   (pathname-match-p
+;;    name
+;;    (make-pathname :defaults swank-loader::*source-directory*
+;;                   :name (pathname-name name)
+;;                   :type (pathname-type name)
+;;                   :version (pathname-version name))))
+
+;; (defun is-ignorable-fun-p (x)
+;;   (or
+;;    (in-swank-package-p (frame-name x))
+;;    (multiple-value-bind (file position)
+;;        (ignore-errors (si::bc-file (car x)))
+;;      (declare (ignore position))
+;;      (if file (is-swank-source-p file)))))
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
@@ -396,7 +419,7 @@
                         (name (si::frs-tag f)))
                    (unless (si::fixnump name)
                      (push name (third x)))))))
-    (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*)))
+    (setf *backtrace* (nreverse *backtrace*))
     (set-break-env)
     (set-current-ihs)
     (let ((*ihs-base* *ihs-top*))
@@ -417,7 +440,8 @@
 (defun function-position (fun)
   (multiple-value-bind (file position)
       (si::bc-file fun)
-    (and file (make-location `(:file ,file) `(:position ,position)))))
+    (when file
+      (make-file-location file position))))
 
 (defun frame-function (frame)
   (let* ((x (first frame))
@@ -529,6 +553,8 @@
       (let ((tmp (find-source-location (symbol-function name))))
         `(((defun ,name) ,tmp)))))
 
+;;; FIXME: BC-FILE may return "/tmp/ECLXXXXXXKMOXtm" which are the
+;;; temporary files comming from C-c C-c.
 (defimplementation find-source-location (obj)
   (or
    (typecase obj
@@ -576,7 +602,7 @@
 (defimplementation profile-package (package callers methods)
   (declare (ignore callers methods))
   (eval `(profile:profile ,(package-name (find-package package)))))
-)                                       ; progn
+) ; #+profile (progn ...
 
 ;;;; Threads
 
@@ -611,8 +637,8 @@
 
   (defimplementation find-thread (id)
     (mp:with-lock (*thread-id-map-lock*)
-      (let* ((thread-pointer (gethash id *thread-id-map*))
-             (thread (and thread-pointer (si:weak-pointer-value thread-pointer))))
+      (let* ((thread-ptr (gethash id *thread-id-map*))
+             (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
         (unless thread
           (remhash id *thread-id-map*))
         thread)))




From trittweiler at common-lisp.net  Mon Feb 22 12:40:31 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 22 Feb 2010 07:40:31 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NjXaR-00013Z-0t@common-lisp.net>

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

Modified Files:
	slime.el swank-backend.lisp 
Log Message:
	Make it possible for SWANK backends to specify locations based on
	a TAGS file.

	* slime.el (slime-postprocess-xref, slime-postprocess-xrefs): New
	functions. They convert TAGS based locations from SWANK into
	file+position based locations because the rest of Slime expects
	and works with those.
	(slime-find-definitions): Call slime-postprocess-xrefs.
	(slime-xref): Ditto.
	(slime-etags-to-locations): The function which does the actual
	conversion. Extracted from `slime-etags-definitions'.
	(slime-etags-definitions): Use it.

	* swank-backend (defimplementation): Add implicit BLOCK.
	(:etags-file, :tag): Mentioned for possible values in :LOCATION.


--- /project/slime/cvsroot/slime/slime.el	2010/02/20 14:37:32	1.1278
+++ /project/slime/cvsroot/slime/slime.el	2010/02/22 12:40:30	1.1279
@@ -3857,9 +3857,33 @@
     (window    (pop-to-buffer (current-buffer) t))
     (frame     (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))))
 
+(defun slime-postprocess-xref (original-xref)
+  "Process (for normalization purposes) an Xref comming directly
+from SWANK before the rest of Slime sees it. In particular,
+convert ETAGS based xrefs to actual file+position based
+locations."
+  (if (not (slime-xref-has-location-p original-xref))
+      (list original-xref)
+      (let ((loc (slime-xref.location original-xref)))
+        (destructure-case (slime-location.buffer loc)
+          ((:etags-file tags-file)
+           (destructure-case (slime-location.position loc)
+             ((:tag &rest tags)
+              (visit-tags-table tags-file)
+              (mapcar #'(lambda (loc)
+                          (make-slime-xref 
+                           :dspec (slime-xref.dspec original-xref)
+                           :location loc))
+                      (mapcan #'slime-etags-to-locations tags)))))
+          (t 
+           (list original-xref))))))
+
+(defun slime-postprocess-xrefs (xrefs)
+  (mapcan #'slime-postprocess-xref xrefs))
+
 (defun slime-find-definitions (name)
   "Find definitions for NAME."
-  (funcall slime-find-definitions-function name))
+  (slime-postprocess-xrefs (funcall slime-find-definitions-function name)))
 
 (defun slime-find-definitions-rpc (name)
   (slime-eval `(swank:find-definitions-for-emacs ,name)))
@@ -3883,11 +3907,10 @@
           (t
            (error "No known definition for: %s" name)))))
 
-(defun slime-etags-definitions (name)
-  "Search definitions matching NAME in the tags file.
-The result is a (possibly empty) list of definitions."
-  (require 'etags)
-  (let ((defs '()))
+(defun slime-etags-to-locations (name)
+  "Search for definitions matching `name' in the currently active
+tags table. Return a possibly empty list of slime-locations."
+  (let ((locs '()))
     (save-excursion
       (let ((first-time t))
         (while (visit-tags-table-buffer (not first-time))
@@ -3896,13 +3919,20 @@
           (while (search-forward name nil t)
             (beginning-of-line)
             (destructuring-bind (hint line &rest pos) (etags-snarf-tag)
-              (unless (eq hint t)       ; hint==t if we are in a filename line
-                (let ((file (expand-file-name (file-of-tag))))
-                  (let ((loc `(:location (:file ,file)
-                                         (:line ,line)
-                                         (:snippet ,hint))))
-                    (push (list hint loc) defs))))))))
-      (reverse defs))))
+              (unless (eq hint t) ; hint==t if we are in a filename line
+                (push `(:location (:file ,(expand-file-name (file-of-tag)))
+                                  (:line ,line)
+                                  (:snippet ,hint)) 
+                       locs))))))
+      (nreverse locs))))
+
+(defun slime-etags-definitions (name)
+  "Search definitions matching NAME in the tags file.
+The result is a (possibly empty) list of definitions."
+  (mapcar #'(lambda (loc)
+              (make-slime-xref :dspec (second (slime-location.hints loc))
+                               :location loc))
+          (slime-etags-to-locations name)))
 
 ;;;;; first-change-hook
 
@@ -4772,7 +4802,8 @@
    `(swank:xref ',type ',symbol)
    (slime-rcurry (lambda (result type symbol package cont)
                    (slime-check-xref-implemented type result)
-                   (let ((file-alist (cadr (slime-analyze-xrefs result))))
+                   (let* ((xrefs (slime-postprocess-xrefs result))
+                          (file-alist (cadr (slime-analyze-xrefs result))))
                      (funcall (or cont 'slime-show-xrefs)
                               file-alist type symbol package)))
                  type 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/17 17:04:46	1.192
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/22 12:40:30	1.193
@@ -168,7 +168,9 @@
   (assert (every #'symbolp args) ()
           "Complex lambda-list not supported: ~S ~S" name args)
   `(progn
-     (setf (get ',name 'implementation) (lambda ,args , at body))
+     (setf (get ',name 'implementation)
+           ;; For implicit BLOCK. FLET because of interplay w/ decls.
+           (flet ((,name ,args , at body)) #',name))
      (if (member ',name *interface-functions*)
          (setq *unimplemented-interfaces*
                (remove ',name *unimplemented-interfaces*))
@@ -816,9 +818,15 @@
   hints)
 
 (defstruct (:error (:type list) :named (:constructor)) message)
-(defstruct (:file (:type list) :named (:constructor)) name)
-(defstruct (:buffer (:type list) :named (:constructor)) name)
+
+;;; Valid content for BUFFER slot
+(defstruct (:file       (:type list) :named (:constructor)) name)
+(defstruct (:buffer     (:type list) :named (:constructor)) name)
+(defstruct (:etags-file (:type list) :named (:constructor)) filename)
+
+;;; Valid content for POSITION slot
 (defstruct (:position (:type list) :named (:constructor)) pos)
+(defstruct (:tag      (:type list) :named (:constructor)) tag1 tag2)
 
 (defun make-error-location (datum &rest args)
   (cond ((typep datum 'condition)




From trittweiler at common-lisp.net  Mon Feb 22 12:56:36 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 22 Feb 2010 07:56:36 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NjXq0-0001qK-ME@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	Make M-. be able to jump right into the C source for ECL.

	Because it's based on TAGS files, M-. and M-* will DTRT once in a
	.c file.

	* swank-ecl.lisp (assert-TAGS-file): New helper.
	(classify-definition-name): Ditto.
	(find-definitions-for-type): Ditto. Understands Lisp and C
	functions.
	(find-definitions): Use them.
	(source-location): New helper. Extracted from FIND-SOURCE-LOCATION.
	(find-source-location): Use it.
	(swank-compile-string): Only try to delete temporary files if they
	exist.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/20 19:15:59	1.1992
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/22 12:56:36	1.1993
@@ -1,3 +1,38 @@
+2010-02-22  Tobias C. Rittweiler <tcr at freebits.de>
+
+	Make M-. be able to jump right into the C source for ECL.
+
+	Because it's based on TAGS files, M-. and M-* will DTRT once in a
+	.c file.
+
+	* swank-ecl.lisp (assert-TAGS-file): New helper.
+	(classify-definition-name): Ditto.
+	(find-definitions-for-type): Ditto. Understands Lisp and C
+	functions.
+	(find-definitions): Use them.
+	(source-location): New helper. Extracted from FIND-SOURCE-LOCATION.
+	(find-source-location): Use it.
+	(swank-compile-string): Only try to delete temporary files if they
+	exist.
+
+2010-02-22  Tobias C. Rittweiler <tcr at freebits.de>
+
+	Make it possible for SWANK backends to specify locations based on
+	a TAGS file.
+
+	* slime.el (slime-postprocess-xref, slime-postprocess-xrefs): New
+	functions. They convert TAGS based locations from SWANK into
+	file+position based locations because the rest of Slime expects
+	and works with those.
+	(slime-find-definitions): Call slime-postprocess-xrefs.
+	(slime-xref): Ditto.
+	(slime-etags-to-locations): The function which does the actual
+	conversion. Extracted from `slime-etags-definitions'.
+	(slime-etags-definitions): Use it.
+
+	* swank-backend (defimplementation): Add implicit BLOCK.
+	(:etags-file, :tag): Mentioned for possible values in :LOCATION.
+
 2010-02-20  Tobias C. Rittweiler <tcr at freebits.de>
 
 	More work on ECL's swank-backend.
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/20 19:15:59	1.53
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/22 12:56:36	1.54
@@ -213,7 +213,9 @@
 
 (defun make-file-location (file file-position)
   ;; File positions in CL start at 0, but Emacs' buffer positions
-  ;; start at 1.
+  ;; start at 1. We specify (:ALIGN T) because the positions comming
+  ;; from ECL point at right after the toplevel form appearing before
+  ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case.
   (make-location `(:file ,(namestring file))
                  `(:position ,(1+ file-position))
                  `(:align t)))
@@ -249,15 +251,22 @@
   (with-compilation-hooks ()
     (let ((*buffer-name* buffer)        ; for compilation hooks
           (*buffer-start-position* position))
-      (let ((file (si:mkstemp "TMP:ECL-SWANK-")))
+      (let ((file (si:mkstemp "TMP:ECL-SWANK-"))
+            (fasl-file)
+            (warnings-p)
+            (failure-p))
         (unwind-protect
              (with-open-file (file-stream file :direction :output
                                                :if-exists :supersede)
                (write-string string file-stream)
                (finish-output file-stream)
-               (not (nth-value 2 (compile-file file :load t))))
-          (delete-file file)
-          (delete-file (compile-file-pathname file)))))))
+               (multiple-value-setq (fasl-file warnings-p failure-p)
+                 (compile-file file :load t)))
+          (when (probe-file file)
+            (delete-file file))
+          (when fasl-file
+            (delete-file fasl-file)))
+        (not failure-p)))))
 
 ;;;; Documentation
 
@@ -548,28 +557,96 @@
 
 ;;;; Definitions
 
+(defconstant +TAGS+ #P"SYS:TAGS")
+
+;;; FIXME: this depends on a patch not yet merged into ECL upstream.
+;;; When it's in, remove this.
+
+(defun get-source-pathname ()
+  #+#. (swank-backend::with-symbol 'get-source-pathname 'si)
+  (si:get-source-pathname))
+
+(defun assert-TAGS-file (fail)
+  (flet ((fail (x)
+           (funcall fail x)))
+    (let ((ecl-src-dir (get-source-pathname)))
+      (unless ecl-src-dir
+        (fail (make-error-location "Do not know where ECL's source directory ~
+                                    is. You can set the environment variable ~
+                                    `ECLSRCDIR' for that purpose.")))
+      (unless (probe-file ecl-src-dir)
+        (fail (make-error-location "ECL's source directory ~S does not ~
+                                    seem to exist." ecl-src-dir)))
+      (unless (probe-file +TAGS+)
+        (fail (make-error-location "No TAGS file ~A. You can create it by ~
+                                    the command `make TAGS'"
+                                   (truename +TAGS+)))))))
+
+(defun classify-definition-name (name)
+  (let ((types '()))
+    (when (fboundp name)
+      (cond ((special-operator-p name)
+             (push :special-operator types))
+            ((macro-function name)
+             (push :macro types))
+            ((typep (fdefinition name) 'generic-function)
+             (push :generic-function types))
+            ((si:mangle-name name t)
+             (push :c-function types))
+            (t
+             (push :lisp-function types))))
+    types))
+
+(defun find-definitions-for-type (name type)
+  (ecase type
+    (:lisp-function
+     (list `((defun ,name) ,(source-location (symbol-function name)))))
+    (:c-function
+     (assert-TAGS-file #'(lambda (x) (return-from find-definitions-for-type x)))
+     (multiple-value-bind (flag c-name) (si:mangle-name name t)
+       (assert flag)
+       ;; In ECL's code base sometimes the mangled name is used
+       ;; directly, sometimes ECL's DPP magic of @LISP:SYMBOL is used.
+       ;; We cannot predict here, so we just provide two candidates.
+       (let* ((candidate1 c-name)
+              (candidate2 (format nil "~A::~A"
+                                  (package-name (symbol-package name))
+                                  (symbol-name name)))
+              (loc (make-location `(:etags-file ,(namestring (truename +TAGS+)))
+                                  `(:tag ,candidate1 ,candidate2))))
+         (list `((c-function ,name) ,loc)))))
+    (:generic-function
+     (loop for method in (clos:generic-function-methods (fdefinition name))
+           for specs = (clos:method-specializers method)
+           for loc   = (source-location method)
+           when loc
+             collect `((defmethod ,name ,specs) ,loc)))
+    (:macro
+     (values 'defmacro (source-location (macro-function name))))
+    (:special-operator)))
+
 (defimplementation find-definitions (name)
-  (if (fboundp name)
-      (let ((tmp (find-source-location (symbol-function name))))
-        `(((defun ,name) ,tmp)))))
-
-;;; FIXME: BC-FILE may return "/tmp/ECLXXXXXXKMOXtm" which are the
-;;; temporary files comming from C-c C-c.
-(defimplementation find-source-location (obj)
-  (or
-   (typecase obj
-     (function
-      (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
-        (if (and file pos) 
-            (make-location
-              `(:file ,(namestring file))
-              `(:position ,pos)
-              `(:snippet
-                ,(with-open-file (s file)
-                   (file-position s pos)
-                   (skip-comments-and-whitespace s)
-                   (read-snippet s))))))))
-   `(:error ,(format nil "Source definition of ~S not found" obj))))
+  (mapcan #'(lambda (type) (find-definitions-for-type name type))
+          (classify-definition-name name)))
+
+(defun source-location (object)
+  (typecase object
+    (function
+     ;; FIXME: EXT:C-F-FILE may return "/tmp/ECL_SWANK_KMOXtm" which
+     ;; are the temporary files stemming from C-c C-c.
+     (multiple-value-bind (file pos) (ext:compiled-function-file object)
+       (when file
+         (assert (probe-file file))
+         (assert (not (minusp pos)))
+         (make-file-location file pos))))
+    (method
+     ;; FIXME: This will always return NIL at the moment; ECL does not
+     ;; store debug information for methods yet.
+     (source-location (clos:method-function object)))))
+
+(defimplementation find-source-location (object)
+  (or (source-location object)
+      (make-error-location "Source definition of ~S not found" object)))
 
 ;;;; Profiling
 




From trittweiler at common-lisp.net  Mon Feb 22 21:38:46 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 22 Feb 2010 16:38:46 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NjfzK-0007FB-6c@common-lisp.net>

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

Modified Files:
	ChangeLog swank-backend.lisp swank-sbcl.lisp 
Log Message:
	* swank-backend.lisp (converting-errors-to-error-location): Moved
	here from swank-sbcl.lisp so other backends can make use of it, too.

	* swank-sbcl.lisp: The above macro was called slightly
	differently, so update uses accordingly.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/22 12:56:36	1.1993
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/22 21:38:45	1.1994
@@ -1,5 +1,13 @@
 2010-02-22  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-backend.lisp (converting-errors-to-error-location): Moved
+	here from swank-sbcl.lisp so other backends can make use of it, too.
+
+	* swank-sbcl.lisp: The above macro was called slightly
+	differently, so update uses accordingly.
+
+2010-02-22  Tobias C. Rittweiler <tcr at freebits.de>
+
 	Make M-. be able to jump right into the C source for ECL.
 
 	Because it's based on TAGS files, M-. and M-* will DTRT once in a
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/22 12:40:30	1.193
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/22 21:38:46	1.194
@@ -828,6 +828,18 @@
 (defstruct (:position (:type list) :named (:constructor)) pos)
 (defstruct (:tag      (:type list) :named (:constructor)) tag1 tag2)
 
+(defmacro converting-errors-to-error-location (&body body)
+  "Catches errors during BODY and converts them to an error location."
+  (let ((gblock (gensym "CONVERTING-ERRORS+")))
+    `(block ,gblock
+       (handler-bind ((error
+                       #'(lambda (e)
+                            (if *debug-swank-backend*
+                                nil     ;decline
+                                (return-from ,gblock
+                                  (make-error-location e))))))
+         , at body))))
+
 (defun make-error-location (datum &rest args)
   (cond ((typep datum 'condition)
          `(:error ,(format nil "Error: ~A" datum)))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/01/05 21:20:38	1.266
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/02/22 21:38:46	1.267
@@ -641,18 +641,6 @@
 
 ;;;; Definitions
 
-(defmacro converting-errors-to-location (&body body)
-  "Catches error and converts them to an error location."
-  (let ((gblock (gensym "CONVERTING-ERRORS+")))
-    `(block ,gblock
-       (handler-bind ((error
-                       #'(lambda (e)
-                            (if *debug-swank-backend*
-                                nil     ;decline
-                                (return-from ,gblock
-                                  (make-error-location e))))))
-         , at body))))
-
 (defparameter *definition-types*
   '(:variable defvar
     :constant defconstant
@@ -693,7 +681,7 @@
         for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
         append (loop for defsrc in defsrcs collect
                      (list (make-dspec type name defsrc)
-                           (converting-errors-to-location
+                           (converting-errors-to-error-location
                              (definition-source-for-emacs defsrc type name))))))
 
 (defimplementation find-source-location (obj)
@@ -717,7 +705,7 @@
               (with-output-to-string (s)
                 (print-unreadable-object (obj s :type t :identity t))))
              (t (princ-to-string obj)))))
-    (converting-errors-to-location
+    (converting-errors-to-error-location
       (let ((defsrc (sb-introspect:find-definition-source obj)))
         (definition-source-for-emacs defsrc
                                      (general-type-of obj)
@@ -853,7 +841,7 @@
 
 (defun source-location-for-xref-data (xref-data)
   (destructuring-bind (name . defsrc) xref-data
-    (list name (converting-errors-to-location
+    (list name (converting-errors-to-error-location
                  (definition-source-for-emacs defsrc 'function name)))))
 
 (defimplementation list-callers (symbol)
@@ -895,7 +883,7 @@
   "Describe where the function FN was defined.
 Return a list of the form (NAME LOCATION)."
   (let ((name (function-name fn)))
-    (list name (converting-errors-to-location
+    (list name (converting-errors-to-error-location
                  (function-source-location fn name)))))
 
 ;;; macroexpansion
@@ -1142,7 +1130,7 @@
 ;;; source-path-file-position and friends are in swank-source-path-parser
 
 (defimplementation frame-source-location (index)
-  (converting-errors-to-location
+  (converting-errors-to-error-location
     (code-location-source-location
      (sb-di:frame-code-location (nth-frame index)))))
 




From trittweiler at common-lisp.net  Mon Feb 22 21:43:31 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 22 Feb 2010 16:43:31 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Njg3v-0007z7-3C@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	Make swank-ecl.lisp work with latest ECL Git HEAD.

	* swank-ecl.lisp (assert-TAGS-file): Simplified.
	(assert-source-directory): New helper.
	(c-function-p): New helper.
	(c-function): Type based on above.
	(source-location): Move bits from FIND-DEFINITIONS-FOR-TYPE to
	this function. Use CONVERTING-ERRORS-TO-ERROR-LOCATION.
	(find-definitions-for-type): Simplified by using it.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/22 21:38:45	1.1994
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/22 21:43:30	1.1995
@@ -1,5 +1,17 @@
 2010-02-22  Tobias C. Rittweiler <tcr at freebits.de>
 
+	Make swank-ecl.lisp work with latest ECL Git HEAD.
+
+	* swank-ecl.lisp (assert-TAGS-file): Simplified.
+	(assert-source-directory): New helper.
+	(c-function-p): New helper.
+	(c-function): Type based on above.
+	(source-location): Move bits from FIND-DEFINITIONS-FOR-TYPE to
+	this function. Use CONVERTING-ERRORS-TO-ERROR-LOCATION.
+	(find-definitions-for-type): Simplified by using it.
+
+2010-02-22  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank-backend.lisp (converting-errors-to-error-location): Moved
 	here from swank-sbcl.lisp so other backends can make use of it, too.
 
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/22 12:56:36	1.54
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/22 21:43:31	1.55
@@ -557,30 +557,29 @@
 
 ;;;; Definitions
 
-(defconstant +TAGS+ #P"SYS:TAGS")
-
-;;; FIXME: this depends on a patch not yet merged into ECL upstream.
-;;; When it's in, remove this.
-
-(defun get-source-pathname ()
-  #+#. (swank-backend::with-symbol 'get-source-pathname 'si)
-  (si:get-source-pathname))
-
-(defun assert-TAGS-file (fail)
-  (flet ((fail (x)
-           (funcall fail x)))
-    (let ((ecl-src-dir (get-source-pathname)))
-      (unless ecl-src-dir
-        (fail (make-error-location "Do not know where ECL's source directory ~
-                                    is. You can set the environment variable ~
-                                    `ECLSRCDIR' for that purpose.")))
-      (unless (probe-file ecl-src-dir)
-        (fail (make-error-location "ECL's source directory ~S does not ~
-                                    seem to exist." ecl-src-dir)))
-      (unless (probe-file +TAGS+)
-        (fail (make-error-location "No TAGS file ~A. You can create it by ~
-                                    the command `make TAGS'"
-                                   (truename +TAGS+)))))))
+;;; FIXME: There ought to be a better way.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun c-function-p (object)
+    (and (functionp object)
+         (let ((fn-name (function-name object)))
+           (and fn-name (si:mangle-name fn-name t) t)))))
+
+(deftype c-function ()
+  `(satisfies c-function-p))
+
+(defvar +TAGS+ (namestring (translate-logical-pathname #P"SYS:TAGS")))
+
+(defun assert-source-directory ()
+  (unless (probe-file #P"SRC:")
+    (error "ECL's source directory ~A does not exist. ~
+            You can specify a different location via the environment ~
+            variable `ECLSRCDIR'."
+           (namestring (translate-logical-pathname #P"SYS:"))))) 
+
+(defun assert-TAGS-file ()
+  (unless (probe-file +TAGS+)
+    (error "No TAGS file ~A found. It should have been installed with ECL."
+           +TAGS+)))
 
 (defun classify-definition-name (name)
   (let ((types '()))
@@ -600,21 +599,9 @@
 (defun find-definitions-for-type (name type)
   (ecase type
     (:lisp-function
-     (list `((defun ,name) ,(source-location (symbol-function name)))))
+     (list `((defun ,name) ,(source-location (fdefinition name)))))
     (:c-function
-     (assert-TAGS-file #'(lambda (x) (return-from find-definitions-for-type x)))
-     (multiple-value-bind (flag c-name) (si:mangle-name name t)
-       (assert flag)
-       ;; In ECL's code base sometimes the mangled name is used
-       ;; directly, sometimes ECL's DPP magic of @LISP:SYMBOL is used.
-       ;; We cannot predict here, so we just provide two candidates.
-       (let* ((candidate1 c-name)
-              (candidate2 (format nil "~A::~A"
-                                  (package-name (symbol-package name))
-                                  (symbol-name name)))
-              (loc (make-location `(:etags-file ,(namestring (truename +TAGS+)))
-                                  `(:tag ,candidate1 ,candidate2))))
-         (list `((c-function ,name) ,loc)))))
+     (list `((c-function ,name) ,(source-location (fdefinition name)))))
     (:generic-function
      (loop for method in (clos:generic-function-methods (fdefinition name))
            for specs = (clos:method-specializers method)
@@ -622,27 +609,45 @@
            when loc
              collect `((defmethod ,name ,specs) ,loc)))
     (:macro
-     (values 'defmacro (source-location (macro-function name))))
+     (list `((defmacro ,name) ,(source-location (macro-function name)))))
     (:special-operator)))
 
 (defimplementation find-definitions (name)
   (mapcan #'(lambda (type) (find-definitions-for-type name type))
           (classify-definition-name name)))
 
+
 (defun source-location (object)
-  (typecase object
-    (function
-     ;; FIXME: EXT:C-F-FILE may return "/tmp/ECL_SWANK_KMOXtm" which
-     ;; are the temporary files stemming from C-c C-c.
-     (multiple-value-bind (file pos) (ext:compiled-function-file object)
-       (when file
-         (assert (probe-file file))
-         (assert (not (minusp pos)))
-         (make-file-location file pos))))
-    (method
-     ;; FIXME: This will always return NIL at the moment; ECL does not
-     ;; store debug information for methods yet.
-     (source-location (clos:method-function object)))))
+  (converting-errors-to-error-location
+    (typecase object
+      (c-function
+       (assert-source-directory)
+       (assert-TAGS-file)
+       (let ((lisp-name (function-name object)))
+         (assert lisp-name)
+         (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t)
+           (assert flag)
+           ;; In ECL's code base sometimes the mangled name is used
+           ;; directly, sometimes ECL's DPP magic of @LISP:SYMBOL is used.
+           ;; We cannot predict here, so we just provide two candidates.
+           (let* ((candidate1 c-name)
+                  (candidate2 (format nil "~A::~A"
+                                      (package-name (symbol-package lisp-name))
+                                      (symbol-name lisp-name))))
+             (make-location `(:etags-file ,+TAGS+)
+                            `(:tag ,candidate1 ,candidate2))))))
+      (function
+       ;; FIXME: EXT:C-F-FILE may return "/tmp/ECL_SWANK_KMOXtm" which
+       ;; are the temporary files stemming from C-c C-c.
+       (multiple-value-bind (file pos) (ext:compiled-function-file object)
+         (when file
+           (assert (probe-file file))
+           (assert (not (minusp pos)))
+           (make-file-location file pos))))
+      (method
+       ;; FIXME: This will always return NIL at the moment; ECL does not
+       ;; store debug information for methods yet.
+       (source-location (clos:method-function object))))))
 
 (defimplementation find-source-location (object)
   (or (source-location object)




From trittweiler at common-lisp.net  Tue Feb 23 20:50:55 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 23 Feb 2010 15:50:55 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nk1iZ-0008D8-Jh@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	* swank-ecl.lisp (preferred-communication-style): Go back to
	NIL. Some parts (like the compiler and CLOS) of ECL do not seem to
	be thread-safe yet. Also get rid of non-working implementation of
	:FD-HANDLER.
	(poll-streams, wait-for-input): Implement on top of select() for
	communication-style=NIL.
	(*descriptor-handlers*, add-fd-handler, remove-fd-handlers): Get
	rid of.
	(grovel-docstring-for-arglist): Get rid of it, too.
	(arglist): ECL now provides an extra accessor to a function's
	arglist. Use that instead.
	(emacs-inspect): Get rid of the default method. Don't see its
	point.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/22 21:43:30	1.1995
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/23 20:50:55	1.1996
@@ -1,3 +1,19 @@
+2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-ecl.lisp (preferred-communication-style): Go back to
+	NIL. Some parts (like the compiler and CLOS) of ECL do not seem to
+	be thread-safe yet. Also get rid of non-working implementation of
+	:FD-HANDLER.
+	(poll-streams, wait-for-input): Implement on top of select() for
+	communication-style=NIL.
+	(*descriptor-handlers*, add-fd-handler, remove-fd-handlers): Get
+	rid of.
+	(grovel-docstring-for-arglist): Get rid of it, too.
+	(arglist): ECL now provides an extra accessor to a function's
+	arglist. Use that instead.
+	(emacs-inspect): Get rid of the default method. Don't see its
+	point.
+
 2010-02-22  Tobias C. Rittweiler <tcr at freebits.de>
 
 	Make swank-ecl.lisp work with latest ECL Git HEAD.
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/22 21:43:31	1.55
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/23 20:50:55	1.56
@@ -49,6 +49,15 @@
 
 ;;;; TCP Server
 
+(defimplementation preferred-communication-style ()
+  ;; While ECL does provide threads, some parts of it are not
+  ;; thread-safe (2010-02-23), including the compiler and CLOS.
+  nil
+  ;; ECL on Windows does not provide condition-variables
+  ;; (or #+(and threads (not windows)) :spawn
+  ;;     nil)
+  )
+
 (defun resolve-hostname (name)
   (car (sb-bsd-sockets:host-ent-addresses
         (sb-bsd-sockets:get-host-by-name name))))
@@ -66,8 +75,6 @@
   (nth-value 1 (sb-bsd-sockets:socket-name socket)))
 
 (defimplementation close-socket (socket)
-  (when (eq (preferred-communication-style) :fd-handler)
-    (remove-fd-handlers socket))
   (sb-bsd-sockets:socket-close socket))
 
 (defimplementation accept-connection (socket
@@ -85,11 +92,12 @@
             (return (sb-bsd-sockets:socket-accept socket))
           (sb-bsd-sockets:interrupted-error ()))))
 
-(defimplementation preferred-communication-style ()
-  ;; ECL on Windows does not provide condition-variables
-  (or #+(and threads (not windows)) :spawn
-      #+serve-event :fd-handler
-      nil))
+(defimplementation socket-fd (socket)
+  (etypecase socket
+    (fixnum socket)
+    (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
+    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+    (file-stream (si:file-stream-fd socket))))
 
 (defvar *external-format-to-coding-system*
   '((:latin-1
@@ -144,46 +152,34 @@
   (ext:quit))
 
 
-;;;; Serve Event Handlers
-
-;;; FIXME: verify this is correct implementation
 
+;;; Instead of busy waiting with communication-style NIL, use select()
+;;; on the sockets' streams.
 #+serve-event
 (progn
-  
-(defun socket-fd (socket)
-  (etypecase socket
-    (fixnum socket)
-    (two-way-stream (socket-fd (two-way-stream-input-stream socket)))
-    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
-    (file-stream (si:file-stream-fd socket))))
-
-(defvar *descriptor-handlers* (make-hash-table :test 'eql))
-
-(defimplementation add-fd-handler (socket fun)
-  (let* ((fd (socket-fd socket))
-         (handler (gethash fd *descriptor-handlers*)))
-    (when handler
-      (serve-event:remove-fd-handler handler))
-    (setf (gethash fd *descriptor-handlers*)
-          (serve-event:add-fd-handler fd :input #'(lambda (x)
-                                                    (declare (ignore x))
-                                                    (funcall fun))))
-    (serve-event:serve-event)))
-
-(defimplementation remove-fd-handlers (socket)
-  (let ((handler (gethash (socket-fd socket) *descriptor-handlers*)))
-    (when handler
-      (serve-event:remove-fd-handler handler))))
-
-(defimplementation wait-for-input (streams &optional timeout)
-  (assert (member timeout '(nil t)))
-  (loop
-     (let ((ready (remove-if-not #'listen streams)))
-       (when ready (return ready)))
-     ;; (when timeout (return nil))
-     (when (check-slime-interrupts) (return :interrupt))
-     (serve-event:serve-event)))
+  (defun poll-streams (streams timeout)
+    (let* ((serve-event::*descriptor-handlers*
+            (copy-list serve-event::*descriptor-handlers*))
+           (active-fds '())
+           (fd-stream-alist
+            (loop for s in streams
+                  for fd = (socket-fd s)
+                  collect (cons (socket-fd s) s)
+                  do (serve-event:add-fd-handler fd :input
+                                                 #'(lambda (fd)
+                                                     (push fd active-fds))))))
+      (serve-event:serve-event timeout)
+      (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))
+
+  (defimplementation wait-for-input (streams &optional timeout)
+    (assert (member timeout '(nil t)))
+    (loop
+      (cond ((check-slime-interrupts) (return :interrupt))
+            (timeout (return (poll-streams streams 0)))
+            (t
+             (let ((ready (poll-streams streams 0.2)))
+               (when ready
+                 (return ready)))))))  
 
 ) ; #+serve-event (progn ...
 
@@ -230,7 +226,9 @@
         (position (c:compiler-message-file-position condition)))
     (if (and position (not (minusp position)))
         (if *buffer-name*
-            (make-buffer-location *buffer-name* *buffer-start-position* position)
+            (make-buffer-location *buffer-name*
+                                  *buffer-start-position*
+                                  position)
             (make-file-location file position))
         (make-error-location "No location found."))))
 
@@ -270,47 +268,10 @@
 
 ;;;; Documentation
 
-(defun grovel-docstring-for-arglist (name type)
-  (flet ((compute-arglist-offset (docstring)
-           (when docstring
-             (let ((pos1 (search "Args: " docstring)))
-               (and pos1 (+ pos1 6))))))
-    (let* ((docstring (si::get-documentation name type))
-           (pos (compute-arglist-offset docstring)))
-      (if pos
-          (multiple-value-bind (arglist errorp)
-              (ignore-errors
-                (values (read-from-string docstring t nil :start pos)))
-            (if (or errorp (not (listp arglist)))
-                :not-available
-                ; ECL for some reason includes macro name at the first place
-                (if (or (macro-function name)
-                        (special-operator-p name)) 
-                    (cdr arglist)
-                    arglist)))
-          :not-available ))))
-
 (defimplementation arglist (name)
-  (cond ((and (symbolp name) (special-operator-p name))
-         (grovel-docstring-for-arglist name 'function))
-        ((and (symbolp name) (macro-function name))
-         (grovel-docstring-for-arglist name 'function))
-        ((or (functionp name) (fboundp name))
-         (multiple-value-bind (name fndef)
-             (if (functionp name)
-                 (values (function-name name) name)
-                 (values name (fdefinition name)))
-           (typecase fndef
-             (generic-function
-              (clos::generic-function-lambda-list fndef))
-             (compiled-function
-              (grovel-docstring-for-arglist name 'function))
-             (function
-              (let ((fle (function-lambda-expression fndef)))
-                (case (car fle)
-                  (si:lambda-block (caddr fle))
-                  (t               :not-available)))))))
-        (t :not-available)))
+  (multiple-value-bind (arglist foundp)
+      (si::function-lambda-list name)
+    (if foundp arglist :not-available)))
 
 (defimplementation function-name (f)
   (typecase f
@@ -335,6 +296,7 @@
     (:class (documentation name 'class))
     (t nil)))
 
+
 ;;; Debugging
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -499,62 +461,20 @@
        var-id))
 
 (defimplementation disassemble-frame (frame-number)
-  (let ((fun (frame-fun (elt *backtrace* frame-number))))
+  (let ((fun (frame-function (elt *backtrace* frame-number))))
     (disassemble fun)))
 
 (defimplementation eval-in-frame (form frame-number)
   (let ((env (second (elt *backtrace* frame-number))))
     (si:eval-with-env form env)))
 
+
 ;;;; Inspector
 
-(defmethod emacs-inspect ((o t))
-  ; ecl clos support leaves some to be desired
-  (cond
-    ((streamp o)
-     (list*
-      (format nil "~S is an ordinary stream~%" o)
-      (append
-       (list
-        "Open for "
-        (cond
-          ((ignore-errors (interactive-stream-p o)) "Interactive")
-          ((and (input-stream-p o) (output-stream-p o)) "Input and output")
-          ((input-stream-p o) "Input")
-          ((output-stream-p o) "Output"))
-        `(:newline) `(:newline))
-       (label-value-line*
-        ("Element type" (stream-element-type o))
-        ("External format" (stream-external-format o)))
-       (ignore-errors (label-value-line*
-                       ("Broadcast streams" (broadcast-stream-streams o))))
-       (ignore-errors (label-value-line*
-                       ("Concatenated streams" (concatenated-stream-streams o))))
-       (ignore-errors (label-value-line*
-                       ("Echo input stream" (echo-stream-input-stream o))))
-       (ignore-errors (label-value-line*
-                       ("Echo output stream" (echo-stream-output-stream o))))
-       (ignore-errors (label-value-line*
-                       ("Output String" (get-output-stream-string o))))
-       (ignore-errors (label-value-line*
-                       ("Synonym symbol" (synonym-stream-symbol o))))
-       (ignore-errors (label-value-line*
-                       ("Input stream" (two-way-stream-input-stream o))))
-       (ignore-errors (label-value-line*
-                       ("Output stream" (two-way-stream-output-stream o)))))))
-    ((si:instancep o)
-     (let* ((cl (si:instance-class o))
-            (slots (clos:class-slots cl)))
-       (list* (format nil "~S is an instance of class ~A~%"
-                      o (clos::class-name cl))
-               (loop for x in slots append
-                    (let* ((name (clos:slot-definition-name x))
-                           (value (clos::slot-value o name)))
-                      (list
-                       (format nil "~S: " name)
-                       `(:value ,value)
-                       `(:newline)))))))))
+;;; FIXME: Would be nice if it was possible to inspect objects
+;;; implemented in C.
 
+
 ;;;; Definitions
 
 ;;; FIXME: There ought to be a better way.
@@ -601,7 +521,7 @@
     (:lisp-function
      (list `((defun ,name) ,(source-location (fdefinition name)))))
     (:c-function
-     (list `((c-function ,name) ,(source-location (fdefinition name)))))
+     (list `((c-source ,name) ,(source-location (fdefinition name)))))
     (:generic-function
      (loop for method in (clos:generic-function-methods (fdefinition name))
            for specs = (clos:method-specializers method)
@@ -653,14 +573,12 @@
   (or (source-location object)
       (make-error-location "Source definition of ~S not found" object)))
 
+
 ;;;; Profiling
 
 #+profile
 (progn
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (require 'profile))
-
 (defimplementation profile (fname)
   (when fname (eval `(profile:profile ,fname))))
 
@@ -686,6 +604,7 @@
   (eval `(profile:profile ,(package-name (find-package package)))))
 ) ; #+profile (progn ...
 
+
 ;;;; Threads
 
 #+threads




From trittweiler at common-lisp.net  Tue Feb 23 20:54:30 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 23 Feb 2010 15:54:30 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nk1m2-0008I8-DD@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	* slime.el (slime-postprocess-xref): Show a TAGS entry's hints as
	part of an Xref's dspec for the case of multiple matches.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/23 20:50:55	1.1996
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/23 20:54:30	1.1997
@@ -1,5 +1,10 @@
 2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* slime.el (slime-postprocess-xref): Show a TAGS entry's hints as
+	part of an Xref's dspec for the case of multiple matches.
+
+2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank-ecl.lisp (preferred-communication-style): Go back to
 	NIL. Some parts (like the compiler and CLOS) of ECL do not seem to
 	be thread-safe yet. Also get rid of non-working implementation of
--- /project/slime/cvsroot/slime/slime.el	2010/02/22 12:40:30	1.1279
+++ /project/slime/cvsroot/slime/slime.el	2010/02/23 20:54:30	1.1280
@@ -3870,11 +3870,13 @@
            (destructure-case (slime-location.position loc)
              ((:tag &rest tags)
               (visit-tags-table tags-file)
-              (mapcar #'(lambda (loc)
-                          (make-slime-xref 
-                           :dspec (slime-xref.dspec original-xref)
-                           :location loc))
-                      (mapcan #'slime-etags-to-locations tags)))))
+              (mapcar #'(lambda (xref)
+                          (let ((old-dspec (slime-xref.dspec original-xref))
+                                (new-dspec (slime-xref.dspec xref)))
+                            (setf (slime-xref.dspec xref) 
+                                  (format "%s: %s" old-dspec new-dspec))
+                            xref))
+                      (mapcan #'slime-etags-definitions tags)))))
           (t 
            (list original-xref))))))
 




From trittweiler at common-lisp.net  Tue Feb 23 22:57:25 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 23 Feb 2010 17:57:25 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nk3gz-0000CZ-G6@common-lisp.net>

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

Modified Files:
	ChangeLog swank-backend.lisp swank-ecl.lisp 
Log Message:
	* swank-backend.lisp (when-let): New macro. For backends and
	swank.lisp.

	* swank-ecl.lisp: Use it. Also use new location support of ECL git
	HEAD.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/23 20:54:30	1.1997
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/23 22:57:25	1.1998
@@ -1,5 +1,13 @@
 2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-backend.lisp (when-let): New macro. For backends and
+	swank.lisp.
+
+	* swank-ecl.lisp: Use it. Also use new location support of ECL git
+	HEAD.
+
+2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* slime.el (slime-postprocess-xref): Show a TAGS entry's hints as
 	part of an Xref's dspec for the case of multiple matches.
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/22 21:38:46	1.194
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/23 22:57:25	1.195
@@ -34,6 +34,7 @@
            #:declaration-arglist
            #:type-specifier-arglist
            #:with-struct
+           #:when-let
            ;; interrupt macro for the backend
            #:*pending-slime-interrupts*
            #:check-slime-interrupts
@@ -253,6 +254,10 @@
                      (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
           , at body)))))
 
+(defmacro when-let ((var value) &body body)
+  `(let ((,var ,value))
+     (when ,var , at body)))
+
 (defun with-symbol (name package)
   "Generate a form suitable for testing with #+."
   (if (find-symbol (string name) (string package))
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/23 20:50:55	1.56
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/23 22:57:25	1.57
@@ -177,9 +177,8 @@
       (cond ((check-slime-interrupts) (return :interrupt))
             (timeout (return (poll-streams streams 0)))
             (t
-             (let ((ready (poll-streams streams 0.2)))
-               (when ready
-                 (return ready)))))))  
+             (when-let (ready (poll-streams streams 0.2))
+               (return ready))))))  
 
 ) ; #+serve-event (progn ...
 
@@ -270,7 +269,7 @@
 
 (defimplementation arglist (name)
   (multiple-value-bind (arglist foundp)
-      (si::function-lambda-list name)
+      (ext:function-lambda-list name)
     (if foundp arglist :not-available)))
 
 (defimplementation function-name (f)
@@ -284,9 +283,8 @@
 (defimplementation describe-symbol-for-emacs (symbol)
   (let ((result '()))
     (dolist (type '(:VARIABLE :FUNCTION :CLASS))
-      (let ((doc (describe-definition symbol type)))
-        (when doc
-          (setf result (list* type doc result)))))
+      (when-let (doc (describe-definition symbol type))
+        (setf result (list* type doc result))))
     result))
 
 (defimplementation describe-definition (name type)
@@ -371,12 +369,10 @@
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (declare (type function debugger-loop-fn))
-  (let* ((*tpl-commands* si::tpl-commands)
-         (*ihs-top* (ihs-top))
+  (let* ((*ihs-top* (ihs-top))
          (*ihs-current* *ihs-top*)
          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
          (*frs-top* (frs-top))
-         (*read-suppress* nil)
          (*tpl-level* (1+ *tpl-level*))
          (*backtrace* (loop for ihs from 0 below *ihs-top*
                             collect (list (si::ihs-fun ihs)
@@ -514,14 +510,27 @@
              (push :c-function types))
             (t
              (push :lisp-function types))))
+    (when (boundp name)
+      (cond ((constantp name)
+             (push :constant types))
+            (t
+             (push :global-variable types))))
     types))
 
-(defun find-definitions-for-type (name type)
+(defun find-definitions-by-name (name)
+  (when-let (annotations (ext:get-annotation name 'si::location :all))
+    (loop for annotation in annotations
+          collect (destructuring-bind (op file . pos) annotation
+                    `((,op ,name) ,(make-file-location file pos))))))
+
+(defun find-definitions-by-type (name type)
   (ecase type
     (:lisp-function
-     (list `((defun ,name) ,(source-location (fdefinition name)))))
+     (when-let (loc (source-location (fdefinition name)))
+       (list `((defun ,name) ,loc))))
     (:c-function
-     (list `((c-source ,name) ,(source-location (fdefinition name)))))
+     (when-let (loc (source-location (fdefinition name)))
+       (list `((c-source ,name) ,loc))))
     (:generic-function
      (loop for method in (clos:generic-function-methods (fdefinition name))
            for specs = (clos:method-specializers method)
@@ -529,13 +538,14 @@
            when loc
              collect `((defmethod ,name ,specs) ,loc)))
     (:macro
-     (list `((defmacro ,name) ,(source-location (macro-function name)))))
-    (:special-operator)))
+     (when-let (loc (source-location (macro-function name)))
+       (list `((defmacro ,name) ,loc))))
+    ((:special-operator :constant :global-variable))))
 
 (defimplementation find-definitions (name)
-  (mapcan #'(lambda (type) (find-definitions-for-type name type))
-          (classify-definition-name name)))
-
+  (nconc (find-definitions-by-name name)
+         (mapcan #'(lambda (type) (find-definitions-by-type name type))
+                 (classify-definition-name name))))
 
 (defun source-location (object)
   (converting-errors-to-error-location




From trittweiler at common-lisp.net  Thu Feb 25 16:35:23 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 25 Feb 2010 11:35:23 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NkggN-0005xj-5M@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
	* swank-loader.lisp (lisp-version-string): Add git-commit ids for
	ECL because individual commits do not guarantee fasl
	compatibility.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/23 22:57:25	1.1998
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/25 16:35:22	1.1999
@@ -1,3 +1,9 @@
+2010-02-25  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-loader.lisp (lisp-version-string): Add git-commit ids for
+	ECL because individual commits do not guarantee fasl
+	compatibility.
+
 2010-02-23  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-backend.lisp (when-let): New macro. For backends and
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/20 18:20:46	1.100
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/25 16:35:23	1.101
@@ -59,10 +59,19 @@
     :sparc64 :sparc :hppa64 :hppa
     :pentium3 :pentium4))
 
+#+ecl
+(defun ecl-version-string ()
+  #+#.(cl:if (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) '(:and) '(:or))
+  (format nil "~A-~A"
+          (lisp-implementation-version) 
+          (subseq (ext:lisp-implementation-vcs-id) 0 8))
+  #-#.(cl:if (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) '(:and) '(:or))
+  (lisp-implementation-version))
+
 (defun lisp-version-string ()
   #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
                                     (lisp-implementation-version))
-  #+(or cormanlisp scl sbcl ecl)       (lisp-implementation-version)
+  #+(or cormanlisp scl sbcl) (lisp-implementation-version)
   #+lispworks (lisp-implementation-version)
   #+allegro   (format nil "~A~A~A~A"
                       excl::*common-lisp-version-number*
@@ -73,7 +82,8 @@
                        (:+ics "-ics")))
   #+clisp     (let ((s (lisp-implementation-version)))
                 (subseq s 0 (position #\space s)))
-  #+armedbear (lisp-implementation-version))
+  #+armedbear (lisp-implementation-version)
+  #+ecl (ecl-version-string) )
 
 (defun unique-dir-name ()
   "Return a name that can be used as a directory name that is




From sboukarev at common-lisp.net  Thu Feb 25 22:35:50 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 25 Feb 2010 17:35:50 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NkmJC-0004k6-7J@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp (ecl-version-string): In
#+(or) (progn #+#.(cl:print cl:nil) 1) PRINT does run on SBCL, which
breaks #+#.(cl:if (cl:find-symbol "SYMBOL" :ext) ...) here, guard it with
(find-package :ext) until further investigations.


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/25 16:35:22	1.1999
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/25 22:35:50	1.2000
@@ -1,3 +1,10 @@
+2010-02-25  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-loader.lisp (ecl-version-string): In
+	#+(or) (progn #+#.(cl:print cl:nil) 1) PRINT does run on SBCL, which
+	breaks #+#.(cl:if (cl:find-symbol "SYMBOL" :ext) ...) here, guard it with
+	(find-package :ext) until further investigations.
+
 2010-02-25  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-loader.lisp (lisp-version-string): Add git-commit ids for
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/25 16:35:23	1.101
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/25 22:35:50	1.102
@@ -61,11 +61,15 @@
 
 #+ecl
 (defun ecl-version-string ()
-  #+#.(cl:if (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) '(:and) '(:or))
+  #+#.(cl:if (cl:and
+              (cl:find-package :ext)
+              (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)) '(:and) '(:or))
   (format nil "~A-~A"
           (lisp-implementation-version) 
           (subseq (ext:lisp-implementation-vcs-id) 0 8))
-  #-#.(cl:if (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) '(:and) '(:or))
+  #-#.(cl:if (cl:and
+              (cl:find-package :ext)
+              (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)) '(:and) '(:or))
   (lisp-implementation-version))
 
 (defun lisp-version-string ()




From sboukarev at common-lisp.net  Fri Feb 26 21:02:59 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 26 Feb 2010 16:02:59 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nl7Kt-0006UO-L0@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
* swank-loader.lisp (ecl-version-string): Check length of
the result of ext:lisp-implementation-vcs-id before doing subseq.
On CVS it returns "unknown".


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/25 22:35:50	1.2000
+++ /project/slime/cvsroot/slime/ChangeLog	2010/02/26 21:02:59	1.2001
@@ -1,3 +1,9 @@
+2010-02-26  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-loader.lisp (ecl-version-string): Check length of
+	the result of ext:lisp-implementation-vcs-id before doing subseq.
+	On CVS it returns "unknown".
+
 2010-02-25  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-loader.lisp (ecl-version-string): In
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/25 22:35:50	1.102
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/26 21:02:59	1.103
@@ -59,18 +59,16 @@
     :sparc64 :sparc :hppa64 :hppa
     :pentium3 :pentium4))
 
+(defun q (s) (read-from-string s))
+
 #+ecl
 (defun ecl-version-string ()
-  #+#.(cl:if (cl:and
-              (cl:find-package :ext)
-              (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)) '(:and) '(:or))
-  (format nil "~A-~A"
-          (lisp-implementation-version) 
-          (subseq (ext:lisp-implementation-vcs-id) 0 8))
-  #-#.(cl:if (cl:and
-              (cl:find-package :ext)
-              (cl:find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)) '(:and) '(:or))
-  (lisp-implementation-version))
+  (format nil "~A~@[-~A~]"
+          (lisp-implementation-version)
+          (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext)
+            (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id"))))
+              (when (>= (length vcs-id) 8)
+                (subseq vcs-id 0 8))))))
 
 (defun lisp-version-string ()
   #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /"))
@@ -233,8 +231,6 @@
 (defun contrib-dir (base-dir)
   (append-dir base-dir "contrib"))
 
-(defun q (s) (read-from-string s))
-
 (defun load-swank (&key (src-dir *source-directory*)
                         (fasl-dir *fasl-directory*))
   (compile-files (src-files *swank-files* src-dir) fasl-dir t)