From trittweiler at common-lisp.net  Mon Mar  1 12:26:02 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 01 Mar 2010 07:26:02 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nm4hG-0007aT-5t@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	Fix that annoying bug that caused being constantly asked to switch
	connection in case one had multiple connections running and quit
	from one.

	* slime.el (slime-modeline-string): Bail out early because
	`slime-current-package' involves `slime-connection' in case the
	slime-repl contrib is used, and querying the user in a
	periodically called function is rather annoying..


--- /project/slime/cvsroot/slime/ChangeLog	2010/02/26 21:02:59	1.2001
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/01 12:26:01	1.2002
@@ -1,3 +1,14 @@
+2010-03-01  Tobias C. Rittweiler <tcr at freebits.de>
+
+	Fix that annoying bug that caused being constantly asked to switch
+	connection in case one had multiple connections running and quit
+	from one.
+
+	* slime.el (slime-modeline-string): Bail out early because
+	`slime-current-package' involves `slime-connection' in case the
+	slime-repl contrib is used, and querying the user in a
+	periodically called function is rather annoying..
+
 2010-02-26  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-loader.lisp (ecl-version-string): Check length of
--- /project/slime/cvsroot/slime/slime.el	2010/02/23 20:54:30	1.1280
+++ /project/slime/cvsroot/slime/slime.el	2010/03/01 12:26:01	1.1281
@@ -435,18 +435,21 @@
 \"Slime\" only appears if we aren't connected.  If connected,
 include package-name, connection-name, and possibly some state
 information."
