From jsnellman at common-lisp.net  Sat Jul  1 07:11:31 2006
From: jsnellman at common-lisp.net (jsnellman)
Date: Sat,  1 Jul 2006 03:11:31 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060701071131.C5F274031@common-lisp.net>

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

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


--- /project/slime/cvsroot/slime/ChangeLog	2006/06/26 06:29:15	1.915
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/01 07:11:31	1.916
@@ -1,3 +1,9 @@
+2006-07-01  Lu?s Oliveira  <loliveira at common-lisp.net>
+ 
+ 	* swank-sbcl.lisp (locate-compiler-note): Change first branch to
+ 	handle the changes introduced by the previous patch to
+ 	swank-compile-string.
+	
 2006-06-26  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-sbcl.lisp (find-definitions): Remove backward
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/06/26 06:28:06	1.157
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/07/01 07:11:31	1.158
@@ -4,7 +4,7 @@
 ;;;
 ;;; Created 2003, Daniel Barlow <dan at metacircles.com>
 ;;;
-;;; This code has been placed in the Public Domain.  All warranties are 
+;;; This code has been placed in the Public Domain.  All warranties are
 ;;; disclaimed.
 
 ;;; Requires the SB-INTROSPECT contrib.
@@ -27,7 +27,7 @@
 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
 
 (defun swank-mop:slot-definition-documentation (slot)
-  (sb-pcl::documentation slot t))  
+  (sb-pcl::documentation slot t))
 
 ;;; TCP Server
 
@@ -41,7 +41,7 @@
           (not (sb-alien:extern-alien "linux_no_threads_p" sb-alien:boolean)))
       :spawn)
     (t :fd-handler)))
-        
+
 (defun resolve-hostname (name)
   (car (sb-bsd-sockets:host-ent-addresses
         (sb-bsd-sockets:get-host-by-name name))))
@@ -62,7 +62,7 @@
   (sb-sys:invalidate-descriptor (socket-fd socket))
   (sb-bsd-sockets:socket-close socket))
 
-(defimplementation accept-connection (socket &key 
+(defimplementation accept-connection (socket &key
                                       (external-format :iso-latin-1-unix)
                                       (buffering :full) timeout)
   (declare (ignore timeout))
@@ -95,14 +95,14 @@
 (defimplementation remove-sigio-handlers (socket)
   (let ((fd (socket-fd socket)))
     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
-    (sb-sys:invalidate-descriptor fd)) 
+    (sb-sys:invalidate-descriptor fd))
   (close socket))
 
 (defimplementation add-fd-handler (socket fn)
   (declare (type function fn))
   (let ((fd (socket-fd socket)))
     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
-    (sb-sys:add-fd-handler fd :input (lambda (_) 
+    (sb-sys:add-fd-handler fd :input (lambda (_)
                                        _
                                        (funcall fn)))))
 
@@ -128,13 +128,13 @@
                                        :input t
                                        :element-type 'character
                                        :buffering buffering
-                                       #+sb-unicode :external-format 
+                                       #+sb-unicode :external-format
                                        #+sb-unicode ef
                                        )))
 
 (defun accept (socket)
   "Like socket-accept, but retry on EAGAIN."
-  (loop (handler-case 
+  (loop (handler-case
             (return (sb-bsd-sockets:socket-accept socket))
           (sb-bsd-sockets:interrupted-error ()))))
 
@@ -190,9 +190,9 @@
 	(read stream t nil t))))
  (values))
 