-  (let* ((conn (slime-current-connection))
-         (local (and conn (eq conn slime-buffer-connection)))
-         (pkg (slime-current-package)))
-    (cond ((not conn) (and slime-mode " Slime"))
-          ((concat " "
-                   (if local "{" "[")
-                   (if pkg (slime-pretty-package-name pkg) "?")
-                   " "
-                   ;; ignore errors for closed connections
-                   (ignore-errors (slime-connection-name conn))
-                   (slime-modeline-state-string conn)
-                   (if local "}" "]"))))))
+  (let ((conn (slime-current-connection)))
+    ;; Bail out early in case there's no connection, so we won't
+    ;; implicitly invoke `slime-connection' which may query the user.
+    (if (not conn)
+        (and slime-mode " Slime")
+        (let ((local (eq conn slime-buffer-connection))
+              (pkg   (slime-current-package)))
+          (concat " "
+                  (if local "{" "[")
+                  (if pkg (slime-pretty-package-name pkg) "?")
+                  " "
+                  ;; ignore errors for closed connections
+                  (ignore-errors (slime-connection-name conn))
+                  (slime-modeline-state-string conn)
+                  (if local "}" "]"))))))
 
 (defun slime-pretty-package-name (name)
   "Return a pretty version of a package name NAME."




From sboukarev at common-lisp.net  Mon Mar  1 15:42:08 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 01 Mar 2010 10:42:08 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nm7l2-0000VX-8Y@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (documentation-symbol): Show arglists for functions too.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/01 12:26:01	1.2002
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/01 15:42:07	1.2003
@@ -1,3 +1,7 @@
+2010-03-01  Stas Boukarev  <stassats at gmail.com>
+
+	* swank.lisp (documentation-symbol): Show arglists for functions too.
+
 2010-03-01  Tobias C. Rittweiler <tcr at freebits.de>
 
 	Fix that annoying bug that caused being constantly asked to switch
--- /project/slime/cvsroot/slime/swank.lisp	2010/02/17 17:04:46	1.689
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/01 15:42:08	1.690
@@ -3008,7 +3008,9 @@
               (when vdoc
                 (format string "Variable:~% ~a~2%" vdoc))
               (when fdoc
-                (format string "Function:~% ~a" fdoc))))
+                (format string "Function:~% Arglist: ~a~2% ~a"
+                        (swank-backend:arglist sym)
+                        fdoc))))
           (format nil "No such symbol, ~a." symbol-name)))))
 
 




From sboukarev at common-lisp.net  Tue Mar  2 12:38:07 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 02 Mar 2010 07:38:07 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmRMV-0007l1-9p@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank-abcl.lisp swank-allegro.lisp 
	swank-backend.lisp swank-ccl.lisp swank-clisp.lisp 
	swank-cmucl.lisp swank-corman.lisp swank-ecl.lisp 
	swank-lispworks.lisp swank-sbcl.lisp swank-scl.lisp swank.lisp 
Log Message:
* slime.el (slime-compile-and-load-file): Accept C-u arguments for
compilation policy the same way as slime-compile-defun.

* swank.lisp (compile-file-for-emacs): Take an additional policy argument.
* swank-backend.lisp (swank-compile-file): Ditto.

* swank-sbcl.lisp (compiler-policy, (setf compiler-policy)):
rename from get/set-compiler-policy.
(with-compiler-policy): New macro.
(swank-compile-file): Use with-compiler-policy.
(swank-compile-string): Ditto.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/01 15:42:07	1.2003
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/02 12:38:06	1.2004
@@ -1,3 +1,17 @@
+2010-03-02  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-compile-and-load-file): Accept C-u arguments for
+	compilation policy the same way as slime-compile-defun.
+
+	* swank.lisp (compile-file-for-emacs): Take an additional policy argument.
+	* swank-backend.lisp (swank-compile-file): Ditto.
+
+	* swank-sbcl.lisp (compiler-policy, (setf compiler-policy)):
+	rename from get/set-compiler-policy.
+	(with-compiler-policy): New macro.
+	(swank-compile-file): Use with-compiler-policy.
+	(swank-compile-string): Ditto.
+
 2010-03-01  Stas Boukarev  <stassats at gmail.com>
 
 	* swank.lisp (documentation-symbol): Show arglists for functions too.
--- /project/slime/cvsroot/slime/slime.el	2010/03/01 12:26:01	1.1281
+++ /project/slime/cvsroot/slime/slime.el	2010/03/02 12:38:06	1.1282
@@ -2498,7 +2498,7 @@
 ;; FIXME: I doubt that anybody uses this directly and it seems to be
 ;; only an ugly way to pass arguments.
 (defvar slime-compilation-policy nil
-  "When non-nil compile defuns with this debug optimization level.")
+  "When non-nil compile with these optimization settings.")
 
 (defun slime-compute-policy (arg)
   "Return the policy for the prefix argument ARG."
@@ -2526,15 +2526,21 @@
   "Return all compiler notes, warnings, and errors."
   (slime-compilation-result.notes slime-last-compilation-result))
 
-(defun slime-compile-and-load-file ()
+(defun slime-compile-and-load-file (&optional policy)
   "Compile and load the buffer's file and highlight compiler notes.
 
+With (positive) prefix argument the file is compiled with maximal
+debug settings (`C-u'). With negative prefix argument it is compiled for
+speed (`M--'). If a numeric argument is passed set debug or speed settings
+to it depending on its sign.
+
 Each source location that is the subject of a compiler note is
 underlined and annotated with the relevant information. The commands
 `slime-next-note' and `slime-previous-note' can be used to navigate
 between compiler notes and to display their full details."
-  (interactive)
-  (slime-compile-file t))
+  (interactive "P")
+  (let ((slime-compilation-policy (slime-compute-policy policy)))
+    (slime-compile-file t)))
 
 ;;; FIXME: This should become a DEFCUSTOM
 (defvar slime-compile-file-options '()
@@ -2556,16 +2562,19 @@
   (let ((file (slime-to-lisp-filename (buffer-file-name))))
     (slime-eval-async
      `(swank:compile-file-for-emacs ,file ,(if load t nil) 
-                                    ',slime-compile-file-options)
+                                    :options ',slime-compile-file-options
+                                    :policy ',slime-compilation-policy)
      #'slime-compilation-finished)
     (message "Compiling %s..." file)))
 
 (defun slime-compile-defun (&optional raw-prefix-arg)
   "Compile the current toplevel form. 
 
-If invoked with a simple prefix-arg (`C-u'), compile the defun
-with maximum debug setting. If invoked with a numeric prefix arg,
-compile with a debug setting of that number."
+With (positive) prefix argument the form is compiled with maximal
+debug settings (`C-u'). With negative prefix argument it is compiled for
+speed (`M--'). If a numeric argument is passed set debug or speed settings
+to it depending on its sign."
+  
   (interactive "P")
   (let ((slime-compilation-policy (slime-compute-policy raw-prefix-arg)))
     (if (use-region-p)
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2010/01/28 09:52:19	1.81
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2010/03/02 12:38:06	1.82
@@ -421,8 +421,9 @@
                                  (list :position 1)))))))))
 
 (defimplementation swank-compile-file (input-file output-file
-                                       load-p external-format)
-  (declare (ignore external-format))
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore external-format policy))
   (let ((jvm::*resignal-compiler-warnings* t)
         (*abcl-signaled-conditions* nil))
     (handler-bind ((warning #'handle-compiler-warning))
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/01/25 10:50:10	1.131
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/02 12:38:06	1.132
@@ -313,7 +313,9 @@
     (funcall function)))
 
 (defimplementation swank-compile-file (input-file output-file 
-                                       load-p external-format)
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
   (handler-case
       (with-compilation-hooks ()
         (let ((*buffer-name* nil)
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/23 22:57:25	1.195
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/03/02 12:38:06	1.196
@@ -423,19 +423,24 @@
 source information.
 
 If POLICY is supplied, and non-NIL, it may be used by certain
-implementations to compile with a debug optimization quality of its
+implementations to compile with optimization qualities of its
 value.
 
 Should return T on successfull compilation, NIL otherwise.
 ")
 
 (definterface swank-compile-file (input-file output-file load-p 
-                                             external-format)
+                                             external-format
+                                             &key policy)
    "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
 If LOAD-P is true, load the file after compilation.
 EXTERNAL-FORMAT is a value returned by find-external-format or
 :default.
 
+If POLICY is supplied, and non-NIL, it may be used by certain
+implementations to compile with optimization qualities of its
+value.
+
 Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
 like `compile-file'")
 
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2010/02/20 15:12:19	1.15
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2010/03/02 12:38:06	1.16
@@ -175,7 +175,9 @@
       (funcall function))))
 
 (defimplementation swank-compile-file (input-file output-file
-                                       load-p external-format)
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
   (with-compilation-hooks ()
     (compile-file input-file 
                   :output-file output-file 
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2009/11/02 09:20:33	1.92
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2010/03/02 12:38:06	1.93
@@ -605,7 +605,9 @@
                           :location (compiler-note-location))))
 
 (defimplementation swank-compile-file (input-file output-file
-                                       load-p external-format)
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
   (with-compilation-hooks ()
     (with-compilation-unit ()
       (multiple-value-bind (fasl-file warningsp failurep)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/02/17 17:04:46	1.219
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/03/02 12:38:06	1.220
@@ -405,8 +405,9 @@
       (funcall function))))
 
 (defimplementation swank-compile-file (input-file output-file
-                                       load-p external-format)
-  (declare (ignore external-format))
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore external-format policy))
   (clear-xref-info input-file)
   (with-compilation-hooks ()
     (let ((*buffer-name* nil)
--- /project/slime/cvsroot/slime/swank-corman.lisp	2009/06/21 07:22:56	1.24
+++ /project/slime/cvsroot/slime/swank-corman.lisp	2010/03/02 12:38:07	1.25
@@ -362,8 +362,9 @@
     (funcall fn)))
 
 (defimplementation swank-compile-file (input-file output-file 
-				       load-p external-format)
-  (declare (ignore external-format))
+				       load-p external-format
+                                       &key policy)
+  (declare (ignore external-format policy))
   (with-compilation-hooks ()
     (let ((*buffer-name* nil)
 	  (*compile-filename* input-file))
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/02/23 22:57:25	1.57
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/02 12:38:07	1.58
@@ -236,7 +236,9 @@
     (funcall function)))
 
 (defimplementation swank-compile-file (input-file output-file
-                                       load-p external-format)
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
   (with-compilation-hooks ()
     (compile-file input-file :output-file output-file
                   :load load-p
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2009/11/02 09:20:34	1.135
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/03/02 12:38:07	1.136
@@ -464,7 +464,9 @@
                                        ,location))))))
 
 (defimplementation swank-compile-file (input-file output-file
-                                       load-p external-format)
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
   (with-swank-compilation-unit (input-file)
     (compile-file input-file 
                   :output-file output-file
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/02/22 21:38:46	1.267
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/03/02 12:38:07	1.268
@@ -558,12 +558,37 @@
 
 (defvar *trap-load-time-warnings* nil)
 
+(defun compiler-policy (qualities)
+  "Return compiler policy qualities present in the QUALITIES alist.
+QUALITIES is an alist with (quality . value)"
+  #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
+  (loop with policy = (sb-ext:restrict-compiler-policy)
+        for (quality) in qualities
+        collect (cons quality
+                      (or (cdr (assoc quality policy))
+                          0))))
+
+(defun (setf compiler-policy) (policy)
+  (declare (ignorable policy))
+  #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
+  (loop for (qual . value) in policy
+        do (sb-ext:restrict-compiler-policy qual value)))
+
+(defmacro with-compiler-policy (policy &body body)
+  (let ((current-policy (gensym)))
+    `(let ((,current-policy (compiler-policy ,policy)))
+       (setf (compiler-policy) ,policy)
+       (unwind-protect (progn , at body)
+         (setf (compiler-policy) ,current-policy)))))
+
 (defimplementation swank-compile-file (input-file output-file 
-                                       load-p external-format)
+                                       load-p external-format
+                                       &key policy)
   (multiple-value-bind (output-file warnings-p failure-p)
-      (with-compilation-hooks ()
-        (compile-file input-file :output-file output-file
-                      :external-format external-format))
+      (with-compiler-policy policy
+        (with-compilation-hooks ()
+          (compile-file input-file :output-file output-file
+                        :external-format external-format)))
     (values output-file warnings-p
             (or failure-p
                 (when load-p
@@ -593,27 +618,12 @@
   "Return a temporary file name to compile strings into."
   (tempnam nil nil))
 
-(defun get-compiler-policy (default-policy)
-  (declare (ignorable default-policy))
-  #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
-  (remove-duplicates (append default-policy (sb-ext:restrict-compiler-policy))
-                     :key #'car))
-
-(defun set-compiler-policy (policy)
-  (declare (ignorable policy))
-  #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
-   (loop for (qual . value) in policy
-         do (sb-ext:restrict-compiler-policy qual value)))
-
 (defimplementation swank-compile-string (string &key buffer position filename
                                          policy)
   (let ((*buffer-name* buffer)
         (*buffer-offset* position)
         (*buffer-substring* string)
-        (temp-file-name (temp-file-name))
-        (saved-policy (get-compiler-policy '((debug . 0) (speed . 0)))))
-    (when policy
-      (set-compiler-policy policy))
+        (temp-file-name (temp-file-name)))
     (flet ((load-it (filename)
              (when filename (load filename)))
            (compile-it (cont)
@@ -631,11 +641,11 @@
       (with-open-file (s temp-file-name :direction :output :if-exists :error)
         (write-string string s))
       (unwind-protect
-           (if *trap-load-time-warnings*
-               (compile-it #'load-it)
-               (load-it (compile-it #'identity)))
+           (with-compiler-policy policy
+            (if *trap-load-time-warnings*
+                (compile-it #'load-it)
+                (load-it (compile-it #'identity))))
         (ignore-errors
-          (set-compiler-policy saved-policy)
           (delete-file temp-file-name)
           (delete-file (compile-file-pathname temp-file-name)))))))
 
--- /project/slime/cvsroot/slime/swank-scl.lisp	2009/11/02 09:20:34	1.35
+++ /project/slime/cvsroot/slime/swank-scl.lisp	2010/03/02 12:38:07	1.36
@@ -439,7 +439,9 @@
       (funcall function))))
 
 (defimplementation swank-compile-file (input-file output-file 
-                                       load-p external-format)
+                                       load-p external-format
+                                       &key policy)
+  (declare (ignore policy))
   (with-compilation-hooks ()
     (let ((*buffer-name* nil)
           (ext:*ignore-extra-close-parentheses* nil))
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/01 15:42:08	1.690
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/02 12:38:07	1.691
@@ -2650,7 +2650,7 @@
                  (funcall function)))))
       (make-compilation-result (reverse notes) (and successp t) seconds))))
 
-(defslimefun compile-file-for-emacs (filename load-p &optional options)
+(defslimefun compile-file-for-emacs (filename load-p &key options policy)
   "Compile FILENAME and, when LOAD-P, load the result.
 Record compiler notes signalled as `compiler-condition's."
   (with-buffer-syntax ()
@@ -2663,7 +2663,8 @@
                                  (fasl-pathname pathname options)
                                  load-p
                                  (or (guess-external-format pathname)
-                                     :default))
+                                     :default)
+                                 :policy policy)
            (declare (ignore output-pathname warnings?))
            (not failure?)))))))
 




From sboukarev at common-lisp.net  Tue Mar  2 12:39:21 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 02 Mar 2010 07:39:21 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NmRNh-00084c-GV@common-lisp.net>

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

Modified Files:
	slime.texi 
Log Message:
* doc/slime.texi (Compilation): Update.


--- /project/slime/cvsroot/slime/doc/slime.texi	2010/02/01 14:51:26	1.96
+++ /project/slime/cvsroot/slime/doc/slime.texi	2010/03/02 12:39:21	1.97
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2010/02/01 14:51:26 $}
+ at set UPDATED @code{$Date: 2010/03/02 12:39:21 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -866,8 +866,9 @@
 give some feedback which part was chosen.
 
 With (positive) prefix argument the form is compiled with maximal
-debug settings (@kbd{C-u C-c C-c}).  With negative prefix argument it is compiled for
-speed (@kbd{M-- C-c C-c}).
+debug settings (@kbd{C-u C-c C-c}). With negative prefix argument it is compiled for
+speed (@kbd{M-- C-c C-c}). If a numeric argument is passed set debug or speed settings
+to it depending on its sign.
 
 The code for the region is executed after compilation.  In principle,
 the command writes the region to a file, compiles that file, and loads
@@ -879,6 +880,11 @@
 whether the compilation failed: occasionally you may end up in the
 debugger during the load step.
 
+With (positive) prefix argument the file is compiled with maximal
+debug settings (@kbd{C-u C-c C-k}). With negative prefix argument it is compiled for
+speed (@kbd{M-- C-c C-k}). If a numeric argument is passed set debug or speed settings
+to it depending on its sign.
+
 @kbditem{C-c M-k, slime-compile-file}
 Compile (but don't load) the current buffer's source file.
 




From sboukarev at common-lisp.net  Tue Mar  2 12:40:42 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 02 Mar 2010 07:40:42 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmRP0-0000Dd-UW@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Forgot to commit ChangeLog.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/02 12:38:06	1.2004
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/02 12:40:42	1.2005
@@ -12,6 +12,8 @@
 	(swank-compile-file): Use with-compiler-policy.
 	(swank-compile-string): Ditto.
 
+	* doc/slime.texi (Compilation): Update.
+
 2010-03-01  Stas Boukarev  <stassats at gmail.com>
 
 	* swank.lisp (documentation-symbol): Show arglists for functions too.




From sboukarev at common-lisp.net  Tue Mar  2 14:36:48 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 02 Mar 2010 09:36:48 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmTDM-0007Sr-65@common-lisp.net>

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (definition-source-for-emacs): Don't error when source
location doesn't contain form position, point emacs to the beginning of a source file
and if it's a function provide a snippet "(defun <name> ".


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/02 12:40:42	1.2005
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/02 14:36:47	1.2006
@@ -1,5 +1,11 @@
 2010-03-02  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-sbcl.lisp (definition-source-for-emacs): Don't error when source
+	location doesn't contain form position, point emacs to the beginning of a source file
+	and if it's a function provide a snippet "(defun <name> ".
+
+2010-03-02  Stas Boukarev  <stassats at gmail.com>
+
 	* slime.el (slime-compile-and-load-file): Accept C-u arguments for
 	compilation policy the same way as slime-compile-defun.
 
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/03/02 12:38:07	1.268
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/03/02 14:36:48	1.269
@@ -728,6 +728,7 @@
       definition-source
     (cond ((getf plist :emacs-buffer) :buffer)
           ((and pathname (or form-path character-offset)) :file)
+          (pathname :file-without-position)
           (t :invalid))))
 
 (defun definition-source-for-emacs (definition-source type name)
@@ -764,6 +765,11 @@
                         ;; 0, buffer positions in Emacs start from 1.
                         `(:position ,(1+ pos))
                         `(:snippet ,snippet))))
+      (:file-without-position
+       (make-location `(:file ,(namestring (translate-logical-pathname pathname)))
+                      '(:position 1)
+                      (when (eql type :function)
+                        `(:snippet ,(format nil "(defun ~a " (symbol-name name))))))
       (:invalid
        (error "DEFINITION-SOURCE of ~A ~A did not contain ~
                meaningful information."




From heller at common-lisp.net  Wed Mar  3 11:56:36 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 03 Mar 2010 06:56:36 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmnBs-00028K-4F@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Make eval-in-frame display multiple values; not only the first.

* swank.lisp (values-to-string): New macro.
(eval-string-in-frame): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/02 14:36:47	1.2006
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:56:35	1.2007
@@ -181,6 +181,13 @@
 	resulting in duplicate modeline strings.
 	Reported by Leo Liu.
 
+2010-02-19  Helmut Eller  <heller at common-lisp.net>
+
+	Make eval-in-frame display multiple values; not only the first.
+
+	* swank.lisp (values-to-string): New macro.
+	(eval-string-in-frame): Use it.
+
 2010-02-18  Mark Harig <idirectscm at aim.com>
 
 	The compiler warns about various stuff. Fix some of it.
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/02 12:38:07	1.691
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:56:35	1.692
@@ -2012,6 +2012,9 @@
                        *echo-area-prefix* i i i i)))
             (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
 
+(defmacro values-to-string (values)
+  `(format-values-for-echo-area (multiple-value-list ,values)))
+
 (defslimefun interactive-eval (string)
   (with-buffer-syntax ()
     (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
@@ -2068,13 +2071,13 @@
   "A list of variables bindings during pretty printing.
 Used by pprint-eval.")
 
-(defun swank-pprint (list)
-  "Bind some printer variables and pretty print each object in LIST."
+(defun swank-pprint (values)
+  "Bind some printer variables and pretty print each object in VALUES."
   (with-buffer-syntax ()
     (with-bindings *swank-pprint-bindings*
-      (cond ((null list) "; No value")
+      (cond ((null values) "; No value")
             (t (with-output-to-string (*standard-output*)
-                 (dolist (o list)
+                 (dolist (o values)
                    (pprint o)
                    (terpri))))))))
   
@@ -2553,16 +2556,14 @@
      ,form))
 
 (defslimefun eval-string-in-frame (string index)
-  (to-string
-   (with-retry-restart (:msg "Retry SLIME evaluation request.")
-     (eval-in-frame (wrap-sldb-vars (from-string string))
-                    index))))
+  (values-to-string
+   (eval-in-frame (wrap-sldb-vars (from-string string))
+                  index)))
 
 (defslimefun pprint-eval-string-in-frame (string index)
   (swank-pprint
-   (with-retry-restart (:msg "Retry SLIME evaluation request.")
-     (multiple-value-list 
-      (eval-in-frame (wrap-sldb-vars (from-string string)) index)))))
+   (multiple-value-list 
+    (eval-in-frame (wrap-sldb-vars (from-string string)) index))))
 
 (defslimefun frame-locals-and-catch-tags (index)
   "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX.




From heller at common-lisp.net  Wed Mar  3 11:56:44 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 03 Mar 2010 06:56:44 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmnC0-00028s-LW@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Use @ instead of # to mark object in the inspect history.

* swank.lisp (print-part-to-string): Use @.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:56:35	1.2007
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:56:44	1.2008
@@ -181,6 +181,12 @@
 	resulting in duplicate modeline strings.
 	Reported by Leo Liu.
 
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
+	Use @ instead of # to mark object in the inspect history.
+
+	* swank.lisp (print-part-to-string): Use @.
+
 2010-02-19  Helmut Eller  <heller at common-lisp.net>
 
 	Make eval-in-frame display multiple values; not only the first.
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:56:35	1.692
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:56:44	1.693
@@ -3261,7 +3261,7 @@
   (let* ((string (to-line value))
          (pos (position value *inspector-history*)))
     (if pos
-        (format nil "#~D=~A" pos string)
+        (format nil "@~D=~A" pos string)
         string)))
 
 (defun content-range (list start end)




From heller at common-lisp.net  Wed Mar  3 11:56:52 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 03 Mar 2010 06:56:52 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmnC8-00029S-Ub@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Don't try to bind keywords in inspector-eval.

* swank.lisp (inspector-eval): For now, don't bind symbols which
are constantp.  Maybe something better can be found later.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:56:44	1.2008
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:56:52	1.2009
@@ -183,6 +183,13 @@
 
 2010-03-03  Helmut Eller  <heller at common-lisp.net>
 
+	Don't try to bind keywords in inspector-eval.
+
+	* swank.lisp (inspector-eval): For now, don't bind symbols which
+	are constantp.  Maybe something better can be found later.
+
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
 	Use @ instead of # to mark object in the inspect history.
 
 	* swank.lisp (print-part-to-string): Use @.
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:56:44	1.693
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:56:52	1.694
@@ -3323,7 +3323,8 @@
                  (read-from-string string)))
          (ignorable (remove-if #'boundp (mapcar #'car context))))
     (to-string (eval `(let ((* ',obj) (- ',form)
-                            . ,(loop for (var . val) in context collect
+                            . ,(loop for (var . val) in context 
+                                     unless (constantp var) collect 
                                      `(,var ',val)))
                         (declare (ignorable . ,ignorable))
                         ,form)))))




From heller at common-lisp.net  Wed Mar  3 11:57:03 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 03 Mar 2010 06:57:03 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmnCJ-0002A6-NF@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
* slime.el (slime-inspector-history): New command.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:56:52	1.2009
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:57:03	1.2010
@@ -183,6 +183,9 @@
 
 2010-03-03  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el (slime-inspector-history): New command.
+
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
 	Don't try to bind keywords in inspector-eval.
 
 	* swank.lisp (inspector-eval): For now, don't bind symbols which
--- /project/slime/cvsroot/slime/slime.el	2010/03/02 12:38:06	1.1282
+++ /project/slime/cvsroot/slime/slime.el	2010/03/03 11:57:03	1.1283
@@ -6580,6 +6580,11 @@
   (interactive (list (slime-read-from-minibuffer "Inspector eval: ")))
   (slime-eval-with-transcript `(swank:inspector-eval ,string)))
 
+(defun slime-inspector-history ()
+  "Show the previously inspected objects."
+  (interactive)
+  (slime-eval-describe `(swank:inspector-history)))
+
 (defun slime-inspector-show-source (part)
   (interactive (list (or (get-text-property (point) 'slime-part-number)
                          (error "No part at point"))))
@@ -6673,6 +6678,7 @@
   ("d" 'slime-inspector-describe)
   ("p" 'slime-inspector-pprint)
   ("e" 'slime-inspector-eval)
+  ("h" 'slime-inspector-history)
   ("q" 'slime-inspector-quit)
   ("g" 'slime-inspector-reinspect)
   ("v" 'slime-inspector-toggle-verbose)
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:56:52	1.694
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:57:03	1.695
@@ -3329,6 +3329,23 @@
                         (declare (ignorable . ,ignorable))
                         ,form)))))
 
+(defslimefun inspector-history ()
+  (with-output-to-string (out)
+    (let ((newest (loop for s = *istate* then next
+                        for next = (istate.next s)
+                        if (not next) return s)))
+      (format out "--- next/prev chain ---")
+      (loop for s = newest then (istate.previous s) while s do
+            (let ((val (istate.object s)))
+              (format out "~%~:[  ~; *~]@~d " 
+                      (eq s *istate*)
+                      (position val *inspector-history*))
+              (print-unreadable-object (val out :type t :identity t)))))
+    (format out "~%~%--- all visited objects ---")
+    (loop for val across *inspector-history* for i from 0 do
+          (format out "~%~2,' d " i)
+          (print-unreadable-object (val out :type t :identity t)))))
+
 (defslimefun quit-inspector ()
   (reset-inspector)
   nil)




From heller at common-lisp.net  Wed Mar  3 11:57:11 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 03 Mar 2010 06:57:11 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmnCR-0002B0-N1@common-lisp.net>

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

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
Don't special case special operators with M-. for CMUCL.

* swank-cmucl.lisp (function-definitions): Special operators will
have IR1-translators anyway, so no need to mark them "special".
(gf-definitions): Renamed from generic-function-definitions.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:57:03	1.2010
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:57:11	1.2011
@@ -183,9 +183,18 @@
 
 2010-03-03  Helmut Eller  <heller at common-lisp.net>
 
+	Don't special case special operators with M-. for CMUCL.
+
+	* swank-cmucl.lisp (function-definitions): Special operators will
+	have IR1-translators anyway, so no need to mark them "special".
+	(gf-definitions): Renamed from generic-function-definitions.
+
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el (slime-inspector-history): New command.
 
 2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
 	Don't try to bind keywords in inspector-eval.
 
 	* swank.lisp (inspector-eval): For now, don't bind symbols which
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/03/02 12:38:06	1.220
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/03/03 11:57:11	1.221
@@ -912,20 +912,16 @@
 regular functions, generic functions, methods and macros.
 NAME can any valid function name (e.g, (setf car))."
   (let ((macro?    (and (symbolp name) (macro-function name)))
-        (special?  (and (symbolp name) (special-operator-p name)))
         (function? (and (ext:valid-function-name-p name)
                         (ext:info :function :definition name)
                         (if (symbolp name) (fboundp name) t))))
     (cond (macro? 
            (list `((defmacro ,name)
                    ,(function-location (macro-function name)))))
-          (special?
-           (list `((:special-operator ,name) 
-                   (:error ,(format nil "Special operator: ~S" name)))))
           (function?
            (let ((function (fdefinition name)))
              (if (genericp function)
-                 (generic-function-definitions name function)
+                 (gf-definitions name function)
                  (list (list `(function ,name)
                              (function-location function)))))))))
 
@@ -1029,7 +1025,7 @@
 
 ;;;;;; Generic functions and methods
 
-(defun generic-function-definitions (name function)
+(defun gf-definitions (name function)
   "Return the definitions of a generic function and its methods."
   (cons (list `(defgeneric ,name) (gf-location function))
         (gf-method-definitions function)))




From heller at common-lisp.net  Wed Mar  3 11:57:19 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 03 Mar 2010 06:57:19 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmnCZ-0002Bc-0B@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Fix ChangeLog

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:57:11	1.2011
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:57:18	1.2012
@@ -1,15 +1,49 @@
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
+	Don't special case special operators with M-. for CMUCL.
+
+	* swank-cmucl.lisp (function-definitions): Special operators will
+	have IR1-translators anyway, so no need to mark them "special".
+	(gf-definitions): Renamed from generic-function-definitions.
+
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-inspector-history): New command.
+
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
+	Don't try to bind keywords in inspector-eval.
+
+	* swank.lisp (inspector-eval): For now, don't bind symbols which
+	are constantp.  Maybe something better can be found later.
+
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
+	Use @ instead of # to mark object in the inspect history.
+
+	* swank.lisp (print-part-to-string): Use @.
+
+2010-03-03  Helmut Eller  <heller at common-lisp.net>
+
+	Make eval-in-frame display multiple values; not only the first.
+
+	* swank.lisp (values-to-string): New macro.
+	(eval-string-in-frame): Use it.
+
 2010-03-02  Stas Boukarev  <stassats at gmail.com>
 
-	* swank-sbcl.lisp (definition-source-for-emacs): Don't error when source
-	location doesn't contain form position, point emacs to the beginning of a source file
-	and if it's a function provide a snippet "(defun <name> ".
+	* swank-sbcl.lisp (definition-source-for-emacs): Don't error when
+	source location doesn't contain form position, point emacs to the
+	beginning of a source file and if it's a function provide a
+	snippet "(defun <name> ".
 
 2010-03-02  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-compile-and-load-file): Accept C-u arguments for
 	compilation policy the same way as slime-compile-defun.
 
-	* swank.lisp (compile-file-for-emacs): Take an additional policy argument.
+	* swank.lisp (compile-file-for-emacs): Take an additional policy
+	argument.
 	* swank-backend.lisp (swank-compile-file): Ditto.
 
 	* swank-sbcl.lisp (compiler-policy, (setf compiler-policy)):
@@ -181,38 +215,6 @@
 	resulting in duplicate modeline strings.
 	Reported by Leo Liu.
 
-2010-03-03  Helmut Eller  <heller at common-lisp.net>
-
-	Don't special case special operators with M-. for CMUCL.
-
-	* swank-cmucl.lisp (function-definitions): Special operators will
-	have IR1-translators anyway, so no need to mark them "special".
-	(gf-definitions): Renamed from generic-function-definitions.
-
-2010-03-03  Helmut Eller  <heller at common-lisp.net>
-
-	* slime.el (slime-inspector-history): New command.
-
-2010-03-03  Helmut Eller  <heller at common-lisp.net>
-
-	Don't try to bind keywords in inspector-eval.
-
-	* swank.lisp (inspector-eval): For now, don't bind symbols which
-	are constantp.  Maybe something better can be found later.
-
-2010-03-03  Helmut Eller  <heller at common-lisp.net>
-
-	Use @ instead of # to mark object in the inspect history.
-
-	* swank.lisp (print-part-to-string): Use @.
-
-2010-02-19  Helmut Eller  <heller at common-lisp.net>
-
-	Make eval-in-frame display multiple values; not only the first.
-
-	* swank.lisp (values-to-string): New macro.
-	(eval-string-in-frame): Use it.
-
 2010-02-18  Mark Harig <idirectscm at aim.com>
 
 	The compiler warns about various stuff. Fix some of it.




From sboukarev at common-lisp.net  Wed Mar  3 19:51:33 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 03 Mar 2010 14:51:33 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NmubV-0002d9-Fm@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
* doc/slime.texi (Inspector): document slime-inspector-eval.
Patch by Mark Harig.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/03 11:57:18	1.2012
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/03 19:51:33	1.2013
@@ -1,3 +1,8 @@
+2010-03-03  Stas Boukarev  <stassats at gmail.com>
+
+	* doc/slime.texi (Inspector): document slime-inspector-eval.
+	Patch by Mark Harig.
+
 2010-03-03  Helmut Eller  <heller at common-lisp.net>
 
 	Don't special case special operators with M-. for CMUCL.




From sboukarev at common-lisp.net  Wed Mar  3 19:51:33 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 03 Mar 2010 14:51:33 -0500
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NmubV-0002dH-NN@common-lisp.net>

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

Modified Files:
	slime.texi 
Log Message:
* doc/slime.texi (Inspector): document slime-inspector-eval.
Patch by Mark Harig.


--- /project/slime/cvsroot/slime/doc/slime.texi	2010/03/02 12:39:21	1.97
+++ /project/slime/cvsroot/slime/doc/slime.texi	2010/03/03 19:51:33	1.98
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2010/03/02 12:39:21 $}
+ at set UPDATED @code{$Date: 2010/03/03 19:51:33 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -1211,6 +1211,9 @@
 @kbditem{d, slime-inspector-describe}
 Describe the slot at point.
 
+ at kbditem{e, slime-inspector-eval}
+Evaluate an expression in the context of the inspected object.
+
 @kbditem{v, slime-inspector-toggle-verbose}
 Toggle between verbose and terse mode. Default is determined by
 `swank:*inspector-verbose*'.




From mevenson at common-lisp.net  Thu Mar  4 13:22:29 2010
From: mevenson at common-lisp.net (CVS User mevenson)
Date: Thu, 04 Mar 2010 08:22:29 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NnB0X-0003Mo-SK@common-lisp.net>

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

Modified Files:
	ChangeLog swank-abcl.lisp 
Log Message:
swank-abcl.lisp (emacs-inspect): Define default method to use the
result of SYS:INSPECTED-PARTS if non-nil.



--- /project/slime/cvsroot/slime/ChangeLog	2010/03/03 19:51:33	1.2013
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/04 13:22:29	1.2014
@@ -1,3 +1,8 @@
+2010-03-04  Mark Evenson  <evenson at panix.com>
+
+	* swank-abcl.lisp (emacs-inspect): Define default method to use
+	the result of SYS:INSPECTED-PARTS if non-nil. 
+
 2010-03-03  Stas Boukarev  <stassats at gmail.com>
 
 	* doc/slime.texi (Inspector): document slime-inspector-eval.
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2010/03/02 12:38:06	1.82
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2010/03/04 13:22:29	1.83
@@ -517,6 +517,14 @@
 |#
 
 ;;;; Inspecting
+(defmethod emacs-inspect ((o t))
+  (let ((parts (sys:inspected-parts o)))
+    `("The object is of type " ,(symbol-name (type-of o)) "." (:newline)
+      ,@(if parts
+           (loop :for (label . value) :in parts
+              :appending (label-value-line label value))
+            (list "No inspectable parts, dumping output of CL:DESCRIBE:" '(:newline) 
+                  (with-output-to-string (desc) (describe o desc)))))))
 
 (defmethod emacs-inspect ((slot mop::slot-definition))
   `("Name: " (:value ,(mop::%slot-definition-name slot))
@@ -544,20 +552,8 @@
                    `("Documentation:" (:newline) ,(documentation f t) (:newline)))
       ,@(when (function-lambda-expression f)
               `("Lambda expression:" 
-                (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))
-
-#|
-;;; XXX -- the default SLIME implementation looks ok.  Remove?  --ME 20100111
-(defmethod emacs-inspect ((o t))
-  (let* ((class (class-of o))
-         (slots (mop::class-slots class)))
-            (mapcar (lambda (slot)
-                      (let ((name (mop::slot-definition-name slot)))
-                        (cons (princ-to-string name)
-                              (slot-value o name))))
-                    slots)))
-|#
-
+                (:newline) ,(princ-to-string
+                             (function-lambda-expression f)) (:newline)))))
 
 ;;; Although by convention toString() is supposed to be a
 ;;; non-computationally expensive operation this isn't always the




From trittweiler at common-lisp.net  Fri Mar  5 11:05:52 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 05 Mar 2010 06:05:52 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NnVLs-00086p-GC@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	Ecl: Make M-. work on function interactively compiled via C-c C-c.

	* swank-ecl.lisp (*tmpfile-map*, note-buffer-tmpfile)
	(tmpfile-to-buffer): New helpers.
	(swank-compile-string): Use them. Also use new COMPILE-FILE
	keywords :SOURCE-TRUENAME and :SOURCE-OFFSET available in ECL
	HEAD.
	(find-definitions): Slurp in definition of
	FIND-DEFINITIONS-BY-NAME.
	(find-definitions-by-name): Hence not needed anymore.
	(source-location): Use TMPFILE-TO-BUFFER to get buffer source
	location of interactively compiled functions.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/04 13:22:29	1.2014
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/05 11:05:52	1.2015
@@ -1,7 +1,22 @@
+2010-03-05  Tobias C. Rittweiler <tcr at freebits.de>
+
+	Ecl: Make M-. work on function interactively compiled via C-c C-c.
+
+	* swank-ecl.lisp (*tmpfile-map*, note-buffer-tmpfile)
+	(tmpfile-to-buffer): New helpers.
+	(swank-compile-string): Use them. Also use new COMPILE-FILE
+	keywords :SOURCE-TRUENAME and :SOURCE-OFFSET available in ECL
+	HEAD.
+	(find-definitions): Slurp in definition of
+	FIND-DEFINITIONS-BY-NAME.
+	(find-definitions-by-name): Hence not needed anymore.
+	(source-location): Use TMPFILE-TO-BUFFER to get buffer source
+	location of interactively compiled functions.
+
 2010-03-04  Mark Evenson  <evenson at panix.com>
 
 	* swank-abcl.lisp (emacs-inspect): Define default method to use
-	the result of SYS:INSPECTED-PARTS if non-nil. 
+	the result of SYS:INSPECTED-PARTS if non-nil.
 
 2010-03-03  Stas Boukarev  <stassats at gmail.com>
 
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/02 12:38:07	1.58
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/05 11:05:52	1.59
@@ -206,20 +206,6 @@
                  (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. 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)))
-
-(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)))
@@ -244,25 +230,40 @@
                   :load load-p
                   :external-format external-format)))
 
+(defvar *tmpfile-map* (make-hash-table :test #'equal))
+
+(defun note-buffer-tmpfile (tmp-file buffer-name)
+  ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
+  (let ((tmp-namestring (namestring (truename tmp-file))))
+    (setf (gethash tmp-namestring *tmpfile-map*) buffer-name))
+  tmp-file)
+
+(defun tmpfile-to-buffer (tmp-file)
+  (gethash tmp-file *tmpfile-map*))
+
 (defimplementation swank-compile-string (string &key buffer position filename
                                                 policy)
-  (declare (ignore filename policy))
+  (declare (ignore policy))
   (with-compilation-hooks ()
     (let ((*buffer-name* buffer)        ; for compilation hooks
           (*buffer-start-position* position))
-      (let ((file (si:mkstemp "TMP:ECL-SWANK-"))
+      (let ((tmp-file (si:mkstemp "TMP:ecl-swank-tmpfile-"))
             (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)
+             (with-open-file (tmp-stream tmp-file :direction :output
+                                                  :if-exists :supersede)
+               (write-string string tmp-stream)
+               (finish-output tmp-stream)
                (multiple-value-setq (fasl-file warnings-p failure-p)
-                 (compile-file file :load t)))
-          (when (probe-file file)
-            (delete-file file))
+                 (compile-file tmp-file
+                   :load t
+                   :source-truename (or filename
+                                        (note-buffer-tmpfile tmp-file buffer))
+                   :source-offset (1- position))))
+          (when (probe-file tmp-file)
+            (delete-file tmp-file))
           (when fasl-file
             (delete-file fasl-file)))
         (not failure-p)))))
@@ -475,29 +476,35 @@
 
 ;;;; Definitions
 
-;;; 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)))))
+(defvar +TAGS+ (namestring (translate-logical-pathname #P"SYS:TAGS")))
 
-(deftype c-function ()
-  `(satisfies c-function-p))
+(defun make-file-location (file file-position)
+  ;; File positions in CL start at 0, but Emacs' buffer positions
+  ;; 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)))
 
-(defvar +TAGS+ (namestring (translate-logical-pathname #P"SYS:TAGS")))
+(defun make-buffer-location (buffer-name start-position &optional (offset 0))
+  (make-location `(:buffer ,buffer-name)
+                 `(:offset ,start-position ,offset)
+                 `(:align t)))
 
-(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 make-TAGS-location (&rest tags)
+  (make-location `(:etags-file ,+TAGS+)
+                 `(:tag , at tags)))
 
-(defun assert-TAGS-file ()
-  (unless (probe-file +TAGS+)
-    (error "No TAGS file ~A found. It should have been installed with ECL."
-           +TAGS+)))
+(defimplementation find-definitions (name)
+  (let ((annotations (ext:get-annotation name 'si::location :all)))
+    (cond (annotations
+           (loop for annotation in annotations
+                 collect (destructuring-bind (dspec file . pos) annotation
+                           `(,dspec ,(make-file-location file pos)))))
+          (t
+           (mapcan #'(lambda (type) (find-definitions-by-type name type))
+                   (classify-definition-name name))))))
 
 (defun classify-definition-name (name)
   (let ((types '()))
@@ -519,12 +526,6 @@
              (push :global-variable types))))
     types))
 
-(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
@@ -542,48 +543,78 @@
     (:macro
      (when-let (loc (source-location (macro-function name)))
        (list `((defmacro ,name) ,loc))))
-    ((:special-operator :constant :global-variable))))
+    (:constant
+     (when-let (loc (source-location name))
+       (list `((defconstant ,name) ,loc))))
+    (:global-variable
+     (when-let (loc (source-location name))
+       (list `((defvar ,name) ,loc))))
+    (:special-operator)))
 
-(defimplementation find-definitions (name)
-  (nconc (find-definitions-by-name name)
-         (mapcan #'(lambda (type) (find-definitions-by-type name type))
-                 (classify-definition-name name))))
+;;; FIXME: There ought to be a better way.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun c-function-name-p (name)
+    (and (symbolp name) (si:mangle-name name t) t))
+  (defun c-function-p (object)
+    (and (functionp object)
+         (let ((fn-name (function-name object)))
+           (and fn-name (c-function-name-p fn-name))))))
+
+(deftype c-function ()
+  `(satisfies c-function-p))
+
+(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 source-location (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))))))
+   (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  ((package (package-name (symbol-package lisp-name)))
+                 (symbol  (symbol-name lisp-name)))
+            (make-TAGS-location c-name
+                                (format nil "~A::~A" package symbol)
+                                (format nil "~(~A::~A~)" package symbol))))))
+     (function
+      (multiple-value-bind (file pos) (ext:compiled-function-file object)
+        (cond ((not file)
+               (return-from source-location nil))
+              ((setq file (tmpfile-to-buffer file))
+               (make-buffer-location file pos))
+              (t
+               (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)))
+     ((member nil t)
+      (multiple-value-bind (flag c-name) (si:mangle-name object)
+        (assert flag)
+        (make-TAGS-location c-name))))))
 
 (defimplementation find-source-location (object)
   (or (source-location object)
-      (make-error-location "Source definition of ~S not found" object)))
+      (make-error-location "Source definition of ~S not found." object)))
 
 
 ;;;; Profiling




From trittweiler at common-lisp.net  Fri Mar  5 16:11:40 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 05 Mar 2010 11:11:40 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nna7o-00050t-RA@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	* swank-ecl.lisp: Make backend depend on ECL version 10.3.1 which
	just got released. We do not support older versions. Previous
	version pretty much didn't work in combination with Slime anyway.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/05 11:05:52	1.2015
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/05 16:11:40	1.2016
@@ -1,5 +1,11 @@
 2010-03-05  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-ecl.lisp: Make backend depend on ECL version 10.3.1 which
+	just got released. We do not support older versions. Previous
+	version pretty much didn't work in combination with Slime anyway.
+
+2010-03-05  Tobias C. Rittweiler <tcr at freebits.de>
+
 	Ecl: Make M-. work on function interactively compiled via C-c C-c.
 
 	* swank-ecl.lisp (*tmpfile-map*, note-buffer-tmpfile)
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/05 11:05:52	1.59
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/05 16:11:40	1.60
@@ -12,10 +12,10 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT)))
-    (when (or (not version) (< (symbol-value version) 100201))
+    (when (or (not version) (< (symbol-value version) 100301))
       (error "~&IMPORTANT:~%  ~
               The version of ECL you're using (~A) is too old.~%  ~
-              Please upgrade to at least 10.2.1.~%  ~
+              Please upgrade to at least 10.3.1.~%  ~
               Sorry for the inconvenience.~%~%"
              (lisp-implementation-version)))))
 




From heller at common-lisp.net  Fri Mar  5 17:45:26 2010
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 05 Mar 2010 12:45:26 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NnbaY-0003Cd-Qn@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
* swank-ccl.lisp: Indentation fixes.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/05 16:11:40	1.2016
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/05 17:45:26	1.2017
@@ -1,3 +1,7 @@
+2010-03-05  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-ccl.lisp: Indentation fixes.
+
 2010-03-05  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-ecl.lisp: Make backend depend on ECL version 10.3.1 which
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2010/03/02 12:38:06	1.16
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2010/03/05 17:45:26	1.17
@@ -1,13 +1,13 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;; -*- indent-tabs-mode: nil -*-
 ;;;
-;;; openmcl-swank.lisp --- SLIME backend for OpenMCL.
+;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
 ;;;
 ;;; Copyright (C) 2003, James Bielman  <jamesjb at jamesjb.com>
 ;;;
 ;;; This program is licensed under the terms of the Lisp Lesser GNU
-;;; Public License, known as the LLGPL, and distributed with OpenMCL
+;;; Public License, known as the LLGPL, and distributed with Clozure CL
 ;;; as the file "LICENSE".  The LLGPL consists of a preamble and the
-;;; LGPL, which is distributed with OpenMCL as the file "LGPL".  Where
+;;; LGPL, which is distributed with Clozure CL as the file "LGPL".  Where
 ;;; these conflict, the preamble takes precedence.
 ;;;
 ;;; The LLGPL is also available online at
@@ -83,7 +83,6 @@
     `(or (find-symbol ,str :swank)
          (error "There is no symbol named ~a in the SWANK package" ,str))))
 
-
 ;;; TCP Server
 
 (defimplementation preferred-communication-style ()
@@ -100,11 +99,11 @@
   (close socket))
 
 (defimplementation accept-connection (socket &key external-format
-                                             buffering timeout)
+                                      buffering timeout)
   (declare (ignore buffering timeout))
-  (ccl:accept-connection socket :wait t
-                         :stream-args (and external-format
-                                           `(:external-format ,external-format))))
+  (let ((stream-args (and external-format
+                          `(:external-format ,external-format))))
+    (ccl:accept-connection socket :wait t :stream-args stream-args)))
 
 (defvar *external-format-to-coding-system*
   '((:iso-8859-1 
@@ -184,8 +183,8 @@
                   :load load-p
                   :external-format external-format)))
 
-;; Use a temp file rather than in-core compilation in order to handle eval-when's
-;; as compile-time.
+;; Use a temp file rather than in-core compilation in order to handle
+;; eval-when's as compile-time.
 (defimplementation swank-compile-string (string &key buffer position filename
                                          policy)
   (declare (ignore policy))
@@ -317,9 +316,10 @@
          (ccl:*signal-printing-errors* nil))
     (funcall debugger-loop-fn)))
 
+;; This is called for an async interrupt and is running in a random
+;; thread not selected by the user, so don't use thread-local vars
+;; such as *emacs-connection*.
 (defun find-repl-thread ()
-  ;; This is called for an async interrupt and is running in a random thread not
-  ;; selected by the user, so don't use thread-local vars such as *emacs-connection*.
   (let* ((conn (funcall (swank-sym default-connection))))
     (and conn
          (let ((*break-on-signals* nil))
@@ -389,24 +389,20 @@
     (let ((lfun (ccl:frame-function p context)))
       (format stream "(~S" (or (ccl:function-name lfun) lfun))
       (let* ((unavailable (cons nil nil))
-            (args (ccl:frame-supplied-arguments p context :unknown-marker unavailable)))
+             (args (ccl:frame-supplied-arguments p context 
+                                                 :unknown-marker unavailable)))
         (declare (dynamic-extent unavailable))
         (if (eq args unavailable)
-          (format stream " #<Unknown Arguments>")
-          (loop for arg in args
-                do (if (eq arg unavailable)
-                     (format stream " #<Unavailable>")
-                     (format stream " ~s" arg)))))
+            (format stream " #<Unknown Arguments>")
+            (dolist (arg args)
+              (if (eq arg unavailable)
+                  (format stream " #<Unavailable>")
+                  (format stream " ~s" arg)))))
       (format stream ")"))))
 
 (defmacro with-frame ((p context) frame-number &body body)
   `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
 
-(defimplementation frame-call (frame-number)
-  (with-frame (p context) frame-number
-    (with-output-to-string (stream)
-      (print-frame (list :frame p context) stream))))
-
 (defun call/frame (frame-number if-found)
   (map-backtrace  
    (lambda (p context)
@@ -414,6 +410,10 @@
        (funcall if-found p context)))
    frame-number))
 
+(defimplementation frame-call (frame-number)
+  (with-frame (p context) frame-number
+    (with-output-to-string (stream)
+      (print-frame (list :frame p context) stream))))
 
 (defimplementation frame-var-value (frame var)
   (with-frame (p context) frame
@@ -456,7 +456,6 @@
       (format t "LFUN: ~a~%PC: ~a  FP: #x~x  CONTEXT: ~a~%" lfun pc p context)
       (disassemble lfun))))
 
-
 ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
 ;; contains some interesting details:
 ;; 
@@ -494,11 +493,6 @@
 ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
 ;; which returns a source-note for the source at offset pc in the
 ;; function.
-;; 
-;; Currently the only thing that makes use of any of this is the
-;; disassembler.  ILISP and current version of Slime still use
-;; backward-compatible functions that deal with filenames only.  The plan
-;; is to make Slime, and our IDE, use this eventually.
 
 (defun function-source-location (function)
   (source-note-to-source-location
@@ -529,7 +523,8 @@
              (cond ((gethash filename *temp-file-map*)
                     (list :buffer (gethash filename *temp-file-map*)))
                    ((probe-file filename)
-                    (list :file (ccl:native-translated-namestring (truename filename))))
+                    (list :file (ccl:native-translated-namestring
+                                 (truename filename))))
                    (t (error "File ~s doesn't exist" filename)))))
     (handler-case
         (cond ((ccl:source-note-p source)
@@ -539,15 +534,17 @@
                  (make-location
                   (when file-name (filename-to-buffer (pathname file-name)))
                   (when start-pos (list :position (1+ start-pos)))
-                  (when full-text (list :snippet (subseq full-text  0 (min 40 (length full-text))))))))
+                  (when full-text 
+                    (list :snippet (subseq full-text 0 
+                                           (min 40 (length full-text))))))))
               ((and source name)
+               ;; This branch is probably never used
                (make-location
                 (filename-to-buffer source)
-                (list :function-name (let ((*package* (find-package :swank-io-package))) ;; should be buffer package.
-                                       (with-standard-io-syntax
-                                           (princ-to-string (if (functionp name)
-                                                              (ccl:function-name name)
-                                                              name)))))))
+                (list :function-name (princ-to-string 
+                                      (if (functionp name)
+                                          (ccl:function-name name)
+                                          name)))))
               (t `(:error ,(funcall if-nil-thunk))))
       (error (c) `(:error ,(princ-to-string c))))))
 




From heller at common-lisp.net  Fri Mar  5 17:45:34 2010
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 05 Mar 2010 12:45:34 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nnbag-0003DF-JL@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
Remove some unused stuff.

* swank-ccl.lisp (openmcl-set-debug-switches)
(*interesting-internal-frames*)
(interesting-frame-p): Unused. Deleted.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/05 17:45:26	1.2017
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/05 17:45:34	1.2018
@@ -1,5 +1,13 @@
 2010-03-05  Helmut Eller  <heller at common-lisp.net>
 
+	Remove some unused stuff.
+
+	* swank-ccl.lisp (openmcl-set-debug-switches)
+	(*interesting-internal-frames*)
+	(interesting-frame-p): Unused. Deleted.
+
+2010-03-05  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-ccl.lisp: Indentation fixes.
 
 2010-03-05  Tobias C. Rittweiler <tcr at freebits.de>
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2010/03/05 17:45:26	1.17
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2010/03/05 17:45:34	1.18
@@ -300,16 +300,6 @@
 
 ;;; Debugging
 
-(defun openmcl-set-debug-switches ()
-  (setq ccl:*fasl-save-definitions* nil)
-  (setq ccl:*fasl-save-doc-strings* t)
-  (setq ccl:*fasl-save-local-symbols* t)
-  (setq ccl:*save-arglist-info* t)
-  (setq ccl:*save-definitions* nil)
-  (setq ccl:*save-doc-strings* t)
-  (setq ccl:*save-local-symbols* t)
-  (ccl:start-xref))
-
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (let* (;;(*debugger-hook* nil)
          ;; don't let error while printing error take us down
@@ -320,12 +310,12 @@
 ;; thread not selected by the user, so don't use thread-local vars
 ;; such as *emacs-connection*.
 (defun find-repl-thread ()
-  (let* ((conn (funcall (swank-sym default-connection))))
+  (let* ((*break-on-signals* nil)
+         (conn (funcall (swank-sym default-connection))))
     (and conn
-         (let ((*break-on-signals* nil))
-           (ignore-errors ;; this errors if no repl-thread
-             (funcall (swank-sym repl-thread) conn))))))
-  
+         (ignore-errors ;; this errors if no repl-thread
+           (funcall (swank-sym repl-thread) conn)))))
+
 (defimplementation call-with-debugger-hook (hook fun)
   (let ((*debugger-hook* hook)
         (ccl:*break-hook* hook)
@@ -347,34 +337,7 @@
     (ccl:map-call-frames function
                          :origin ccl:*top-error-frame*
                          :start-frame-number start-frame-number
-                         :count (- end-frame-number start-frame-number)
-                         :test (and (not t) ;(not (symbol-value (swank-sym *sldb-show-internal-frames*)))
-                                    'interesting-frame-p))))
-
-;; Exceptions
-(defvar *interesting-internal-frames* ())
-
-(defun interesting-frame-p (p context)
-  ;; A frame is interesting if it has at least one external symbol in its name.
-  (labels ((internal (obj)
-             ;; For a symbol, return true if the symbol is internal, i.e. not
-             ;; declared to be external.  For a cons or list, everything
-             ;; must be internal.  For a method, the name must be internal.
-             ;; Nothing else is internal.
-             (typecase obj
-               (cons (and (internal (car obj)) (internal (cdr obj))))
-               (symbol (and (eq (symbol-package obj) (find-package :ccl))
-                            (eq :internal (nth-value 1 (find-symbol (symbol-name obj) :ccl)))
-                            (not (member obj *interesting-internal-frames*))))
-               (method (internal (ccl:method-name obj)))
-               (t nil))))
-    (let* ((lfun (ccl:frame-function p context))
-           (internal-frame-p (internal (ccl:function-name lfun))))
-      #+debug (format t "~S is ~@[not ~]internal~%"
-                      (ccl:function-name lfun)
-                      (not internal-frame-p))
-      (not internal-frame-p))))
-
+                         :count (- end-frame-number start-frame-number))))
 
 (defimplementation compute-backtrace (start-frame-number end-frame-number)
   (let (result)




From sboukarev at common-lisp.net  Sun Mar  7 07:40:47 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 07 Mar 2010 02:40:47 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NoB6V-0004Gw-46@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
* swank-ecl.lisp (source-location): Don't do
(setq file (tmpfile-to-buffer file)) in a COND condition,
otherwise next cond clause will get null file.
Apply translate-logical-pathname to pathnames.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/05 17:45:34	1.2018
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/07 07:40:46	1.2019
@@ -1,3 +1,10 @@
+2010-03-07  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-ecl.lisp (source-location): Don't do
+	(setq file (tmpfile-to-buffer file)) in a COND condition,
+	otherwise next cond clause will get null file.
+	Apply translate-logical-pathname to pathnames.
+
 2010-03-05  Helmut Eller  <heller at common-lisp.net>
 
 	Remove some unused stuff.
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/05 16:11:40	1.60
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/07 07:40:46	1.61
@@ -597,12 +597,12 @@
       (multiple-value-bind (file pos) (ext:compiled-function-file object)
         (cond ((not file)
                (return-from source-location nil))
-              ((setq file (tmpfile-to-buffer file))
-               (make-buffer-location file pos))
+              ((tmpfile-to-buffer file)
+               (make-buffer-location (tmpfile-to-buffer file) pos))
               (t
                (assert (probe-file file))
                (assert (not (minusp pos)))
-               (make-file-location file pos)))))
+               (make-file-location (translate-logical-pathname file) pos)))))
      (method
       ;; FIXME: This will always return NIL at the moment; ECL does not
       ;; store debug information for methods yet.




From trittweiler at common-lisp.net  Sun Mar  7 14:09:51 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Sun, 07 Mar 2010 09:09:51 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NoHB1-0001nd-GD@common-lisp.net>

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

Modified Files:
	ChangeLog slime-autodoc.el swank-arglists.lisp 
Log Message:
	* swank-arglists.lisp (extract-local-op-arglists): Fix for
	`(labels ((foo (x) ...)|'.

	* slime-autodoc.el (autodoc.1): Add test cases.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/02/20 18:46:24	1.348
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/07 14:09:51	1.349
@@ -1,3 +1,10 @@
+2010-03-07  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	* swank-arglists.lisp (extract-local-op-arglists): Fix for
+	`(labels ((foo (x) ...)|'.
+
+	* slime-autodoc.el (autodoc.1): Add test cases.
+
 2010-02-20  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* slime-fancy.el: Call init function for fancy
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/02/15 21:42:37	1.35
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/03/07 14:09:51	1.36
@@ -316,7 +316,14 @@
        "(declare ((string &optional ===> size <===) &rest variables))")
       ("(declare (type (string *HERE*"
        "(declare (type (string &optional ===> size <===) &rest variables))")
-      )
+
+      ;; Test local functions
+      ("(flet ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)")
+      ("(macrolet ((foo (x y) `(+ ,x ,y))) (foo *HERE*" "(foo ===> x <=== y)")
+      ("(labels ((foo (x y) (+ x y))) (foo *HERE*" "(foo ===> x <=== y)")
+      ("(labels ((foo (x y) (+ x y)) 
+                 (bar (y) (foo *HERE*" 
+       "(foo ===> x <=== y)"))
   (slime-check-top-level)
   (with-temp-buffer
     (setq slime-buffer-package "COMMON-LISP-USER")
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/01/06 18:23:44	1.57
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/07 14:09:51	1.58
@@ -1285,22 +1285,23 @@
   (:method ((operator (eql 'cl:flet)) args)
     (let ((defs (first args))
           (body (rest args)))
-      (cond ((null body) nil)           ; `(flet ((foo (x) |'
-            ((atom defs) nil)           ; `(flet ,foo (|'
+      (cond ((null body) nil)            ; `(flet ((foo (x) |'
+            ((atom defs) nil)            ; `(flet ,foo (|'
             (t (%collect-op/argl-alist defs)))))
   ;; LABELS
   (:method ((operator (eql 'cl:labels)) args)
     ;; Notice that we only have information to "look backward" and
     ;; show arglists of previously occuring local functions.
-    (let ((defs (first args))
-          (body (rest args)))
-      (cond ((atom defs) nil)
-            ((not (null body))
-             (extract-local-op-arglists 'cl:flet args))
-            (t
-             (let ((def.body (cddr (car (last defs)))))
-               (when def.body
-                 (%collect-op/argl-alist defs)))))))
+    (destructuring-bind (defs . body) args
+      (unless (atom defs)                ; `(labels ,foo (|'
+        (let ((current-def (car (last defs))))
+          (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|'
+                ((not (null body))
+                 (extract-local-op-arglists 'cl:flet args))
+                (t
+                 (let ((def.body (cddr current-def)))
+                   (when def.body
+                     (%collect-op/argl-alist defs)))))))))
   ;; MACROLET
   (:method ((operator (eql 'cl:macrolet)) args)
     (extract-local-op-arglists 'cl:labels args)))




From sboukarev at common-lisp.net  Sun Mar  7 14:28:55 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 07 Mar 2010 09:28:55 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NoHTT-0003J9-6w@common-lisp.net>

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

Modified Files:
	ChangeLog swank-fancy-inspector.lisp 
Log Message:
* swank-fancy-inspector.lisp: Add buttons
for selecting default sorting order and default grouping method of
slots of a class.

(all-slots-for-inspector): Implement the above feature.
Move the default method from :method option of the GF to a separate
defmethod, this method is quite large and :method eats space for
indentation.
(*inspector-slots-default-order*):
New variable, accepts :unsorted and :alphabetically
(*inspector-slots-default-grouping*): New variable,
accepts :all and :inheritance.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/07 14:09:51	1.349
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/07 14:28:55	1.350
@@ -1,3 +1,18 @@
+2010-03-07  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-fancy-inspector.lisp: Add buttons
+	for selecting default sorting order and default grouping method of
+	slots of a class.
+
+	(all-slots-for-inspector): Implement the above feature.
+	Move the default method from :method option of the GF to a separate
+	defmethod, this method is quite large and :method eats space for
+	indentation.
+	(*inspector-slots-default-order*):
+	New variable, accepts :unsorted and :alphabetically
+	(*inspector-slots-default-grouping*): New variable,
+	accepts :all and :inheritance.
+
 2010-03-07  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	* swank-arglists.lisp (extract-local-op-arglists): Fix for
@@ -10,10 +25,12 @@
 	* 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
-	`swank:fuzzy-completion-selected' will be sent to the default connection.
+	* 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>
 
--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2009/08/05 17:15:35	1.22
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2010/03/07 14:28:55	1.23
@@ -215,74 +215,100 @@
   (assert (eq (car box) :box))
   (setf (cdr box) value))
 
-(defgeneric all-slots-for-inspector (object)
-  (:method ((object standard-object))
-    (let* ((class           (class-of object))
-           (direct-slots    (swank-mop:class-direct-slots class))
-           (effective-slots (sort (copy-seq (swank-mop:class-slots class))
-                                  #'string< :key #'swank-mop:slot-definition-name))
-           (longest-slot-name-length
-            (loop for slot :in effective-slots
-                  maximize (length (symbol-name
-                                    (swank-mop:slot-definition-name slot)))))
-           (checklist
-            (reinitialize-checklist
-             (ensure-istate-metadata object :checklist
-                                       (make-checklist (length effective-slots)))))
-           (grouping-kind
-            ;; We box the value so we can re-set it.
-            (ensure-istate-metadata object :grouping-kind (box :alphabetically)))
-           (effective-slots
-            ;; We need this rebinding because the this list must be in
-            ;; the same order as they checklist buttons are created.
-            (ecase (ref grouping-kind)
-              (:alphabetically effective-slots)
-              (:inheritance    (stable-sort-by-inheritance effective-slots class)))))
-      `("--------------------"
-        (:newline)
-        "  "
-        (:action ,(case (ref grouping-kind)
-                    (:alphabetically "[group slots by inheritance]")
-                    (:inheritance    "[group slots alphabetically]"))
-                 ,(lambda ()
-                    ;; We have to do this as the order of slots will
-                    ;; be sorted differently.
-                    (fill (checklist.buttons checklist) nil)
-                    (case (ref grouping-kind)
-                      (:alphabetically (setf (ref grouping-kind) :inheritance))
-                      (:inheritance    (setf (ref grouping-kind) :alphabetically))))
-                 :refreshp t)
-        (:newline)
-        ,@ (case (ref grouping-kind)
-             (:alphabetically
-              `((:newline)
-                "All Slots:"
-                (:newline)
-                ,@(make-slot-listing checklist object class
-                                     effective-slots direct-slots
-                                     longest-slot-name-length)))
-             (:inheritance
-              (list-all-slots-by-inheritance checklist object class
-                                             effective-slots direct-slots
-                                             longest-slot-name-length)))
-        (:newline)
-        (:action "[set value]"
-                 ,(lambda ()
-                    (do-checklist (idx checklist)
-                      (query-and-set-slot class object (nth idx effective-slots))))
-                 :refreshp t)
-        "  "
-        (:action "[make unbound]"
-                 ,(lambda ()
-                    (do-checklist (idx checklist)
-                      (swank-mop:slot-makunbound-using-class
-                       class object (nth idx effective-slots))))
-                 :refreshp t)
-        (:newline)
-        ))))
+(defvar *inspector-slots-default-order* :alphabetically
+  "Accepted values: :alphabetically and :unsorted")
+
+(defvar *inspector-slots-default-grouping* :all
+  "Accepted values: :inheritance and :all")
+
+(defgeneric all-slots-for-inspector (object))
+
+(defmethod all-slots-for-inspector ((object standard-object))
+  (let* ((class           (class-of object))
+         (direct-slots    (swank-mop:class-direct-slots class))
+         (effective-slots (swank-mop:class-slots class))
+         (longest-slot-name-length
+          (loop for slot :in effective-slots
+                maximize (length (symbol-name
+                                  (swank-mop:slot-definition-name slot)))))
+         (checklist
+          (reinitialize-checklist
+           (ensure-istate-metadata object :checklist
+                                   (make-checklist (length effective-slots)))))
+         (grouping-kind
+          ;; We box the value so we can re-set it.
+          (ensure-istate-metadata object :grouping-kind
+                                  (box *inspector-slots-default-grouping*)))
+         (sort-order
+          (ensure-istate-metadata object :sort-order
+                                  (box *inspector-slots-default-order*)))
+         (sorted-slots (sort (copy-seq effective-slots)
+                             (ecase (ref sort-order)
+                               (:alphabetically #'string<)
+                               (:unsorted (constantly nil)))
+                             :key #'swank-mop:slot-definition-name))
+         (effective-slots
+          (ecase (ref grouping-kind)
+            (:all sorted-slots)
+            (:inheritance (stable-sort-by-inheritance sorted-slots class)))))
+    `("--------------------"
+      (:newline)
+      " Group slots by inheritance "
+      (:action ,(ecase (ref grouping-kind)
+                       (:all "[ ]")
+                       (:inheritance "[X]"))
+               ,(lambda ()
+                        ;; We have to do this as the order of slots will
+                        ;; be sorted differently.
+                        (fill (checklist.buttons checklist) nil)
+                        (setf (ref grouping-kind)
+                              (ecase (ref grouping-kind)
+                                (:all :inheritance)
+                                (:inheritance :all))))
+               :refreshp t)
+      (:newline)
+      " Sort slots alphabetically  "
+      (:action ,(ecase (ref sort-order)
+                       (:unsorted "[ ]")
+                       (:alphabetically "[X]"))
+               ,(lambda ()
+                        (fill (checklist.buttons checklist) nil)
+                        (setf (ref sort-order)
+                              (ecase (ref sort-order)
+                                (:unsorted :alphabetically)
+                                (:alphabetically :unsorted))))
+               :refreshp t)
+      (:newline)
+      ,@ (case (ref grouping-kind)
+           (:all
+            `((:newline)
+              "All Slots:"
+              (:newline)
+              ,@(make-slot-listing checklist object class
+                                   effective-slots direct-slots
+                                   longest-slot-name-length)))
+           (:inheritance
+            (list-all-slots-by-inheritance checklist object class
+                                           effective-slots direct-slots
+                                           longest-slot-name-length)))
+      (:newline)
+      (:action "[set value]"
+               ,(lambda ()
+                        (do-checklist (idx checklist)
+                          (query-and-set-slot class object
+                                              (nth idx effective-slots))))
+               :refreshp t)
+      "  "
+      (:action "[make unbound]"
+               ,(lambda ()
+                        (do-checklist (idx checklist)
+                          (swank-mop:slot-makunbound-using-class
+                           class object (nth idx effective-slots))))
+               :refreshp t)
+      (:newline))))
 
-(defun list-all-slots-by-inheritance (checklist object class effective-slots direct-slots
-                                      longest-slot-name-length)
+(defun list-all-slots-by-inheritance (checklist object class effective-slots
+                                      direct-slots longest-slot-name-length)
   (flet ((slot-home-class (slot)
            (slot-home-class-using-class slot class)))
     (let ((current-slots '()))
@@ -347,7 +373,8 @@
                        class))))
 
 (defun stable-sort-by-inheritance (slots class)
-  (stable-sort slots #'string< 
+  (stable-sort (copy-seq slots)
+               #'string< 
                :key #'(lambda (s)
                         (class-name (slot-home-class-using-class s class)))))
 




From heller at common-lisp.net  Sun Mar  7 16:22:10 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 07 Mar 2010 11:22:10 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NoJF4-0003vJ-K0@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
Handle src-locs of compiler warnings in Allegro 8.2.
Didn't somebody already fix that?

* swank-allegro.lisp (location-for-warning)
(handle-undefined-functions-warning): In 8.2 src-locs include not
only start but also and end positions.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/07 07:40:46	1.2019
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/07 16:22:10	1.2020
@@ -1,3 +1,12 @@
+2010-03-07  Helmut Eller  <heller at common-lisp.net>
+
+	Handle src-locs of compiler warnings in Allegro 8.2.
+	Didn't somebody already fix that?
+
+	* swank-allegro.lisp (location-for-warning)
+	(handle-undefined-functions-warning): In 8.2 src-locs include not
+	only start but also and end positions.
+
 2010-03-07  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-ecl.lisp (source-location): Don't do
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/02 12:38:06	1.132
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/07 16:22:10	1.133
@@ -251,7 +251,7 @@
 
 (defun handle-compiler-warning (condition)
   (declare (optimize (debug 3) (speed 0) (space 0)))
-   (cond ((and (not *buffer-name*) 
+  (cond ((and (not *buffer-name*) 
               (compiler-undefined-functions-called-warning-p condition))
          (handle-undefined-functions-warning condition))
         (t
@@ -277,9 +277,12 @@
             (list :offset *buffer-start-position* 0)))
           (loc
            (destructuring-bind (file . pos) loc
-             (make-location
-              (list :file (namestring (truename file)))
-              (list :position (1+ pos)))))
+             (let ((start (cond ((consp pos) ; 8.2 and newer
+                                 (car pos))
+                                (t pos))))
+               (make-location
+                (list :file (namestring (truename file)))
+                (list :position (1+ start))))))
           (t
            (make-error-location "No error location available.")))))
 
@@ -295,17 +298,26 @@
                            `(:position ,pos)))
         (make-error-location "No error location available."))))
 
+;; TODO: report it as a bug to Franz that the condition's plist
+;; slot contains (:loc nil).
 (defun handle-undefined-functions-warning (condition)
   (let ((fargs (slot-value condition 'excl::format-arguments)))
-    (loop for (fname . pos-file) in (car fargs) do
-          (loop for (pos file) in pos-file do
-                (signal-compiler-condition
-                 :original-condition condition
-                 :severity :warning
-                 :message (format nil "Undefined function referenced: ~S" 
-                                  fname)
-                 :location (make-location (list :file file)
-                                          (list :position (1+ pos))))))))
+    (loop for (fname . locs) in (car fargs) do
+          (dolist (loc locs)
+            (multiple-value-bind (pos file) (ecase (length loc)
+                                              (2 (values-list loc))
+                                              (3 (destructuring-bind 
+                                                       (start end file) loc
+                                                   (declare (ignore end))
+                                                   (values start file))))
+              (signal-compiler-condition
+               :original-condition condition
+               :severity :warning
+               :message (format nil "Undefined function referenced: ~S" 
+                                fname)
+               :location (make-location (list :file file)
+                                        (list :position (1+ pos)))))))))
+
 (defimplementation call-with-compilation-hooks (function)
   (handler-bind ((warning       #'handle-compiler-warning)
                  (compiler-note #'handle-compiler-warning)
@@ -426,11 +438,11 @@
   (handler-case
       (etypecase file
         (pathname
-           (find-definition-in-file fspec type file top-level))
+         (find-definition-in-file fspec type file top-level))
         ((member :top-level)
-           (make-error-location "Defined at toplevel: ~A" (fspec->string fspec)))
+         (make-error-location "Defined at toplevel: ~A" (fspec->string fspec)))
         (string
-           (find-definition-in-buffer file)))
+         (find-definition-in-buffer file)))
     (error (e)
       (make-error-location "Error: ~A" e))))
 
@@ -471,9 +483,9 @@
             (list fspec
                   (make-error-location "Unknown source location for ~A" 
                                        (fspec->string fspec))))
-           (loop for (fspec type file top-level) in defs 
-                 collect (list (list type fspec)
-                               (find-fspec-location fspec type file top-level))))))))
+           (loop for (fspec type file top-level) in defs collect 
+                 (list (list type fspec)
+                       (find-fspec-location fspec type file top-level))))))))
 
 (defimplementation find-definitions (symbol)
   (fspec-definition-locations symbol))




From heller at common-lisp.net  Sun Mar  7 16:22:17 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sun, 07 Mar 2010 11:22:17 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NoJFB-0003wG-TR@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (count-cr): Deleted.  No longer used.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/07 16:22:10	1.2020
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/07 16:22:17	1.2021
@@ -1,5 +1,9 @@
 2010-03-07  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-allegro.lisp (count-cr): Deleted.  No longer used.
+
+2010-03-07  Helmut Eller  <heller at common-lisp.net>
+
 	Handle src-locs of compiler warnings in Allegro 8.2.
 	Didn't somebody already fix that?
 
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/07 16:22:10	1.133
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/07 16:22:17	1.134
@@ -394,22 +394,6 @@
   (etypecase fspec
     (symbol fspec)
     (list (fspec-primary-name (second fspec)))))
-
-;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
-;; single character, but file-position counts them as two.  Here we do
-;; our own conversion.
-(defun count-cr (file pos)
-  (let* ((bufsize 256)
-         (type '(unsigned-byte 8))
-         (buf (make-array bufsize :element-type type))
-         (cr-count 0))
-  (with-open-file (stream file :direction :input :element-type type)
-    (loop for bytes-read = (read-sequence buf stream) do
-          (incf cr-count (count (char-code #\return) buf 
-                                :end (min pos bytes-read)))
-          (decf pos bytes-read)
-          (when (<= pos 0)
-            (return cr-count))))))
               
 (defun find-definition-in-file (fspec type file top-level)
   (let* ((part




From sboukarev at common-lisp.net  Sun Mar  7 17:04:00 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 07 Mar 2010 12:04:00 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NoJtY-0006t1-Ui@common-lisp.net>

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

Modified Files:
	ChangeLog swank-fancy-inspector.lisp 
Log Message:
* contrib/swank-fancy-inspector.lisp (stable-sort-by-inheritance): Remove copy-seq,
unnecessarily put in the previous commit.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/07 14:28:55	1.350
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/07 17:04:00	1.351
@@ -1,5 +1,10 @@
 2010-03-07  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-fancy-inspector.lisp (stable-sort-by-inheritance): Remove copy-seq,
+	unnecessarily put in the previous commit.
+
+2010-03-07  Stas Boukarev  <stassats at gmail.com>
+
 	* swank-fancy-inspector.lisp: Add buttons
 	for selecting default sorting order and default grouping method of
 	slots of a class.
--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2010/03/07 14:28:55	1.23
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2010/03/07 17:04:00	1.24
@@ -373,8 +373,7 @@
                        class))))
 
 (defun stable-sort-by-inheritance (slots class)
-  (stable-sort (copy-seq slots)
-               #'string< 
+  (stable-sort slots #'string< 
                :key #'(lambda (s)
                         (class-name (slot-home-class-using-class s class)))))
 




From trittweiler at common-lisp.net  Mon Mar  8 09:47:12 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 08 Mar 2010 04:47:12 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NoZYO-000473-Go@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	Make swank:connection-info include information about initially
	passed coding-system, and the resulting external-format of the
	socket. Debugging aid.

	* swank.lisp (connection.external-format): New function.
	(start-server, create-server): Pass down coding-system, not
	external-format.
	(setup-server): Pass down both, coding-system and external-format.
	(serve-connection): Ditto.
	(create-connection): Set coding-system slot of CONNECTION.
	(connection-info): Include coding-system and external-format.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/07 16:22:17	1.2021
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/08 09:47:12	1.2022
@@ -1,3 +1,17 @@
+2010-03-08  Tobias C. Rittweiler <tcr at freebits.de>
+
+	Make swank:connection-info include information about initially
+	passed coding-system, and the resulting external-format of the
+	socket. Debugging aid.
+
+	* swank.lisp (connection.external-format): New function.
+	(start-server, create-server): Pass down coding-system, not
+	external-format.
+	(setup-server): Pass down both, coding-system and external-format.
+	(serve-connection): Ditto.
+	(create-connection): Set coding-system slot of CONNECTION.
+	(connection-info): Include coding-system and external-format.
+
 2010-03-07  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-allegro.lisp (count-cr): Deleted.  No longer used.
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/03 11:57:03	1.695
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/08 09:47:12	1.696
@@ -301,6 +301,9 @@
   (declare (ignore depth))
   (print-unreadable-object (conn stream :type t :identity t)))
 
+(defun connection.external-format (connection)
+  (stream-external-format (connection.socket-io connection)))
+
 (defvar *connections* '()
   "List of all active connections, with the most recent at the front.")
 
@@ -639,8 +642,7 @@
 This is the entry point for Emacs."
   (setup-server 0
                 (lambda (port) (announce-server-port port-file port))
-                style dont-close 
-                (find-external-format-or-lose coding-system)))
+                style dont-close coding-system))
 
 (defun create-server (&key (port default-server-port)
                       (style *communication-style*)
@@ -649,8 +651,8 @@
   "Start a SWANK server on PORT running in STYLE.
 If DONT-CLOSE is true then the listen socket will accept multiple
 connections, otherwise it will be closed after the first."
-  (setup-server port #'simple-announce-function style dont-close 
-                (find-external-format-or-lose coding-system)))
+  (setup-server port #'simple-announce-function
+                style dont-close coding-system))
 
 (defun find-external-format-or-lose (coding-system)
   (or (find-external-format coding-system)
@@ -658,14 +660,18 @@
 
 (defparameter *loopback-interface* "127.0.0.1")
 
-(defun setup-server (port announce-fn style dont-close external-format)
+(defun setup-server (port announce-fn style dont-close coding-system)
   (declare (type function announce-fn))
   (init-log-output)
-  (let* ((socket (create-socket *loopback-interface* port))
+  (let* ((external-format (find-external-format-or-lose coding-system))
+         (socket (create-socket *loopback-interface* port))
          (local-port (local-port socket)))
     (funcall announce-fn local-port)
     (flet ((serve ()
-             (serve-connection socket style dont-close external-format)))
+             ;; We pass down the coding-system so we can put it into a
+             ;; CONNECTION for debugging purposes.
+             (serve-connection socket style dont-close
+                               external-format coding-system)))
       (ecase style
         (:spawn
          (initialize-multiprocessing
@@ -716,7 +722,7 @@
                  :coding-system coding-system))
 
 
-(defun serve-connection (socket style dont-close external-format)
+(defun serve-connection (socket style dont-close external-format coding-system)
   (let ((closed-socket-p nil))
     (unwind-protect
          (let ((client (accept-authenticated-connection
@@ -724,7 +730,7 @@
            (unless dont-close
              (close-socket socket)
              (setf closed-socket-p t))
-           (let ((connection (create-connection client style)))
+           (let ((connection (create-connection client style coding-system)))
              (run-hook *new-connection-hook* connection)
              (push connection *connections*)
              (serve-requests connection)))
@@ -1281,7 +1287,7 @@
             (unless c (return))
             (write-char c str)))))
 
-(defun create-connection (socket-io style)
+(defun create-connection (socket-io style coding-system)
   (let ((success nil))
     (unwind-protect
          (let ((c (ecase style
@@ -1302,6 +1308,7 @@
                                       :serve-requests #'simple-serve-requests))
                     )))
            (setf (connection.communication-style c) style)
+           (setf (connection.coding-system c) coding-system)
            (setf success t)
            c)
       (unless success
@@ -1713,19 +1720,25 @@
 FEATURES: a list of keywords
 PACKAGE: a list (&key NAME PROMPT)
 VERSION: the protocol version"
-  (setq *slime-features* *features*)
-  `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
-    :lisp-implementation (:type ,(lisp-implementation-type)
-                          :name ,(lisp-implementation-type-name)
-                          :version ,(lisp-implementation-version))
-    :machine (:instance ,(machine-instance)
-              :type ,(machine-type)
-              :version ,(machine-version))
-    :features ,(features-for-emacs)
-    :modules ,*modules*
-    :package (:name ,(package-name *package*)
-              :prompt ,(package-string-for-prompt *package*))
-    :version ,*swank-wire-protocol-version*))
+  (let ((c *emacs-connection*))
+    (setq *slime-features* *features*)
+    `(:pid ,(getpid) :style ,(connection.communication-style c)
+      :encoding (:coding-system ,(connection.coding-system c)
+                 ;; external-formats are totally implementation-dependent,
+                 ;; so better play safe.
+                 :external-format ,(prin1-to-string
+                                    (connection.external-format c)))
+      :lisp-implementation (:type ,(lisp-implementation-type)
+                            :name ,(lisp-implementation-type-name)
+                            :version ,(lisp-implementation-version))
+      :machine (:instance ,(machine-instance)
+               :type ,(machine-type)
+               :version ,(machine-version))
+      :features ,(features-for-emacs)
+      :modules ,*modules*
+      :package (:name ,(package-name *package*)
+               :prompt ,(package-string-for-prompt *package*))
+      :version ,*swank-wire-protocol-version*)))
 
 (defslimefun io-speed-test (&optional (n 1000) (m 1))
   (let* ((s *standard-output*)




From trittweiler at common-lisp.net  Mon Mar  8 09:59:33 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 08 Mar 2010 04:59:33 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NoZkL-0004KZ-Pt@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (close-connection): Include initially passed
	coding-system in debugging output.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/08 09:47:12	1.2022
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/08 09:59:33	1.2023
@@ -1,5 +1,10 @@
 2010-03-08  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (close-connection): Include initially passed
+	coding-system in debugging output.
+
+2010-03-08  Tobias C. Rittweiler <tcr at freebits.de>
+
 	Make swank:connection-info include information about initially
 	passed coding-system, and the resulting external-format of the
 	socket. Debugging aid.
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/08 09:47:12	1.696
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/08 09:59:33	1.697
@@ -302,7 +302,8 @@
   (print-unreadable-object (conn stream :type t :identity t)))
 
 (defun connection.external-format (connection)
-  (stream-external-format (connection.socket-io connection)))
+  (ignore-errors
+    (stream-external-format (connection.socket-io connection))))
 
 (defvar *connections* '()
   "List of all active connections, with the most recent at the front.")
@@ -946,11 +947,13 @@
                         ;; Connection to Emacs lost. [~%~
                         ;;  condition: ~A~%~
                         ;;  type: ~S~%~
-                        ;;  encoding: ~A style: ~S dedicated: ~S]~%"
+                        ;;  encoding: ~A vs. ~A~%~
+                        ;;  style: ~S dedicated: ~S]~%"
             backtrace
             (escape-non-ascii (safe-condition-message condition) )
             (type-of condition)
-            (ignore-errors (stream-external-format (connection.socket-io c)))
+            (connection.coding-system c)
+            (connection.external-format c)
             (connection.communication-style c)
             *use-dedicated-output-stream*)
     (finish-output *log-output*))




From trittweiler at common-lisp.net  Mon Mar  8 11:57:05 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 08 Mar 2010 06:57:05 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Noba5-0004IQ-5F@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (dispatch-interrupt-event): Take a connection because
	it boils down to SIGNAL-INTERRUPT which uses USE-THREADS-P which
	needs a connection.
	(install-fd-handler): Adapted accordingly.
	(simple-serve-event): Adapted accordingly. Additionally, remove
	superfluous WITH-SWANK-PROTOCOL-HANDLER as that's established by
	WITH-CONNECTION already.
	(simple-repl): Show "abort inferior lisp" restart only if not a
	more appropriate "abort some REX" restart is available. Also make
	sure to return in case of END-OF-FILE, otherwise there's an
	infinite loop where we end up in the debugger again and again
	until the user eventually selects close-connection restart himself.
	(make-repl-input-stream): Use WITH-TOP-LEVEL-RESTART so
	`sldb-quit' can be used in SLDB.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/08 09:59:33	1.2023
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/08 11:57:04	1.2024
@@ -1,5 +1,22 @@
 2010-03-08  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (dispatch-interrupt-event): Take a connection because
+	it boils down to SIGNAL-INTERRUPT which uses USE-THREADS-P which
+	needs a connection.
+	(install-fd-handler): Adapted accordingly.
+	(simple-serve-event): Adapted accordingly. Additionally, remove
+	superfluous WITH-SWANK-PROTOCOL-HANDLER as that's established by
+	WITH-CONNECTION already.
+	(simple-repl): Show "abort inferior lisp" restart only if not a
+	more appropriate "abort some REX" restart is available. Also make
+	sure to return in case of END-OF-FILE, otherwise there's an
+	infinite loop where we end up in the debugger again and again
+	until the user eventually selects close-connection restart himself.
+	(make-repl-input-stream): Use WITH-TOP-LEVEL-RESTART so
+	`sldb-quit' can be used in SLDB.
+
+2010-03-08  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (close-connection): Include initially passed
 	coding-system in debugging output.
 
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/08 09:59:33	1.697
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/08 11:57:04	1.698
@@ -1213,13 +1213,14 @@
         (install-sigint-handler 
          (lambda () 
            (invoke-or-queue-interrupt
-            (lambda () 
-              (with-connection (connection)
-                (dispatch-interrupt-event)))))))
+            (lambda () (dispatch-interrupt-event connection))))))
   (handle-requests connection t))
 
-(defun dispatch-interrupt-event ()
-  (dispatch-event `(:emacs-interrupt ,(current-thread-id))))
+(defun dispatch-interrupt-event (connection)
+  ;; This boils down to SIGNAL-INTERRUPT which uses USE-THREADS-P
+  ;; which needs *EMACS-CONNECTION*.
+  (with-connection (connection)
+    (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))
 
 (defun deinstall-fd-handler (connection)
   (log-event "deinstall-fd-handler~%")
@@ -1229,34 +1230,46 @@
 ;;;;;; Simple sequential IO
 
 (defun simple-serve-requests (connection)
-  (unwind-protect 
+  (unwind-protect
        (with-connection (connection)
          (call-with-user-break-handler
-          (lambda () 
-            (invoke-or-queue-interrupt #'dispatch-interrupt-event))
+          (lambda ()
+            (invoke-or-queue-interrupt
+             #'(lambda () (dispatch-interrupt-event connection))))
           (lambda ()
             (with-simple-restart (close-connection "Close SLIME connection")
               ;;(handle-requests connection)
               (let* ((stdin (real-input-stream *standard-input*))
                      (*standard-input* (make-repl-input-stream connection 
                                                                stdin)))
-                (with-swank-protocol-error-handler (connection)
-                  (simple-repl)))))))
+                (simple-repl))))))
     (close-connection connection nil (safe-backtrace))))
 
 (defun simple-repl ()
-  (loop
-   (with-simple-restart (abort "Abort")
-     (format t "~a> " (package-string-for-prompt *package*))
-     (force-output)
-     (let ((form (read)))
-       (let ((- form)
-             (values (multiple-value-list (eval form))))
-         (setq *** **  ** *  * (car values)
-               /// //  // /  / values
-               +++ ++  ++ +  + form)
-         (cond ((null values) (format t "; No values~&"))
-               (t (mapc (lambda (v) (format t "~s~&" v)) values))))))))
+  (flet ((read-eval-print ()
+           (format t "~a> " (package-string-for-prompt *package*))
+           (force-output)
+           (let ((form (read)))
+             (let ((- form)
+                   (values (multiple-value-list (eval form))))
+               (setq *** **  ** *  * (car values)
+                     /// //  // /  / values
+                     +++ ++  ++ +  + form)
+               (cond ((null values) (format t "; No values~&"))
+                     (t (mapc (lambda (v) (format t "~s~&" v)) values)))))))
+    (loop
+      (restart-case
+          (handler-case (read-eval-print)
+            (end-of-file () (return)))
+        (abort (&optional c)
+          :report "Return to inferior-lisp's top-level."
+          :test (lambda (c)
+                  (declare (ignore c))
+                  ;; Do not show this restart if a more appropriate
+                  ;; top-level restart is available (e.g. for REXs and
+                  ;; hence the slime-repl.)
+                  (not (top-level-restart-p)))
+          (declare (ignore c)))))))
 
 (defun make-repl-input-stream (connection stdin)
   (make-input-stream
@@ -1268,21 +1281,22 @@
                 (if (open-stream-p stdin) 
                     :stdin-open :stdin-closed))
      (loop
-      (let* ((socket (connection.socket-io connection))
-             (inputs (list socket stdin))
-             (ready (wait-for-input inputs)))
-        (cond ((eq ready :interrupt)
-               (check-slime-interrupts))
-              ((member socket ready)
-               ;; A Slime request from Emacs is pending; make sure to
-               ;; redirect IO to the REPL buffer.
-               (with-io-redirection (connection)
-                 (handle-requests connection t)))
-              ((member stdin ready)
-               ;; User typed something into the  *inferior-lisp* buffer,
-               ;; so do not redirect.
-               (return (read-non-blocking stdin)))
-              (t (assert (null ready)))))))))
+       (with-top-level-restart (connection nil)
+         (let* ((socket (connection.socket-io connection))
+                (inputs (list socket stdin))
+                (ready (wait-for-input inputs)))
+           (cond ((eq ready :interrupt)
+                  (check-slime-interrupts))
+                 ((member socket ready)
+                  ;; A Slime request from Emacs is pending; make sure to
+                  ;; redirect IO to the REPL buffer.
+                  (with-io-redirection (connection)
+                    (handle-requests connection t)))
+                 ((member stdin ready)
+                  ;; User typed something into the  *inferior-lisp* buffer,
+                  ;; so do not redirect.
+                  (return (read-non-blocking stdin)))
+                 (t (assert (null ready))))))))))
 
 (defun read-non-blocking (stream)
   (with-output-to-string (str)




From heller at common-lisp.net  Mon Mar  8 12:21:43 2010
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 08 Mar 2010 07:21:43 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nobxv-0006jX-Uu@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
Try to use source-level debugging features in Allegro 8.2

* swank-allegro.lisp (disassemble-frame): Use undocumented
debugger::dyn-fd-analyze to figure out the PC and display it.
(pc-source-location, ldb-code-to-src-loc, longest-common-prefix)
(source-paths-of): New functions.
(frame-source-location): Use pc-source-location.  Still far from
optimal since Allegro rarely records source regions and anonymous
functions don't seem to carry source level debug-info at all.
(*temp-file-map*, buffer-or-file-location, find-fspec-location):
Use a table to map temp-file names back to Emacs buffers instead
of putting an eval-when-compile form in the source.  The
eval-when-compile form messed up source positions.
(*temp-file-header-end-position*, find-definition-in-buffer):
Deleted.
(compile-from-temp-file): Bind excl:*load-source-debug-info* and
compiler:save-source-level-debug-info-switch so that Allegro
doesn't try to load debug-info from deleted files.  Also put
the filename in *temp-file-map*.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/08 11:57:04	1.2024
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/08 12:21:43	1.2025
@@ -1,3 +1,25 @@
+2010-03-08  Helmut Eller  <heller at common-lisp.net>
+
+	Try to use source-level debugging features in Allegro 8.2
+
+	* swank-allegro.lisp (disassemble-frame): Use undocumented
+	debugger::dyn-fd-analyze to figure out the PC and display it.
+	(pc-source-location, ldb-code-to-src-loc, longest-common-prefix)
+	(source-paths-of): New functions.
+	(frame-source-location): Use pc-source-location.  Still far from
+	optimal since Allegro rarely records source regions and anonymous
+	functions don't seem to carry source level debug-info at all.
+	(*temp-file-map*, buffer-or-file-location, find-fspec-location):
+	Use a table to map temp-file names back to Emacs buffers instead
+	of putting an eval-when-compile form in the source.  The
+	eval-when-compile form messed up source positions.
+	(*temp-file-header-end-position*, find-definition-in-buffer):
+	Deleted.
+	(compile-from-temp-file): Bind excl:*load-source-debug-info* and
+	compiler:save-source-level-debug-info-switch so that Allegro
+	doesn't try to load debug-info from deleted files.  Also put
+	the filename in *temp-file-map*.
+
 2010-03-08  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (dispatch-interrupt-event): Take a connection because
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/07 16:22:17	1.134
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/08 12:21:43	1.135
@@ -12,7 +12,12 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (require :sock)
-  (require :process))
+  (require :process)
+  #+(version>= 8 2)
+  (require 'lldb)
+  )
+
+;;(declaim (optimize debug)) 
 
 (import-from :excl *gray-stream-symbols* :swank-backend)
 
@@ -131,9 +136,10 @@
     (funcall debugger-loop-fn)))
 
 (defimplementation sldb-break-at-start (fname)
-  ;; :print-before is kind of mis-used but we just want to stuff our break form
-  ;; somewhere. This does not work for setf, :before and :after methods, which
-  ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10.
+  ;; :print-before is kind of mis-used but we just want to stuff our
+  ;; break form somewhere. This does not work for setf, :before and
+  ;; :after methods, which need special syntax in the trace call, see
+  ;; ACL's doc/debugging.htm chapter 10.
   (eval `(trace (,fname
                  :print-before
                  ((break "Function start breakpoint of ~A" ',fname)))))
@@ -182,13 +188,73 @@
     (debugger:frame-var-value frame var)))
 
 (defimplementation disassemble-frame (index)
-  (disassemble (debugger:frame-function (nth-frame index))))
+  (let ((frame (nth-frame index)))
+    (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+      (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
+      (disassemble (debugger:frame-function frame)))))
 
 (defimplementation frame-source-location (index)
-  (let* ((frame (nth-frame index))
-         (expr (debugger:frame-expression frame))
-         (fspec (first expr)))
-    (second (first (fspec-definition-locations fspec)))))
+  (let* ((frame (nth-frame index)))
+    (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+      (declare (ignore x xx xxx))
+      #+(version>= 8 2)
+      (pc-source-location fun pc)
+      #-(version>= 8 2)
+      (function-source-location fun)
+      )))
+
+(defun function-source-location (fun)
+  (cadr (car (fspec-definition-locations fun))))
+
+#+(version>= 8 2)
+(defun pc-source-location (fun pc)
+  (let* ((debug-info (excl::function-source-debug-info fun)))
+    (cond ((not debug-info)
+           (function-source-location fun))
+          (t 
+           (let* ((return-loc (find pc debug-info :key #'excl::ldb-code-pc))
+                  (prev (and return-loc (excl::ldb-code-prev-rec return-loc)))
+                  (call-loc (if (integerp prev) 
+                                (aref debug-info prev) 
+                                return-loc)))
+             (cond ((not call-loc)
+                    (ldb-code-to-src-loc (aref debug-info 0)))
+                   (t
+                    (ldb-code-to-src-loc call-loc))))))))
+
+#+(version>= 8 2)
+(defun ldb-code-to-src-loc (code)
+  (let* ((start (excl::ldb-code-start-char code))
+         (func (excl::ldb-code-func code))
+         (loc (buffer-or-file-location (excl:source-file func) (or start 0))))
+    (cond (start loc)
+          (t
+           (let* ((debug-info (excl::function-source-debug-info func))
+                  (whole (aref debug-info 0))
+                  (paths (source-paths-of (excl::ldb-code-source whole)
+                                          (excl::ldb-code-source code)))
+                  (path (longest-common-prefix paths))
+                  (start (excl::ldb-code-start-char whole)))
+             (make-location (location-buffer loc) 
+                            `(:source-path (0 . ,path) ,start)))))))
+
+(defun longest-common-prefix (sequences)
+  (assert sequences)
+  (flet ((common-prefix (s1 s2)
+           (let ((diff-pos (mismatch s1 s2)))
+             (if diff-pos (subseq s1 0 diff-pos) s1))))
+    (reduce #'common-prefix sequences)))
+
+(defun source-paths-of (whole part)
+  (let ((result '()))
+    (labels ((walk (form path)
+               (cond ((eq form part) 
+                      (push (reverse path) result))
+                     ((consp form)
+                      (loop for i from 0 while (consp form) do
+                            (walk (pop form) (cons i path)))))))
+      (walk whole '())
+      (reverse result))))
 
 (defimplementation eval-in-frame (form frame-number)
   (let ((frame (nth-frame frame-number)))
@@ -228,7 +294,6 @@
 (defvar *buffer-start-position*)
 (defvar *buffer-string*)
 (defvar *compile-filename* nil)
-(defvar *temp-file-header-end-position* nil)
 
 (defun compiler-note-p (object)
   (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
@@ -292,8 +357,7 @@
     (if (integerp pos)
         (if *buffer-name*
             (make-location `(:buffer ,*buffer-name*)
-                           `(:offset ,*buffer-start-position*
-                                     ,(- pos *temp-file-header-end-position* 1)))
+                           `(:offset ,*buffer-start-position* ,pos))
             (make-location `(:file ,(namestring (truename file)))
                            `(:position ,pos)))
         (make-error-location "No error location available."))))
@@ -345,11 +409,19 @@
            (funcall fn file tmpname))
       (delete-file tmpname))))
 
-(defun compile-from-temp-file (header string)
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+  "A mapping from tempfile names to Emacs buffer names.")
+
+(defun compile-from-temp-file (string buffer offset file)
   (call-with-temp-file 
    (lambda (stream filename)
-     (write-string header stream)
-     (let ((*temp-file-header-end-position* (file-position stream)))
+     (let ((excl:*load-source-file-info* t)
+           (sys:*source-file-types* '(nil)) ; suppress .lisp extension
+           #+(version>= 8 2)
+           (compiler:save-source-level-debug-info-switch t)
+           #+(version>= 8 2)
+           (excl:*load-source-debug-info* t) ; NOTE: requires lldb
+           )
        (write-string string stream)
        (finish-output stream)
        (multiple-value-bind (binary-filename warnings? failure?)
@@ -360,6 +432,8 @@
              (compile-file filename :load-after-compile t))
          (declare (ignore warnings?))
          (when binary-filename
+           (setf (gethash (pathname stream) *temp-file-map*)
+                 (list buffer offset file))
            (delete-file binary-filename))
          (not failure?))))))
 
@@ -375,26 +449,27 @@
                (if filename 
                    (merge-pathnames (pathname filename))
                    *default-pathname-defaults*)))
-          ;; We store the source buffer in excl::*source-pathname* as a
-          ;; string of the form <buffername>;<start-offset>.  Quite ugly
-          ;; encoding, but the fasl file is corrupted if we use some
-          ;; other datatype.
-          (compile-from-temp-file
-           (format nil "~S~%~S~%" 
-                   `(in-package ,(package-name *package*))
-                   `(eval-when (:compile-toplevel :load-toplevel)
-                      (setq excl::*source-pathname*
-                            ',(format nil "~A;~D" buffer position))))
-           string)))
+          (compile-from-temp-file string buffer position filename)))
     (reader-error () (values nil nil t))))
 
 ;;;; Definition Finding
 
+(defun buffer-or-file-location (file offset)
+  (let* ((probe (gethash file *temp-file-map*)))
+    (cond ((not probe)
+           (make-location `(:file ,(namestring (truename file)))
+                          `(:position ,(1+ offset))))
+          (t
+           (destructuring-bind (buffer start file) probe
+             (declare (ignore file))
+             (make-location `(:buffer ,buffer)
+                            `(:offset ,start ,offset)))))))
+
 (defun fspec-primary-name (fspec)
   (etypecase fspec
     (symbol fspec)
     (list (fspec-primary-name (second fspec)))))
-              
+
 (defun find-definition-in-file (fspec type file top-level)
   (let* ((part
           (or (scm::find-definition-in-definition-group
@@ -411,33 +486,33 @@
                   (list :function-name (string (fspec-primary-name fspec))))))
     (make-location (list :file (namestring (truename file)))
                    pos)))
-  
-(defun find-definition-in-buffer (filename)
-  (let ((pos (position #\; filename :from-end t)))
-    (make-location
-     (list :buffer (subseq filename 0 pos))
-     (list :offset (parse-integer (subseq filename (1+ pos))) 0))))
 
 (defun find-fspec-location (fspec type file top-level)
   (handler-case
       (etypecase file
         (pathname
-         (find-definition-in-file fspec type file top-level))
+         (let ((probe (gethash file *temp-file-map*)))
+           (cond (probe
+                  (destructuring-bind (buffer offset file) probe
+                    (declare (ignore file))
+                    (make-location `(:buffer ,buffer)
+                                   `(:offset ,offset 0))))
+                 (t
+                  (find-definition-in-file fspec type file top-level)))))
         ((member :top-level)
-         (make-error-location "Defined at toplevel: ~A" (fspec->string fspec)))
-        (string
-         (find-definition-in-buffer file)))
+         (make-error-location "Defined at toplevel: ~A" (fspec->string fspec))))
     (error (e)
       (make-error-location "Error: ~A" e))))
 
 (defun fspec->string (fspec)
-  (etypecase fspec
+  (typecase fspec
     (symbol (let ((*package* (find-package :keyword)))
               (prin1-to-string fspec)))
     (list (format nil "(~A ~A)"
                   (prin1-to-string (first fspec))
                   (let ((*package* (find-package :keyword)))
-                    (prin1-to-string (second fspec)))))))
+                    (prin1-to-string (second fspec)))))
+    (t (princ-to-string fspec))))
 
 (defun fspec-definition-locations (fspec)
   (cond




From heller at common-lisp.net  Mon Mar  8 16:20:10 2010
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 08 Mar 2010 11:20:10 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nofgg-00017F-8y@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
Fix some of the brokeness in the last change.

* swank-allegro.lisp (frame-source-location): Deal with frames for
undefined functions better.
(ldb-code-to-src-loc): Handle temp-files properly.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/08 12:21:43	1.2025
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/08 16:20:10	1.2026
@@ -1,5 +1,13 @@
 2010-03-08  Helmut Eller  <heller at common-lisp.net>
 
+	Fix some of the brokeness in the last change.
+
+	* swank-allegro.lisp (frame-source-location): Deal with frames for
+	undefined functions better.
+	(ldb-code-to-src-loc): Handle temp-files properly.
+
+2010-03-08  Helmut Eller  <heller at common-lisp.net>
+
 	Try to use source-level debugging features in Allegro 8.2
 
 	* swank-allegro.lisp (disassemble-frame): Use undocumented
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/08 12:21:43	1.135
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/08 16:20:10	1.136
@@ -17,8 +17,6 @@
   (require 'lldb)
   )
 
-;;(declaim (optimize debug)) 
-
 (import-from :excl *gray-stream-symbols* :swank-backend)
 
 ;;; swank-mop
@@ -197,11 +195,14 @@
   (let* ((frame (nth-frame index)))
     (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
       (declare (ignore x xx xxx))
-      #+(version>= 8 2)
-      (pc-source-location fun pc)
-      #-(version>= 8 2)
-      (function-source-location fun)
-      )))
+      (cond (pc
+             #+(version>= 8 2)
+             (pc-source-location fun pc)
+             #-(version>= 8 2)
+             (function-source-location fun))
+            (t ; frames for unbound functions etc end up here
+             (cadr (car (fspec-definition-locations
+                         (car (debugger:frame-expression frame))))))))))
 
 (defun function-source-location (fun)
   (cadr (car (fspec-definition-locations fun))))
@@ -226,17 +227,26 @@
 (defun ldb-code-to-src-loc (code)
   (let* ((start (excl::ldb-code-start-char code))
          (func (excl::ldb-code-func code))
-         (loc (buffer-or-file-location (excl:source-file func) (or start 0))))
-    (cond (start loc)
+         (src-file (excl:source-file func)))
+    (cond (start 
+           (buffer-or-file-location src-file start))
           (t
            (let* ((debug-info (excl::function-source-debug-info func))
                   (whole (aref debug-info 0))
                   (paths (source-paths-of (excl::ldb-code-source whole)
                                           (excl::ldb-code-source code)))
                   (path (longest-common-prefix paths))
-                  (start (excl::ldb-code-start-char whole)))
-             (make-location (location-buffer loc) 
-                            `(:source-path (0 . ,path) ,start)))))))
+                  (start (excl::ldb-code-start-char whole))
+                  (probe (gethash src-file *temp-file-map*)))
+             (cond ((not probe)
+                    (make-location `(:file ,(namestring (truename src-file)))
+                                   `(:source-path (0 . ,path) ,start)))
+                   (t
+                    (destructuring-bind (buffer bstart file) probe
+                      (declare (ignore file))
+                      (make-location `(:buffer ,buffer)
+                                     `(:source-path (0 . ,path) 
+                                                    ,(+ bstart start)))))))))))
 
 (defun longest-common-prefix (sequences)
   (assert sequences)




From sboukarev at common-lisp.net  Mon Mar  8 16:32:00 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 08 Mar 2010 11:32:00 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nofs8-00025C-27@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* contrib/slime-repl.el (slime-call-defun): Work also on defvar/defparameter.

* slime.el (slime-extract-context): Add defvar and defparameter.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/08 16:20:10	1.2026
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/08 16:31:59	1.2027
@@ -1,3 +1,7 @@
+2010-03-08  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-extract-context): Add defvar and defparameter.
+
 2010-03-08  Helmut Eller  <heller at common-lisp.net>
 
 	Fix some of the brokeness in the last change.
--- /project/slime/cvsroot/slime/slime.el	2010/03/03 11:57:03	1.1283
+++ /project/slime/cvsroot/slime/slime.el	2010/03/08 16:31:59	1.1284
@@ -4274,6 +4274,9 @@
  (define-setf-expander n.ame (...) ...)  -> (:define-setf-expander name)
  (define-modify-macro n.ame (...) ...)   -> (:define-modify-macro name)
  (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
+ (defvar n.ame (...) ...)                -> (:defvar name)
+ (defparameter n.ame (...) ...)          -> (:defparameter name)
+ (defconstant n.ame (...) ...)           -> (:defconstant name)
 
 For other contexts we return the symbol at point."
   (let ((name (slime-symbol-at-point)))
@@ -4325,6 +4328,9 @@
            `(:define-setf-expander ,name))
           ((slime-in-expression-p '(defsetf *))
            `(:defsetf ,name))
+          ((slime-in-expression-p '(defvar *))       `(:defvar ,name))
+          ((slime-in-expression-p '(defparameter *)) `(:defparameter ,name))
+          ((slime-in-expression-p '(defconstant *))  `(:defconstant ,name))
           (t 
            name))))
 




From sboukarev at common-lisp.net  Mon Mar  8 16:32:00 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 08 Mar 2010 11:32:00 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Nofs8-00025P-Dv@common-lisp.net>

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

Modified Files:
	ChangeLog slime-repl.el 
Log Message:
* contrib/slime-repl.el (slime-call-defun): Work also on defvar/defparameter.

* slime.el (slime-extract-context): Add defvar and defparameter.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/07 17:04:00	1.351
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/08 16:32:00	1.352
@@ -1,7 +1,11 @@
+2010-03-08  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-repl.el (slime-call-defun): Work also on defvar/defparameter.
+
 2010-03-07  Stas Boukarev  <stassats at gmail.com>
 
-	* swank-fancy-inspector.lisp (stable-sort-by-inheritance): Remove copy-seq,
-	unnecessarily put in the previous commit.
+	* swank-fancy-inspector.lisp (stable-sort-by-inheritance): Remove
+	copy-seq, unnecessarily put in the previous commit.
 
 2010-03-07  Stas Boukarev  <stassats at gmail.com>
 
--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2010/01/31 20:17:27	1.37
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2010/03/08 16:32:00	1.38
@@ -1444,18 +1444,24 @@
 (defun slime-call-defun ()
   "Insert a call to the toplevel form defined around point into the REPL."
   (interactive)
-  (flet ((insert-call (symbol)
+  (flet ((insert-call (symbol &optional (function-call-p t))
            (let* ((qualified-symbol-name (slime-qualify-cl-symbol-name symbol))
                   (symbol-name (slime-cl-symbol-name qualified-symbol-name))
                   (symbol-package (slime-cl-symbol-package qualified-symbol-name))
-                  (function-call 
-                   (format "(%s " (if (equalp (slime-lisp-package) symbol-package)
-                                      symbol-name
-                                      qualified-symbol-name))))
+                  (call (if (equalp (slime-lisp-package) symbol-package)
+                            symbol-name
+                            qualified-symbol-name)))
              (slime-switch-to-output-buffer)
              (goto-char slime-repl-input-start-mark)
-             (insert function-call)
-             (save-excursion (insert ")")))))           
+             (insert (if function-call-p
+                         "("
+                         " "))
+             (insert call)
+             (when function-call-p
+               (insert " ")
+               (save-excursion (insert ")")))
+             (unless function-call-p
+               (goto-char slime-repl-input-start-mark)))))           
     (let ((toplevel (slime-parse-toplevel-form)))
       (if (symbolp toplevel)
           (error "Not in a function definition")
@@ -1465,6 +1471,8 @@
             ((:defmethod symbol &rest args)
              (declare (ignore args))
              (insert-call symbol))
+            (((:defparameter :defvar :defconstant) symbol)
+             (insert-call symbol nil))
             (t
              (error "Not in a function definition")))))))
 




From sboukarev at common-lisp.net  Mon Mar  8 16:35:06 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 08 Mar 2010 11:35:06 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Nofv8-00027a-4t@common-lisp.net>

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

Modified Files:
	ChangeLog swank-fancy-inspector.lisp 
Log Message:
* contrib/swank-fancy-inspector.lisp (all-slots-for-inspector): Sort class
names when grouping by inheritance the same way as slots are sorted.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/08 16:32:00	1.352
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/08 16:35:06	1.353
@@ -1,5 +1,10 @@
 2010-03-08  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-fancy-inspector.lisp (all-slots-for-inspector): Sort class
+	names when grouping by inheritance the same way as slots are sorted.
+
+2010-03-08  Stas Boukarev  <stassats at gmail.com>
+
 	* slime-repl.el (slime-call-defun): Work also on defvar/defparameter.
 
 2010-03-07  Stas Boukarev  <stassats at gmail.com>
--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2010/03/07 17:04:00	1.24
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp	2010/03/08 16:35:06	1.25
@@ -242,15 +242,16 @@
          (sort-order
           (ensure-istate-metadata object :sort-order
                                   (box *inspector-slots-default-order*)))
+         (sort-predicate (ecase (ref sort-order)
+                           (:alphabetically #'string<)
+                           (:unsorted (constantly nil))))
          (sorted-slots (sort (copy-seq effective-slots)
-                             (ecase (ref sort-order)
-                               (:alphabetically #'string<)
-                               (:unsorted (constantly nil)))
+                             sort-predicate
                              :key #'swank-mop:slot-definition-name))
          (effective-slots
           (ecase (ref grouping-kind)
             (:all sorted-slots)
-            (:inheritance (stable-sort-by-inheritance sorted-slots class)))))
+            (:inheritance (stable-sort-by-inheritance sorted-slots class sort-predicate)))))
     `("--------------------"
       (:newline)
       " Group slots by inheritance "
@@ -372,8 +373,8 @@
                                :key #'swank-mop:slot-definition-name :test #'eq)
                        class))))
 
-(defun stable-sort-by-inheritance (slots class)
-  (stable-sort slots #'string< 
+(defun stable-sort-by-inheritance (slots class predicate)
+  (stable-sort slots predicate
                :key #'(lambda (s)
                         (class-name (slot-home-class-using-class s class)))))
 




From heller at common-lisp.net  Tue Mar  9 08:02:38 2010
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 09 Mar 2010 03:02:38 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NouOk-0000XC-B0@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
Some more fixes for Allegro

* swank-allegro.lisp (function-source-location): Use
xref::object-to-function-name which seems to work better for some
cases.
(fspec-definition-locations): For :top-level-forms return a list
of ((fspec loc)) not just (fspec loc).  Also deal with the file
vs. buffer issue.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/08 16:31:59	1.2027
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/09 08:02:37	1.2028
@@ -1,3 +1,14 @@
+2010-03-09  Helmut Eller  <heller at common-lisp.net>
+
+	Some more fixes for Allegro
+
+	* swank-allegro.lisp (function-source-location): Use
+	xref::object-to-function-name which seems to work better for some
+	cases.
+	(fspec-definition-locations): For :top-level-forms return a list
+	of ((fspec loc)) not just (fspec loc).  Also deal with the file
+	vs. buffer issue.
+
 2010-03-08  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-extract-context): Add defvar and defparameter.
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/08 16:20:10	1.136
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/09 08:02:37	1.137
@@ -205,7 +205,7 @@
                          (car (debugger:frame-expression frame))))))))))
 
 (defun function-source-location (fun)
-  (cadr (car (fspec-definition-locations fun))))
+  (cadr (car (fspec-definition-locations (xref::object-to-function-name fun)))))
 
 #+(version>= 8 2)
 (defun pc-source-location (fun pc)
@@ -464,16 +464,22 @@
 
 ;;;; Definition Finding
 
-(defun buffer-or-file-location (file offset)
+(defun buffer-or-file (file file-fun buffer-fun)
   (let* ((probe (gethash file *temp-file-map*)))
-    (cond ((not probe)
-           (make-location `(:file ,(namestring (truename file)))
-                          `(:position ,(1+ offset))))
-          (t
+    (cond (probe 
            (destructuring-bind (buffer start file) probe
              (declare (ignore file))
-             (make-location `(:buffer ,buffer)
-                            `(:offset ,start ,offset)))))))
+             (funcall buffer-fun buffer start)))
+          (t (funcall file-fun (namestring (truename file)))))))
+
+(defun buffer-or-file-location (file offset)
+  (buffer-or-file file 
+                  (lambda (filename)
+                    (make-location `(:file ,filename)
+                                   `(:position ,(1+ offset))))
+                  (lambda (buffer start)
+                    (make-location `(:buffer ,buffer)
+                                   `(:offset ,start ,offset)))))
 
 (defun fspec-primary-name (fspec)
   (etypecase fspec
@@ -530,10 +536,8 @@
           (eql (car fspec) :top-level-form))
      (destructuring-bind (top-level-form file &optional position) fspec 
        (declare (ignore top-level-form))
-       (list fspec
-             (make-location (list :buffer file) ; FIXME: should use :file
-                            (list :position position)
-                            (list :align t)))))
+       `((,fspec
+          ,(buffer-or-file-location file position)))))
     ((and (listp fspec) (eq (car fspec) :internal))
      (destructuring-bind (_internal next _n) fspec
        (declare (ignore _internal _n))




From heller at common-lisp.net  Tue Mar  9 08:15:05 2010
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 09 Mar 2010 03:15:05 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Nouan-00012P-S9@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
(ldb-code-to-src-loc): Don't use *temp-file-map* before it is declared.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/09 08:02:37	1.2028
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/09 08:15:05	1.2029
@@ -8,6 +8,8 @@
 	(fspec-definition-locations): For :top-level-forms return a list
 	of ((fspec loc)) not just (fspec loc).  Also deal with the file
 	vs. buffer issue.
+	(ldb-code-to-src-loc): Don't use *temp-file-map* before it is
+	declared.
 
 2010-03-08  Stas Boukarev  <stassats at gmail.com>
 
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/09 08:02:37	1.137
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/09 08:15:05	1.138
@@ -236,18 +236,17 @@
                   (paths (source-paths-of (excl::ldb-code-source whole)
                                           (excl::ldb-code-source code)))
                   (path (longest-common-prefix paths))
-                  (start (excl::ldb-code-start-char whole))
-                  (probe (gethash src-file *temp-file-map*)))
-             (cond ((not probe)
-                    (make-location `(:file ,(namestring (truename src-file)))
-                                   `(:source-path (0 . ,path) ,start)))
-                   (t
-                    (destructuring-bind (buffer bstart file) probe
-                      (declare (ignore file))
-                      (make-location `(:buffer ,buffer)
-                                     `(:source-path (0 . ,path) 
-                                                    ,(+ bstart start)))))))))))
-
+                  (start (excl::ldb-code-start-char whole)))
+             (buffer-or-file 
+              src-file 
+              (lambda (file) 
+                (make-location `(:file ,file) 
+                               `(:source-path (0 . ,path) ,start)))
+              (lambda (buffer bstart)
+                (make-location `(:buffer ,buffer)
+                               `(:source-path (0 . ,path)
+                                              ,(+ bstart start))))))))))
+ 
 (defun longest-common-prefix (sequences)
   (assert sequences)
   (flet ((common-prefix (s1 s2)




From heller at common-lisp.net  Tue Mar  9 09:20:13 2010
From: heller at common-lisp.net (CVS User heller)
Date: Tue, 09 Mar 2010 04:20:13 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Novbp-0005WN-PB@common-lisp.net>

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
(pc-source-location): Be a bit more fuzzy when searching the
code-location for a pc.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/09 08:15:05	1.2029
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/09 09:20:13	1.2030
@@ -10,6 +10,8 @@
 	vs. buffer issue.
 	(ldb-code-to-src-loc): Don't use *temp-file-map* before it is
 	declared.
+	(pc-source-location): Be a bit more fuzzy when searching the
+	code-location for a pc.
 
 2010-03-08  Stas Boukarev  <stassats at gmail.com>
 
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/09 08:15:05	1.138
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/09 09:20:13	1.139
@@ -213,15 +213,15 @@
     (cond ((not debug-info)
            (function-source-location fun))
           (t 
-           (let* ((return-loc (find pc debug-info :key #'excl::ldb-code-pc))
-                  (prev (and return-loc (excl::ldb-code-prev-rec return-loc)))
-                  (call-loc (if (integerp prev) 
-                                (aref debug-info prev) 
-                                return-loc)))
-             (cond ((not call-loc)
+           (let* ((code-loc (find-if (lambda (c)
+                                       (<= (- pc (sys::natural-width))
+                                           (excl::ldb-code-pc c)
+                                           pc))
+                                     debug-info)))
+             (cond ((not code-loc)
                     (ldb-code-to-src-loc (aref debug-info 0)))
                    (t
-                    (ldb-code-to-src-loc call-loc))))))))
+                    (ldb-code-to-src-loc code-loc))))))))
 
 #+(version>= 8 2)
 (defun ldb-code-to-src-loc (code)




From sboukarev at common-lisp.net  Tue Mar  9 14:10:37 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 09 Mar 2010 09:10:37 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Np08r-0002H2-In@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* contrib/slime-repl.el (slime-call-defun): When on defclass insert
 (make-instance 'name).

* slime.el (slime-parse-context): Add defclass.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/09 09:20:13	1.2030
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/09 14:10:37	1.2031
@@ -1,3 +1,7 @@
+2010-03-09  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-parse-context): Add defclass.
+
 2010-03-09  Helmut Eller  <heller at common-lisp.net>
 
 	Some more fixes for Allegro
--- /project/slime/cvsroot/slime/slime.el	2010/03/08 16:31:59	1.1284
+++ /project/slime/cvsroot/slime/slime.el	2010/03/09 14:10:37	1.1285
@@ -4275,8 +4275,9 @@
  (define-modify-macro n.ame (...) ...)   -> (:define-modify-macro name)
  (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name)
  (defvar n.ame (...) ...)                -> (:defvar name)
- (defparameter n.ame (...) ...)          -> (:defparameter name)
- (defconstant n.ame (...) ...)           -> (:defconstant name)
+ (defparameter n.ame ...)                -> (:defparameter name)
+ (defconstant n.ame ...)                 -> (:defconstant name)
+ (defclass n.ame ...)                    -> (:defclass name)
 
 For other contexts we return the symbol at point."
   (let ((name (slime-symbol-at-point)))
@@ -4331,6 +4332,7 @@
           ((slime-in-expression-p '(defvar *))       `(:defvar ,name))
           ((slime-in-expression-p '(defparameter *)) `(:defparameter ,name))
           ((slime-in-expression-p '(defconstant *))  `(:defconstant ,name))
+          ((slime-in-expression-p '(defclass *))     `(:defclass ,name))
           (t 
            name))))
 




From sboukarev at common-lisp.net  Tue Mar  9 14:10:38 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 09 Mar 2010 09:10:38 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Np08s-0002HJ-1e@common-lisp.net>

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

Modified Files:
	ChangeLog slime-repl.el 
Log Message:
* contrib/slime-repl.el (slime-call-defun): When on defclass insert
 (make-instance 'name).

* slime.el (slime-parse-context): Add defclass.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/08 16:35:06	1.353
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/09 14:10:37	1.354
@@ -1,3 +1,8 @@
+2010-03-09  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-repl.el (slime-call-defun): When on defclass insert
+	 (make-instance 'name).
+
 2010-03-08  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-fancy-inspector.lisp (all-slots-for-inspector): Sort class
--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2010/03/08 16:32:00	1.38
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2010/03/09 14:10:37	1.39
@@ -1444,7 +1444,8 @@
 (defun slime-call-defun ()
   "Insert a call to the toplevel form defined around point into the REPL."
   (interactive)
-  (flet ((insert-call (symbol &optional (function-call-p t))
+  (flet ((insert-call (symbol &key (function t)
+                              defclass)
            (let* ((qualified-symbol-name (slime-qualify-cl-symbol-name symbol))
                   (symbol-name (slime-cl-symbol-name qualified-symbol-name))
                   (symbol-package (slime-cl-symbol-package qualified-symbol-name))
@@ -1453,14 +1454,16 @@
                             qualified-symbol-name)))
              (slime-switch-to-output-buffer)
              (goto-char slime-repl-input-start-mark)
-             (insert (if function-call-p
+             (insert (if function
                          "("
                          " "))
+             (if defclass
+                 (insert "make-instance '"))
              (insert call)
-             (when function-call-p
+             (when function
                (insert " ")
                (save-excursion (insert ")")))
-             (unless function-call-p
+             (unless function
                (goto-char slime-repl-input-start-mark)))))           
     (let ((toplevel (slime-parse-toplevel-form)))
       (if (symbolp toplevel)
@@ -1472,7 +1475,9 @@
              (declare (ignore args))
              (insert-call symbol))
             (((:defparameter :defvar :defconstant) symbol)
-             (insert-call symbol nil))
+             (insert-call symbol :function nil))
+            (((:defclass) symbol)
+             (insert-call symbol :defclass t))
             (t
              (error "Not in a function definition")))))))
 




From sboukarev at common-lisp.net  Tue Mar  9 14:42:22 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 09 Mar 2010 09:42:22 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Np0da-0004cW-Oa@common-lisp.net>

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

Modified Files:
	ChangeLog slime-presentations.el swank-presentations.lisp 
Log Message:
* swank-presentations.lisp (inspect-presentation): Throw an error when
trying to access unrecorded object.
(lookup-presented-object-or-lose): Rename from `get-repl-result'.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/09 14:10:37	1.354
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/09 14:42:22	1.355
@@ -1,5 +1,11 @@
 2010-03-09  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-presentations.lisp (inspect-presentation): Throw an error when
+	trying to access unrecorded object.
+	(lookup-presented-object-or-lose): Rename from `get-repl-result'.
+
+2010-03-09  Stas Boukarev  <stassats at gmail.com>
+
 	* slime-repl.el (slime-call-defun): When on defclass insert
 	 (make-instance 'name).
 
--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2010/02/15 21:42:37	1.28
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2010/03/09 14:42:22	1.29
@@ -632,12 +632,12 @@
 the presented object."
   (let ((id (slime-presentation-id presentation)))
     (etypecase id
-      (number         
+      (number
        ;; Make sure it works even if *read-base* is not 10.
-       (format "(swank:get-repl-result #10r%d)" id))
+       (format "(swank:lookup-presented-object-or-lose %d.)" id))
       (list
        ;; for frame variables and inspector parts
-       (format "(swank:get-repl-result '%s)" id)))))
+       (format "(swank:lookup-presented-object-or-lose '%s)" id)))))
 
 (defun slime-buffer-substring-with-reified-output (start end)
   (let ((str-props (buffer-substring start end))
--- /project/slime/cvsroot/slime/contrib/swank-presentations.lisp	2008/02/21 20:49:10	1.5
+++ /project/slime/cvsroot/slime/contrib/swank-presentations.lisp	2010/03/09 14:42:22	1.6
@@ -81,7 +81,7 @@
             (values (inspector-nth-part part-index) t)
             (values nil nil)))))))
 
-(defslimefun get-repl-result (id)
+(defslimefun lookup-presented-object-or-lose (id)
   "Get the result of the previous REPL evaluation with ID."
   (multiple-value-bind (object foundp) (lookup-presented-object id)
     (cond (foundp object)
@@ -226,7 +226,7 @@
                 (disassemble object)))))
 
 (defslimefun inspect-presentation (id reset-p)
-  (let ((what (lookup-presented-object id)))
+  (let ((what (lookup-presented-object-or-lose id)))
     (when reset-p
       (reset-inspector))
     (inspect-object what)))




From sboukarev at common-lisp.net  Tue Mar  9 23:26:23 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 09 Mar 2010 18:26:23 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Np8oh-0001E7-Mr@common-lisp.net>

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

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
* swank-arglists.lisp (arglist-ref): Don't error if a &key name isn't
a :keyword symbol. And also handle non-:keyword keyword parameters.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/09 14:42:22	1.355
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/09 23:26:23	1.356
@@ -1,5 +1,10 @@
 2010-03-09  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-arglists.lisp (arglist-ref): Don't error if a &key name isn't
+	a :keyword symbol. And also handle non-:keyword keyword parameters.
+
+2010-03-09  Stas Boukarev  <stassats at gmail.com>
+
 	* swank-presentations.lisp (inspect-presentation): Throw an error when
 	trying to access unrecorded object.
 	(lookup-presented-object-or-lose): Rename from `get-repl-result'.
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/07 14:09:51	1.58
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/09 23:26:23	1.59
@@ -1396,8 +1396,10 @@
          (let* ((argument      (nth arg-index provided-arguments))
                 (provided-keys (subseq provided-arguments positional-args#)))
            (loop for (key value) on provided-keys by #'cddr
-                 when (eq value argument) 
-                 return key)))))))
+                 when (eq value argument)
+                 return (match key
+                            (('quote symbol) symbol)
+                            (_ key)))))))))
 
 (defun arglist-ref (arglist &rest indices)
   "Returns the parameter in ARGLIST along the INDICIES path. Numbers
@@ -1416,10 +1418,14 @@
                      do (decf index args#)
                    finally (return (or rest nil)))))
          (ref-keyword-arg (arglist keyword)
-           (assert (symbolp keyword) (keyword))
-           (do-decoded-arglist arglist
-             (&key (kw arg) (when (eq kw keyword)
-                              (return-from ref-keyword-arg arg))))
+           ;; keyword argument may be any symbol,
+           ;; not only from the KEYWORD package.
+           (let ((keyword (match keyword
+                            (('quote symbol) symbol)
+                            (_ keyword))))
+             (do-decoded-arglist arglist
+               (&key (kw arg) (when (eq kw keyword)
+                                (return-from ref-keyword-arg arg)))))
            nil))
     (dolist (index indices)
       (assert (arglist-p arglist))




From sboukarev at common-lisp.net  Wed Mar 10 00:02:53 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 09 Mar 2010 19:02:53 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1Np9O1-0003m0-Jq@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
* swank-ccl.lisp (emacs-inspect function): Print closed over variables
in case of closure.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/09 14:10:37	1.2031
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/10 00:02:53	1.2032
@@ -1,5 +1,10 @@
 2010-03-09  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-ccl.lisp (emacs-inspect function): Print closed over variables
+	in case of closure.
+
+2010-03-09  Stas Boukarev  <stassats at gmail.com>
+
 	* slime.el (slime-parse-context): Add defclass.
 
 2010-03-09  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2010/03/05 17:45:34	1.18
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2010/03/10 00:02:53	1.19
@@ -628,6 +628,26 @@
                                  "Underlying UVECTOR"))))
               (t value)))))
 
+(defmethod emacs-inspect ((f function))
+  (append
+   (label-value-line "Name" (function-name f))
+   `("Its argument list is: " 
+     ,(princ-to-string (arglist f)) (:newline))
+   (label-value-line "Documentation" (documentation  f t))
+   (when (function-lambda-expression f)
+     (label-value-line "Lambda Expression"
+                       (function-lambda-expression f)))
+   (when (ccl:function-source-note f)
+     (label-value-line "Source note"
+                       (ccl:function-source-note f)))
+   (when (typep f 'ccl:compiled-lexical-closure)
+     (append
+      (label-value-line "Inner function" (ccl::closure-function f))
+      '("Closed over values:" (:newline))
+      (loop for (name value) in (ccl::closure-closed-over-values f)
+            append (label-value-line (format nil " ~a" name)
+                                     value))))))
+
 (defclass uvector-inspector ()
   ((object :initarg :object)))
 




From trittweiler at common-lisp.net  Wed Mar 10 11:30:22 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Wed, 10 Mar 2010 06:30:22 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NpK7K-0001vq-Rg@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	* swank-ecl.lisp (*original-sigint-handler*)
	(install-sigint-handler): Deleted; we directly implement
	call-with-user-break-handler instead.
	(call-with-user-break-handler): New. Correctly interrupt main
	thread instead of newly spawned handle-signal thread on SIGINT.
	(make-interrupt-handler): New helper.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/10 00:02:53	1.2032
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/10 11:30:22	1.2033
@@ -1,3 +1,12 @@
+2010-03-10  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-ecl.lisp (*original-sigint-handler*)
+	(install-sigint-handler): Deleted; we directly implement
+	call-with-user-break-handler instead.
+	(call-with-user-break-handler): New. Correctly interrupt main
+	thread instead of newly spawned handle-signal thread on SIGINT.
+	(make-interrupt-handler): New helper.
+
 2010-03-09  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-ccl.lisp (emacs-inspect function): Print closed over variables
@@ -62,7 +71,7 @@
 	it boils down to SIGNAL-INTERRUPT which uses USE-THREADS-P which
 	needs a connection.
 	(install-fd-handler): Adapted accordingly.
-	(simple-serve-event): Adapted accordingly. Additionally, remove
+	(simple-serve-requests): Adapted accordingly. Additionally, remove
 	superfluous WITH-SWANK-PROTOCOL-HANDLER as that's established by
 	WITH-CONNECTION already.
 	(simple-repl): Show "abort inferior lisp" restart only if not a
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/07 07:40:46	1.61
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/10 11:30:22	1.62
@@ -124,19 +124,33 @@
 
 ;;;; Unix Integration
 
-(defvar *original-sigint-handler* #'si:terminal-interrupt)
+;;; If ECL is built with thread support, it'll spawn a helper thread
+;;; executing the SIGINT handler. We do not want to BREAK into that
+;;; helper but into the main thread, though. This is coupled with the
+;;; current choice of NIL as communication-style in so far as ECL's
+;;; main-thread is also the Slime's REPL thread.
 
-(defimplementation install-sigint-handler (handler)
-  (declare (function handler))
-  (let ((old-handler (symbol-function 'si:terminal-interrupt)))
+(defimplementation call-with-user-break-handler (real-handler function)
+  (let ((old-handler #'si:terminal-interrupt))
     (setf (symbol-function 'si:terminal-interrupt)
-          (if (eq handler *original-sigint-handler*)
-              handler
-              (lambda (&rest args)
-                (declare (ignore args))
-                (funcall handler)
-                (continue))))
-    old-handler))
+          (make-interrupt-handler real-handler))
+    (unwind-protect (funcall function)
+      (setf (symbol-function 'si:terminal-interrupt) old-handler))))
+
+#+threads
+(defun make-interrupt-handler (real-handler)
+  (let ((main-thread (find 'si:top-level (mp:all-processes)
+                           :key #'mp:process-name)))
+    #'(lambda (&rest args)
+        (declare (ignore args))
+        (mp:interrupt-process main-thread real-handler))))
+
+#-threads
+(defun make-interrupt-handler (real-handler)
+  #'(lambda (&rest args)
+      (declare (ignore args))
+      (funcall real-handler)))
+
 
 (defimplementation getpid ()
   (si:getpid))




From trittweiler at common-lisp.net  Thu Mar 11 09:02:29 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 11 Mar 2010 04:02:29 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NpeHl-0008BB-Cl@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	* swank-ecl.lisp (source-location): Move call to
	TRANSLATE-LOGICAL-PATHNAME from here into MAKE-FILE-LOCATION
	because locations-via-annotations may now also involve logical
	pathnames.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/10 11:30:22	1.2033
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/11 09:02:29	1.2034
@@ -1,5 +1,12 @@
 2010-03-10  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank-ecl.lisp (source-location): Move call to
+	TRANSLATE-LOGICAL-PATHNAME from here into MAKE-FILE-LOCATION
+	because locations-via-annotations may now also involve logical
+	pathnames.
+
+2010-03-10  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank-ecl.lisp (*original-sigint-handler*)
 	(install-sigint-handler): Deleted; we directly implement
 	call-with-user-break-handler instead.
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/10 11:30:22	1.62
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/11 09:02:29	1.63
@@ -249,8 +249,8 @@
 (defun note-buffer-tmpfile (tmp-file buffer-name)
   ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring.
   (let ((tmp-namestring (namestring (truename tmp-file))))
-    (setf (gethash tmp-namestring *tmpfile-map*) buffer-name))
-  tmp-file)
+    (setf (gethash tmp-namestring *tmpfile-map*) buffer-name)
+    tmp-namestring))
 
 (defun tmpfile-to-buffer (tmp-file)
   (gethash tmp-file *tmpfile-map*))
@@ -497,7 +497,7 @@
   ;; 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))
+  (make-location `(:file ,(namestring (translate-logical-pathname file)))
                  `(:position ,(1+ file-position))
                  `(:align t)))
 
@@ -616,7 +616,7 @@
               (t
                (assert (probe-file file))
                (assert (not (minusp pos)))
-               (make-file-location (translate-logical-pathname file) 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.




From trittweiler at common-lisp.net  Thu Mar 11 09:05:50 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 11 Mar 2010 04:05:50 -0500
Subject: [slime-cvs] CVS slime
Message-ID: <E1NpeL0-0008FN-Oe@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (signal-interrupt): Removed.
	(interrupt-worker-thread): Slurp in definition of
	signal-interrupt. No need for invoke-or-queue-interrupt twice in
	case we do not use threads. Thus micro-prettification of
	backtraces.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/11 09:02:29	1.2034
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/11 09:05:50	1.2035
@@ -1,5 +1,13 @@
 2010-03-10  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (signal-interrupt): Removed.
+	(interrupt-worker-thread): Slurp in definition of
+	signal-interrupt. No need for invoke-or-queue-interrupt twice in
+	case we do not use threads. Thus micro-prettification of
+	backtraces.
+
+2010-03-10  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank-ecl.lisp (source-location): Move call to
 	TRANSLATE-LOGICAL-PATHNAME from here into MAKE-FILE-LOCATION
 	because locations-via-annotations may now also involve logical
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/08 11:57:04	1.698
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/11 09:05:50	1.699
@@ -1014,9 +1014,12 @@
                     (spawn (lambda ()) :name "ephemeral"))))
     (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
     (assert thread)
-    (signal-interrupt thread
-                      (lambda ()
-                        (invoke-or-queue-interrupt #'simple-break)))))
+    (cond ((use-threads-p)
+           (interrupt-thread thread
+                             (lambda ()
+                               ;; safely interrupt THREAD
+                               (invoke-or-queue-interrupt #'simple-break))))
+          (t (simple-break)))))
 
 (defun thread-for-evaluation (id)
   "Find or create a thread to evaluate the next request."
@@ -1099,15 +1102,10 @@
 (defun send-to-emacs (event)
   "Send EVENT to Emacs."
   ;;(log-event "send-to-emacs: ~a" event)
-  (cond ((use-threads-p) 
+  (cond ((use-threads-p)
          (send (connection.control-thread *emacs-connection*) event))
         (t (dispatch-event event))))
 
-(defun signal-interrupt (thread interrupt)
-  (log-event "signal-interrupt [~a]: ~a ~a~%" (use-threads-p) thread interrupt)
-  (cond ((use-threads-p) (interrupt-thread thread interrupt))
-        (t (funcall interrupt))))
-
 (defun wait-for-event (pattern &optional timeout)
   (log-event "wait-for-event: ~s ~s~%" pattern timeout)
   (without-slime-interrupts
@@ -1217,8 +1215,8 @@
   (handle-requests connection t))
 
 (defun dispatch-interrupt-event (connection)
-  ;; This boils down to SIGNAL-INTERRUPT which uses USE-THREADS-P
-  ;; which needs *EMACS-CONNECTION*.
+  ;; This boils down to INTERRUPT-WORKER-THREAD which uses
+  ;; USE-THREADS-P which needs *EMACS-CONNECTION*.
   (with-connection (connection)
     (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))
 




From sboukarev at common-lisp.net  Fri Mar 12 23:59:24 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 12 Mar 2010 18:59:24 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NqElI-00047t-Qs@common-lisp.net>

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

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
* swank-arglists.lisp (extract-local-op-arglists (eql 'labels)):
Fix (labels ((name |))).


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/09 23:26:23	1.356
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/12 23:59:24	1.357
@@ -1,3 +1,8 @@
+2010-03-12  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-arglists.lisp (extract-local-op-arglists (eql 'labels)):
+	Fix (labels ((name |))).
+
 2010-03-09  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-arglists.lisp (arglist-ref): Don't error if a &key name isn't
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/09 23:26:23	1.59
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/12 23:59:24	1.60
@@ -1293,7 +1293,7 @@
     ;; Notice that we only have information to "look backward" and
     ;; show arglists of previously occuring local functions.
     (destructuring-bind (defs . body) args
-      (unless (atom defs)                ; `(labels ,foo (|'
+      (unless (or (atom defs) (null body))   ; `(labels ,foo (|'
         (let ((current-def (car (last defs))))
           (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|'
                 ((not (null body))




From sboukarev at common-lisp.net  Sat Mar 13 03:08:04 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 12 Mar 2010 22:08:04 -0500
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NqHhs-0000Hq-I1@common-lisp.net>

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

Modified Files:
	ChangeLog slime-asdf.el 
Log Message:
* slime-asdf.el: use slime-from-lisp-filename so that slime-tramp can work.
Reported by Peter Stirling.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/12 23:59:24	1.357
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/13 03:08:04	1.358
@@ -1,3 +1,8 @@
+2010-03-13  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-asdf.el: use slime-from-lisp-filename so that slime-tramp can work.
+	Reported by Peter Stirling.
+
 2010-03-12  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-arglists.lisp (extract-local-op-arglists (eql 'labels)):
--- /project/slime/cvsroot/slime/contrib/slime-asdf.el	2010/02/15 21:42:37	1.28
+++ /project/slime/cvsroot/slime/contrib/slime-asdf.el	2010/03/13 03:08:04	1.29
@@ -66,7 +66,8 @@
 
 (defun slime-determine-asdf-system (filename buffer-package)
   "Try to determine the asdf system that `filename' belongs to."
-  (slime-eval `(swank:asdf-determine-system ,filename ,buffer-package)))
+  (slime-eval `(swank:asdf-determine-system ,(slime-to-lisp-filename filename)
+                                            ,buffer-package)))
 
 (defun slime-who-depends-on-rpc (system)
   (slime-eval `(swank:who-depends-on ,system)))
@@ -105,7 +106,8 @@
    `(swank:asdf-system-files ,name)
    (lambda (files)
      (when files
-       (let ((files (nreverse files)))
+       (let ((files (mapcar 'slime-from-lisp-filename
+                            (nreverse files))))
          (find-file-other-window (car files))
          (mapc 'find-file (cdr files)))))))
 
@@ -115,7 +117,7 @@
   (slime-eval-async `(swank:asdf-system-directory ,name)
    (lambda (directory)
      (when directory
-       (dired directory)))))
+       (dired (slime-from-lisp-filename directory))))))
 
 (if (fboundp 'rgrep)
     (defun slime-rgrep-system (sys-name regexp)
@@ -124,7 +126,8 @@
                           (list (slime-read-system-name nil nil t)
                                 (grep-read-regexp))))
       (rgrep regexp "*.lisp"
-             (slime-eval `(swank:asdf-system-directory ,sys-name))))
+             (slime-from-lisp-filename
+              (slime-eval `(swank:asdf-system-directory ,sys-name)))))
     (defun slime-rgrep-system ()
       (interactive)
       (error "This command is only supported on GNU Emacs >21.x.")))
@@ -133,7 +136,8 @@
     (defun slime-isearch-system (sys-name)
       "Run `isearch-forward' on the files of an ASDF system."
       (interactive (list (slime-read-system-name nil nil t)))
-      (let* ((files (slime-eval `(swank:asdf-system-files ,sys-name)))
+      (let* ((files (mapcar 'slime-from-lisp-filename
+                            (slime-eval `(swank:asdf-system-files ,sys-name))))
              (multi-isearch-next-buffer-function
               (lexical-let* 
                   ((buffers-forward  (mapcar #'find-file-noselect files))
@@ -172,7 +176,8 @@
       ;; `tags-query-replace' actually uses `query-replace-regexp'
       ;; internally.
       (tags-query-replace (regexp-quote from) to delimited
-                          '(slime-eval `(swank:asdf-system-files ,name)))
+                          '(mapcar 'slime-from-lisp-filename
+                            (slime-eval `(swank:asdf-system-files ,name))))
     (error
      ;; Kludge: `tags-query-replace' does not actually return but
      ;; signals an unnamed error with the below error
@@ -222,7 +227,7 @@
       `(swank:asdf-system-files ,system)
     (lambda (files)
       (dolist (file files)
-        (let ((buffer (get-file-buffer file)))
+        (let ((buffer (get-file-buffer (slime-from-lisp-filename file))))
           (when buffer
             (with-current-buffer buffer
               (save-buffer buffer)))))




From trittweiler at common-lisp.net  Tue Mar 16 16:20:08 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 16 Mar 2010 12:20:08 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NrZV2-00051H-9W@common-lisp.net>

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

Modified Files:
	ChangeLog swank-ecl.lisp 
Log Message:
	* swank-ecl.lisp (source-location): Also return EXT::FOO as
	candidate to search through the TAGS file because SI and EXT both
	name the same package, and in ECL's code base, sometimes the
	former, sometimes the latter is used.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/11 09:05:50	1.2035
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/16 16:20:07	1.2036
@@ -1,3 +1,10 @@
+2010-03-16  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank-ecl.lisp (source-location): Also return EXT::FOO as
+	candidate to search through the TAGS file because SI and EXT both
+	name the same package, and in ECL's code base, sometimes the
+	former, sometimes the latter is used.
+
 2010-03-10  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (signal-interrupt): Removed.
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/11 09:02:29	1.63
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/16 16:20:08	1.64
@@ -178,7 +178,7 @@
            (fd-stream-alist
             (loop for s in streams
                   for fd = (socket-fd s)
-                  collect (cons (socket-fd s) s)
+                  collect (cons fd s)
                   do (serve-event:add-fd-handler fd :input
                                                  #'(lambda (fd)
                                                      (push fd active-fds))))))
@@ -589,6 +589,9 @@
     (error "No TAGS file ~A found. It should have been installed with ECL."
            +TAGS+)))
 
+(defun package-names (package)
+  (cons (package-name package) (package-nicknames package)))
+
 (defun source-location (object)
   (converting-errors-to-error-location
    (typecase object
@@ -600,13 +603,15 @@
         (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  ((package (package-name (symbol-package lisp-name)))
-                 (symbol  (symbol-name lisp-name)))
-            (make-TAGS-location c-name
-                                (format nil "~A::~A" package symbol)
-                                (format nil "~(~A::~A~)" package symbol))))))
+          ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or
+          ;; @EXT::SYMBOL is used. We cannot predict here, so we just
+          ;; provide several candidates.
+          (apply #'make-TAGS-location
+                 c-name
+                 (loop with s = (symbol-name lisp-name)
+                       for p in (package-names (symbol-package lisp-name))
+                       collect (format nil "~A::~A" p s)
+                       collect (format nil "~(~A::~A~)" p s))))))
      (function
       (multiple-value-bind (file pos) (ext:compiled-function-file object)
         (cond ((not file)




From trittweiler at common-lisp.net  Thu Mar 18 11:52:34 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 18 Mar 2010 07:52:34 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NsEHC-000799-NR@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (connection): Add socket slot, make slot-io slot not
	be required to be filled in during object creation. Add
	inferior-lisp slot so we can know whether a connection belongs to
	a superior Emacs process. Need for that will come in following
	commit.
	(make-connection): Our constructor.
	(create-connection): Removed; not needed anymore.
	(finish-connection-setup): Function to fill socket-io slot.
	(start-server): Results in inferior-lisp slot being T.
	(create-server): Results in inferior-lisp slot being NIL.
	(setup-server): Adapted accordingly. Construct connection early so
	we do not have to pass down all the meta information explicitly.
	(serve-connection): Adapted accordingly.
	(accept-authenticated-client): Renamed from
	accept-authenticated-connection.
	(dispatch-event): Get rid of unused :%apply and :end-of-stream
	events.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/16 16:20:07	1.2036
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/18 11:52:34	1.2037
@@ -1,3 +1,23 @@
+2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp (connection): Add socket slot, make slot-io slot not
+	be required to be filled in during object creation. Add
+	inferior-lisp slot so we can know whether a connection belongs to
+	a superior Emacs process. Need for that will come in following
+	commit.
+	(make-connection): Our constructor.
+	(create-connection): Removed; not needed anymore.
+	(finish-connection-setup): Function to fill socket-io slot.
+	(start-server): Results in inferior-lisp slot being T.
+	(create-server): Results in inferior-lisp slot being NIL.
+	(setup-server): Adapted accordingly. Construct connection early so
+	we do not have to pass down all the meta information explicitly.
+	(serve-connection): Adapted accordingly.
+	(accept-authenticated-client): Renamed from
+	accept-authenticated-connection.
+	(dispatch-event): Get rid of unused :%apply and :end-of-stream
+	events.
+
 2010-03-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-ecl.lisp (source-location): Also return EXT::FOO as
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/11 09:05:50	1.699
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/18 11:52:34	1.700
@@ -246,10 +246,12 @@
 ;;; freed/closed/killed when we disconnect.
 
 (defstruct (connection
+             (:constructor %make-connection)
              (:conc-name connection.)
              (:print-function print-connection))
+  (socket           (missing-arg) :type t :read-only t)
   ;; Raw I/O stream of socket connection.
-  (socket-io        (missing-arg) :type stream :read-only t)
+  (socket-io        nil :type (or stream null))
   ;; Optional dedicated output socket (backending `user-output' slot).
   ;; Has a slot so that it can be closed with the connection.
   (dedicated-output nil :type (or stream null))
@@ -293,10 +295,36 @@
   (communication-style nil :type (member nil :spawn :sigio :fd-handler))
   ;; The coding system for network streams.
   coding-system
+  ;; True if the connection belongs to a superior Emacs process.
+  inferior-lisp
   ;; The SIGINT handler we should restore when the connection is
   ;; closed.
   saved-sigint-handler)
 
+(defun make-connection (socket style coding-system inferiorp)
+  (multiple-value-bind (serve cleanup)
+      (ecase style
+        (:spawn
+         (values #'spawn-threads-for-connection #'cleanup-connection-threads))
+        (:sigio
+         (values #'install-sigio-handler #'deinstall-sigio-handler))
+        (:fd-handler
+         (values #'install-fd-handler #'deinstall-fd-handler))
+        ((nil)
+         (values #'simple-serve-requests nil)))
+    (%make-connection :socket socket
+                      :communication-style style
+                      :coding-system coding-system
+                      :inferior-lisp inferiorp
+                      :serve-requests serve
+                      :cleanup cleanup)))
+
+(defun finish-connection-setup (connection socket-io)
+  (setf (connection.socket-io connection) socket-io)
+  (run-hook *new-connection-hook* connection)
+  (push connection *connections*)
+  connection)
+
 (defun print-connection (conn stream depth)
   (declare (ignore depth))
   (print-unreadable-object (conn stream :type t :identity t)))
@@ -643,7 +671,7 @@
 This is the entry point for Emacs."
   (setup-server 0
                 (lambda (port) (announce-server-port port-file port))
-                style dont-close coding-system))
+                style dont-close coding-system t))
 
 (defun create-server (&key (port default-server-port)
                       (style *communication-style*)
@@ -653,7 +681,7 @@
 If DONT-CLOSE is true then the listen socket will accept multiple
 connections, otherwise it will be closed after the first."
   (setup-server port #'simple-announce-function
-                style dont-close coding-system))
+                style dont-close coding-system nil))
 
 (defun find-external-format-or-lose (coding-system)
   (or (find-external-format coding-system)
@@ -661,18 +689,16 @@
 
 (defparameter *loopback-interface* "127.0.0.1")
 
-(defun setup-server (port announce-fn style dont-close coding-system)
+(defun setup-server (port announce-fn style dont-close coding-system inferiorp)
   (declare (type function announce-fn))
   (init-log-output)
   (let* ((external-format (find-external-format-or-lose coding-system))
          (socket (create-socket *loopback-interface* port))
-         (local-port (local-port socket)))
+         (local-port (local-port socket))
+         (connection (make-connection socket style coding-system inferiorp)))
     (funcall announce-fn local-port)
     (flet ((serve ()
-             ;; We pass down the coding-system so we can put it into a
-             ;; CONNECTION for debugging purposes.
-             (serve-connection socket style dont-close
-                               external-format coding-system)))
+             (serve-connection connection external-format dont-close)))
       (ecase style
         (:spawn
          (initialize-multiprocessing
@@ -723,22 +749,20 @@
                  :coding-system coding-system))
 
 
-(defun serve-connection (socket style dont-close external-format coding-system)
-  (let ((closed-socket-p nil))
+(defun serve-connection (connection external-format dont-close)
+  (let ((closed-socket-p nil)
+        (socket (connection.socket connection)))
     (unwind-protect
-         (let ((client (accept-authenticated-connection
-                        socket :external-format external-format)))
+         (let ((client (accept-authenticated-client socket
+                        :external-format external-format)))
            (unless dont-close
              (close-socket socket)
              (setf closed-socket-p t))
-           (let ((connection (create-connection client style coding-system)))
-             (run-hook *new-connection-hook* connection)
-             (push connection *connections*)
-             (serve-requests connection)))
+           (serve-requests (finish-connection-setup connection client)))
       (unless (or dont-close closed-socket-p)
         (close-socket socket)))))
 
-(defun accept-authenticated-connection (&rest args)
+(defun accept-authenticated-client (&rest args)
   (let ((new (apply #'accept-connection args))
         (success nil))
     (unwind-protect
@@ -1068,10 +1092,10 @@
      (encode-message `(:return , at args) (current-socket-io)))
     ((:emacs-interrupt thread-id)
      (interrupt-worker-thread thread-id))
-    (((:write-string 
+    (((:write-string
        :debug :debug-condition :debug-activate :debug-return :channel-send
        :presentation-start :presentation-end
-       :new-package :new-features :ed :%apply :indentation-update
+       :new-package :new-features :ed :indentation-update
        :eval :eval-no-wait :background-message :inspect :ping
        :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
       &rest _)
@@ -1082,8 +1106,6 @@
     ((:emacs-channel-send channel-id msg)
      (let ((ch (find-channel channel-id)))
        (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
-    (((:end-of-stream))
-     (close-connection *emacs-connection* nil (safe-backtrace)))
     ((:reader-error packet condition)
      (encode-message `(:reader-error ,packet 
                                      ,(safe-condition-message condition))
@@ -1301,34 +1323,6 @@
     (loop (let ((c (read-char-no-hang stream)))
             (unless c (return))
             (write-char c str)))))
-
-(defun create-connection (socket-io style coding-system)
-  (let ((success nil))
-    (unwind-protect
-         (let ((c (ecase style
-                    (:spawn
-                     (make-connection :socket-io socket-io
-                                      :serve-requests #'spawn-threads-for-connection
-                                      :cleanup #'cleanup-connection-threads))
-                    (:sigio
-                     (make-connection :socket-io socket-io
-                                      :serve-requests #'install-sigio-handler
-                                      :cleanup #'deinstall-sigio-handler))
-                    (:fd-handler
-                     (make-connection :socket-io socket-io
-                                      :serve-requests #'install-fd-handler
-                                      :cleanup #'deinstall-fd-handler))
-                    ((nil)
-                     (make-connection :socket-io socket-io
-                                      :serve-requests #'simple-serve-requests))
-                    )))
-           (setf (connection.communication-style c) style)
-           (setf (connection.coding-system c) coding-system)
-           (setf success t)
-           c)
-      (unless success
-        (close socket-io :abort t)))))
-
 
 ;;;; IO to Emacs
 ;;;




From trittweiler at common-lisp.net  Thu Mar 18 12:29:08 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 18 Mar 2010 08:29:08 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NsEqa-0006Bv-1R@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank-backend.lisp swank-ecl.lisp 
	swank.lisp 
Log Message:
	Add an ATTACH-GDB restart to SLDB.

	* swank.lisp (call-with-gdb-restart): New. Sends the new :gdb-attach event to Emacs.
	(with-gdb-restart): Sugar.
	(with-top-level-restart): Also expand to with-gdb-restart.
	(dispatch-event): Add :gdb-attach event.

	* swank-backend.lisp (gdb-initial-commands): New interface
	function so backends can customize how gdb needs to be configured
	for their implementation.

	* swank-ecl.lisp (gdb-initial-commands): Implement.

	* slime.el (slime-dispatch-event): Add clause for :gdb-attach.
	(slime-attach-gdb): New.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/18 11:52:34	1.2037
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/18 12:29:07	1.2038
@@ -1,7 +1,25 @@
 2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
 
-	* swank.lisp (connection): Add socket slot, make slot-io slot not
-	be required to be filled in during object creation. Add
+	Add an ATTACH-GDB restart to SLDB.
+
+	* swank.lisp (call-with-gdb-restart): New. Sends the new :gdb-attach event to Emacs.
+	(with-gdb-restart): Sugar.
+	(with-top-level-restart): Also expand to with-gdb-restart.
+	(dispatch-event): Add :gdb-attach event.
+
+	* swank-backend.lisp (gdb-initial-commands): New interface
+	function so backends can customize how gdb needs to be configured
+	for their implementation.
+
+	* swank-ecl.lisp (gdb-initial-commands): Implement.
+
+	* slime.el (slime-dispatch-event): Add clause for :gdb-attach.
+	(slime-attach-gdb): New.
+
+2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp (connection): Add socket slot, make socket-io slot
+	not be required to be filled in during object creation. Add
 	inferior-lisp slot so we can know whether a connection belongs to
 	a superior Emacs process. Need for that will come in following
 	commit.
--- /project/slime/cvsroot/slime/slime.el	2010/03/09 14:10:37	1.1285
+++ /project/slime/cvsroot/slime/slime.el	2010/03/18 12:29:07	1.1286
@@ -2277,6 +2277,9 @@
           ((:debug-condition thread message)
            (assert thread)
            (message "%s" message))
+          ((:gdb-attach pid gdb-cmds)
+           (message "Attaching gdb to pid %d..." pid)
+           (slime-attach-gdb pid gdb-cmds))
           ((:ping thread tag)
            (slime-send `(:emacs-pong ,thread ,tag)))
           ((:reader-error packet condition)
@@ -2290,6 +2293,19 @@
                  (remove* id (slime-rex-continuations) :key #'car))
            (error "Invalid rpc: %s" message))))))
 
+(defun slime-attach-gdb (pid commands)
+  (gud-gdb (format "gdb -p %d" pid))
+  (with-current-buffer gud-comint-buffer
+    (dolist (cmd commands)
+      ;; First wait until gdb was initialized, then wait until current
+      ;; command was processed.
+      (while (not (looking-back comint-prompt-regexp))
+        (sit-for 0.01))
+      ;; We do not use `gud-call' because we want the initial commands
+      ;; to be displayed by the user so he knows what he's got.
+      (insert cmd)
+      (comint-send-input))))
+
 (defun slime-send (sexp)
   "Send SEXP directly over the wire on the current connection."
   (slime-net-send sexp (slime-connection)))
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/03/02 12:38:06	1.196
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/03/18 12:29:07	1.197
@@ -789,6 +789,11 @@
   (declare (ignore condition))
   '())
 
+(definterface gdb-initial-commands ()
+  "List of gdb commands supposed to be executed first for the
+   ATTACH-GDB restart."
+  nil)
+
 (definterface activate-stepping (frame-number)
   "Prepare the frame FRAME-NUMBER for stepping.")
 
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/16 16:20:08	1.64
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/18 12:29:07	1.65
@@ -481,6 +481,11 @@
   (let ((env (second (elt *backtrace* frame-number))))
     (si:eval-with-env form env)))
 
+(defimplementation gdb-initial-commands ()
+  ;; These signals are used by the GC.
+  #+linux '("handle SIGPWR  noprint nostop"
+            "handle SIGXCPU noprint nostop"))
+
 
 ;;;; Inspector
 
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/18 11:52:34	1.700
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/18 12:29:07	1.701
@@ -471,6 +471,30 @@
   (check-type msg string)
   `(call-with-retry-restart ,msg #'(lambda () , at body)))
 
+(defun call-with-gdb-restart (pid thunk)
+  (let ((process (format nil "~A-~A (pid ~D)"
+                         (lisp-implementation-type)
+                         (lisp-implementation-version)
+                         pid)))
+    (restart-bind
+        ((attach-gdb
+          #'(lambda ()
+              (send-to-emacs `(:gdb-attach ,pid ,(gdb-initial-commands)))
+              (format nil "GDB attached to ~A" process))
+           :report-function #'(lambda (s)
+                                (format s "Attach GDB to ~A" process))
+           :test-function   #'(lambda (c)
+                                (declare (ignore c))
+                                ;; Do not show this restart if
+                                ;; we're connected remotely.
+                                (connection.inferior-lisp
+                                 *emacs-connection*)
+                                t)))
+      (funcall thunk))))
+
+(defmacro with-gdb-restart (() &body body)
+  `(call-with-gdb-restart (getpid) #'(lambda () , at body)))
+
 (defmacro with-struct* ((conc-name get obj) &body body)
   (let ((var (gensym)))
     `(let ((,var ,obj))
@@ -896,19 +920,20 @@
 ;; Execute K if the restart is invoked.
 (defmacro with-top-level-restart ((connection k) &body body)
   `(with-connection (,connection)
-     (restart-case
-         ;; We explicitly rebind (and do not look at user's
-         ;; customization), so sldb-quit will always be our restart
-         ;; for rex requests.
-         (let ((*sldb-quit-restart* (find-restart 'abort))
-               (*toplevel-restart-available* t))
-           (declare (special *toplevel-restart-available*))
-           , at body)
-       (abort (&optional v)
-         :report "Return to SLIME's top level."
-         (declare (ignore v))
-         (force-user-output)
-         ,k))))
+     (with-gdb-restart ()
+       (restart-case
+           ;; We explicitly rebind (and do not look at user's
+           ;; customization), so sldb-quit will always be our restart
+           ;; for rex requests.
+           (let ((*sldb-quit-restart* (find-restart 'abort))
+                 (*toplevel-restart-available* t))
+             (declare (special *toplevel-restart-available*))
+             , at body)
+         (abort (&optional v)
+           :report "Return to SLIME's top level."
+           (declare (ignore v))
+           (force-user-output)
+           ,k)))))
 
 (defun top-level-restart-p ()
   ;; FIXME: this could probably be done better; previously this used
@@ -1094,6 +1119,7 @@
      (interrupt-worker-thread thread-id))
     (((:write-string
        :debug :debug-condition :debug-activate :debug-return :channel-send
+       :gdb-attach
        :presentation-start :presentation-end
        :new-package :new-features :ed :indentation-update
        :eval :eval-no-wait :background-message :inspect :ping




From trittweiler at common-lisp.net  Thu Mar 18 12:30:35 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 18 Mar 2010 08:30:35 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NsErz-0006a8-M2@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (open-dedicated-output-stream): Forgot to rename
	accept-authenticated-connection to accept-authenticated-client
	here.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/18 12:29:07	1.2038
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/18 12:30:35	1.2039
@@ -1,5 +1,11 @@
 2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (open-dedicated-output-stream): Forgot to rename
+	accept-authenticated-connection to accept-authenticated-client
+	here.
+
+2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
+
 	Add an ATTACH-GDB restart to SLDB.
 
 	* swank.lisp (call-with-gdb-restart): New. Sends the new :gdb-attach event to Emacs.
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/18 12:29:07	1.701
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/18 12:30:35	1.702
@@ -897,7 +897,7 @@
     (unwind-protect
          (let ((port (local-port socket)))
            (encode-message `(:open-dedicated-output-stream ,port) socket-io)
-           (let ((dedicated (accept-authenticated-connection 
+           (let ((dedicated (accept-authenticated-client
                              socket 
                              :external-format 
                              (or (ignore-errors




From trittweiler at common-lisp.net  Thu Mar 18 12:37:34 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 18 Mar 2010 08:37:34 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NsEyk-0006u9-4f@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (call-with-gdb-restart): Forgot to remove trailing T.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/18 12:30:35	1.2039
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/18 12:37:34	1.2040
@@ -1,5 +1,9 @@
 2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (call-with-gdb-restart): Forgot to remove trailing T.
+
+2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (open-dedicated-output-stream): Forgot to rename
 	accept-authenticated-connection to accept-authenticated-client
 	here.
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/18 12:30:35	1.702
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/18 12:37:34	1.703
@@ -488,8 +488,7 @@
                                 ;; Do not show this restart if
                                 ;; we're connected remotely.
                                 (connection.inferior-lisp
-                                 *emacs-connection*)
-                                t)))
+                                 *emacs-connection*))))
       (funcall thunk))))
 
 (defmacro with-gdb-restart (() &body body)




From trittweiler at common-lisp.net  Thu Mar 18 15:59:57 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 18 Mar 2010 11:59:57 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NsI8b-00059h-Va@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
	Add M-x slime-attach-gdb as an interactive function.

	The ATTACH-GDB restart is nice because it's convenient and the
	backends can specify customized gdb configuration.

	Sometimes, if the Lisp is too screwed up, going over a restart
	involving the SWANK middle layer may not be possible. For that, a
	manual M-x slime-attach-gdb may come in handy.

	* slime.el (slime-read-connection): New helper.
	(slime-attach-gdb): Use it. Make it an interactive function.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/18 12:37:34	1.2040
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/18 15:59:57	1.2041
@@ -1,5 +1,19 @@
 2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
 
+	Add M-x slime-attach-gdb as an interactive function.
+
+	The ATTACH-GDB restart is nice because it's convenient and the
+	backends can specify customized gdb configuration.
+
+	Sometimes, if the Lisp is too screwed up, going over a restart
+	involving the SWANK middle layer may not be possible. For that, a
+	manual M-x slime-attach-gdb may come in handy.
+
+	* slime.el (slime-read-connection): New helper.
+	(slime-attach-gdb): Use it. Make it an interactive function.
+
+2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (call-with-gdb-restart): Forgot to remove trailing T.
 
 2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
--- /project/slime/cvsroot/slime/slime.el	2010/03/18 12:29:07	1.1286
+++ /project/slime/cvsroot/slime/slime.el	2010/03/18 15:59:57	1.1287
@@ -764,6 +764,19 @@
                               `(swank:list-all-package-names t)))
 		     nil t initial-value)))
 
+(defun slime-read-connection (prompt &optional initial-value)
+  "Read a connection from the minibuffer. Returns the net
+process, or nil."
+  (assert (memq initial-value slime-net-processes))
+  (flet ((connection-identifier (p)
+           (format "%s (pid %d)" (slime-connection-name p) (slime-pid p))))
+    (let ((candidates (mapcar #'(lambda (p)
+                                  (cons (connection-identifier p) p))
+                              slime-net-processes)))
+      (cdr (assoc (completing-read prompt candidates 
+                                   nil t (connection-identifier initial-value))
+                  candidates)))))
+
 ;; Interface
 (defun slime-read-symbol-name (prompt &optional query)
   "Either read a symbol name or choose the one at point.
@@ -2293,7 +2306,11 @@
                  (remove* id (slime-rex-continuations) :key #'car))
            (error "Invalid rpc: %s" message))))))
 
-(defun slime-attach-gdb (pid commands)
+(defun slime-attach-gdb (pid &optional commands)
+  "Run `gud-gdb'on the connection with PID `pid'."
+  (interactive 
+   (list (slime-pid (slime-read-connection "Attach gdb to: "
+                                           (slime-connection)))))
   (gud-gdb (format "gdb -p %d" pid))
   (with-current-buffer gud-comint-buffer
     (dolist (cmd commands)




From trittweiler at common-lisp.net  Thu Mar 18 18:24:25 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Thu, 18 Mar 2010 14:24:25 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NsKOP-0003X5-UW@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
	Remove attach-gdb restart. Instead add SLDB shortcut `A'.

	* slime.el (slime-dispatch-event): Remove :gdb-attach.
	(slime-attach-gdb): Changed API. Takes connection not pid now and
	lightweight &optional arg. If not lightweight, get the default gdb
	config from the inferior Lisp.
	(sldb-break-with-system-debugger): New command, bound to `A' in
	sldb. Called this way to mimick
	`sldb-break-with-default-debugger', and because it may make sense
	to go beyond gdb in future, e.g. to invoke the Java Debugger for
	ABCL.

	* swank.lisp (call-with-gdb-restart, with-gdb-restart): Removed.
	(with-top-level-restart): Remove use of with-gdb-restart.
	(make-connection, start-server, create-server, setup-server):
	Remove inferior-lisp flag again. Not needed anymore.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/18 15:59:57	1.2041
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/18 18:24:25	1.2042
@@ -1,5 +1,24 @@
 2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
 
+	Remove attach-gdb restart. Instead add SLDB shortcut `A'.
+
+	* slime.el (slime-dispatch-event): Remove :gdb-attach.
+	(slime-attach-gdb): Changed API. Takes connection not pid now and
+	lightweight &optional arg. If not lightweight, get the default gdb
+	config from the inferior Lisp.
+	(sldb-break-with-system-debugger): New command, bound to `A' in
+	sldb. Called this way to mimick
+	`sldb-break-with-default-debugger', and because it may make sense
+	to go beyond gdb in future, e.g. to invoke the Java Debugger for
+	ABCL.
+
+	* swank.lisp (call-with-gdb-restart, with-gdb-restart): Removed.
+	(with-top-level-restart): Remove use of with-gdb-restart.
+	(make-connection, start-server, create-server, setup-server):
+	Remove inferior-lisp flag again. Not needed anymore.
+
+2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
+
 	Add M-x slime-attach-gdb as an interactive function.
 
 	The ATTACH-GDB restart is nice because it's convenient and the
--- /project/slime/cvsroot/slime/slime.el	2010/03/18 15:59:57	1.1287
+++ /project/slime/cvsroot/slime/slime.el	2010/03/18 18:24:25	1.1288
@@ -2290,9 +2290,6 @@
           ((:debug-condition thread message)
            (assert thread)
            (message "%s" message))
-          ((:gdb-attach pid gdb-cmds)
-           (message "Attaching gdb to pid %d..." pid)
-           (slime-attach-gdb pid gdb-cmds))
           ((:ping thread tag)
            (slime-send `(:emacs-pong ,thread ,tag)))
           ((:reader-error packet condition)
@@ -2306,23 +2303,6 @@
                  (remove* id (slime-rex-continuations) :key #'car))
            (error "Invalid rpc: %s" message))))))
 
-(defun slime-attach-gdb (pid &optional commands)
-  "Run `gud-gdb'on the connection with PID `pid'."
-  (interactive 
-   (list (slime-pid (slime-read-connection "Attach gdb to: "
-                                           (slime-connection)))))
-  (gud-gdb (format "gdb -p %d" pid))
-  (with-current-buffer gud-comint-buffer
-    (dolist (cmd commands)
-      ;; First wait until gdb was initialized, then wait until current
-      ;; command was processed.
-      (while (not (looking-back comint-prompt-regexp))
-        (sit-for 0.01))
-      ;; We do not use `gud-call' because we want the initial commands
-      ;; to be displayed by the user so he knows what he's got.
-      (insert cmd)
-      (comint-send-input))))
-
 (defun slime-send (sexp)
   "Send SEXP directly over the wire on the current connection."
   (slime-net-send sexp (slime-connection)))
@@ -5400,6 +5380,7 @@
   ("b"    'sldb-break-on-return)
   ("a"    'sldb-abort)
   ("q"    'sldb-quit)
+  ("A"    'sldb-break-with-system-debugger)
   ("B"    'sldb-break-with-default-debugger)
   ("P"    'sldb-print-condition)
   ("C"    'sldb-inspect-condition)
@@ -6093,6 +6074,37 @@
        nil slime-current-thread)
     ((:abort))))
 
+(defun sldb-break-with-system-debugger (&optional lightweight)
+  "Enter system debugger (gdb)."
+  (interactive "P")
+  (slime-attach-gdb slime-buffer-connection lightweight))
+
+(defun slime-attach-gdb (connection &optional lightweight)
+  "Run `gud-gdb'on the connection with PID `pid'. 
+
+If `lightweight' is given, do not send any request to the
+inferior Lisp (e.g. to obtain default gdb config) but only
+operate from the Emacs side; intended for cases where the Lisp is
+truly screwed up."
+  (interactive
+   (list (slime-read-connection "Attach gdb to: " (slime-connection)) "P"))
+  (let ((pid (slime-pid connection))
+        (commands (unless lightweight
+                    (let ((slime-dispatching-connection connection))
+                      (slime-eval `(swank:gdb-initial-commands))))))
+    (gud-gdb (format "gdb -p %d" pid))
+    (with-current-buffer gud-comint-buffer
+      (dolist (cmd commands)
+        ;; First wait until gdb was initialized, then wait until current
+        ;; command was processed.
+        (while (not (looking-back comint-prompt-regexp))
+          (sit-for 0.01))
+        ;; We do not use `gud-call' because we want the initial commands
+        ;; to be displayed by the user so he knows what he's got.
+        (insert cmd)
+        (comint-send-input)))))
+
+
 (defun sldb-step ()
   "Step to next basic-block boundary."
   (interactive)
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/18 12:37:34	1.703
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/18 18:24:25	1.704
@@ -51,6 +51,7 @@
            ;; These are re-exported directly from the backend:
            #:buffer-first-change
            #:frame-source-location
+           #:gdb-initial-commands
            #:restart-frame
            #:sldb-step 
            #:sldb-break
@@ -295,13 +296,11 @@
   (communication-style nil :type (member nil :spawn :sigio :fd-handler))
   ;; The coding system for network streams.
   coding-system
-  ;; True if the connection belongs to a superior Emacs process.
-  inferior-lisp
   ;; The SIGINT handler we should restore when the connection is
   ;; closed.
   saved-sigint-handler)
 
-(defun make-connection (socket style coding-system inferiorp)
+(defun make-connection (socket style coding-system)
   (multiple-value-bind (serve cleanup)
       (ecase style
         (:spawn
@@ -315,7 +314,6 @@
     (%make-connection :socket socket
                       :communication-style style
                       :coding-system coding-system
-                      :inferior-lisp inferiorp
                       :serve-requests serve
                       :cleanup cleanup)))
 
@@ -471,29 +469,6 @@
   (check-type msg string)
   `(call-with-retry-restart ,msg #'(lambda () , at body)))
 
-(defun call-with-gdb-restart (pid thunk)
-  (let ((process (format nil "~A-~A (pid ~D)"
-                         (lisp-implementation-type)
-                         (lisp-implementation-version)
-                         pid)))
-    (restart-bind
-        ((attach-gdb
-          #'(lambda ()
-              (send-to-emacs `(:gdb-attach ,pid ,(gdb-initial-commands)))
-              (format nil "GDB attached to ~A" process))
-           :report-function #'(lambda (s)
-                                (format s "Attach GDB to ~A" process))
-           :test-function   #'(lambda (c)
-                                (declare (ignore c))
-                                ;; Do not show this restart if
-                                ;; we're connected remotely.
-                                (connection.inferior-lisp
-                                 *emacs-connection*))))
-      (funcall thunk))))
-
-(defmacro with-gdb-restart (() &body body)
-  `(call-with-gdb-restart (getpid) #'(lambda () , at body)))
-
 (defmacro with-struct* ((conc-name get obj) &body body)
   (let ((var (gensym)))
     `(let ((,var ,obj))
@@ -694,7 +669,7 @@
 This is the entry point for Emacs."
   (setup-server 0
                 (lambda (port) (announce-server-port port-file port))
-                style dont-close coding-system t))
+                style dont-close coding-system))
 
 (defun create-server (&key (port default-server-port)
                       (style *communication-style*)
@@ -704,7 +679,7 @@
 If DONT-CLOSE is true then the listen socket will accept multiple
 connections, otherwise it will be closed after the first."
   (setup-server port #'simple-announce-function
-                style dont-close coding-system nil))
+                style dont-close coding-system))
 
 (defun find-external-format-or-lose (coding-system)
   (or (find-external-format coding-system)
@@ -712,13 +687,13 @@
 
 (defparameter *loopback-interface* "127.0.0.1")
 
-(defun setup-server (port announce-fn style dont-close coding-system inferiorp)
+(defun setup-server (port announce-fn style dont-close coding-system)
   (declare (type function announce-fn))
   (init-log-output)
   (let* ((external-format (find-external-format-or-lose coding-system))
          (socket (create-socket *loopback-interface* port))
          (local-port (local-port socket))
-         (connection (make-connection socket style coding-system inferiorp)))
+         (connection (make-connection socket style coding-system)))
     (funcall announce-fn local-port)
     (flet ((serve ()
              (serve-connection connection external-format dont-close)))
@@ -919,20 +894,19 @@
 ;; Execute K if the restart is invoked.
 (defmacro with-top-level-restart ((connection k) &body body)
   `(with-connection (,connection)
-     (with-gdb-restart ()
-       (restart-case
-           ;; We explicitly rebind (and do not look at user's
-           ;; customization), so sldb-quit will always be our restart
-           ;; for rex requests.
-           (let ((*sldb-quit-restart* (find-restart 'abort))
-                 (*toplevel-restart-available* t))
-             (declare (special *toplevel-restart-available*))
-             , at body)
-         (abort (&optional v)
-           :report "Return to SLIME's top level."
-           (declare (ignore v))
-           (force-user-output)
-           ,k)))))
+     (restart-case
+         ;; We explicitly rebind (and do not look at user's
+         ;; customization), so sldb-quit will always be our restart
+         ;; for rex requests.
+         (let ((*sldb-quit-restart* (find-restart 'abort))
+               (*toplevel-restart-available* t))
+           (declare (special *toplevel-restart-available*))
+           , at body)
+       (abort (&optional v)
+         :report "Return to SLIME's top level."
+         (declare (ignore v))
+         (force-user-output)
+         ,k))))
 
 (defun top-level-restart-p ()
   ;; FIXME: this could probably be done better; previously this used
@@ -1118,7 +1092,6 @@
      (interrupt-worker-thread thread-id))
     (((:write-string
        :debug :debug-condition :debug-activate :debug-return :channel-send
-       :gdb-attach
        :presentation-start :presentation-end
        :new-package :new-features :ed :indentation-update
        :eval :eval-no-wait :background-message :inspect :ping




From trittweiler at common-lisp.net  Fri Mar 19 12:32:31 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Fri, 19 Mar 2010 08:32:31 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NsbNP-0002Nj-06@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el swank-backend.lisp swank-ecl.lisp 
	swank.lisp 
Log Message:
	* slime.el (slime-lisp-implementation-program): New connection
	variable.
	(slime-set-connection-info): Adapted to set it.
	(slime-attach-gdb): Use it to invoke gdb so gdb is able to find
	debugging symbols on non-Linux platforms.

	* swank.lisp (connection-info): Include lisp-implementation-program.

	* swank-backend.lisp (lisp-implementation-program): New interface.
	Default implementation based on command-line-args.

	* swank-ecl.lisp (command-line-args): Implement.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/18 18:24:25	1.2042
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/19 12:32:30	1.2043
@@ -1,3 +1,18 @@
+2010-03-19  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* slime.el (slime-lisp-implementation-program): New connection
+	variable.
+	(slime-set-connection-info): Adapted to set it.
+	(slime-attach-gdb): Use it to invoke gdb so gdb is able to find
+	debugging symbols on non-Linux platforms.
+
+	* swank.lisp (connection-info): Include lisp-implementation-program.
+
+	* swank-backend.lisp (lisp-implementation-program): New interface.
+	Default implementation based on command-line-args.
+
+	* swank-ecl.lisp (command-line-args): Implement.
+
 2010-03-18  Tobias C. Rittweiler <tcr at freebits.de>
 
 	Remove attach-gdb restart. Instead add SLDB shortcut `A'.
@@ -45,7 +60,8 @@
 
 	Add an ATTACH-GDB restart to SLDB.
 
-	* swank.lisp (call-with-gdb-restart): New. Sends the new :gdb-attach event to Emacs.
+	* swank.lisp (call-with-gdb-restart): New. Sends the new
+	:gdb-attach event to Emacs.
 	(with-gdb-restart): Sugar.
 	(with-top-level-restart): Also expand to with-gdb-restart.
 	(dispatch-event): Add :gdb-attach event.
--- /project/slime/cvsroot/slime/slime.el	2010/03/18 18:24:25	1.1288
+++ /project/slime/cvsroot/slime/slime.el	2010/03/19 12:32:30	1.1289
@@ -1838,6 +1838,9 @@
 (slime-def-connection-var slime-lisp-implementation-name nil
   "The short name for the Lisp implementation.")
 
+(slime-def-connection-var slime-lisp-implementation-program nil
+  "The argv[0] of the process running the Lisp implementation.")
+
 (slime-def-connection-var slime-connection-name nil
   "The short name for connection.")
 
@@ -1892,10 +1895,11 @@
             (slime-communication-style) style
             (slime-lisp-features) features
             (slime-lisp-modules) modules)
-      (destructuring-bind (&key type name version) lisp-implementation
+      (destructuring-bind (&key type name version program) lisp-implementation
         (setf (slime-lisp-implementation-type) type
               (slime-lisp-implementation-version) version
               (slime-lisp-implementation-name) name
+              (slime-lisp-implementation-program) program
               (slime-connection-name) (slime-generate-connection-name name)))
       (destructuring-bind (&key instance type version) machine
         (setf (slime-machine-instance) instance)))
@@ -6088,11 +6092,12 @@
 truly screwed up."
   (interactive
    (list (slime-read-connection "Attach gdb to: " (slime-connection)) "P"))
-  (let ((pid (slime-pid connection))
+  (let ((pid  (slime-pid connection))
+        (file (slime-lisp-implementation-program connection))
         (commands (unless lightweight
                     (let ((slime-dispatching-connection connection))
                       (slime-eval `(swank:gdb-initial-commands))))))
-    (gud-gdb (format "gdb -p %d" pid))
+    (gud-gdb (format "gdb -p %d %s" pid (or file "")))
     (with-current-buffer gud-comint-buffer
       (dolist (cmd commands)
         ;; First wait until gdb was initialized, then wait until current
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/03/18 12:29:07	1.197
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/03/19 12:32:30	1.198
@@ -342,6 +342,12 @@
   "Return a short name for the Lisp implementation."
   (lisp-implementation-type))
 
+(definterface lisp-implementation-program ()
+  "Return the argv[0] of the running Lisp process, or NIL."
+  (let ((file (car (command-line-args))))
+    (when (and file (probe-file file))
+      (namestring (truename file)))))
+
 (definterface socket-fd (socket-stream)
   "Return the file descriptor for SOCKET-STREAM.")
 
@@ -362,7 +368,8 @@
 This is thin wrapper around exec(3).")
 
 (definterface command-line-args ()
-  "Return a list of strings as passed by the OS.")
+  "Return a list of strings as passed by the OS."
+  nil)
 
 
 ;; pathnames are sooo useless
--- /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/18 12:29:07	1.65
+++ /project/slime/cvsroot/slime/swank-ecl.lisp	2010/03/19 12:32:30	1.66
@@ -486,6 +486,9 @@
   #+linux '("handle SIGPWR  noprint nostop"
             "handle SIGXCPU noprint nostop"))
 
+(defimplementation command-line-args ()
+  (loop for n from 0 below (si:argc) collect (si:argv n)))
+
 
 ;;;; Inspector
 
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/18 18:24:25	1.704
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/19 12:32:30	1.705
@@ -1737,7 +1737,8 @@
                                     (connection.external-format c)))
       :lisp-implementation (:type ,(lisp-implementation-type)
                             :name ,(lisp-implementation-type-name)
-                            :version ,(lisp-implementation-version))
+                            :version ,(lisp-implementation-version)
+                            :program ,(lisp-implementation-program))
       :machine (:instance ,(machine-instance)
                :type ,(machine-type)
                :version ,(machine-version))




From sboukarev at common-lisp.net  Sat Mar 20 08:27:50 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 20 Mar 2010 04:27:50 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Nsu2A-0007oY-FY@common-lisp.net>

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

Modified Files:
	ChangeLog slime-c-p-c.el slime-fuzzy.el slime-presentations.el 
Log Message:
* slime-c-p-c.el, slime-fuzzy.el: Don't define keys on slime-repl-mode-map
if slime-repl isn't loaded.
* slime-presentations.el: Refuse to load if slime-repl isn't loaded.
Reported by Robert Goldman.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/13 03:08:04	1.358
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/20 08:27:50	1.359
@@ -1,3 +1,10 @@
+2010-03-20  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-c-p-c.el, slime-fuzzy.el: Don't define keys on slime-repl-mode-map
+	if slime-repl isn't loaded.
+	* slime-presentations.el: Refuse to load if slime-repl isn't loaded.
+	Reported by Robert Goldman.
+
 2010-03-13  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-asdf.el: use slime-from-lisp-filename so that slime-tramp can work.
--- /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2010/02/15 21:42:37	1.21
+++ /project/slime/cvsroot/slime/contrib/slime-c-p-c.el	2010/03/20 08:27:50	1.22
@@ -176,14 +176,16 @@
    `(progn
       (setq slime-complete-symbol-function ',slime-complete-symbol-function)
       (remove-hook 'slime-connected-hook 'slime-c-p-c-on-connect)
-      (define-key slime-mode-map "\C-c\C-s"
-	',(lookup-key slime-mode-map "\C-c\C-s"))
-      (define-key slime-repl-mode-map "\C-c\C-s"
-	',(lookup-key slime-repl-mode-map "\C-c\C-s")))
+      ,@(when (featurep 'slime-repl)
+              `((define-key slime-mode-map "\C-c\C-s"
+                  ',(lookup-key slime-mode-map "\C-c\C-s"))
+                (define-key slime-repl-mode-map "\C-c\C-s"
+                  ',(lookup-key slime-repl-mode-map "\C-c\C-s")))))
    slime-c-p-c-init-undo-stack)
   (setq slime-complete-symbol-function 'slime-complete-symbol*)
   (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form)
-  (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form))
+  (when (featurep 'slime-repl)
+    (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form)))
 
 (defun slime-c-p-c-unload ()
   (while slime-c-p-c-init-undo-stack
--- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2010/02/19 10:38:07	1.16
+++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2010/03/20 08:27:50	1.17
@@ -600,6 +600,7 @@
 
 (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))
+  (when (featurep 'slime-repl)
+   (define-key slime-repl-mode-map "\C-c\M-i" 'slime-fuzzy-complete-symbol)))
 
 (provide 'slime-fuzzy)
--- /project/slime/cvsroot/slime/contrib/slime-presentations.el	2010/03/09 14:42:22	1.29
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el	2010/03/20 08:27:50	1.30
@@ -13,6 +13,9 @@
 ;;   (add-hook 'slime-load-hook (lambda () (require 'slime-presentations)))
 ;;
 
+(unless (featurep 'slime-repl)
+  (error "slime-presentations requires slime-repl contrib"))
+
 (defface slime-repl-output-mouseover-face
   (if (featurep 'xemacs)
       '((t (:bold t)))




From sboukarev at common-lisp.net  Sun Mar 21 12:41:09 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 21 Mar 2010 08:41:09 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NtKSr-0004I7-GQ@common-lisp.net>

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

Modified Files:
	ChangeLog 
Added Files:
	start-swank.lisp 
Log Message:
* start-swank.lisp: New file for starting swank by simply doing
sbcl --load start-swank.lisp


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/19 12:32:30	1.2043
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/21 12:41:09	1.2044
@@ -1,3 +1,8 @@
+2010-03-21  Stas Boukarev  <stassats at gmail.com>
+
+	* start-swank.lisp: New file for starting swank by simply loading
+	sbcl --load start-swank.lisp
+
 2010-03-19  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el (slime-lisp-implementation-program): New connection

--- /project/slime/cvsroot/slime/start-swank.lisp	2010/03/21 12:41:09	NONE
+++ /project/slime/cvsroot/slime/start-swank.lisp	2010/03/21 12:41:09	1.1
;;; This file is intended to be loaded by an implementation to
;;; get a running swank server
;;; e.g. sbcl --load start-swank.lisp
;;;
;;; Default port is 4005
;;; Default encoding is "iso-latin-1-unix"
;;;  see Emacs variable `slime-net-valid-coding-systems' for possible values.

;;; For additional swank-side configurations see
;;; 6.2 section section of the Slime user manual.

(load (merge-pathnames "swank-loader.lisp" *load-truename*))

(swank-loader:init)

(swank:create-server :port 4005
                     :coding-system "iso-latin-1-unix"

                     ;; if non-nil the connection won't be closed
                     ;; after connecting
                     :dont-close nil)



From sboukarev at common-lisp.net  Sun Mar 21 13:45:28 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 21 Mar 2010 09:45:28 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NtLT6-0004J9-VR@common-lisp.net>

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

Modified Files:
	ChangeLog start-swank.lisp 
Log Message:
* start-swank.lisp: Document options to swank-loader:init.

* doc/slime.texi (Miscellaneous): mention
`sldb-break-with-system-debugger'.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/21 12:41:09	1.2044
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/21 13:45:28	1.2045
@@ -1,5 +1,12 @@
 2010-03-21  Stas Boukarev  <stassats at gmail.com>
 
+	* start-swank.lisp: Document options to swank-loader:init.
+
+	* doc/slime.texi (Miscellaneous): mention
+	`sldb-break-with-system-debugger'.
+
+2010-03-21  Stas Boukarev  <stassats at gmail.com>
+
 	* start-swank.lisp: New file for starting swank by simply loading
 	sbcl --load start-swank.lisp
 
--- /project/slime/cvsroot/slime/start-swank.lisp	2010/03/21 12:41:09	1.1
+++ /project/slime/cvsroot/slime/start-swank.lisp	2010/03/21 13:45:28	1.2
@@ -7,11 +7,14 @@
 ;;;  see Emacs variable `slime-net-valid-coding-systems' for possible values.
 
 ;;; For additional swank-side configurations see
-;;; 6.2 section section of the Slime user manual.
+;;; 6.2 section of the Slime user manual.
 
 (load (merge-pathnames "swank-loader.lisp" *load-truename*))
 
-(swank-loader:init)
+(swank-loader:init
+ :delete nil         ; delete any existing SWANK packages
+ :reload nil         ; reload SWANK, even if the SWANK package already exists
+ :load-contribs nil) ; load all contribs
 
 (swank:create-server :port 4005
                      :coding-system "iso-latin-1-unix"




From sboukarev at common-lisp.net  Sun Mar 21 13:45:29 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 21 Mar 2010 09:45:29 -0400
Subject: [slime-cvs] CVS slime/doc
Message-ID: <E1NtLT7-0004JQ-AA@common-lisp.net>

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

Modified Files:
	slime.texi 
Log Message:
* start-swank.lisp: Document options to swank-loader:init.

* doc/slime.texi (Miscellaneous): mention
`sldb-break-with-system-debugger'.


--- /project/slime/cvsroot/slime/doc/slime.texi	2010/03/03 19:51:33	1.98
+++ /project/slime/cvsroot/slime/doc/slime.texi	2010/03/21 13:45:29	1.99
@@ -12,7 +12,7 @@
 @set EDITION 3.0-alpha
 @set SLIMEVER 3.0-alpha
 @c @set UPDATED @today{}
- at set UPDATED @code{$Date: 2010/03/03 19:51:33 $}
+ at set UPDATED @code{$Date: 2010/03/21 13:45:29 $}
 @set TITLE SLIME User Manual
 @settitle @value{TITLE}, version @value{EDITION}
 
@@ -1489,6 +1489,8 @@
 
 @kbditem{:, slime-interactive-eval}
 Evaluate an expression entered in the minibuffer.
+ at kbditem{A, sldb-break-with-system-debugger}
+Attach debugger (e.g. gdb) to the current lisp process.
 
 @end table
 




From trittweiler at common-lisp.net  Tue Mar 23 20:21:48 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 23 Mar 2010 16:21:48 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NuAbk-0008BF-NI@common-lisp.net>

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

Modified Files:
	ChangeLog slime-autodoc.el 
Log Message:
	Do not do an unnecessary autodoc RPC request in case we're not
	actually inside a form.

	* slime-autodoc.el (slime-make-autodoc-rpc-form): Return nil if
	not inside a form.
	(slime-autodoc): Adapted accordingly to propagate nil to eldoc.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/20 08:27:50	1.359
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/23 20:21:48	1.360
@@ -1,3 +1,12 @@
+2010-03-23  Tobias C. Rittweiler  <tcr at freebits.de>
+
+	Do not do an unnecessary autodoc RPC request in case we're not
+	actually inside a form.
+
+	* slime-autodoc.el (slime-make-autodoc-rpc-form): Return nil if
+	not inside a form.
+	(slime-autodoc): Adapted accordingly to propagate nil to eldoc.
+
 2010-03-20  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-c-p-c.el, slime-fuzzy.el: Don't define keys on slime-repl-mode-map
--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/03/07 14:09:51	1.36
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/03/23 20:21:48	1.37
@@ -62,12 +62,13 @@
   "Return a cache key and a swank form."
   (let* ((levels slime-autodoc-accuracy-depth)
          (buffer-form (slime-parse-form-upto-point levels)))
-    (values buffer-form
-            (multiple-value-bind (width height)
-                (slime-autodoc-message-dimensions)
-              `(swank:autodoc ',buffer-form
-                              :print-right-margin ,width
-                              :print-lines ,height)))))
+    (when buffer-form
+      (values buffer-form
+              (multiple-value-bind (width height)
+                  (slime-autodoc-message-dimensions)
+                `(swank:autodoc ',buffer-form
+                                :print-right-margin ,width
+                                :print-lines ,height))))))
 
 (defun slime-autodoc-global-at-point ()
   "Return the global variable name at point, if any."
@@ -166,22 +167,24 @@
       (unless (slime-inside-string-or-comment-p)
         (multiple-value-bind (cache-key retrieve-form) 
             (slime-make-autodoc-rpc-form)
-          (let ((cached (slime-get-cached-autodoc cache-key)))
-            (if cached
-                cached
-                ;; If nothing is in the cache, we first decline (by
-                ;; returning nil), and fetch the arglist information
-                ;; asynchronously.
-                (prog1 nil
-                  (slime-eval-async retrieve-form
-                    (lexical-let ((cache-key cache-key))
-                      (lambda (doc)
-                        (unless (eq doc :not-available) 
-                          (setq doc (slime-format-autodoc doc))
-                          ;; Now that we've got our information,
-                          ;; get it to the user ASAP.
-                          (eldoc-message doc)
-                          (slime-store-into-autodoc-cache cache-key doc)))))))))))))
+          (let ((it))
+            (cond 
+              ((not cache-key) nil)
+              ((setq cached (slime-get-cached-autodoc cache-key)) cached)
+              (t
+               ;; If nothing is in the cache, we first decline (by
+               ;; returning nil), and fetch the arglist information
+               ;; asynchronously.
+               (slime-eval-async retrieve-form
+                 (lexical-let ((cache-key cache-key))
+                   (lambda (doc)
+                     (unless (eq doc :not-available) 
+                       (setq doc (slime-format-autodoc doc))
+                       ;; Now that we've got our information,
+                       ;; get it to the user ASAP.
+                       (eldoc-message doc)
+                       (slime-store-into-autodoc-cache cache-key doc)))))
+               nil))))))))
 
 (make-variable-buffer-local (defvar slime-autodoc-mode nil))
 




From trittweiler at common-lisp.net  Tue Mar 23 20:24:16 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Tue, 23 Mar 2010 16:24:16 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NuAe8-0000DN-5n@common-lisp.net>

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

Modified Files:
	slime-autodoc.el 
Log Message:
Oops typo


--- /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/03/23 20:21:48	1.37
+++ /project/slime/cvsroot/slime/contrib/slime-autodoc.el	2010/03/23 20:24:16	1.38
@@ -167,7 +167,7 @@
       (unless (slime-inside-string-or-comment-p)
         (multiple-value-bind (cache-key retrieve-form) 
             (slime-make-autodoc-rpc-form)
-          (let ((it))
+          (let ((cached))
             (cond 
               ((not cache-key) nil)
               ((setq cached (slime-get-cached-autodoc cache-key)) cached)




From sboukarev at common-lisp.net  Sat Mar 27 02:07:57 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 26 Mar 2010 22:07:57 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NvLRN-0007Fw-VQ@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-check-location-buffer-name-sanity): Less duplication,
reuse slime-check-location-filename-sanity.
(slime-check-location-filename-sanity): Do any work only when
slime-warn-when-possibly-tricked-by-M-. is non-nil.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/21 13:45:28	1.2045
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/27 02:07:57	1.2046
@@ -1,3 +1,10 @@
+2010-03-27  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-check-location-buffer-name-sanity): Less duplication,
+	reuse slime-check-location-filename-sanity.
+	(slime-check-location-filename-sanity): Do any work only when
+	slime-warn-when-possibly-tricked-by-M-. is non-nil.
+
 2010-03-21  Stas Boukarev  <stassats at gmail.com>
 
 	* start-swank.lisp: Document options to swank-loader:init.
--- /project/slime/cvsroot/slime/slime.el	2010/03/19 12:32:30	1.1289
+++ /project/slime/cvsroot/slime/slime.el	2010/03/27 02:07:57	1.1290
@@ -3197,33 +3197,29 @@
 you should check twice before modifying.")
 
 (defun slime-maybe-warn-for-different-source-root (target-filename buffer-filename)
-  (when slime-warn-when-possibly-tricked-by-M-.
-    (let ((guessed-target (slime-file-name-merge-source-root target-filename
-                                                             buffer-filename)))
-      (when (and guessed-target
-                 (not (equal guessed-target target-filename))
-                 (file-exists-p guessed-target))
-        (slime-message "Attention: This is `%s'."
-                       (concat (slime-highlight-differences-in-dirname
-                                 (file-name-directory target-filename)
-                                 (file-name-directory guessed-target))
-                               (file-name-nondirectory target-filename)))))))
+  (let ((guessed-target (slime-file-name-merge-source-root target-filename
+                                                           buffer-filename)))
+    (when (and guessed-target
+               (not (equal guessed-target target-filename))
+               (file-exists-p guessed-target))
+      (slime-message "Attention: This is `%s'."
+                     (concat (slime-highlight-differences-in-dirname
+                              (file-name-directory target-filename)
+                              (file-name-directory guessed-target))
+                             (file-name-nondirectory target-filename))))))
 
 (defun slime-check-location-filename-sanity (filename)
-  (flet ((file-truename-safe (filename) (and filename (file-truename filename))))
-    (let ((target-filename (file-truename-safe filename))
-          (buffer-filename (file-truename-safe (buffer-file-name))))
-      (when buffer-filename
-        (slime-maybe-warn-for-different-source-root target-filename buffer-filename)))))
+  (when slime-warn-when-possibly-tricked-by-M-.
+    (flet ((file-truename-safe (filename) (and filename (file-truename filename))))
+      (let ((target-filename (file-truename-safe filename))
+            (buffer-filename (file-truename-safe (buffer-file-name))))
+        (when buffer-filename
+          (slime-maybe-warn-for-different-source-root
+           target-filename buffer-filename))))))
 
 (defun slime-check-location-buffer-name-sanity (buffer-name)
-  (flet ((file-truename-safe (filename) (and filename (file-truename filename))))
-    (let ((old-buffer-filename (file-truename-safe (buffer-file-name)))
-          (target-buffer-filename (file-truename-safe
-                                   (buffer-file-name (get-buffer buffer-name)))))
-      (when (and target-buffer-filename old-buffer-filename)
-        (slime-maybe-warn-for-different-source-root target-buffer-filename
-                                                    old-buffer-filename)))))
+  (slime-check-location-filename-sanity
+   (buffer-file-name (get-buffer buffer-name))))
 
 
 




From trittweiler at common-lisp.net  Mon Mar 29 14:30:59 2010
From: trittweiler at common-lisp.net (CVS User trittweiler)
Date: Mon, 29 Mar 2010 10:30:59 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NwFzX-0005Os-Nr@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
	* swank.lisp (connection-info): Use princ-to-string rather than
	prin1-to-string as the latter may barf if *print-readably* is nil.


--- /project/slime/cvsroot/slime/ChangeLog	2010/03/27 02:07:57	1.2046
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/29 14:30:59	1.2047
@@ -1,3 +1,8 @@
+2010-03-29  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp (connection-info): Use princ-to-string rather than
+	prin1-to-string as the latter may barf if *print-readably* is nil.
+
 2010-03-27  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-check-location-buffer-name-sanity): Less duplication,
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/19 12:32:30	1.705
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/29 14:30:59	1.706
@@ -1733,7 +1733,7 @@
       :encoding (:coding-system ,(connection.coding-system c)
                  ;; external-formats are totally implementation-dependent,
                  ;; so better play safe.
-                 :external-format ,(prin1-to-string
+                 :external-format ,(princ-to-string
                                     (connection.external-format c)))
       :lisp-implementation (:type ,(lisp-implementation-type)
                             :name ,(lisp-implementation-type-name)




From heller at common-lisp.net  Mon Mar 29 15:57:28 2010
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 29 Mar 2010 11:57:28 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NwHLE-0008Hu-B7@common-lisp.net>

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

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Minor cleanups

* swank.lisp (connection): Make socket-io read-only again.
(*connections*): Move declaration before first use.
(finish-connection-setup): Merged into make-connection.
(accept-connections): Renamed from serve-connection and
reorganized so that the socket-io slot can be read-only.
(accept-authenticated-connection): Renamed to authenticate-client.
Update callers accordingly.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/29 14:30:59	1.2047
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/29 15:57:28	1.2048
@@ -1,3 +1,15 @@
+2010-03-29  Helmut Eller  <heller at common-lisp.net>
+
+	Minor cleanups
+
+	* swank.lisp (connection): Make socket-io read-only again.
+	(*connections*): Move declaration before first use.
+	(finish-connection-setup): Merged into make-connection.
+	(accept-connections): Renamed from serve-connection and
+	reorganized so that the socket-io slot can be read-only.
+	(accept-authenticated-connection): Renamed to authenticate-client.
+	Update callers accordingly.
+
 2010-03-29  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (connection-info): Use princ-to-string rather than
--- /project/slime/cvsroot/slime/swank.lisp	2010/03/29 14:30:59	1.706
+++ /project/slime/cvsroot/slime/swank.lisp	2010/03/29 15:57:28	1.707
@@ -250,9 +250,11 @@
              (:constructor %make-connection)
              (:conc-name connection.)
              (:print-function print-connection))
+  ;; The listening socket. (usually closed)
   (socket           (missing-arg) :type t :read-only t)
-  ;; Raw I/O stream of socket connection.
-  (socket-io        nil :type (or stream null))
+  ;; Character I/O stream of socket connection.  Read-only to avoid
+  ;; race conditions during initialization.
+  (socket-io        (missing-arg) :type stream :read-only t)
   ;; Optional dedicated output socket (backending `user-output' slot).
   ;; Has a slot so that it can be closed with the connection.
   (dedicated-output nil :type (or stream null))
@@ -300,37 +302,10 @@
   ;; closed.
   saved-sigint-handler)
 
-(defun make-connection (socket style coding-system)
-  (multiple-value-bind (serve cleanup)
-      (ecase style
-        (:spawn
-         (values #'spawn-threads-for-connection #'cleanup-connection-threads))
-        (:sigio
-         (values #'install-sigio-handler #'deinstall-sigio-handler))
-        (:fd-handler
-         (values #'install-fd-handler #'deinstall-fd-handler))
-        ((nil)
-         (values #'simple-serve-requests nil)))
-    (%make-connection :socket socket
-                      :communication-style style
-                      :coding-system coding-system
-                      :serve-requests serve
-                      :cleanup cleanup)))
-
-(defun finish-connection-setup (connection socket-io)
-  (setf (connection.socket-io connection) socket-io)
-  (run-hook *new-connection-hook* connection)
-  (push connection *connections*)
-  connection)
-
 (defun print-connection (conn stream depth)
   (declare (ignore depth))
   (print-unreadable-object (conn stream :type t :identity t)))
 
-(defun connection.external-format (connection)
-  (ignore-errors
-    (stream-external-format (connection.socket-io connection))))
-
 (defvar *connections* '()
   "List of all active connections, with the most recent at the front.")
 
@@ -346,6 +321,31 @@
 recently established one."
   (first *connections*))
 
+(defun make-connection (socket stream style coding-system)
+  (multiple-value-bind (serve cleanup)
+      (ecase style
+        (:spawn
+         (values #'spawn-threads-for-connection #'cleanup-connection-threads))
+        (:sigio
+         (values #'install-sigio-handler #'deinstall-sigio-handler))
+        (:fd-handler
+         (values #'install-fd-handler #'deinstall-fd-handler))
+        ((nil)
+         (values #'simple-serve-requests nil)))
+    (let ((conn (%make-connection :socket socket
+                                  :socket-io stream
+                                  :communication-style style
+                                  :coding-system coding-system
+                                  :serve-requests serve
+                                  :cleanup cleanup)))
+      (run-hook *new-connection-hook* conn)
+      (push conn *connections*)
+      conn)))
+
+(defun connection.external-format (connection)
+  (ignore-errors
+    (stream-external-format (connection.socket-io connection))))
+
 (defslimefun ping (tag)
   tag)
 
@@ -690,13 +690,11 @@
 (defun setup-server (port announce-fn style dont-close coding-system)
   (declare (type function announce-fn))
   (init-log-output)
-  (let* ((external-format (find-external-format-or-lose coding-system))
-         (socket (create-socket *loopback-interface* port))
-         (local-port (local-port socket))
-         (connection (make-connection socket style coding-system)))
+  (let* ((socket (create-socket *loopback-interface* port))
+         (local-port (local-port socket)))
     (funcall announce-fn local-port)
     (flet ((serve ()
-             (serve-connection connection external-format dont-close)))
+             (accept-connections socket style coding-system dont-close)))
       (ecase style
         (:spawn
          (initialize-multiprocessing
@@ -746,35 +744,23 @@
   (create-server :port port :style style :dont-close dont-close
                  :coding-system coding-system))
 
-
-(defun serve-connection (connection external-format dont-close)
-  (let ((closed-socket-p nil)
-        (socket (connection.socket connection)))
-    (unwind-protect
-         (let ((client (accept-authenticated-client socket
-                        :external-format external-format)))
-           (unless dont-close
-             (close-socket socket)
-             (setf closed-socket-p t))
-           (serve-requests (finish-connection-setup connection client)))
-      (unless (or dont-close closed-socket-p)
-        (close-socket socket)))))
-
-(defun accept-authenticated-client (&rest args)
-  (let ((new (apply #'accept-connection args))
-        (success nil))
-    (unwind-protect
-         (let ((secret (slime-secret)))
-           (when secret
-             (set-stream-timeout new 20)
-             (let ((first-val (decode-message new)))
-               (unless (and (stringp first-val) (string= first-val secret))
-                 (error "Incoming connection doesn't know the password."))))
-           (set-stream-timeout new nil)
-           (setf success t))
-      (unless success
-        (close new :abort t)))
-    new))
+(defun accept-connections (socket style coding-system dont-close)
+  (let* ((ef (find-external-format-or-lose coding-system))
+         (client (unwind-protect 
+                      (accept-connection socket :external-format ef)
+                   (unless dont-close
+                     (close-socket socket)))))
+    (authenticate-client client)
+    (serve-requests (make-connection socket client style coding-system))))
+
+(defun authenticate-client (stream)
+  (let ((secret (slime-secret)))
+    (when secret
+      (set-stream-timeout stream 20)
+      (let ((first-val (decode-message stream)))
+        (unless (and (stringp first-val) (string= first-val secret))
+          (error "Incoming connection doesn't know the password.")))
+      (set-stream-timeout stream nil))))
 
 (defun slime-secret ()
   "Finds the magic secret from the user's home directory.  Returns nil
@@ -871,7 +857,7 @@
     (unwind-protect
          (let ((port (local-port socket)))
            (encode-message `(:open-dedicated-output-stream ,port) socket-io)
-           (let ((dedicated (accept-authenticated-client
+           (let ((dedicated (accept-connection
                              socket 
                              :external-format 
                              (or (ignore-errors
@@ -879,6 +865,7 @@
                                  :default)
                              :buffering *dedicated-output-stream-buffering*
                              :timeout 30)))
+             (authenticate-client dedicated)
              (close-socket socket)
              (setf socket nil)
              dedicated))




From heller at common-lisp.net  Mon Mar 29 15:57:35 2010
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 29 Mar 2010 11:57:35 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NwHLL-0008If-Uo@common-lisp.net>

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

Modified Files:
	ChangeLog swank-loader.lisp 
Log Message:
Compile swank-sbcl-exts only for SBCL.

* swank-loader.lisp (*contribs*): Add #+sbcl.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/29 15:57:28	1.2048
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/29 15:57:35	1.2049
@@ -1,5 +1,11 @@
 2010-03-29  Helmut Eller  <heller at common-lisp.net>
 
+	Compile swank-sbcl-exts only for SBCL.
+
+	* swank-loader.lisp (*contribs*): Add #+sbcl.
+
+2010-03-29  Helmut Eller  <heller at common-lisp.net>
+
 	Minor cleanups
 
 	* swank.lisp (connection): Make socket-io read-only again.
--- /project/slime/cvsroot/slime/swank-loader.lisp	2010/02/26 21:02:59	1.103
+++ /project/slime/cvsroot/slime/swank-loader.lisp	2010/03/29 15:57:35	1.104
@@ -219,7 +219,7 @@
     #+(or asdf sbcl ecl) swank-asdf
     swank-package-fu
     swank-hyperdoc
-    swank-sbcl-exts
+    #+sbcl swank-sbcl-exts
     )
   "List of names for contrib modules.")
 




From heller at common-lisp.net  Mon Mar 29 15:57:44 2010
From: heller at common-lisp.net (CVS User heller)
Date: Mon, 29 Mar 2010 11:57:44 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1NwHLU-0008Jl-Ut@common-lisp.net>

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

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el: Add gud as compile-time dependency.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/29 15:57:35	1.2049
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/29 15:57:44	1.2050
@@ -1,5 +1,9 @@
 2010-03-29  Helmut Eller  <heller at common-lisp.net>
 
+	* slime.el: Add gud as compile-time dependency.
+
+2010-03-29  Helmut Eller  <heller at common-lisp.net>
+
 	Compile swank-sbcl-exts only for SBCL.
 
 	* swank-loader.lisp (*contribs*): Add #+sbcl.
--- /project/slime/cvsroot/slime/slime.el	2010/03/27 02:07:57	1.1290
+++ /project/slime/cvsroot/slime/slime.el	2010/03/29 15:57:44	1.1291
@@ -75,7 +75,8 @@
   (require 'apropos)
   (require 'outline)
   (require 'etags)
-  (require 'compile))
+  (require 'compile)
+  (require 'gud))
 
 (eval-and-compile 
   (defvar slime-path




From sboukarev at common-lisp.net  Tue Mar 30 02:07:10 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Mon, 29 Mar 2010 22:07:10 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1NwQrG-0006DA-Fr@common-lisp.net>

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

Modified Files:
	ChangeLog swank-arglists.lisp 
Log Message:
* contrib/swank-arglists.lisp (*arglist-show-packages*): New
customization variable, when non-nil show qualified symbols.
(with-arglist-io-syntax): new macro for respecting the above variable.
(decoded-arglist-to-string, decoded-arglist-to-template-string): Use
the macro above.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/23 20:21:48	1.360
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/03/30 02:07:10	1.361
@@ -1,3 +1,11 @@
+2010-03-30  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-arglists.lisp (*arglist-show-packages*): New
+	customization variable, when non-nil show qualified symbols.
+	(with-arglist-io-syntax): new macro for respecting the above variable.
+	(decoded-arglist-to-string, decoded-arglist-to-template-string): Use
+	the macro above.
+
 2010-03-23  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Do not do an unnecessary autodoc RPC request in case we're not
--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/12 23:59:24	1.60
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2010/03/30 02:07:10	1.61
@@ -373,27 +373,38 @@
     (*print-readably* . nil)
     (*print-level*    . 10)
     (*print-length*   . 20)
-    (*print-escape*   . nil))) ; no package qualifiers.
+    (*print-escape*   . nil)))
+
+(defvar *arglist-show-packages* t)
+
+(defmacro with-arglist-io-syntax (&body body)
+  (let ((package (gensym)))
+    `(let ((,package *package*))
+       (with-standard-io-syntax
+         (let ((*package* (if *arglist-show-packages*
+                              *package*
+                              ,package)))
+           (with-bindings *arglist-pprint-bindings*
+             , at body))))))
 
 (defun decoded-arglist-to-string (decoded-arglist
                                   &key operator highlight
                                   print-right-margin print-lines)
   (with-output-to-string (*standard-output*)
-    (with-standard-io-syntax
-      (with-bindings *arglist-pprint-bindings*
-	(let ((*print-right-margin* print-right-margin)
-	      (*print-lines* print-lines))
-	  (print-decoded-arglist decoded-arglist 
-                                 :operator operator 
-                                 :highlight highlight))))))
+    (with-arglist-io-syntax
+      (let ((*print-right-margin* print-right-margin)
+            (*print-lines* print-lines))
+        (print-decoded-arglist decoded-arglist 
+                               :operator operator 
+                               :highlight highlight)))))
 
-(defun decoded-arglist-to-template-string (decoded-arglist &key (prefix "(") (suffix ")"))
+(defun decoded-arglist-to-template-string (decoded-arglist
+                                           &key (prefix "(") (suffix ")"))
   (with-output-to-string (*standard-output*)
-    (with-standard-io-syntax
-      (with-bindings *arglist-pprint-bindings*
-        (print-decoded-arglist-as-template decoded-arglist
-                                           :prefix prefix
-                                           :suffix suffix)))))
+    (with-arglist-io-syntax
+      (print-decoded-arglist-as-template decoded-arglist
+                                         :prefix prefix
+                                         :suffix suffix))))
 
 ;;;; Arglist Decoding / Encoding