-(defvar *shebang-readtable* 
+(defvar *shebang-readtable*
   (let ((*readtable* (copy-readtable nil)))
-    (set-dispatch-macro-character #\# #\! 
+    (set-dispatch-macro-character #\# #\!
                                   (lambda (s c n) (shebang-reader s c n))
                                   *readtable*)
     *readtable*))
@@ -216,7 +216,7 @@
 (defvar *debootstrap-packages* t)
 
 (defun call-with-debootstrapping (fun)
-  (handler-bind ((sb-int:bootstrap-package-not-found 
+  (handler-bind ((sb-int:bootstrap-package-not-found
                   #'sb-int:debootstrap-package))
     (funcall fun)))
 
@@ -224,7 +224,7 @@
   `(call-with-debootstrapping (lambda () , at body)))
 
 (defimplementation call-with-syntax-hooks (fn)
-  (cond ((and *debootstrap-packages* 
+  (cond ((and *debootstrap-packages*
               (sbcl-package-p *package*))
          (with-debootstrapping (funcall fn)))
         (t
@@ -291,20 +291,18 @@
       (list :error "No error location available")))
 
 (defun locate-compiler-note (file source-path source)
-  (cond ((and ;;(eq file :lisp)
-              *buffer-name*)
+  (cond ((and (not (eq file :lisp)) *buffer-name*)
          ;; Compiling from a buffer
          (let ((position (+ *buffer-offset*
                             (source-path-string-position
-                             (cons 0 (nthcdr 2 source-path))
-                             *buffer-substring*))))
+                             source-path *buffer-substring*))))
            (make-location (list :buffer *buffer-name*)
                           (list :position position))))
         ((and (pathnamep file) (null *buffer-name*))
          ;; Compiling from a file
          (make-location (list :file (namestring file))
                         (list :position
-                              (1+ (source-path-file-position 
+                              (1+ (source-path-file-position
                                    source-path file)))))
         ((and (eq file :lisp) (stringp source))
          ;; Compiling macro generated code
@@ -360,9 +358,9 @@
 
 (defvar *trap-load-time-warnings* nil)
 
-(defimplementation swank-compile-file (filename load-p 
+(defimplementation swank-compile-file (filename load-p
                                        &optional external-format)
-  (let ((ef (if external-format 
+  (let ((ef (if external-format
                 (find-external-format external-format)
                 :default)))
     (handler-case
@@ -396,7 +394,7 @@
         (*buffer-offset* position)
         (*buffer-substring* string)
         (filename (temp-file-name)))
-    (flet ((compile-it (fn) 
+    (flet ((compile-it (fn)
              (with-compilation-hooks ()
                (with-compilation-unit
                    (:source-plist (list :emacs-buffer buffer
@@ -594,7 +592,7 @@
   (declare (type function debugger-loop-fn))
   (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
 	 (sb-debug:*stack-top-hint* nil))
-    (handler-bind ((sb-di:debug-condition 
+    (handler-bind ((sb-di:debug-condition
 		    (lambda (condition)
                       (signal (make-condition
                                'sldb-condition
@@ -644,7 +642,7 @@
 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
 ;;; which returns the source location for a _code-location_.
-;;; 
+;;;
 ;;; Maybe these should be named code-location-file-source-location,
 ;;; etc, turned into generic functions, or something. In the very
 ;;; least the names should indicate the main entry point vs. helper
@@ -661,7 +659,7 @@
           (t (error "Cannot find source location for: ~A " code-location)))))
 
 (defun lisp-source-location (code-location)
-  (let ((source (prin1-to-string 
+  (let ((source (prin1-to-string
                  (sb-debug::code-location-source-form code-location 100))))
     (make-location `(:source-form ,source) '(:position 0))))
 
@@ -671,8 +669,8 @@
         (let* ((pos (string-source-position code-location emacs-string))
                (snipped (with-input-from-string (s emacs-string)
                           (read-snippet s pos))))
-          (make-location `(:buffer ,emacs-buffer) 
-                         `(:position ,(+ emacs-position pos)) 
+          (make-location `(:buffer ,emacs-buffer)
+                         `(:position ,(+ emacs-position pos))
                          `(:snippet ,snipped))))
       (fallback-source-location code-location)))
 
@@ -691,14 +689,14 @@
   (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
 
 (defun code-location-debug-source-created (code-location)
-  (sb-c::debug-source-created 
+  (sb-c::debug-source-created
    (sb-di::code-location-debug-source code-location)))
 
 (defun code-location-debug-fun-fun (code-location)
   (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
 
 (defun code-location-has-debug-block-info-p (code-location)
-  (handler-case 
+  (handler-case
       (progn (sb-di:code-location-debug-block code-location)
              t)
     (sb-di:no-debug-blocks  () nil)))
@@ -727,9 +725,9 @@
       (code-location-source-location code-location)
       (handler-case (code-location-source-location code-location)
         (error (c) (list :error (format nil "~A" c))))))
-                                               
+
 (defimplementation frame-source-location-for-emacs (index)
-  (safe-source-location-for-emacs 
+  (safe-source-location-for-emacs
    (sb-di:frame-code-location (nth-frame index))))
 
 (defun frame-debug-vars (frame)
@@ -761,7 +759,7 @@
 (defimplementation eval-in-frame (form index)
   (let ((frame (nth-frame index)))
     (funcall (the function
-               (sb-di:preprocess-for-eval form 
+               (sb-di:preprocess-for-eval form
                                           (sb-di:frame-code-location frame)))
              frame)))
 
@@ -783,7 +781,7 @@
 (defimplementation restart-frame (index)
   (let ((frame (nth-frame index)))
     (return-from-frame index (sb-debug::frame-call-as-list frame))))
-    
+
 ;;;;; reference-conditions
 
 (defimplementation format-sldb-condition (condition)
@@ -858,26 +856,26 @@
                     (:code (sb-kernel:fun-code-header o)))))
 	  ((= header sb-vm:closure-header-widetag)
 	   (values "A closure."
-                   (append 
+                   (append
                     (label-value-line :function (sb-kernel:%closure-fun o))
                     `("Closed over values:" (:newline))
                     (loop for i below (1- (sb-kernel:get-closure-length o))
-                          append (label-value-line 
+                          append (label-value-line
                                   i (sb-kernel:%closure-index-ref o i))))))
 	  (t (call-next-method o)))))
 
 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
   (declare (ignore _))
   (values (format nil "~A is a code data-block." o)
-          (append 
-           (label-value-line* 
+          (append
+           (label-value-line*
             (:code-size (sb-kernel:%code-code-size o))
             (:entry-points (sb-kernel:%code-entry-points o))
             (:debug-info (sb-kernel:%code-debug-info o))
-            (:trace-table-offset (sb-kernel:code-header-ref 
+            (:trace-table-offset (sb-kernel:code-header-ref
                                   o sb-vm:code-trace-table-offset-slot)))
            `("Constants:" (:newline))
-           (loop for i from sb-vm:code-constants-offset 
+           (loop for i from sb-vm:code-constants-offset
                  below (sb-kernel:get-header-data o)
                  append (label-value-line i (sb-kernel:code-header-ref o i)))
            `("Code:" (:newline)
@@ -885,8 +883,8 @@
                  (cond ((sb-kernel:%code-debug-info o)
                         (sb-disassem:disassemble-code-component o :stream s))
                        (t
-                        (sb-disassem:disassemble-memory 
-                         (sb-disassem::align 
+                        (sb-disassem:disassemble-memory
+                         (sb-disassem::align
                           (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
                                        sb-vm:lowtag-mask)
                              (* sb-vm:code-constants-offset
@@ -902,12 +900,12 @@
            (:name (sb-kernel:fdefn-name o))
            (:function (sb-kernel:fdefn-fun o)))))
 
-(defmethod inspect-for-emacs :around ((o generic-function) 
+(defmethod inspect-for-emacs :around ((o generic-function)
                                       (inspector sbcl-inspector))
   (declare (ignore inspector))
   (multiple-value-bind (title contents) (call-next-method)
     (values title
-            (append 
+            (append
              contents
              (label-value-line*
               (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
@@ -921,21 +919,21 @@
        #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
 (progn
   (defvar *thread-id-counter* 0)
-  
+
   (defvar *thread-id-counter-lock*
     (sb-thread:make-mutex :name "thread id counter lock"))
 
   (defun next-thread-id ()
     (sb-thread:with-mutex (*thread-id-counter-lock*)
       (incf *thread-id-counter*)))
-  
+
   (defparameter *thread-id-map* (make-hash-table))
 
   ;; This should be a thread -> id map but as weak keys are not
   ;; supported it is id -> map instead.
   (defvar *thread-id-map-lock*
     (sb-thread:make-mutex :name "thread id map lock"))
-  
+
   (defimplementation spawn (fn &key name)
     (sb-thread:make-thread fn :name name))
 
@@ -969,7 +967,7 @@
                     (remhash id *thread-id-map*)
                     nil)))
             nil))))
-  
+
   (defimplementation thread-name (thread)
     ;; sometimes the name is not a string (e.g. NIL)
     (princ-to-string (sb-thread:thread-name thread)))
@@ -998,7 +996,7 @@
 
   (defimplementation all-threads ()
     (sb-thread:list-all-threads))
- 
+
   (defimplementation interrupt-thread (thread fn)
     (sb-thread:interrupt-thread thread fn))
 
@@ -1012,7 +1010,7 @@
   (defvar *mailboxes* (list))
   (declaim (type list *mailboxes*))
 
-  (defstruct (mailbox (:conc-name mailbox.)) 
+  (defstruct (mailbox (:conc-name mailbox.))
     thread
     (mutex (sb-thread:make-mutex))
     (waitqueue  (sb-thread:make-waitqueue))
@@ -1049,20 +1047,20 @@
 
   ;; XXX race conditions
   (defvar *auto-flush-streams* '())
-  
+
   (defvar *auto-flush-thread* nil)
 
   (defimplementation make-stream-interactive (stream)
     (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
     (unless *auto-flush-thread*
       (setq *auto-flush-thread*
-            (sb-thread:make-thread #'flush-streams 
+            (sb-thread:make-thread #'flush-streams
                                    :name "auto-flush-thread"))))
 
   (defun flush-streams ()
     (loop
-     (setq *auto-flush-streams* 
-           (remove-if (lambda (x) 
+     (setq *auto-flush-streams*
+           (remove-if (lambda (x)
                         (not (and (open-stream-p x)
                                   (output-stream-p x))))
                       *auto-flush-streams*))
@@ -1074,7 +1072,7 @@
 (defimplementation quit-lisp ()
   #+sb-thread
   (dolist (thread (remove (current-thread) (all-threads)))
-    (ignore-errors (sb-thread:interrupt-thread 
+    (ignore-errors (sb-thread:interrupt-thread
                     thread (lambda () (sb-ext:quit :recklessly-p t)))))
   (sb-ext:quit))
 
@@ -1107,7 +1105,7 @@
 
 (defimplementation toggle-trace (spec)
   (ecase (car spec)
-    ((setf) 
+    ((setf)
      (toggle-trace-aux spec))
     ((:defmethod)
      (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))



From heller at common-lisp.net  Wed Jul 12 20:25:23 2006
From: heller at common-lisp.net (heller)
Date: Wed, 12 Jul 2006 16:25:23 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060712202523.6B98D1900F@common-lisp.net>

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

Modified Files:
	swank.asd swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak
hashtables.

* swank.asd: Set *source-directory* to the asdf component dir.



--- /project/slime/cvsroot/slime/swank.asd	2005/08/29 20:02:58	1.3
+++ /project/slime/cvsroot/slime/swank.asd	2006/07/12 20:25:23	1.4
@@ -22,3 +22,7 @@
 (asdf:defsystem :swank
     :components ((:file "swank-loader")))
 
+(defpackage :swank-loader)
+(defparameter swank-loader::*source-directory*
+  (asdf:component-pathname (asdf:find-system :swank)))
+
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2006/05/04 14:38:07	1.87
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2006/07/12 20:25:23	1.88
@@ -678,3 +678,12 @@
                        ,(third fspec)))))
         (t
          fspec)))
+
+
+;;;; Weak hashtables
+
+(defimplementation make-weak-key-hash-table (&rest args)
+  (apply #'make-hash-table :weak-keys t args))
+
+(defimplementation make-weak-value-hash-table (&rest args)
+  (apply #'make-hash-table :values :weak args))



From heller at common-lisp.net  Wed Jul 12 20:30:56 2006
From: heller at common-lisp.net (heller)
Date: Wed, 12 Jul 2006 16:30:56 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060712203056.3DF331C00C@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2006/07/01 07:11:31	1.916
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/12 20:30:56	1.917
@@ -1,9 +1,16 @@
+2006-07-11  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak
+	hashtables.
+
+	* swank.asd: Set *source-directory* to the asdf component dir.
+
 2006-07-01  Lu?s Oliveira  <loliveira at common-lisp.net>
  
- 	* swank-sbcl.lisp (locate-compiler-note): Change first branch to
+	* swank-sbcl.lisp (locate-compiler-note): Change first branch to
  	handle the changes introduced by the previous patch to
  	swank-compile-string.
-	
+
 2006-06-26  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-sbcl.lisp (find-definitions): Remove backward



From mkoeppe at common-lisp.net  Thu Jul 13 20:09:10 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Thu, 13 Jul 2006 16:09:10 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060713200910.10D107E021@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(keywords-of-operator): New support function for writing user-defined
`extra-keywords' methods.


--- /project/slime/cvsroot/slime/swank.lisp	2006/06/18 18:21:54	1.385
+++ /project/slime/cvsroot/slime/swank.lisp	2006/07/13 20:09:09	1.386
@@ -2083,6 +2083,18 @@
              :highlight highlight))))))
   nil)
 
+(defun keywords-of-operator (operator)
+  "Return a list of KEYWORD-ARGs that OPERATOR accepts.
+This function is useful for writing EXTRA-KEYWORDS methods for
+user-defined functions which are declared &ALLOW-OTHER-KEYS and which
+forward keywords to OPERATOR."
+  (let ((arglist (form-completion operator nil 
+                                  :remove-args nil)))
+    (unless (eql arglist :not-available)
+      (values 
+       (arglist.keyword-args arglist)
+       (arglist.allow-other-keys-p arglist)))))
+
 (defslimefun completions-for-keyword (name keyword-string)
   (with-buffer-syntax ()
     (let* ((form (operator-designator-to-form name))



From mkoeppe at common-lisp.net  Thu Jul 13 20:09:19 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Thu, 13 Jul 2006 16:09:19 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060713200919.E7B377C016@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/ChangeLog	2006/07/12 20:30:56	1.917
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/13 20:09:19	1.918
@@ -1,3 +1,8 @@
+2006-07-13  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
+
+	* swank.lisp (keywords-of-operator): New support function for
+	writing user-defined `extra-keywords' methods.
+
 2006-07-11  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak



From mkoeppe at common-lisp.net  Sat Jul 15 07:03:12 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Sat, 15 Jul 2006 03:03:12 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060715070312.B5C57431C2@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/ChangeLog	2006/07/13 20:09:19	1.918
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/15 07:03:12	1.919
@@ -1,3 +1,13 @@
+2006-07-15  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
+
+	* slime.el (slime-shared-lisp-mode-hook): New function, factored
+	out from slime-lisp-mode-hook.
+	(slime-lisp-mode-hook): Use it here.
+	(slime-scheme-mode-hook): New function, use
+	slime-shared-lisp-mode-hook. 
+	(slime-setup): If scheme-mode is one of the slime-lisp-modes,
+	install our hook.
+
 2006-07-13  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
 
 	* swank.lisp (keywords-of-operator): New support function for



From mkoeppe at common-lisp.net  Sat Jul 15 07:06:29 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Sat, 15 Jul 2006 03:06:29 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060715070629.861875F003@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
(slime-shared-lisp-mode-hook): New function, factored out from
slime-lisp-mode-hook.  
(slime-lisp-mode-hook): Use it here.
(slime-scheme-mode-hook): New function, use
slime-shared-lisp-mode-hook.  
(slime-setup): If scheme-mode is one of the slime-lisp-modes, install
our hook.


--- /project/slime/cvsroot/slime/slime.el	2006/06/25 08:41:57	1.632
+++ /project/slime/cvsroot/slime/slime.el	2006/07/15 07:06:29	1.633
@@ -72,21 +72,30 @@
 
 (defun* slime-setup (&key autodoc typeout-frame highlight-edits)
   "Setup Emacs so that lisp-mode buffers always use SLIME."
-  (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook)
+  (when (member 'lisp-mode slime-lisp-modes)
+    (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook))
+  (when (member 'scheme-mode slime-lisp-modes)
+    (add-hook 'scheme-mode-hook 'slime-scheme-mode-hook))
   (when typeout-frame
     (add-hook 'slime-connected-hook 'slime-ensure-typeout-frame))
   (setq slime-use-autodoc-mode autodoc)
   (setq slime-use-highlight-edits-mode highlight-edits))
 
-(defun slime-lisp-mode-hook ()
+(defun slime-shared-lisp-mode-hook ()
   (slime-mode 1)
-  (set (make-local-variable 'lisp-indent-function)
-       'common-lisp-indent-function)
   (when slime-use-autodoc-mode
     (slime-autodoc-mode 1))
   (when slime-use-highlight-edits-mode
     (slime-highlight-edits-mode 1)))
 
+(defun slime-lisp-mode-hook ()
+  (slime-shared-lisp-mode-hook)
+  (set (make-local-variable 'lisp-indent-function)
+       'common-lisp-indent-function))
+
+(defun slime-scheme-mode-hook ()
+  (slime-shared-lisp-mode-hook))
+
 (eval-and-compile 
   (defvar slime-path
     (let ((path (or (locate-library "slime") load-file-name)))



From jsnellman at common-lisp.net  Sat Jul 15 11:03:29 2006
From: jsnellman at common-lisp.net (jsnellman)
Date: Sat, 15 Jul 2006 07:03:29 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060715110329.DB0A03049@common-lisp.net>

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
remove linux_no_threads_p, defcondition -> define-condition

--- /project/slime/cvsroot/slime/ChangeLog	2006/07/15 07:03:12	1.919
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/15 11:03:29	1.920
@@ -1,3 +1,12 @@
+2006-07-15  Juho Snellman  <jsnell at iki.fi>
+	* swank-sbcl.lisp (preferred-communication-style): Remove use of
+	  linux_no_threads_p alien variable (the value has been hardcoded to
+	  false for about a year), so that we can also remove it from from SBCL
+	  in the future.
+	  (*definition-types*): defcondition -> define-condition,
+	  to make slime-show-definitions display condition FOO as
+	  (DEFINE-CONDITION FOO) instead of (SWANK-BACKEND::DEFCONDITION FOO).
+
 2006-07-15  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
 
 	* slime.el (slime-shared-lisp-mode-hook): New function, factored
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/07/01 07:11:31	1.158
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2006/07/15 11:03:29	1.159
@@ -36,10 +36,7 @@
     ;; fixme: when SBCL/win32 gains better select() support, remove
     ;; this.
     ((member :win32 *features*) nil)
-    ((and (member :sb-thread *features*)
-          #+linux
-          (not (sb-alien:extern-alien "linux_no_threads_p" sb-alien:boolean)))
-      :spawn)
+    ((member :sb-thread *features*) :spawn)
     (t :fd-handler)))
 
 (defun resolve-hostname (name)
@@ -429,7 +426,7 @@
     :method defmethod
     :setf-expander define-setf-expander
     :structure defstruct
-    :condition defcondition
+    :condition define-condition
     :class defclass
     :method-combination define-method-combination
     :package defpackage



From mkoeppe at common-lisp.net  Sun Jul 16 15:25:33 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Sun, 16 Jul 2006 11:25:33 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060716152533.E82D419000@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
(slime-edit-definition): Invoke the
slime-edit-definition-fall-back-function also in the case where
find-definitions-for-emacs returns an error message.
(slime-edit-definition-fallback-function): Fix typo (find-tag
rather than find-tags).


--- /project/slime/cvsroot/slime/slime.el	2006/07/15 07:06:29	1.633
+++ /project/slime/cvsroot/slime/slime.el	2006/07/16 15:25:33	1.634
@@ -225,13 +225,13 @@
   "Function to call when edit-definition fails to find the source itself.
 The function is called with the definition name, a string, as its argument.
 
-If you want to fallback on TAGS you can set this to `find-tags' or
+If you want to fallback on TAGS you can set this to `find-tag' or
 `slime-edit-definition-with-etags'."
   :type 'symbol
   :group 'slime-mode-mode
   :options '(nil 
              slime-edit-definition-with-etags
-             find-tags))
+             find-tag))
 
 (defcustom slime-compilation-finished-hook 'slime-maybe-list-compiler-notes
   "Hook called with a list of compiler notes after a compilation."
@@ -6322,11 +6322,18 @@
 function name is prompted."
   (interactive (list (slime-read-symbol-name "Name: ")))
   (let ((definitions (slime-eval `(swank:find-definitions-for-emacs ,name))))
-    (if (null definitions)
-        (if slime-edit-definition-fallback-function
-            (funcall slime-edit-definition-fallback-function name)
-          (error "No known definition for: %s" name))
-      (slime-goto-definition name definitions where))))
+    (cond 
+     ((null definitions)
+      (if slime-edit-definition-fallback-function
+          (funcall slime-edit-definition-fallback-function name)
+        (error "No known definition for: %s" name)))
+     ((and (consp definitions) (null (cdr definitions))
+           (eql (car (slime-definition.location (car definitions))) :error))
+      (if slime-edit-definition-fallback-function
+          (funcall slime-edit-definition-fallback-function name)
+        (error "%s" (cadr (slime-definition.location (car definitions))))))
+     (t 
+      (slime-goto-definition name definitions where)))))
 
 (defun slime-goto-definition (name definitions &optional where)
   (slime-push-definition-stack)



From mkoeppe at common-lisp.net  Sun Jul 16 15:25:42 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Sun, 16 Jul 2006 11:25:42 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060716152542.4C5E31D00C@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/ChangeLog	2006/07/15 11:03:29	1.920
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/16 15:25:41	1.921
@@ -1,3 +1,11 @@
+2006-07-16  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
+
+	* slime.el (slime-edit-definition): Invoke the
+	slime-edit-definition-fall-back-function also in the case where
+	find-definitions-for-emacs returns an error message.
+	(slime-edit-definition-fallback-function): Fix typo (find-tag
+	rather than find-tags).
+
 2006-07-15  Juho Snellman  <jsnell at iki.fi>
 	* swank-sbcl.lisp (preferred-communication-style): Remove use of
 	  linux_no_threads_p alien variable (the value has been hardcoded to



From mkoeppe at common-lisp.net  Mon Jul 24 14:01:03 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Mon, 24 Jul 2006 10:01:03 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060724140103.AFA0413001@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
(slime-enclosing-operator-names): For nesting levels
without operator, record nil.
(slime-completions-for-keyword): New argument arg-indices. 
(slime-contextual-completions): Pass all enclosing operators and 
arg-indices to slime-completions-for-keyword.


--- /project/slime/cvsroot/slime/slime.el	2006/07/16 15:25:33	1.634
+++ /project/slime/cvsroot/slime/slime.el	2006/07/24 14:01:03	1.635
@@ -5925,13 +5925,14 @@
     (when (and (< beg (point-max))
                (string= (buffer-substring-no-properties beg (1+ beg)) ":"))
       ;; Contextual keyword completion
-      (let ((operator-names (save-excursion 
-                              (goto-char beg)
-                              (nth-value 0
-                                         (slime-enclosing-operator-names 1)))))
+      (multiple-value-bind (operator-names arg-indices)
+          (save-excursion 
+            (goto-char beg)
+            (slime-enclosing-operator-names))
         (when operator-names
           (let ((completions 
-                 (slime-completions-for-keyword (first operator-names) token)))
+                 (slime-completions-for-keyword operator-names token
+                                                arg-indices)))
             (when (first completions)
               (return-from slime-contextual-completions completions))
             ;; If no matching keyword was found, do regular symbol
@@ -5946,9 +5947,11 @@
 (defun slime-simple-completions (prefix)
   (slime-eval `(swank:simple-completions ,prefix ',(slime-current-package))))
 
-(defun slime-completions-for-keyword (operator-designator prefix)
+(defun slime-completions-for-keyword (operator-designator prefix
+                                                          arg-indices)
   (slime-eval `(swank:completions-for-keyword ',operator-designator
-                                              ,prefix)))
+                                              ,prefix
+                                              ',arg-indices)))
 
 
 ;;;; Fuzzy completion
@@ -10182,9 +10185,14 @@
               (when (member (char-syntax (char-after)) '(?\( ?')) 
                 (incf level)
                 (forward-char 1)
-                (when-let (name (slime-symbol-name-at-point))
-                  (push (slime-parse-extended-operator-name name) result)
-                  (push arg-index arg-indices))
+                (let ((name (slime-symbol-name-at-point)))
+                  (cond
+                   (name
+                    (push (slime-parse-extended-operator-name name) result)
+                    (push arg-index arg-indices))
+                   (t
+                    (push nil result)
+                    (push arg-index arg-indices))))
                 (backward-up-list 1)))))))
     (values 
      (nreverse result)



From mkoeppe at common-lisp.net  Mon Jul 24 14:01:15 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Mon, 24 Jul 2006 10:01:15 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060724140115.A1F5616039@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(find-valid-operator-name): New, factored out from
arglist-for-echo-area.
(arglist-for-echo-area): Use it here.
(print-arglist): New, factored out from decoded-arglist-to-string.
Handle recursive arglist structures that arise in destructuring
macro arglists.
(decode-required-arg, encode-required-arg): New, handle
destructuring patterns.
(decode-keyword-arg, encode-keyword-arg, decode-optional-arg) 
(encode-optional-arg, decode-arglist, encode-arglist): Use them
here to handle destructuring patterns.
(print-decoded-arglist-as-template): Change interface, handle
destructuring patterns.
(decoded-arglist-to-template-string): Use it here.
(enrich-decoded-arglist-with-keywords): New, factored out from
enrich-decoded-arglist-with-extra-keywords. 
(enrich-decoded-arglist-with-extra-keywords): Use it here.
(compute-enriched-decoded-arglist): New generic function, factored
out from arglist-for-insertion, form-completion.  Add specialized
method for with-open-file.
(arglist-for-insertion, form-completion): Use it here.
(arglist-ref): New.
(completions-for-keyword): Change interface, handle destructuring
macro arglists.


--- /project/slime/cvsroot/slime/swank.lisp	2006/07/13 20:09:09	1.386
+++ /project/slime/cvsroot/slime/swank.lisp	2006/07/24 14:01:15	1.387
@@ -1378,18 +1378,26 @@
 
 ;;;; Arglists
 
+(defun find-valid-operator-name (names)
+  "As a secondary result, returns its index."
+  (let ((index 
+         (position-if (lambda (name)
+                        (or (consp name)
+                            (valid-operator-name-p name)))
+                      names)))
+    (if index
+        (values (elt names index) index)
+        (values nil nil))))
+
 (defslimefun arglist-for-echo-area (names &key print-right-margin
                                           print-lines arg-indices)
   "Return the arglist for the first function, macro, or special-op in NAMES."
   (handler-case
       (with-buffer-syntax ()
-        (let ((which (position-if (lambda (name)
-                                    (or (consp name)
-                                        (valid-operator-name-p name)))
-                                  names)))
+        (multiple-value-bind (name which)
+            (find-valid-operator-name names)
           (when which
-            (let ((name (elt names which))
-                  (arg-index (and arg-indices (elt arg-indices which))))
+            (let ((arg-index (and arg-indices (elt arg-indices which))))
               (multiple-value-bind (form operator-name)
                   (operator-designator-to-form name)
                 (let ((*print-right-margin* print-right-margin))
@@ -1428,6 +1436,99 @@
          '())
         (t (cons (car arglist) (clean-arglist (cdr arglist))))))
 
+(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
+  provided-args         ; list of the provided actual arguments
+  required-args         ; list of the required arguments
+  optional-args         ; list of the optional arguments
+  key-p                 ; whether &key appeared
+  keyword-args          ; list of the keywords
+  rest                  ; name of the &rest or &body argument (if any)
+  body-p                ; whether the rest argument is a &body
+  allow-other-keys-p    ; whether &allow-other-keys appeared
+  aux-args              ; list of &aux variables
+  known-junk            ; &whole, &environment
+  unknown-junk)         ; unparsed stuff
+
+(defun print-arglist (arglist &key operator highlight)
+  (let ((index 0)
+        (need-space nil))
+    (labels ((print-arg (arg)
+               (etypecase arg
+                 (arglist               ; destructuring pattern
+                  (print-arglist arg))
+                 (optional-arg 
+                  (princ (encode-optional-arg arg)))
+                 (keyword-arg
+                  (let ((enc-arg (encode-keyword-arg arg)))
+                    (etypecase enc-arg
+                      (symbol (princ enc-arg))
+                      ((cons symbol) 
+                       (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+                         (princ (car enc-arg))
+                         (write-char #\space)
+                         (pprint-fill *standard-output* (cdr enc-arg) nil)))
+                      ((cons cons)
+                       (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+                         (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+                           (prin1 (caar enc-arg))
+                           (write-char #\space)
+                           (print-arg (keyword-arg.arg-name arg)))
+                         (unless (null (cdr enc-arg))
+                           (write-char #\space))
+                         (pprint-fill *standard-output* (cdr enc-arg) nil))))))
+                 (t           ; required formal or provided actual arg
+                  (princ arg))))
+             (print-space ()
+               (ecase need-space
+                 ((nil))
+                 ((:miser)
+                  (write-char #\space)
+                  (pprint-newline :miser))
+                 ((t)
+                  (write-char #\space)
+                  (pprint-newline :fill)))
+               (setq need-space t))
+             (print-with-space (obj)
+               (print-space)
+               (print-arg obj))
+             (print-with-highlight (arg &optional (index-ok-p #'=))
+               (print-space)
+               (cond 
+                 ((and highlight (funcall index-ok-p index highlight))
+                  (princ "===> ")
+                  (print-arg arg)
+                  (princ " <==="))
+                 (t
+                  (print-arg arg)))
+               (incf index)))
+      (pprint-logical-block (nil nil :prefix "(" :suffix ")")
+        (when operator
+          (print-with-highlight operator)
+          (setq need-space :miser))
+	(mapc #'print-with-highlight
+	      (arglist.provided-args arglist))
+        (mapc #'print-with-highlight
+              (arglist.required-args arglist))
+        (when (arglist.optional-args arglist)
+          (print-with-space '&optional)
+          (mapc #'print-with-highlight 
+                (arglist.optional-args arglist)))
+        (when (arglist.key-p arglist)
+          (print-with-space '&key)
+          (mapc #'print-with-space
+                (arglist.keyword-args arglist)))
+        (when (arglist.allow-other-keys-p arglist)
+          (print-with-space '&allow-other-keys))
+        (cond ((not (arglist.rest arglist)))
+              ((arglist.body-p arglist)
+               (print-with-space '&body)
+               (print-with-highlight (arglist.rest arglist) #'<=))
+              (t
+               (print-with-space '&rest)
+               (print-with-highlight (arglist.rest arglist) #'<=)))
+        (mapc #'print-with-space                 
+              (arglist.unknown-junk arglist))))))  
+
 (defun decoded-arglist-to-string (arglist package 
                                   &key operator print-right-margin 
                                   print-lines highlight)
@@ -1443,83 +1544,7 @@
             (*print-level* 10) (*print-length* 20)
             (*print-right-margin* print-right-margin)
             (*print-lines* print-lines))
-        (let ((index 0)
-              (first-arg t))
-          (labels ((print-arg (arg)
-                     (etypecase arg
-                       (symbol (princ arg))
-                       (string (princ arg))
-                       (cons (pprint-logical-block (nil nil :prefix "(" :suffix ")")
-                               (princ (car arg))
-                               (unless (null (cdr arg))
-                                 (write-char #\space))
-                               (pprint-fill *standard-output* (cdr arg) nil)))))
-                   (print-space ()
-                     (unless first-arg
-                       (write-char #\space)
-                       (pprint-newline :fill))
-                     (setf first-arg nil))
-                   (print-with-space (obj)
-                     (print-space)
-                     (print-arg obj))
-                   (print-keyword-arg-with-space (arg)
-                     (print-space)
-                     (etypecase arg
-                       (symbol (princ arg))
-                       ((cons symbol) 
-                        (pprint-logical-block (nil nil :prefix "(" :suffix ")")
-                          (princ (car arg))
-                          (write-char #\space)
-                          (pprint-fill *standard-output* (cdr arg) nil)))
-                       ((cons cons)
-                        (pprint-logical-block (nil nil :prefix "(" :suffix ")")
-                          (pprint-logical-block (nil nil :prefix "(" :suffix ")")
-                            (prin1 (caar arg))
-                            (write-char #\space)
-                            (princ (cadar arg)))
-                          (unless (null (cdr arg))
-                            (write-char #\space))
-                          (pprint-fill *standard-output* (cdr arg) nil)))))
-                   (print-with-highlight (arg &optional (index-ok-p #'=)
-                                              (print-fun #'print-arg))
-                     (print-space)
-                     (cond 
-                       ((and highlight (funcall index-ok-p index highlight))
-                        (princ "===> ")
-                        (funcall print-fun arg)
-                        (princ " <==="))
-                       (t
-                        (funcall print-fun arg)))
-                     (incf index)))
-            (pprint-logical-block (nil nil :prefix "(" :suffix ")")
-              (when operator
-                (print-with-highlight operator))
-              (mapc (lambda (arg)
-                      (print-with-highlight arg #'= #'princ))
-                    (arglist.provided-args arglist))
-              (mapc #'print-with-highlight
-                    (arglist.required-args arglist))
-              (when (arglist.optional-args arglist)
-                (print-with-space '&optional)
-                (mapc #'print-with-highlight 
-                      (mapcar #'encode-optional-arg
-                              (arglist.optional-args arglist))))
-              (when (arglist.key-p arglist)
-                (print-with-space '&key)
-                (mapc #'print-keyword-arg-with-space
-                      (mapcar #'encode-keyword-arg 
-                              (arglist.keyword-args arglist))))
-              (when (arglist.allow-other-keys-p arglist)
-                (print-with-space '&allow-other-keys))
-              (cond ((not (arglist.rest arglist)))
-                    ((arglist.body-p arglist)
-                     (print-with-space '&body)
-                     (print-with-highlight (arglist.rest arglist) #'<=))
-                    (t
-                     (print-with-space '&rest)
-                     (print-with-highlight (arglist.rest arglist) #'<=)))
-              (mapc #'print-with-space                 
-                    (arglist.unknown-junk arglist)))))))))
+        (print-arglist arglist :operator operator :highlight highlight)))))
 
 (defslimefun variable-desc-for-echo-area (variable-name)
   "Return a short description of VARIABLE-NAME, or NIL."
@@ -1530,6 +1555,17 @@
                 (*print-length* 10) (*print-circle* t))
              (format nil "~A => ~A" sym (symbol-value sym)))))))
 
+(defun decode-required-arg (arg)
+  "ARG can be a symbol or a destructuring pattern."
+  (etypecase arg
+    (symbol arg)
+    (list   (decode-arglist arg))))
+
+(defun encode-required-arg (arg)
+  (etypecase arg
+    (symbol arg)
+    (arglist (encode-arglist arg))))
+
 (defstruct (keyword-arg 
             (:conc-name keyword-arg.)
             (:constructor make-keyword-arg (keyword arg-name default-arg)))
@@ -1547,7 +1583,7 @@
         ((and (consp arg)
               (consp (car arg)))
          (make-keyword-arg (caar arg)
-                           (cadar arg)
+                           (decode-required-arg (cadar arg))
                            (cadr arg)))
         ((consp arg)
          (make-keyword-arg (intern (symbol-name (car arg)) keyword-package)
@@ -1557,19 +1593,30 @@
          (error "Bad keyword item of formal argument list"))))
 
 (defun encode-keyword-arg (arg)
-  (if (eql (intern (symbol-name (keyword-arg.arg-name arg)) 
-                   keyword-package)
-           (keyword-arg.keyword arg))
-      (if (keyword-arg.default-arg arg)
-          (list (keyword-arg.arg-name arg)
-                (keyword-arg.default-arg arg))
-          (keyword-arg.arg-name arg))
-      (let ((keyword/name (list (keyword-arg.keyword arg)
-                                (keyword-arg.arg-name arg))))
-        (if (keyword-arg.default-arg arg)
-            (list keyword/name
-                  (keyword-arg.default-arg arg))
-            (list keyword/name)))))
+  (cond
+    ((arglist-p (keyword-arg.arg-name arg))
+     ;; Destructuring pattern
+     (let ((keyword/name (list (keyword-arg.keyword arg)
+                               (encode-required-arg
+                                (keyword-arg.arg-name arg)))))
+       (if (keyword-arg.default-arg arg)
+           (list keyword/name
+                 (keyword-arg.default-arg arg))
+           (list keyword/name))))
+    ((eql (intern (symbol-name (keyword-arg.arg-name arg)) 
+                  keyword-package)
+          (keyword-arg.keyword arg))
+     (if (keyword-arg.default-arg arg)
+         (list (keyword-arg.arg-name arg)
+               (keyword-arg.default-arg arg))
+         (keyword-arg.arg-name arg)))
+    (t
+     (let ((keyword/name (list (keyword-arg.keyword arg)
+                               (keyword-arg.arg-name arg))))
+       (if (keyword-arg.default-arg arg)
+           (list keyword/name
+                 (keyword-arg.default-arg arg))
+           (list keyword/name))))))
 
 (progn
   (assert (equalp (decode-keyword-arg 'x) 
@@ -1592,11 +1639,14 @@
 Return an OPTIONAL-ARG structure."
   (etypecase arg
     (symbol (make-optional-arg arg nil))
-    (list   (make-optional-arg (car arg) (cadr arg)))))
+    (list   (make-optional-arg (decode-required-arg (car arg)) 
+                               (cadr arg)))))
 
 (defun encode-optional-arg (optional-arg)
-  (if (optional-arg.default-arg optional-arg)
-      (list (optional-arg.arg-name optional-arg)
+  (if (or (optional-arg.default-arg optional-arg)
+          (arglist-p (optional-arg.arg-name optional-arg)))
+      (list (encode-required-arg
+             (optional-arg.arg-name optional-arg))
             (optional-arg.default-arg optional-arg))
       (optional-arg.arg-name optional-arg)))
 
@@ -1606,19 +1656,6 @@
   (assert (equalp (decode-optional-arg '(x t))
                   (make-optional-arg 'x t))))
 
-(defstruct (arglist (:conc-name arglist.))
-  provided-args         ; list of the provided actual arguments
-  required-args         ; list of the required arguments
-  optional-args         ; list of the optional arguments
-  key-p                 ; whether &key appeared
-  keyword-args          ; list of the keywords
-  rest                  ; name of the &rest or &body argument (if any)
-  body-p                ; whether the rest argument is a &body
-  allow-other-keys-p    ; whether &allow-other-keys appeared
-  aux-args              ; list of &aux variables
-  known-junk            ; &whole, &environment
-  unknown-junk)         ; unparsed stuff
-
 (define-modify-macro nreversef () nreverse "Reverse the list in PLACE.")
 
 (defun decode-arglist (arglist)
@@ -1661,7 +1698,8 @@
             (push (decode-optional-arg arg)
                   (arglist.aux-args result)))
 	   ((nil)
-	    (push arg (arglist.required-args result)))
+	    (push (decode-required-arg arg)
+                  (arglist.required-args result)))
            ((&whole &environment)
             (setf mode nil)
             (push arg (arglist.known-junk result)))))))
@@ -1674,7 +1712,7 @@
     result))
 
 (defun encode-arglist (decoded-arglist)
-  (append (arglist.required-args decoded-arglist)
+  (append (mapcar #'encode-required-arg (arglist.required-args decoded-arglist))
           (when (arglist.optional-args decoded-arglist)
             '(&optional))
           (mapcar #'encode-optional-arg (arglist.optional-args decoded-arglist))
@@ -1739,37 +1777,48 @@
       (let ((*package* package) (*print-case* :downcase)
             (*print-pretty* t) (*print-circle* nil) (*print-readably* nil)
             (*print-level* 10) (*print-length* 20))
-        (pprint-logical-block (nil nil :prefix prefix :suffix suffix)  
-          (print-decoded-arglist-as-template decoded-arglist))))))
-
-(defun print-decoded-arglist-as-template (decoded-arglist)
-  (let ((first-p t))
-    (flet ((space ()
-             (unless first-p
-               (write-char #\space)
-               (pprint-newline :fill))
-             (setq first-p nil)))
-      (dolist (arg (arglist.required-args decoded-arglist))
-        (space)
-        (princ arg))
-      (dolist (arg (arglist.optional-args decoded-arglist))
-        (space)
-        (format t "[~A]" (optional-arg.arg-name arg)))
-      (dolist (keyword-arg (arglist.keyword-args decoded-arglist))
-        (space)
-        (let ((arg-name (keyword-arg.arg-name keyword-arg))
-              (keyword (keyword-arg.keyword keyword-arg)))
-          (format t "~W ~A" 
-                  (if (keywordp keyword) keyword `',keyword)
-                  arg-name)))
-      (when (and (arglist.rest decoded-arglist)
-                 (or (not (arglist.keyword-args decoded-arglist))
-                     (arglist.allow-other-keys-p decoded-arglist)))
-        (if (arglist.body-p decoded-arglist)
-            (pprint-newline :mandatory)
-            (space))
-        (format t "~A..." (arglist.rest decoded-arglist)))))
-  (pprint-newline :fill))
+        (print-decoded-arglist-as-template decoded-arglist 
+                                           :prefix prefix 
+                                           :suffix suffix)))))
+
+(defun print-decoded-arglist-as-template (decoded-arglist &key
+                                          (prefix "(") (suffix ")"))
+  (pprint-logical-block (nil nil :prefix prefix :suffix suffix)  
+    (let ((first-p t))
+      (flet ((space ()
+               (unless first-p
+                 (write-char #\space)
+                 (pprint-newline :fill))
+               (setq first-p nil))
+             (print-arg-or-pattern (arg)
+               (etypecase arg
+                 (symbol (princ arg))
+                 (string (princ arg))

[256 lines skipped]



From mkoeppe at common-lisp.net  Mon Jul 24 14:01:22 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Mon, 24 Jul 2006 10:01:22 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060724140122.A84141800A@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2006/07/16 15:25:41	1.921
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/24 14:01:22	1.922
@@ -1,3 +1,40 @@
+2006-07-24  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
+
+	Add support for destructuring macro arglists in arglist display,
+	form completion, and keyword completion; in particular for
+	with-open-file.
+	
+	* swank.lisp (find-valid-operator-name): New, factored out from
+	arglist-for-echo-area.
+	(arglist-for-echo-area): Use it here.
+	(print-arglist): New, factored out from decoded-arglist-to-string.
+	Handle recursive arglist structures that arise in destructuring
+	macro arglists.
+	(decode-required-arg, encode-required-arg): New, handle
+	destructuring patterns.
+	(decode-keyword-arg, encode-keyword-arg, decode-optional-arg) 
+	(encode-optional-arg, decode-arglist, encode-arglist): Use them
+	here to handle destructuring patterns.
+	(print-decoded-arglist-as-template): Change interface, handle
+	destructuring patterns.
+	(decoded-arglist-to-template-string): Use it here.
+	(enrich-decoded-arglist-with-keywords): New, factored out from
+	enrich-decoded-arglist-with-extra-keywords. 
+	(enrich-decoded-arglist-with-extra-keywords): Use it here.
+	(compute-enriched-decoded-arglist): New generic function, factored
+	out from arglist-for-insertion, form-completion.  Add specialized
+	method for with-open-file.
+	(arglist-for-insertion, form-completion): Use it here.
+	(arglist-ref): New.
+	(completions-for-keyword): Change interface, handle destructuring
+	macro arglists.
+
+	* slime.el (slime-enclosing-operator-names): For nesting levels
+	without operator, record nil.
+	(slime-completions-for-keyword): New argument arg-indices. 
+	(slime-contextual-completions): Pass all enclosing operators and 
+	arg-indices to slime-completions-for-keyword.
+
 2006-07-16  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
 
 	* slime.el (slime-edit-definition): Invoke the
@@ -7,6 +44,7 @@
 	rather than find-tags).
 
 2006-07-15  Juho Snellman  <jsnell at iki.fi>
+	
 	* swank-sbcl.lisp (preferred-communication-style): Remove use of
 	  linux_no_threads_p alien variable (the value has been hardcoded to
 	  false for about a year), so that we can also remove it from from SBCL



From mkoeppe at common-lisp.net  Mon Jul 24 14:13:23 2006
From: mkoeppe at common-lisp.net (mkoeppe)
Date: Mon, 24 Jul 2006 10:13:23 -0400 (EDT)
Subject: [slime-cvs] CVS slime/doc
Message-ID: <20060724141323.BB2731C00E@common-lisp.net>

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

Added Files:
	.cvsignore 
Log Message:
Ignore generated files.



--- /project/slime/cvsroot/slime/doc/.cvsignore	2006/07/24 14:13:23	NONE
+++ /project/slime/cvsroot/slime/doc/.cvsignore	2006/07/24 14:13:23	1.1
contributors.texi
slime.aux
slime.cp
slime.dvi
slime.fn
slime.info
slime.ky
slime.log
slime.pdf
slime.pg
slime.ps
slime.tmp
slime.toc
slime.tp
slime.vr


From heller at common-lisp.net  Fri Jul 28 15:04:54 2006
From: heller at common-lisp.net (heller)
Date: Fri, 28 Jul 2006 11:04:54 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060728150454.1A9AD3D004@common-lisp.net>

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

Modified Files:
	swank-allegro.lisp 
Log Message:
Profiling functions on Allegro (except for profile-package). From
Willem Broekema.



--- /project/slime/cvsroot/slime/swank-allegro.lisp	2006/07/12 20:25:23	1.88
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2006/07/28 15:04:53	1.89
@@ -488,8 +488,77 @@
 
 ;;;; Profiling
 
+;; Per-function profiling based on description in
+;;  http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data-collection-control-2
+
+(defvar *profiled-functions* ())
+(defvar *profile-depth* 0)
+
+(defmacro with-redirected-y-or-n-p (&body body)
+  ;; If the profiler is restarted when the data from the previous
+  ;; session is not reported yet, the user is warned via Y-OR-N-P.
+  ;; As the CL:Y-OR-N-P question is (for some reason) not directly
+  ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
+  ;; overruled.
+  `(let* ((pkg       (find-package "common-lisp"))
+          (saved-pdl (excl::package-definition-lock pkg))
+          (saved-ynp (symbol-function 'cl:y-or-n-p)))
+     
+     (setf (excl::package-definition-lock pkg) nil
+           (symbol-function 'cl:y-or-n-p)   (symbol-function
+                                             (find-symbol "y-or-n-p-in-emacs"
+                                                          "swank")))
+     (unwind-protect
+         (progn , at body)
+       
+       (setf (symbol-function 'cl:y-or-n-p)      saved-ynp
+             (excl::package-definition-lock pkg) saved-pdl))))
+
+(defun start-acl-profiler ()
+  (with-redirected-y-or-n-p
+      (prof:start-profiler :type :time :count t
+                           :start-sampling-p nil :verbose nil)))
+(defun acl-profiler-active-p ()
+  (not (eq (prof:profiler-status :verbose nil) :inactive)))
+
+(defun stop-acl-profiler ()
+  (prof:stop-profiler :verbose nil))
+
+(excl:def-fwrapper profile-fwrapper (&rest args)
+  ;; Ensures sampling is done during the execution of the function,
+  ;; taking into account recursion.
+  (declare (ignore args))
+  (cond ((zerop *profile-depth*)
+         (let ((*profile-depth* (1+ *profile-depth*)))
+           (prof:start-sampling)
+           (unwind-protect (excl:call-next-fwrapper)
+             (prof:stop-sampling))))
+        (t 
+         (excl:call-next-fwrapper))))
+
+(defimplementation profile (fname)
+  (unless (acl-profiler-active-p)
+    (start-acl-profiler))
+  (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
+  (push fname *profiled-functions*))
+
+(defimplementation profiled-functions ()
+  *profiled-functions*)
+
+(defimplementation unprofile (fname)
+  (excl:funwrap fname 'profile-fwrapper)
+  (setq *profiled-functions* (remove fname *profiled-functions*)))
+
 (defimplementation profile-report ()
-  (prof:show-call-graph))
+  (prof:show-flat-profile :verbose nil)
+  (when *profiled-functions*
+    (start-acl-profiler)))
+
+(defimplementation profile-reset ()
+  (when (acl-profiler-active-p)
+    (stop-acl-profiler)
+    (start-acl-profiler))
+  "Reset profiling counters.")
 
 ;;;; Inspecting
 



From heller at common-lisp.net  Fri Jul 28 15:05:53 2006
From: heller at common-lisp.net (heller)
Date: Fri, 28 Jul 2006 11:05:53 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20060728150553.1931C3D005@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2006/07/24 14:01:22	1.922
+++ /project/slime/cvsroot/slime/ChangeLog	2006/07/28 15:05:52	1.923
@@ -1,3 +1,13 @@
+2006-07-28  Helmut Eller  <heller at common-lisp.net>
+
+	* slime.el (slime-thread-quit): Call swank:quit-thread-browser.
+	Reported by Taylor R Campbell.
+
+2006-07-28  Willem Broekema <metawilm at gmail.com>
+
+	* swank-allegro.lisp: Profiling functions on Allegro (except for
+	profile-package).
+
 2006-07-24  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>
 
 	Add support for destructuring macro arglists in arglist display,
@@ -68,6 +78,7 @@
 	* swank.lisp (keywords-of-operator): New support function for
 	writing user-defined `extra-keywords' methods.
 
+>>>>>>> 1.922
 2006-07-11  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-allegro.lisp (make-weak-key-hash-table): Use ACL's weak