From mbaringer at common-lisp.net  Fri Apr  6 15:42:42 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Fri,  6 Apr 2007 11:42:42 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070406154242.AA60545096@common-lisp.net>

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

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


--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/03/20 11:12:57	1.115
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/04/06 15:42:42	1.116
@@ -105,7 +105,8 @@
    openmcl-mop:slot-definition-type
    openmcl-mop:slot-definition-readers
    openmcl-mop:slot-definition-writers
-   openmcl-mop:slot-boundp-using-class))
+   openmcl-mop:slot-boundp-using-class
+   openmcl-mop:slot-makunbound-using-class))
 
 (defun specializer-name (spec)
   (etypecase spec
--- /project/slime/cvsroot/slime/ChangeLog	2007/03/29 17:12:38	1.1088
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/06 15:42:42	1.1089
@@ -1,3 +1,8 @@
+2007-04-06  Marco Baringer  <mb at bese.it>
+
+	* swank-openmcl.lisp (package swank-mop): Added
+	slot-makunbound-using-class.
+
 2007-03-29  Nikodemus Siivola <nikodemus at random-state.net>
 
 	* swank-sbcl.lisp (swank-compile-string): save the original



From mbaringer at common-lisp.net  Fri Apr  6 15:47:46 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Fri,  6 Apr 2007 11:47:46 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070406154746.CE2D97E005@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/slime.el	2007/03/25 00:10:50	1.773
+++ /project/slime/cvsroot/slime/slime.el	2007/04/06 15:47:43	1.774
@@ -7168,7 +7168,8 @@
             (format "(%s " (slime-qualify-cl-symbol-name symbol))))
       (slime-switch-to-output-buffer)
       (goto-char slime-repl-input-start-mark)
-      (insert function-call))))
+      (insert function-call)
+      (save-excursion (insert ")")))))
 
 ;;;; Edit Lisp value
 ;;;
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/06 15:42:42	1.1089
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/06 15:47:44	1.1090
@@ -1,3 +1,8 @@
+2007-04-06 Michael Weber <michaelw+slime at foldr.org>
+
+	* slime.el (slime-call-defun): insert the closing parenthesis for
+	the form.
+	
 2007-04-06  Marco Baringer  <mb at bese.it>
 
 	* swank-openmcl.lisp (package swank-mop): Added



From mbaringer at common-lisp.net  Fri Apr  6 16:06:44 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Fri,  6 Apr 2007 12:06:44 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070406160644.E6D7153067@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/slime.el	2007/04/06 15:47:43	1.774
+++ /project/slime/cvsroot/slime/slime.el	2007/04/06 16:06:44	1.775
@@ -8367,7 +8367,8 @@
                sldb-previous-frame-number ,num
                point-entered sldb-fetch-more-frames
                start-open t
-               face sldb-section-face)
+               face sldb-section-face
+               mouse-face highlight)
        " --more--")
       (insert "\n"))))
 
@@ -8377,10 +8378,11 @@
   (destructuring-bind (number string) frame
     (let ((props `(frame ,frame sldb-default-action sldb-toggle-details)))
       (slime-propertize-region props
-        (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ")
-        (slime-insert-possibly-as-rectangle
-         (slime-add-face (or face 'sldb-frame-line-face)
-                         string))
+        (slime-propertize-region '(mouse-face highlight)
+          (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ")
+          (slime-insert-possibly-as-rectangle
+           (slime-add-face (or face 'sldb-frame-line-face)
+                           string)))
         (insert "\n")))))
 
 (defun sldb-fetch-more-frames (&rest ignore)
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/06 15:47:44	1.1090
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/06 16:06:44	1.1091
@@ -1,3 +1,10 @@
+2007-04-06  Neil Van Dyke  <neil at neilvandyke.org>
+
+	* slime.el (sldb-insert-frame): Added mouse-face to frame label
+	and expression in Backtrace.
+	(sldb-insert-frames): Added mouse-face to "--more--" label in
+	Backtrace.
+
 2007-04-06 Michael Weber <michaelw+slime at foldr.org>
 
 	* slime.el (slime-call-defun): insert the closing parenthesis for



From mbaringer at common-lisp.net  Sun Apr  8 11:12:24 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 07:12:24 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408111224.07C0D60031@common-lisp.net>

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

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


--- /project/slime/cvsroot/slime/swank.lisp	2007/03/29 17:08:48	1.464
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 11:12:23	1.465
@@ -3469,6 +3469,9 @@
            
 ;;;; Fuzzy completion
 
+;;; For nomenclature of the fuzzy completion section, please read
+;;; through the following docstring.
+
 (defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec)
   "Return an (optionally limited to LIMIT best results) list of
 fuzzy completions for a symbol designator STRING.  The list will
@@ -3477,13 +3480,17 @@
 The result is a list of completion objects, where a completion
 object is:
     (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
-where a CHUNK is a description of a matched string of characters:
-    (OFFSET STRING)
-and FLAGS is a list of keywords describing properties of the symbol.
-For example, the top result for completing \"mvb\" in a package
-that uses COMMON-LISP would be something like:
-    (\"multiple-value-bind\" 42.391666 ((0 \"mul\") (9 \"v\") (15 \"b\"))
+where a CHUNK is a description of a matched substring:
+    (OFFSET SUBSTRING)
+and FLAGS is a list of keywords describing properties of the 
+symbol (see CLASSIFY-SYMBOL).
+
+E.g., completing \"mvb\" in a package that uses COMMON-LISP would
+return something like:
+
+    ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
      (:FBOUNDP :MACRO))
+     ...)
 
 If STRING is package qualified the result list will also be
 qualified.  If string is non-qualified the result strings are
@@ -3503,57 +3510,50 @@
                                 :limit limit :time-limit-in-msec time-limit-in-msec)
           'list))
 
-(defun convert-fuzzy-completion-result (result converter
+
+(defun convert-fuzzy-completion-result (fuzzy-matching converter
                                         internal-p package-name)
   "Converts a result from the fuzzy completion core into
 something that emacs is expecting.  Converts symbols to strings,
 fixes case issues, and adds information describing if the symbol
 is :bound, :fbound, a :class, a :macro, a :generic-function,
 a :special-operator, or a :package."
-  (destructuring-bind (symbol-or-name score chunks) result
+  (destructuring-bind (symbol score chunks) fuzzy-matching
     (multiple-value-bind (name added-length)
         (format-completion-result
-         (if converter
-             (funcall converter 
-                      (if (symbolp symbol-or-name)
-                          (symbol-name symbol-or-name)
-                          symbol-or-name))
-             symbol-or-name)
-         internal-p package-name)
-      (list name score
-            (mapcar
-             #'(lambda (chunk)
-                 ;; fix up chunk positions to account for possible
-                 ;; added package identifier
-                 (list (+ added-length (first chunk))
-                       (second chunk))) 
-             chunks)
-            (loop for flag in '(:boundp :fboundp :generic-function 
-                                :class :macro :special-operator
-                                :package)
-                  if (if (symbolp symbol-or-name)
-                         (case flag
-                           (:boundp (boundp symbol-or-name))
-                           (:fboundp (fboundp symbol-or-name))
-                           (:class (find-class symbol-or-name nil))
-                           (:macro (macro-function symbol-or-name))
-                           (:special-operator
-                            (special-operator-p symbol-or-name))
-                           (:generic-function
-                            (typep (ignore-errors (fdefinition symbol-or-name))
-                                   'generic-function)))
-                         (case flag
-                           (:package (stringp symbol-or-name)
-                                     ;; KLUDGE: depends on internal
-                                     ;; knowledge that packages are
-                                     ;; brought up from the bowels of
-                                     ;; the completion algorithm as
-                                     ;; strings!
-                                     )))
-                  collect flag)))))
+          (funcall (or converter #'identity) (symbol-name symbol))
+          internal-p package-name)
+      (list name
+            score
+            (mapcar #'(lambda (chunk)
+                        ;; fix up chunk positions to account for possible
+                        ;; added package identifier
+                        (list (+ added-length (first chunk))
+                              (second chunk))) 
+                    chunks)
+            (classify-symbol symbol)))))
+
+(defun classify-symbol (symbol)
+  "Returns a list of classifiers that classify SYMBOL according
+to its underneath objects (e.g. :BOUNDP if SYMBOL constitutes a
+special variable.) The list may contain the following classification
+keywords: :BOUNDP, :FBOUNDP, :GENERIC-FUNCTION, :CLASS, :MACRO, 
+:SPECIAL-OPERATOR, and/or :PACKAGE"
+  (check-type symbol symbol)
+  (let (result)
+    (when (boundp symbol)             (push :boundp result))
+    (when (fboundp symbol)            (push :fboundp result))
+    (when (find-class symbol nil)     (push :class result))
+    (when (macro-function symbol)     (push :macro result))
+    (when (special-operator-p symbol) (push :special-operator result))
+    (when (find-package symbol)       (push :package result))
+    (when (typep (ignore-errors (fdefinition symbol))
+                 'generic-function)
+      (push :generic-function result))
+    result))
 
 (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
-  "Prepares list of completion obajects, sorted by SCORE, of fuzzy
+  "Prepares list of completion objects, sorted by SCORE, of fuzzy
 completions of STRING in DEFAULT-PACKAGE-NAME.  If LIMIT is set,
 only the top LIMIT results will be returned."
   (declare (type (or null (integer 0 #.(1- most-positive-fixnum))) limit time-limit-in-msec))
@@ -3561,23 +3561,28 @@
       (parse-completion-arguments string default-package-name)
     (flet ((convert (vector &optional converter)
              (when vector
-               (loop for idx below (length vector)
-                     for el = (aref vector idx)
-                     do (setf (aref vector idx) (convert-fuzzy-completion-result
-                                                 el converter internal-p package-name))))))
+               (map-into vector
+                         #'(lambda (fuzzy-matching)
+                             (convert-fuzzy-completion-result fuzzy-matching converter
+                                                              internal-p package-name))
+                         vector))))
       (let* ((symbols (and package
-                           (fuzzy-find-matching-symbols name
-                                                        package
-                                                        (and (not internal-p)
-                                                             package-name)
+                           (fuzzy-find-matching-symbols name package
                                                         :time-limit-in-msec time-limit-in-msec
-                                                        :return-converted-p nil)))
-             (packs (and (not package-name)
+                                                        :external-only (and (not internal-p)
+                                                                            package-name))))
+             (packages (and (not package-name)
                          (fuzzy-find-matching-packages name)))
              (results))
-        (convert symbols (completion-output-symbol-converter string))
-        (convert packs)
-        (setf results (sort (concatenate 'vector symbols packs) #'> :key #'second))
+        (convert symbols  (completion-output-symbol-converter string))
+        (convert packages #'(lambda (package-name)
+                              (let ((converter (completion-output-package-converter string)))
+                                ;; Present packages with a trailing colon for maximum convenience!
+                                (concatenate 'string (funcall converter package-name) ":"))))
+        ;; Sort alphabetically before sorting by score. (Especially useful when
+        ;; STRING is empty, and SYMBOLS is a list of all possible completions.)
+        (setf results (sort (concatenate 'vector symbols packages) #'string-lessp :key #'first))
+        (setf results (stable-sort results #'> :key #'second))
         (when (and limit
                    (> limit 0)
                    (< limit (length results)))
@@ -3586,59 +3591,62 @@
               (setf results (make-array limit :displaced-to results))))
         results))))
 
-(defun fuzzy-find-matching-symbols (string package external &key time-limit-in-msec return-converted-p)
-  "Return a list of symbols in PACKAGE matching STRING using the
-fuzzy completion algorithm.  If EXTERNAL is true, only external
-symbols are returned."
+(defun fuzzy-find-matching-symbols (string package &key external-only time-limit-in-msec)
+  "Returns a vector of fuzzy matchings (that is a list of the symbol in
+PACKAGE that's matching STRING, its score, and a list of its completion
+chunks), using the fuzzy completion algorithm. If EXTERNAL-ONLY is true,
+only external symbols are considered."
   (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
+        (converter (completion-output-symbol-converter string))
         (time-limit (if time-limit-in-msec
                         (ceiling (/ time-limit-in-msec 1000))
                         0))
         (utime-at-start (get-universal-time))
-        (count 0)
-        (converter (completion-output-symbol-converter string)))
-    (declare (type (integer 0 #.(1- most-positive-fixnum)) count time-limit)
-             (type function converter))
-    (flet ((symbol-match (symbol converted)
-             (and (or (not external)
-                      (symbol-external-p symbol package))
-                  (compute-highest-scoring-completion
-                   string converted))))
-      (block loop
-        (do-symbols* (symbol package)
-          (incf count)
-          (when (and (not (zerop time-limit))
-                     (zerop (mod count 256))  ; ease up on calling get-universal-time like crazy
-                     (>= (- (get-universal-time) utime-at-start) time-limit))
-            (return-from loop))
-          (let* ((converted (funcall converter (symbol-name symbol)))
-                 (result (if return-converted-p converted symbol)))
-            (if (string= "" string)
-                (when (or (and external (symbol-external-p symbol package))
-                          (not external))
-                  (vector-push-extend (list result 0.0 (list (list 0 ""))) completions))
-                (multiple-value-bind (match-result score) (symbol-match symbol converted)
-                  (when match-result
-                    (vector-push-extend (list result score match-result) completions)))))))
-      completions)))
+        (count 0))
+    (declare (type (integer 0 #.(1- most-positive-fixnum)) count time-limit))
+    (declare (type function converter))
+    (flet ((time-exhausted-p ()
+             (and (not (zerop time-limit))
+                  (zerop (mod count 256))  ; ease up on calling get-universal-time like crazy
+                  (incf count)
+                  (>= (- (get-universal-time) utime-at-start) time-limit)))
+           (perform-fuzzy-match (string symbol-name)
+             (let ((converted-symbol-name (funcall converter symbol-name)))
+               (compute-highest-scoring-completion string converted-symbol-name))))
+      (prog1 completions
+        (block loop
+          (do-symbols* (symbol package)
+            (when (time-exhausted-p) (return-from loop))
+            (when (or (not external-only) (symbol-external-p symbol package))
+              (if (string= "" string)
+                  (vector-push-extend (list symbol 0.0 (list (list 0 ""))) completions)
+                  (multiple-value-bind (match-result score)
+                      (perform-fuzzy-match string (symbol-name symbol))
+                    (when match-result
+                      (vector-push-extend (list symbol score match-result) completions)))))))))))
 
 (defun fuzzy-find-matching-packages (name)
-  "Return a list of package names matching NAME using the fuzzy
-completion algorithm."
+  "Returns a vector of relevant fuzzy matchings (that is a list 
+consisting of a symbol representing the package that matches NAME,
+its score, and its completions chunks.)"
   (let ((converter (completion-output-package-converter name))
         (completions (make-array 32 :adjustable t :fill-pointer 0)))
     (declare ;;(optimize (speed 3))
              (type function converter))  
     (loop for package in (list-all-packages)
-          for package-name = (concatenate 'string 
-                                          (funcall converter
-                                                   (package-name package)) 
-                                          ":")
-          for (result score) = (multiple-value-list
+          for package-name   = (package-name package)
+          for converted-name = (funcall converter package-name)
+          for package-symbol = (or (find-symbol package-name)
+                                   (make-symbol package-name)) ; INTERN'd be
+          for (result score) = (multiple-value-list            ;  too invasive.
                                    (compute-highest-scoring-completion
-                                    name package-name))
+                                    name converted-name))
+          ;; We return a symbol that represents the package, a) to make
+          ;; the type of the returned value consistent with the one of
+          ;; FUZZY-FIND-MATCHING-SYMBOLS, and b) to be able to call
+          ;; CLASSIFY-SYMBOL upon it later on.
           when result do
-          (vector-push-extend (list package-name score result) completions))
+          (vector-push-extend (list package-symbol score result) completions))
     completions))
 
 (defslimefun fuzzy-completion-selected (original-string completion)
@@ -3671,7 +3679,7 @@
   "Finds the highest scoring way to complete the abbreviation
 SHORT onto the string FULL, using CHAR= as a equality function for
 letters.  Returns two values:  The first being the completion
-chunks of the high scorer, and the second being the score."
+chunks of the highest scorer, and the second being the score."
   (let* ((scored-results
           (mapcar #'(lambda (result)
                       (cons (score-completion result short full) result))
--- /project/slime/cvsroot/slime/slime.el	2007/04/06 16:06:44	1.775
+++ /project/slime/cvsroot/slime/slime.el	2007/04/08 11:12:23	1.776
@@ -6475,7 +6475,7 @@
                (slime-fuzzy-done))
       (goto-char end)
       (cond ((= (length completion-set) 1)
-             (insert-and-inherit (caar completion-set))
+             (insert-and-inherit (caar completion-set)) ; insert completed string
              (delete-region beg end)
              (goto-char (+ beg (length (caar completion-set))))
              (slime-minibuffer-respecting-message "Sole completion")
@@ -6493,7 +6493,7 @@
   "Click <mouse-2> on a completion to select it.
 In this buffer, type n and p to navigate between completions.
 Type RET to select the completion near point.  Type q to abort.
-Flags: boundp fboundp generic-function class macro special-operator
+Flags: boundp fboundp generic-function class macro special-operator package
 \n"
   "The explanation that gets inserted at the beginning of the
 *Fuzzy Completions* buffer.")
@@ -6503,11 +6503,11 @@
 completion choice into the current buffer, and mark it with the
 proper text properties."
   (let ((start (point))
-        (symbol (first completion))
+        (symbol-name (first completion))
         (score (second completion))
         (chunks (third completion))
         (flags (fourth completion)))
-    (insert symbol)
+    (insert symbol-name)
     (let ((end (point)))
       (dolist (chunk chunks)
         (put-text-property (+ start (first chunk)) 
@@ -6517,13 +6517,14 @@
       (put-text-property start (point) 'mouse-face 'highlight)
       (dotimes (i (- max-length (- end start)))
         (insert " "))
-      (insert (format " %s%s%s%s%s%s %8.2f"
+      (insert (format " %s%s%s%s%s%s%s %8.2f"
                       (if (member :boundp flags) "b" "-")
                       (if (member :fboundp flags) "f" "-")
                       (if (member :generic-function flags) "g" "-")
                       (if (member :class flags) "c" "-")
                       (if (member :macro flags) "m" "-")
                       (if (member :special-operator flags) "s" "-")
+                      (if (member :package flags) "p" "-")
                       score))
       (insert "\n")
       (put-text-property start (point) 'completion completion))))
@@ -6585,9 +6586,12 @@
         (setf max-length (max max-length (length (first completion)))))
       (insert "Completion:")
       (dotimes (i (- max-length 10)) (insert " "))
-      (insert "Flags: Score:\n")
+      ;;     Flags:  Score:
+      ;; ... ------- --------
+      ;;     bfgcmsp 
+      (insert "Flags:  Score:\n")
       (dotimes (i max-length) (insert "-"))
-      (insert " ------ --------\n")
+      (insert " ------- --------\n")
       (setq slime-fuzzy-first (point))
       (dolist (completion completions)
         (slime-fuzzy-insert-completion-choice completion max-length))
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/06 16:06:44	1.1091
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:12:24	1.1092
@@ -1,3 +1,52 @@
+2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp: Cleanup of parts of the fuzzy completion code.
+	Additionally a couple of enhancements. As follows:
+	
+	(fuzzy-completions, fuzzy-completion-selected): Minor 
+	stylistic and clarifying modifications of the docstrings.
+
+	(fuzzy-find-matching-symbols): Huge code reorganization.
+	Organizing relevant code into local function TIME-EXHAUSTED-P,
+	renaming local function SYMBOL-MATCH to PERFORM-FUZZY-MATCH,
+	making previously required argument EXTERNAL to new &key
+	argument :EXTERNAL-ONLY, clarifying docstring.
+
+	(fuzzy-find-matching-packages): Making its return value
+	conformant to that of FUZZY-FIND-MATCHING-SYMBOLS, i.e.
+	instead of returning, among others, a package's name as
+	string, it now returns a symbol representing the package.
+	Accomodates the docstring accordingly. 
+
+	(fuzzy-completion-set): Minor typographical fix in docstring.
+	Changing local function CONVERT to use MAP-INTO instead of
+	doing it essentially manually. Accomodating to changes of
+	FUZZY-FIND-MATCHING-SYMBOLS, resp. -PACKAGES.
+
+	(fuzzy-completion-set):	Additional new feature: 
+	The returned completions are sorted alphabetically by the
+	matched completion string before sorted by its score. 
+	Affects especially the list of all possible completions when 
+	the user hits fuzzy-completion on an empty string within Emacs;
+	also makes the potential limitness of the listed completions
+	clearer to the end user of SLIME.
+
+	(classify-symbol): New function. Returns a list with keywords
+	that classifies a given symbol. (E.g. :BOUNDP, :MACRO &c)
+	Supersedes parts of CONVERT-FUZZY-COMPLETION-RESULT, 
+	implementing them in a more straightforward and proper way;
+	removes prior KLUDGE in that part of the original function.
+
+	(convert-fuzzy-completion-result): The above changes made
+	it possible to simplify this function drastically. Now uses
+	the newly introduced function CLASSIFY-SYMBOL.
+
+	* slime.el: Minor stylistic changes. Additionally:
+	(slime-fuzzy-insert-completion-choice): 
+	(slime-fuzzy-fill-completions-buffer) : Adding use of the 
+	:PACKAGE classification flag returned by SWANK:FUZZY-COMPLETIONS.
+	This flag is called "p".
+
 2007-04-06  Neil Van Dyke  <neil at neilvandyke.org>
 
 	* slime.el (sldb-insert-frame): Added mouse-face to frame label



From mbaringer at common-lisp.net  Sun Apr  8 11:17:14 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 07:17:14 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408111714.734DC6A004@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/slime.el	2007/04/08 11:12:23	1.776
+++ /project/slime/cvsroot/slime/slime.el	2007/04/08 11:17:13	1.777
@@ -6671,7 +6671,9 @@
 (defun slime-fuzzy-highlight-current-completion ()
   "Highlights the current completion, so that the user can see it on the screen."
   (let ((pos (point)))
-    (setq slime-fuzzy-current-completion-overlay (make-overlay (point) (search-forward " ") (current-buffer) t nil))
+    (setq slime-fuzzy-current-completion-overlay 
+          (make-overlay (point) (1- (search-forward " "))
+                        (current-buffer) t nil))
     (overlay-put slime-fuzzy-current-completion-overlay 'face 'secondary-selection)
     (goto-char pos)))
 
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:12:24	1.1092
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:17:13	1.1093
@@ -1,5 +1,12 @@
 2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* slime.el (slime-fuzzy-highlight-current-completion): Fix
+	off-by-one error that causes the currently selected 
+	completion in the *Fuzzy Completion* buffer be highlighted
+	one char too far.
+	
+2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp: Cleanup of parts of the fuzzy completion code.
 	Additionally a couple of enhancements. As follows:
 	



From mbaringer at common-lisp.net  Sun Apr  8 11:21:46 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 07:21:46 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408112146.579CA1008@common-lisp.net>

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

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


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 11:12:23	1.465
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 11:21:45	1.466
@@ -2473,7 +2473,7 @@
       *package*))
 
 (defun eval-for-emacs (form buffer-package id)
-  "Bind *BUFFER-PACKAGE* BUFFER-PACKAGE and evaluate FORM.
+  "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
 Return the result to the continuation ID.
 Errors are trapped and invoke our debugger."
   (call-with-debugger-hook
@@ -3281,25 +3281,43 @@
                                  collect (package-name package)
                                  append (package-nicknames package))))))
 
+;; PARSE-COMPLETION-ARGUMENTS return table:
+;; 
+;;  user behaviour |  NAME  | PACKAGE-NAME | PACKAGE 
+;; ----------------+--------+--------------+-----------------------------------
+;; asdf     [tab]  | "asdf" |     NIL      | #<PACKAGE "DEFAULT-PACKAGE-NAME">
+;;                 |        |              |      or *BUFFER-PACKAGE*
+;; asdf:    [tab]  |   ""   |    "asdf"    | #<PACKAGE "ASDF">
+;;                 |        |              |
+;; asdf:foo [tab]  | "foo"  |    "asdf"    | #<PACKAGE "ASDF">
+;;                 |        |              |
+;; as:fo    [tab]  |  "fo"  |     "as"     | NIL              
+;;                 |        |              |
+;; :        [tab]  |   ""   |      ""      | #<PACKAGE "KEYWORD">
+;;                 |        |              |
+;; :foo     [tab]  | "foo"  |      ""      | #<PACKAGE "KEYWORD">
+;;
 (defun parse-completion-arguments (string default-package-name)
   "Parse STRING as a symbol designator.
 Return these values:
  SYMBOL-NAME
  PACKAGE-NAME, or nil if the designator does not include an explicit package.
- PACKAGE, the package to complete in
+ PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is 
+          NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; 
+          if PACKAGE is non-NIL but a package cannot be found under that name,
+          return NIL.)
  INTERNAL-P, if the symbol is qualified with `::'."
   (multiple-value-bind (name package-name internal-p)
       (tokenize-symbol string)
-    (let ((package (carefully-find-package package-name default-package-name)))
-      (values name package-name package internal-p))))
+    (if package-name
+	(let ((package (guess-package (if (equal package-name "")
+					  "KEYWORD"
+					  package-name))))
+	  (values name package-name package internal-p))
+	(let ((package (guess-package default-package-name)))
+	  (values name package-name (or package *buffer-package*) internal-p))
+	)))
 
-(defun carefully-find-package (name default-package-name)
-  "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or the
-*buffer-package*.  NAME and DEFAULT-PACKAGE-NAME can be nil."
-  (let ((string (cond ((equal name "") "KEYWORD")
-                      (t (or name default-package-name)))))
-    (or (and string (guess-package string))
-        *buffer-package*)))
 
 ;;;;; Format completion results
 ;;;
@@ -3479,9 +3497,13 @@
 
 The result is a list of completion objects, where a completion
 object is:
+
     (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
+
 where a CHUNK is a description of a matched substring:
+
     (OFFSET SUBSTRING)
+
 and FLAGS is a list of keywords describing properties of the 
 symbol (see CLASSIFY-SYMBOL).
 
@@ -3506,31 +3528,49 @@
   ;; but then the network serialization were slower by handling arrays.
   ;; Instead we limit the number of completions that is transferred
   ;; (the limit is set from emacs).
-  (coerce (fuzzy-completion-set string default-package-name
-                                :limit limit :time-limit-in-msec time-limit-in-msec)
+  (coerce (fuzzy-completion-set string default-package-name :limit limit
+                                :time-limit-in-msec time-limit-in-msec)
           'list))
 
 
-(defun convert-fuzzy-completion-result (fuzzy-matching converter
-                                        internal-p package-name)
+;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
+;;; object that will be sent back to Emacs, as described above.
+
+(defstruct (fuzzy-matching (:conc-name   fuzzy-matching.)
+			   (:predicate   fuzzy-matching-p)
+			   (:constructor %make-fuzzy-matching))
+  symbol	    ; The symbol that has been found to match. 
+  score	            ; the higher the better symbol is a match.
+  package-chunks    ; Chunks pertaining to the package identifier of the symbol.
+  symbol-chunks)    ; Chunks pertaining to the symbol's name.
+
+(defun make-fuzzy-matching (symbol score package-chunks symbol-chunks)
+  (%make-fuzzy-matching :symbol symbol :score score
+			:package-chunks package-chunks
+			:symbol-chunks symbol-chunks))
+
+
+(defun fuzzy-convert-matching-for-emacs (fuzzy-matching converter
+					 internal-p package-name)
   "Converts a result from the fuzzy completion core into
 something that emacs is expecting.  Converts symbols to strings,
 fixes case issues, and adds information describing if the symbol
 is :bound, :fbound, a :class, a :macro, a :generic-function,
 a :special-operator, or a :package."
-  (destructuring-bind (symbol score chunks) fuzzy-matching
+  (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks) fuzzy-matching
     (multiple-value-bind (name added-length)
         (format-completion-result
           (funcall (or converter #'identity) (symbol-name symbol))
           internal-p package-name)
       (list name
             score
-            (mapcar #'(lambda (chunk)
-                        ;; fix up chunk positions to account for possible
-                        ;; added package identifier
-                        (list (+ added-length (first chunk))
-                              (second chunk))) 
-                    chunks)
+            (append package-chunks
+		    (mapcar #'(lambda (chunk)
+				;; fix up chunk positions to account for possible
+				;; added package identifier.
+				(let ((offset (first chunk)) (string (second chunk)))
+				  (list (+ added-length offset) string))) 
+			    symbol-chunks))
             (classify-symbol symbol)))))
 
 (defun classify-symbol (symbol)
@@ -3552,50 +3592,107 @@
       (push :generic-function result))
     result))
 
+
 (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
   "Prepares list of completion objects, sorted by SCORE, of fuzzy
 completions of STRING in DEFAULT-PACKAGE-NAME.  If LIMIT is set,
 only the top LIMIT results will be returned."
-  (declare (type (or null (integer 0 #.(1- most-positive-fixnum))) limit time-limit-in-msec))
-  (multiple-value-bind (name package-name package internal-p)
-      (parse-completion-arguments string default-package-name)
-    (flet ((convert (vector &optional converter)
-             (when vector
-               (map-into vector
-                         #'(lambda (fuzzy-matching)
-                             (convert-fuzzy-completion-result fuzzy-matching converter
-                                                              internal-p package-name))
-                         vector))))
-      (let* ((symbols (and package
-                           (fuzzy-find-matching-symbols name package
-                                                        :time-limit-in-msec time-limit-in-msec
-                                                        :external-only (and (not internal-p)
-                                                                            package-name))))
-             (packages (and (not package-name)
-                         (fuzzy-find-matching-packages name)))
-             (results))
-        (convert symbols  (completion-output-symbol-converter string))
-        (convert packages #'(lambda (package-name)
-                              (let ((converter (completion-output-package-converter string)))
-                                ;; Present packages with a trailing colon for maximum convenience!
-                                (concatenate 'string (funcall converter package-name) ":"))))
-        ;; Sort alphabetically before sorting by score. (Especially useful when
-        ;; STRING is empty, and SYMBOLS is a list of all possible completions.)
-        (setf results (sort (concatenate 'vector symbols packages) #'string-lessp :key #'first))
-        (setf results (stable-sort results #'> :key #'second))
+  (check-type (values limit time-limit-in-msec) 
+              (or null (integer 0 #.(1- most-positive-fixnum))))
+  (let* ((completion-set (fuzzy-create-completion-set string default-package-name
+						      time-limit-in-msec)))
         (when (and limit
                    (> limit 0)
-                   (< limit (length results)))
-          (if (array-has-fill-pointer-p results)
-              (setf (fill-pointer results) limit)
-              (setf results (make-array limit :displaced-to results))))
-        results))))
+                   (< limit (length completion-set)))
+          (if (array-has-fill-pointer-p completion-set)
+              (setf (fill-pointer completion-set) limit)
+              (setf completion-set (make-array limit :displaced-to completion-set))))
+    completion-set))
+
+
+(defun fuzzy-create-completion-set (string default-package-name time-limit-in-msec)
+  "Does all the hard work for FUZZY-COMPLETION-SET."
+  (multiple-value-bind (parsed-name parsed-package-name package internal-p)
+      (parse-completion-arguments string default-package-name)
+    (flet ((convert (matchings package-name &optional converter)
+	     ;; Converts MATCHINGS to completion objects for Emacs.
+	     ;; PACKAGE-NAME is the package identifier that's used as prefix
+	     ;; during formatting. If NIL, the identifier is omitted.
+	     (map-into matchings
+		       #'(lambda (m)
+			   (fuzzy-convert-matching-for-emacs m converter
+							     internal-p
+							     package-name))
+		       matchings))
+	   (fix-up (matchings parent-package-matching)
+	     ;; The components of each matching in MATCHINGS have been computed
+	     ;; relative to PARENT-PACKAGE-MATCHING. Make them absolute.
+	     (let* ((p parent-package-matching)
+		    (p.score  (fuzzy-matching.score p))
+		    (p.chunks (fuzzy-matching.package-chunks p)))
+	       (map-into matchings
+			 #'(lambda (m)
+			     (let ((m.score (fuzzy-matching.score m)))
+			       (setf (fuzzy-matching.package-chunks m) p.chunks)
+			       (setf (fuzzy-matching.score m)
+				     (if (string= parsed-name "")
+					 ;; (make packages be sorted before their symbol
+					 ;; matchings while preserving over all orderness
+					 ;; among different symbols in different packages)
+					 (/ p.score 100)        
+					 (+ p.score m.score)))
+			       m))
+			 matchings)))
+	   (find-matchings (designator package)
+	     (fuzzy-find-matching-symbols designator package
+					  :time-limit-in-msec time-limit-in-msec
+					  :external-only (not internal-p))))
+      (let ((symbol-normalizer  (completion-output-symbol-converter string))
+	    (package-normalizer #'(lambda (package-name)
+				    (let ((converter (completion-output-package-converter string)))
+				      ;; Present packages with a trailing colon for maximum convenience!
+				      (concatenate 'string (funcall converter package-name) ":"))))
+	    (symbols) (packages) (results))
+	(cond ((not parsed-package-name)        ; STRING = "asd"
+	       ;; We don't know if user is searching for a package or a symbol
+	       ;; within his current package. So we try to find either.
+	       (setf symbols  (find-matchings parsed-name package)
+		     symbols  (convert symbols nil symbol-normalizer)
+		     packages (fuzzy-find-matching-packages parsed-name)
+		     packages (convert packages nil package-normalizer)))
+	      ((string= parsed-package-name "") ; STRING = ":" or ":foo"
+	       (setf symbols (find-matchings parsed-name package)
+		     symbols (convert symbols "" symbol-normalizer)))
+	      (t	                        ; STRING= "asdf:" or "asdf:foo"
+	       ;; Find fuzzy matchings of the denoted package identifier part.
+	       ;; After that find matchings for the denoted symbol identifier
+	       ;; relative to all those packages found.
+	       (loop
+		  with found-packages = (fuzzy-find-matching-packages parsed-package-name)
+		  for package-matching across found-packages
+		  do
+		  (let* ((pkgsym       (fuzzy-matching.symbol package-matching))
+			 (package-name (symbol-name pkgsym))
+			 (package-name (funcall symbol-normalizer package-name))
+			 (matchings (find-matchings parsed-name (find-package pkgsym))))
+		    (setf matchings (fix-up matchings package-matching))
+		    (setf matchings (convert matchings package-name symbol-normalizer))
+		    (setf symbols   (concatenate 'vector symbols matchings)))
+		  finally ; CONVERT is destructive. So we have to do this at last.
+		  (when (string= parsed-name "")
+		    (setf packages (convert found-packages nil package-normalizer))))))
+	;; Sort alphabetically before sorting by score. (Especially useful when
+	;; PARSED-NAME is empty, and all possible completions are to be returned.)
+	(setf results (concatenate 'vector symbols packages))
+	(setf results (sort results #'string-lessp :key #'first))
+	(setf results (stable-sort results #'> :key #'second))
+	results))))
+
 
 (defun fuzzy-find-matching-symbols (string package &key external-only time-limit-in-msec)
-  "Returns a vector of fuzzy matchings (that is a list of the symbol in
-PACKAGE that's matching STRING, its score, and a list of its completion
-chunks), using the fuzzy completion algorithm. If EXTERNAL-ONLY is true,
-only external symbols are considered."
+  "Returns a vector of fuzzy matchings for matching symbols in PACKAGE, 
+using the fuzzy completion algorithm. If EXTERNAL-ONLY is true, only 
+external symbols are considered."
   (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
         (converter (completion-output-symbol-converter string))
         (time-limit (if time-limit-in-msec
@@ -3607,7 +3704,7 @@
     (declare (type function converter))
     (flet ((time-exhausted-p ()
              (and (not (zerop time-limit))
-                  (zerop (mod count 256))  ; ease up on calling get-universal-time like crazy
+                  (zerop (mod count 256)) ; ease up on calling get-universal-time like crazy
                   (incf count)
                   (>= (- (get-universal-time) utime-at-start) time-limit)))
            (perform-fuzzy-match (string symbol-name)
@@ -3618,17 +3715,19 @@
           (do-symbols* (symbol package)
             (when (time-exhausted-p) (return-from loop))
             (when (or (not external-only) (symbol-external-p symbol package))
-              (if (string= "" string)
-                  (vector-push-extend (list symbol 0.0 (list (list 0 ""))) completions)
+	      (if (string= "" string)
+                  (vector-push-extend (make-fuzzy-matching symbol 0.0 '() '())
+				      completions) ; create vanilla matching.
                   (multiple-value-bind (match-result score)
                       (perform-fuzzy-match string (symbol-name symbol))
                     (when match-result
-                      (vector-push-extend (list symbol score match-result) completions)))))))))))
+                      (vector-push-extend (make-fuzzy-matching symbol score '() match-result)
+					  completions)))))))))))
+
 
 (defun fuzzy-find-matching-packages (name)
-  "Returns a vector of relevant fuzzy matchings (that is a list 
-consisting of a symbol representing the package that matches NAME,
-its score, and its completions chunks.)"
+  "Returns a vector of fuzzy matchings for each package that
+is similiar to NAME."
   (let ((converter (completion-output-package-converter name))
         (completions (make-array 32 :adjustable t :fill-pointer 0)))
     (declare ;;(optimize (speed 3))
@@ -3641,14 +3740,12 @@
           for (result score) = (multiple-value-list            ;  too invasive.
                                    (compute-highest-scoring-completion
                                     name converted-name))
-          ;; We return a symbol that represents the package, a) to make
-          ;; the type of the returned value consistent with the one of
-          ;; FUZZY-FIND-MATCHING-SYMBOLS, and b) to be able to call
-          ;; CLASSIFY-SYMBOL upon it later on.
-          when result do
-          (vector-push-extend (list package-symbol score result) completions))
+          when result do (vector-push-extend
+			   (make-fuzzy-matching package-symbol score result '())
+			   completions))
     completions))
 
+
 (defslimefun fuzzy-completion-selected (original-string completion)
   "This function is called by Slime when a fuzzy completion is
 selected by the user.  It is for future expansion to make
@@ -3662,6 +3759,7 @@
   (declare (ignore original-string completion))
   nil)
 
+
 ;;;;; Fuzzy completion core
 
 (defparameter *fuzzy-recursion-soft-limit* 30
@@ -3773,6 +3871,7 @@
           (push rev-chunks *all-chunks*)
           rev-chunks))))
 
+
 ;;;;; Fuzzy completion scoring
 
 (defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<"
--- /project/slime/cvsroot/slime/swank-backend.lisp	2007/02/25 18:19:55	1.114
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2007/04/08 11:21:45	1.115
@@ -39,6 +39,7 @@
            #:label-value-line
            #:label-value-line*
            #:type-for-emacs
+           #:with-struct
            ))
 
 (defpackage :swank-mop
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:17:13	1.1093
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:21:45	1.1094
@@ -1,5 +1,49 @@
 2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp: Making fuzzy completion semantically right from a
+	user perspective. As an example on SBCL, "sb:with- C-c M-i" will
+	display all exported "with"-style macros in all sb-* packages from
+	now on. :)
+
+	(parse-completion-arguments): Replacing with a semantically-sound
+	implementation, as the previous one was a bit confused. Clarifying
+	docstring. Adding commentary table of various constellations of
+	returned values for thorough explanation.
+
+	(carefully-find-package): Removed. Obsolete by above change.
+
+	(defstruct fuzzy-matching): Introduced to make internally-used
+	datastructure explicit. Distinguishing ``completion chunks''
+	between those pertaining to the symbol itself and those to the
+	package identifier.
+
+	(convert-fuzzy-completion-result): Renamed to
+	FUZZY-CONVERT-MATCHING-FOR-EMACS.
+
+	(fuzzy-convert-matching-for-emacs): Accomodating for the new
+	datastructure. Only the chunks pertaining to the symbol itself are
+	fixed up positionally, the package-chunks are untouched.
+	Necessary for letting package identifiers be highlighted within
+	*Fuzzy Completions* in cases like "sb:with- C-c M-i."
+
+	(fuzzy-completion-set): Taking out most code to become new
+	function FUZZY-CREATE-COMPLETION-SET.
+
+	(fuzzy-create-completion-set): Doing all the hard work. Crux of
+	this changeset. so to speak. Largly rewritten to accomodate all
+	different cases of PARSE-COMPLETION-ARGUMENT.
+
+	(fuzzy-find-matching-symbols, fuzzy-find-matching-packages):
+	Accomodating to new datatstructure FUZZY-MATCHING. Adapting
+	docstring accordingly.
+
+	* swank-backend.lisp: Export WITH-STRUCT.
+	
+	* swank.lisp (eval-for-emacs, fuzzy-completions): 
+	Various trivia like fixing spelling and indentation.
+
+2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* slime.el (slime-fuzzy-highlight-current-completion): Fix
 	off-by-one error that causes the currently selected 
 	completion in the *Fuzzy Completion* buffer be highlighted



From mbaringer at common-lisp.net  Sun Apr  8 11:23:18 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 07:23:18 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408112318.9B6F41A09F@common-lisp.net>

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

Modified Files:
	swank.lisp ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 11:21:45	1.466
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 11:23:17	1.467
@@ -1362,15 +1362,22 @@
 
 ;; FIXME: deal with #\| etc.  hard to do portably.
 (defun tokenize-symbol (string)
+  "STRING is interpreted as the string representation of a symbol
+and is tokenized accordingly. The result is returned in three
+values: The package identifier part, the actual symbol identifier
+part, and a flag if the STRING represents a symbol that is
+internal to the package identifier part. (Notice that the flag is
+also true with an empty package identifier part, as the STRING is
+considered to represent a symbol internal to some current package.)"
   (let ((package (let ((pos (position #\: string)))
                    (if pos (subseq string 0 pos) nil)))
         (symbol (let ((pos (position #\: string :from-end t)))
                   (if pos (subseq string (1+ pos)) string)))
-        (internp (search "::" string)))
+        (internp (not (= (count #\: string) 1))))
     (values symbol package internp)))
 
 (defun tokenize-symbol-thoroughly (string)
-  "This version of tokenize-symbol handles escape characters."
+  "This version of TOKENIZE-SYMBOL handles escape characters."
   (let ((package nil)
         (token (make-array (length string) :element-type 'character
                            :fill-pointer 0))
@@ -1397,7 +1404,7 @@
                                          :fill-pointer 0))))
             (t
              (vector-push-extend (casify-char char) token))))
-    (values token package internp)))
+    (values token package (or (not package) internp))))
 
 (defun casify-char (char)
   "Convert CHAR accoring to readtable-case."
@@ -3333,9 +3340,9 @@
           (sort strings #'string<)))
 
 (defun format-completion-result (string internal-p package-name)
-  (let ((prefix (cond (internal-p (format nil "~A::" package-name))
-                      (package-name (format nil "~A:" package-name))
-                      (t ""))))
+  (let ((prefix (cond ((not package-name) "")
+                      (internal-p (format nil "~A::" package-name))
+                      (t (format nil "~A:" package-name)))))
     (values (concatenate 'string prefix string)
             (length prefix))))
 
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:21:45	1.1094
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:23:17	1.1095
@@ -1,5 +1,19 @@
 2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp (tokenize-symbol, tokenize-symbol-thoroughly):
+	Previously these functions said a string representing a symbol is
+	internal exactly if it contained "::" as substring. Now they say
+	additionally so for symbols without any package identifier, as
+	they are internal to am implicit current package. (Otherwise
+	will break fuzzy completion.)
+
+	(tokenize-symbol): Added docstring.
+
+	* swank.lisp (format-completion-result): Fixed formation
+	for the case that PACKAGE-NAME is NIL but INTERNAL-P is T.
+
+2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp: Making fuzzy completion semantically right from a
 	user perspective. As an example on SBCL, "sb:with- C-c M-i" will
 	display all exported "with"-style macros in all sb-* packages from



From mbaringer at common-lisp.net  Sun Apr  8 12:15:26 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 08:15:26 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408121526.3FB3F3E053@common-lisp.net>

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

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


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 11:23:17	1.467
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 12:15:25	1.468
@@ -3498,11 +3498,17 @@
 ;;; through the following docstring.
 
 (defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec)
-  "Return an (optionally limited to LIMIT best results) list of
-fuzzy completions for a symbol designator STRING.  The list will
-be sorted by score, most likely match first.
+"Returns a list of two values:
 
-The result is a list of completion objects, where a completion
+  An (optionally limited to LIMIT best results) list of fuzzy
+  completions for a symbol designator STRING. The list will be
+  sorted by score, most likely match first.
+
+  A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
+  been exhausted during computation. If that parameter's value is
+  NIL or 0, no time limit is assumed.
+
+The main result is a list of completion objects, where a completion
 object is:
 
     (COMPLETED-STRING SCORE (&rest CHUNKS) FLAGS)
@@ -3531,13 +3537,21 @@
   FOO      - Symbols accessible in the buffer package.
   PKG:FOO  - Symbols external in package PKG.
   PKG::FOO - Symbols accessible in package PKG."
-  ;; We may send this as elisp [] arrays to spare a coerce here,
-  ;; but then the network serialization were slower by handling arrays.
-  ;; Instead we limit the number of completions that is transferred
-  ;; (the limit is set from emacs).
-  (coerce (fuzzy-completion-set string default-package-name :limit limit
-                                :time-limit-in-msec time-limit-in-msec)
-          'list))
+  ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
+  ;; to denote an infinite time limit. Internally, we only use NIL for
+  ;; that purpose, to be able to distinguish between "no time limit
+  ;; alltogether" and "current time limit already exhausted." So we've
+  ;; got to canonicalize its value at first:
+  (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec)))
+         (time-limit (if no-time-limit-p nil time-limit-in-msec)))
+    (multiple-value-bind (completion-set interrupted-p)
+        (fuzzy-completion-set string default-package-name :limit limit
+                              :time-limit-in-msec time-limit)
+      ;; We may send this as elisp [] arrays to spare a coerce here,
+      ;; but then the network serialization were slower by handling arrays.
+      ;; Instead we limit the number of completions that is transferred
+      ;; (the limit is set from Emacs.)
+      (list (coerce completion-set 'list) interrupted-p))))
 
 
 ;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
@@ -3547,11 +3561,12 @@
 			   (:predicate   fuzzy-matching-p)
 			   (:constructor %make-fuzzy-matching))
   symbol	    ; The symbol that has been found to match. 
-  score	            ; the higher the better symbol is a match.
+  score	            ; The higher the better symbol is a match.
   package-chunks    ; Chunks pertaining to the package identifier of the symbol.
   symbol-chunks)    ; Chunks pertaining to the symbol's name.
 
 (defun make-fuzzy-matching (symbol score package-chunks symbol-chunks)
+  (declare (inline %make-fuzzy-matching))
   (%make-fuzzy-matching :symbol symbol :score score
 			:package-chunks package-chunks
 			:symbol-chunks symbol-chunks))
@@ -3573,7 +3588,7 @@
             score
             (append package-chunks
 		    (mapcar #'(lambda (chunk)
-				;; fix up chunk positions to account for possible
+				;; Fix up chunk positions to account for possible
 				;; added package identifier.
 				(let ((offset (first chunk)) (string (second chunk)))
 				  (list (+ added-length offset) string))) 
@@ -3601,24 +3616,29 @@
 
 
 (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
-  "Prepares list of completion objects, sorted by SCORE, of fuzzy
-completions of STRING in DEFAULT-PACKAGE-NAME.  If LIMIT is set,
-only the top LIMIT results will be returned."
+  "Returns two values: an array of completion objects, sorted by
+their score, that is how well they are a match for STRING
+according to the fuzzy completion algorithm.  If LIMIT is set,
+only the top LIMIT results will be returned. Additionally, a flag
+is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
+exhausted."
   (check-type (values limit time-limit-in-msec) 
               (or null (integer 0 #.(1- most-positive-fixnum))))
-  (let* ((completion-set (fuzzy-create-completion-set string default-package-name
-						      time-limit-in-msec)))
-        (when (and limit
-                   (> limit 0)
-                   (< limit (length completion-set)))
-          (if (array-has-fill-pointer-p completion-set)
-              (setf (fill-pointer completion-set) limit)
-              (setf completion-set (make-array limit :displaced-to completion-set))))
-    completion-set))
+  (multiple-value-bind (completion-set interrupted-p)
+      (fuzzy-create-completion-set string default-package-name
+                                   time-limit-in-msec)
+    (when (and limit
+               (> limit 0)
+               (< limit (length completion-set)))
+      (if (array-has-fill-pointer-p completion-set)
+          (setf (fill-pointer completion-set) limit)
+          (setf completion-set (make-array limit :displaced-to completion-set))))
+    (values completion-set interrupted-p)))
 
 
 (defun fuzzy-create-completion-set (string default-package-name time-limit-in-msec)
-  "Does all the hard work for FUZZY-COMPLETION-SET."
+  "Does all the hard work for FUZZY-COMPLETION-SET. If
+TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
   (multiple-value-bind (parsed-name parsed-package-name package internal-p)
       (parse-completion-arguments string default-package-name)
     (flet ((convert (matchings package-name &optional converter)
@@ -3633,7 +3653,7 @@
 		       matchings))
 	   (fix-up (matchings parent-package-matching)
 	     ;; The components of each matching in MATCHINGS have been computed
-	     ;; relative to PARENT-PACKAGE-MATCHING. Make them absolute.
+	     ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
 	     (let* ((p parent-package-matching)
 		    (p.score  (fuzzy-matching.score p))
 		    (p.chunks (fuzzy-matching.package-chunks p)))
@@ -3643,114 +3663,151 @@
 			       (setf (fuzzy-matching.package-chunks m) p.chunks)
 			       (setf (fuzzy-matching.score m)
 				     (if (string= parsed-name "")
-					 ;; (make packages be sorted before their symbol
-					 ;; matchings while preserving over all orderness
-					 ;; among different symbols in different packages)
+					 ;; (Make package matchings be sorted before all the
+                                         ;; relative symbol matchings while preserving over
+					 ;; all orderness.)
 					 (/ p.score 100)        
 					 (+ p.score m.score)))
 			       m))
 			 matchings)))
-	   (find-matchings (designator package)
+	   (find-symbols (designator package time-limit)
 	     (fuzzy-find-matching-symbols designator package
-					  :time-limit-in-msec time-limit-in-msec
-					  :external-only (not internal-p))))
+					  :time-limit-in-msec time-limit
+					  :external-only (not internal-p)))
+           (find-packages (designator time-limit)
+             (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit)))
       (let ((symbol-normalizer  (completion-output-symbol-converter string))
 	    (package-normalizer #'(lambda (package-name)
 				    (let ((converter (completion-output-package-converter string)))
 				      ;; Present packages with a trailing colon for maximum convenience!
 				      (concatenate 'string (funcall converter package-name) ":"))))
-	    (symbols) (packages) (results))
-	(cond ((not parsed-package-name)        ; STRING = "asd"
+            (time-limit time-limit-in-msec) (symbols) (packages) (results))
+	(cond ((not parsed-package-name)        ; E.g. STRING = "asd"
 	       ;; We don't know if user is searching for a package or a symbol
 	       ;; within his current package. So we try to find either.
-	       (setf symbols  (find-matchings parsed-name package)
-		     symbols  (convert symbols nil symbol-normalizer)
-		     packages (fuzzy-find-matching-packages parsed-name)
-		     packages (convert packages nil package-normalizer)))
-	      ((string= parsed-package-name "") ; STRING = ":" or ":foo"
-	       (setf symbols (find-matchings parsed-name package)
-		     symbols (convert symbols "" symbol-normalizer)))
-	      (t	                        ; STRING= "asdf:" or "asdf:foo"
+	       (setf (values packages time-limit) (find-packages parsed-name time-limit))
+               (setf (values symbols  time-limit) (find-symbols parsed-name package time-limit))
+               (setf symbols  (convert symbols nil symbol-normalizer))
+               (setf packages (convert packages nil package-normalizer)))
+	      ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
+	       (setf (values symbols time-limit) (find-symbols parsed-name package time-limit))
+               (setf symbols (convert symbols "" symbol-normalizer)))
+	      (t	                        ; E.g. STRING = "asdf:" or "asdf:foo"
 	       ;; Find fuzzy matchings of the denoted package identifier part.
-	       ;; After that find matchings for the denoted symbol identifier
-	       ;; relative to all those packages found.
-	       (loop
-		  with found-packages = (fuzzy-find-matching-packages parsed-package-name)
-		  for package-matching across found-packages
-		  do
-		  (let* ((pkgsym       (fuzzy-matching.symbol package-matching))
-			 (package-name (symbol-name pkgsym))
-			 (package-name (funcall symbol-normalizer package-name))
-			 (matchings (find-matchings parsed-name (find-package pkgsym))))
-		    (setf matchings (fix-up matchings package-matching))
-		    (setf matchings (convert matchings package-name symbol-normalizer))
-		    (setf symbols   (concatenate 'vector symbols matchings)))
-		  finally ; CONVERT is destructive. So we have to do this at last.
-		  (when (string= parsed-name "")
-		    (setf packages (convert found-packages nil package-normalizer))))))
+	       ;; After that, find matchings for the denoted symbol identifier
+	       ;; relative to all the packages found.
+               (multiple-value-bind (found-packages rest-time-limit)
+                   (find-packages parsed-package-name time-limit-in-msec)
+                 (loop
+                    for package-matching across found-packages
+                    for package-sym  = (fuzzy-matching.symbol package-matching)
+                    for package-name = (funcall symbol-normalizer (symbol-name package-sym))
+                    for package      = (find-package package-sym)
+                    while (or (not time-limit) (> rest-time-limit 0)) do
+                      (multiple-value-bind (matchings remaining-time)
+                          (find-symbols parsed-name package rest-time-limit)
+                        (setf matchings (fix-up matchings package-matching))
+                        (setf matchings (convert matchings package-name symbol-normalizer))
+                        (setf symbols   (concatenate 'vector symbols matchings))
+                        (setf rest-time-limit remaining-time))
+                    finally ; CONVERT is destructive. So we have to do this at last.
+                      (setf time-limit rest-time-limit)
+                      (setf packages (when (string= parsed-name "")
+                                       (convert found-packages nil package-normalizer)))))))
 	;; Sort alphabetically before sorting by score. (Especially useful when
 	;; PARSED-NAME is empty, and all possible completions are to be returned.)
 	(setf results (concatenate 'vector symbols packages))
-	(setf results (sort results #'string-lessp :key #'first))
-	(setf results (stable-sort results #'> :key #'second))
-	results))))
+	(setf results (sort results #'string< :key #'first))  ; SORT + #'STRING-LESSP
+	(setf results (stable-sort results #'> :key #'second));  conses on at least SBCL.
+	(values results (and time-limit (<= time-limit 0)))))))
+
+
+(defun get-real-time-in-msecs ()
+  (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
+    (values (floor (get-internal-real-time) units-per-msec)))) ; return just one value!
 
 
 (defun fuzzy-find-matching-symbols (string package &key external-only time-limit-in-msec)
-  "Returns a vector of fuzzy matchings for matching symbols in PACKAGE, 
-using the fuzzy completion algorithm. If EXTERNAL-ONLY is true, only 
-external symbols are considered."
-  (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
-        (converter (completion-output-symbol-converter string))
-        (time-limit (if time-limit-in-msec
-                        (ceiling (/ time-limit-in-msec 1000))
-                        0))
-        (utime-at-start (get-universal-time))
+  "Returns two values: a vector of fuzzy matchings for matching
+symbols in PACKAGE, using the fuzzy completion algorithm; the
+remaining time limit. 
+
+If EXTERNAL-ONLY is true, only external symbols are considered. A
+TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
+negative, perform a NOP."
+  (let ((time-limit-p (and time-limit-in-msec t))
+        (time-limit (or time-limit-in-msec 0))
+        (rtime-at-start (get-real-time-in-msecs))
         (count 0))
-    (declare (type (integer 0 #.(1- most-positive-fixnum)) count time-limit))
-    (declare (type function converter))
-    (flet ((time-exhausted-p ()
-             (and (not (zerop time-limit))
-                  (zerop (mod count 256)) ; ease up on calling get-universal-time like crazy
-                  (incf count)
-                  (>= (- (get-universal-time) utime-at-start) time-limit)))
+    (declare (type boolean time-limit-p))
+    (declare (type integer time-limit rtime-at-start))
+    (declare (type (integer 0 #.(1- most-positive-fixnum)) count))
+
+    (flet ((recompute-remaining-time (old-remaining-time)
+             (cond ((not time-limit-p)
+                    (values nil nil)) ; propagate NIL back as infinite time limit.
+                   ((> count 0)       ; ease up on getting internal time like crazy.
+                    (setf count (mod (1+ count) 128))
+                    (values nil old-remaining-time))
+                   (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))
+                             (remaining (- time-limit elapsed-time)))
+                        (values (<= remaining 0) remaining)))))
            (perform-fuzzy-match (string symbol-name)
-             (let ((converted-symbol-name (funcall converter symbol-name)))
+             (let* ((converter (completion-output-symbol-converter string))
+                    (converted-symbol-name (funcall converter symbol-name)))
                (compute-highest-scoring-completion string converted-symbol-name))))
-      (prog1 completions
+      (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
+            (rest-time-limit time-limit))
         (block loop
           (do-symbols* (symbol package)
-            (when (time-exhausted-p) (return-from loop))
-            (when (or (not external-only) (symbol-external-p symbol package))
-	      (if (string= "" string)
-                  (vector-push-extend (make-fuzzy-matching symbol 0.0 '() '())
-				      completions) ; create vanilla matching.
-                  (multiple-value-bind (match-result score)
-                      (perform-fuzzy-match string (symbol-name symbol))
-                    (when match-result
-                      (vector-push-extend (make-fuzzy-matching symbol score '() match-result)
-					  completions)))))))))))
-
-
-(defun fuzzy-find-matching-packages (name)
-  "Returns a vector of fuzzy matchings for each package that
-is similiar to NAME."
-  (let ((converter (completion-output-package-converter name))
+            (multiple-value-bind (exhausted? remaining-time)
+                (recompute-remaining-time rest-time-limit)
+              (setf rest-time-limit remaining-time)
+              (cond (exhausted? (return-from loop))
+                    ((or (not external-only) (symbol-external-p symbol package))
+                     (if (string= "" string) ; "" matchs always
+                         (vector-push-extend (make-fuzzy-matching symbol 0.0 '() '())
+                                             completions)
+                         (multiple-value-bind (match-result score)
+                             (perform-fuzzy-match string (symbol-name symbol))
+                           (when match-result
+                             (vector-push-extend
+                              (make-fuzzy-matching symbol score '() match-result)
+                              completions)))))))))
+        (values completions rest-time-limit)))))
+
+
+(defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
+  "Returns a vector of fuzzy matchings for each package that is
+similiar to NAME, and the remaining time limit. 
+Cf. FUZZY-FIND-MATCHING-SYMBOLS."
+  (let ((time-limit-p (and time-limit-in-msec t))
+        (time-limit (or time-limit-in-msec 0))
+        (rtime-at-start (get-real-time-in-msecs))
+        (converter (completion-output-package-converter name))
         (completions (make-array 32 :adjustable t :fill-pointer 0)))
-    (declare ;;(optimize (speed 3))
-             (type function converter))  
-    (loop for package in (list-all-packages)
-          for package-name   = (package-name package)
-          for converted-name = (funcall converter package-name)
-          for package-symbol = (or (find-symbol package-name)
-                                   (make-symbol package-name)) ; INTERN'd be
-          for (result score) = (multiple-value-list            ;  too invasive.
-                                   (compute-highest-scoring-completion
-                                    name converted-name))
-          when result do (vector-push-extend
-			   (make-fuzzy-matching package-symbol score result '())
-			   completions))
-    completions))
+    (declare (type boolean time-limit-p))
+    (declare (type integer time-limit rtime-at-start))
+    (declare (type function converter))
+    (if (and time-limit (<= time-limit 0))
+        (values #() time-limit)
+        (loop for package in (list-all-packages)
+              for package-name   = (package-name package)
+              for converted-name = (funcall converter package-name)
+              for package-symbol = (or (find-symbol package-name)
+                                       (make-symbol package-name)) ; INTERN'd be
+              for (result score) = (multiple-value-list            ;  too invasive.
+                                     (compute-highest-scoring-completion
+                                       name converted-name))
+              when result do (vector-push-extend
+                               (make-fuzzy-matching package-symbol score result '())
+                               completions)
+              finally
+                (return
+                  (values completions
+                          (and time-limit-p
+                               (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)))
+                                 (- time-limit elapsed-time)))))))))
 
 
 (defslimefun fuzzy-completion-selected (original-string completion)
--- /project/slime/cvsroot/slime/slime.el	2007/04/08 11:17:13	1.777
+++ /project/slime/cvsroot/slime/slime.el	2007/04/08 12:15:25	1.778
@@ -6306,6 +6306,10 @@
 (defvar slime-fuzzy-first nil
   "The position of the first completion in the completions buffer.
 The descriptive text and headers are above this.")
+(defvar slime-fuzzy-last nil
+    "The position of the last completion in the completions buffer.
+If the time limit has exhausted during generation possible completion
+choices inside SWANK, an indication is printed below this.")
 (defvar slime-fuzzy-current-completion nil
   "The current completion object.  If this is the same before and
 after point moves in the completions buffer, the text is not
@@ -6466,24 +6470,25 @@
         (comint-dynamic-complete-as-filename))))
   (let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
          (beg (move-marker (make-marker) (slime-symbol-start-pos)))
-         (prefix (buffer-substring-no-properties beg end))
-         (completion-set (slime-fuzzy-completions prefix)))
-    (if (null completion-set)
-        (progn (slime-minibuffer-respecting-message
-                "Can't find completion for \"%s\"" prefix)
-               (ding)
-               (slime-fuzzy-done))
-      (goto-char end)
-      (cond ((= (length completion-set) 1)
-             (insert-and-inherit (caar completion-set)) ; insert completed string
-             (delete-region beg end)
-             (goto-char (+ beg (length (caar completion-set))))
-             (slime-minibuffer-respecting-message "Sole completion")
-             (slime-fuzzy-done))
-            ;; Incomplete
-            (t
-             (slime-minibuffer-respecting-message "Complete but not unique")
-             (slime-fuzzy-choices-buffer completion-set beg end))))))
+         (prefix (buffer-substring-no-properties beg end)))
+    (destructuring-bind (completion-set interrupted-p)
+        (slime-fuzzy-completions prefix)
+      (if (null completion-set)
+          (progn (slime-minibuffer-respecting-message
+                  "Can't find completion for \"%s\"" prefix)
+                 (ding)
+                 (slime-fuzzy-done))
+          (goto-char end)
+          (cond ((null (cdr completion-set)) ; (= (length completion-set) 1)
+                 (insert-and-inherit (caar completion-set)) ; insert completed string
+                 (delete-region beg end)
+                 (goto-char (+ beg (length (caar completion-set))))
+                 (slime-minibuffer-respecting-message "Sole completion")
+                 (slime-fuzzy-done))
+                ;; Incomplete
+                (t
+                 (slime-minibuffer-respecting-message "Complete but not unique")
+                 (slime-fuzzy-choices-buffer completion-set interrupted-p beg end)))))))
 
 
 (defun slime-get-fuzzy-buffer ()
@@ -6549,7 +6554,7 @@
       (setq slime-fuzzy-text text)
       (goto-char slime-fuzzy-end)))))
 
-(defun slime-fuzzy-choices-buffer (completions start end)
+(defun slime-fuzzy-choices-buffer (completions interrupted-p start end)
   "Creates (if neccessary), populates, and pops up the *Fuzzy
 Completions* buffer with the completions from `completions' and
 the completion slot in the current buffer bounded by `start' and
@@ -6566,7 +6571,7 @@
     (set-marker-insertion-type slime-fuzzy-end t)
     (setq slime-fuzzy-original-text (buffer-substring start end))
     (setq slime-fuzzy-text slime-fuzzy-original-text)
-    (slime-fuzzy-fill-completions-buffer completions)
+    (slime-fuzzy-fill-completions-buffer completions interrupted-p)
     (pop-to-buffer (slime-get-fuzzy-buffer))
     (when new-completion-buffer
       (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort))
@@ -6574,7 +6579,7 @@
       ;; switch back to the original buffer
       (switch-to-buffer-other-window slime-fuzzy-target-buffer))))
 
-(defun slime-fuzzy-fill-completions-buffer (completions)
+(defun slime-fuzzy-fill-completions-buffer (completions interrupted-p)
   "Erases and fills the completion buffer with the given completions."
   (with-current-buffer (slime-get-fuzzy-buffer)
     (setq buffer-read-only nil)
@@ -6584,6 +6589,7 @@
     (let ((max-length 12))
       (dolist (completion completions)
         (setf max-length (max max-length (length (first completion)))))
+
       (insert "Completion:")
       (dotimes (i (- max-length 10)) (insert " "))
       ;;     Flags:  Score:
@@ -6593,8 +6599,15 @@
       (dotimes (i max-length) (insert "-"))
       (insert " ------- --------\n")
       (setq slime-fuzzy-first (point))
+
       (dolist (completion completions)
+        (setq slime-fuzzy-last (point)) ; will eventually become the last entry
         (slime-fuzzy-insert-completion-choice completion max-length))
+
+      (when interrupted-p
+        (insert "...\n")
+        (insert "[Interrupted: time limit exhausted]"))
+
       (setq buffer-read-only t))
     (setq slime-fuzzy-current-completion
           (caar completions))
@@ -6645,9 +6658,7 @@
   (interactive)
   (with-current-buffer (slime-get-fuzzy-buffer)
     (slime-fuzzy-dehighlight-current-completion)
-    (let ((point (next-single-char-property-change (point) 'completion)))
-      (when (= point (point-max))
-        (setf point (previous-single-char-property-change (point-max) 'completion nil slime-fuzzy-first)))
+    (let ((point (next-single-char-property-change (point) 'completion nil slime-fuzzy-last)))
       (set-window-point (get-buffer-window (current-buffer)) point)
       (goto-char point))
     (slime-fuzzy-highlight-current-completion)))
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 11:23:17	1.1095
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 12:15:25	1.1096
@@ -1,5 +1,39 @@
 2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp: Making fuzzy completion regard the time limit
+	correctly. Also make it properly use microseconds as time
+	granularity and inform the Emacs side if the time limit has
+	exhausted. Additionally, over all minor and cosmetic changes:
+
+	(fuzzy-completions, fuzzy-completion-set): Returns now
+	additionally a flag indicating whether the time limit has
+	exhausted under the hood. Accomodated docstring accordingly.
+
+	(fuzzy-create-completion-set): Changed to correctly catch and
+	propagate the remaining time limit to the actual match functions,
+	and return once time limit has exhausted. Some aesthetical code 
+	reorganization.
+
+	(get-real-time-in-msecs): New function. 
+
+	(fuzzy-find-matching-symbols, fuzzy-find-matching-packages):
+	Correctly regard the time limit. Use new function
+	GET-REAL-TIME-IN-MSECS for that purpose. Return the remaining
+	time limit as second value.
+
+	* slime.el (slime-fuzzy-complete-symbol): Accomodated to deal with
+	the additionally returned flag of SWANK:FUZZY-COMPLETIONS. Pass
+	the flag by.
+	(slime-fuzzy-choices-buffer): Pass interruption flag by.
+	(slime-fuzzy-fill-completions-buffer): If time limit has exhausted
+	during completion retrieval, show an informational indication as
+	last entry in *Fuzzy Completion*.
+	(slime-fuzzy-last): New variable. To hold the last real completion
+	choice previous to the (possible) Time Limit Exhausted information.
+	(slime-fuzzy-next): Accomodated to not go beneath SLIME-FUZZY-LAST.
+	
+2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (tokenize-symbol, tokenize-symbol-thoroughly):
 	Previously these functions said a string representing a symbol is
 	internal exactly if it contained "::" as substring. Now they say



From mbaringer at common-lisp.net  Sun Apr  8 12:19:32 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 08:19:32 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408121932.6B0334B028@common-lisp.net>

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

Modified Files:
	swank.lisp ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 12:15:25	1.468
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 12:19:31	1.469
@@ -3622,8 +3622,8 @@
 only the top LIMIT results will be returned. Additionally, a flag
 is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
 exhausted."
-  (check-type (values limit time-limit-in-msec) 
-              (or null (integer 0 #.(1- most-positive-fixnum))))
+  (check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
+  (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum))))
   (multiple-value-bind (completion-set interrupted-p)
       (fuzzy-create-completion-set string default-package-name
                                    time-limit-in-msec)
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 12:15:25	1.1096
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 12:19:31	1.1097
@@ -1,3 +1,10 @@
+2007-04-08  Marco Baringer <mb at bese.it>
+
+	* swank.lisp (fuzzy-completion-set): Use two check-type forms
+	instead of a place like (values limit time-limit-in-msec). While
+	sbcl seems to accept this form openmcl doesn't and it's not clear
+	from the spec that this is allowed.
+
 2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp: Making fuzzy completion regard the time limit



From mbaringer at common-lisp.net  Sun Apr  8 12:52:19 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 08:52:19 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408125219.6804E2D16E@common-lisp.net>

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

Modified Files:
	slime.el ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/slime.el	2007/04/08 12:15:25	1.778
+++ /project/slime/cvsroot/slime/slime.el	2007/04/08 12:52:18	1.779
@@ -8170,6 +8170,7 @@
   ((kbd "RET") 'sldb-default-action)
   ("\C-m"      'sldb-default-action)
   ([mouse-2]  'sldb-default-action/mouse)
+  ([follow-link] 'mouse-face)
   ("e"    'sldb-eval-in-frame)
   ("d"    'sldb-pprint-eval-in-frame)
   ("D"    'sldb-disassemble)
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 12:19:31	1.1097
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 12:52:18	1.1098
@@ -1,3 +1,7 @@
+2007-04-07 Harald Hanche-Olsen <hanche at math.ntnu.no>
+
+	* slime.el (sldb-mode-map): Added key definition for follow-link.
+
 2007-04-08  Marco Baringer <mb at bese.it>
 
 	* swank.lisp (fuzzy-completion-set): Use two check-type forms



From mbaringer at common-lisp.net  Sun Apr  8 13:29:14 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 09:29:14 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408132914.0965C2B119@common-lisp.net>

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

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


--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/04/06 15:42:42	1.116
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/04/08 13:29:13	1.117
@@ -321,11 +321,43 @@
                )))))))
 
 (defun xref-locations (relation name &optional (inverse nil))
-  (loop for xref in (if inverse 
-                        (ccl::get-relation  relation name :wild :exhaustive t)
-                        (ccl::get-relation  relation :wild name :exhaustive t))
-        for function = (ccl::xref-entry-name xref)
-        collect `((function ,function) ,(function-source-location (ccl::xref-entry-name xref)))))
+  (flet ((function-source-location (entry)
+           (multiple-value-bind (info name)
+               (ccl::edit-definition-p
+                (ccl::%db-key-from-xref-entry entry)
+                (if (eql (ccl::xref-entry-type entry)
+                         'macro)
+                    'function
+                    (ccl::xref-entry-type entry)))
+             (cond ((not info)
+                    (list :error
+                          (format nil "No source info available for ~A"
+                                  (ccl::xref-entry-name entry))))
+                   ((typep (caar info) 'ccl::method)
+                    `(:location 
+                      (:file ,(remove-filename-quoting
+                               (namestring (translate-logical-pathname
+                                            (cdr (car info))))))
+                      (:method
+                          ,(princ-to-string (ccl::method-name (caar info)))
+                        ,(mapcar 'princ-to-string
+                                 (mapcar #'specializer-name
+                                         (ccl::method-specializers
+                                          (caar info))))
+                        ,@(mapcar 'princ-to-string
+                                  (ccl::method-qualifiers (caar info))))
+                      nil))
+                   (t
+                    (canonicalize-location (cdr (first info)) name))))))
+    (declare (dynamic-extent #'function-source-location))
+    (loop for xref in (if inverse 
+                          (ccl::get-relation relation name
+                                             :wild :exhaustive t)
+                          (ccl::get-relation relation
+                                             :wild name :exhaustive t))
+       for function = (ccl::xref-entry-name xref)
+       collect `((function ,function)
+                 ,(function-source-location xref)))))
 
 (defimplementation who-binds (name)
   (xref-locations :binds name))
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 12:52:18	1.1098
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 13:29:13	1.1099
@@ -1,3 +1,7 @@
+2007-04-08 Takehiko Abe <keke at gol.com>
+
+	* swank-openmcl.lisp (xref-locations):
+	
 2007-04-07 Harald Hanche-Olsen <hanche at math.ntnu.no>
 
 	* slime.el (sldb-mode-map): Added key definition for follow-link.



From mbaringer at common-lisp.net  Sun Apr  8 14:02:37 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 10:02:37 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408140237.C1B28671C8@common-lisp.net>

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

Modified Files:
	swank.lisp swank-clisp.lisp swank-backend.lisp ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 12:19:31	1.469
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 14:02:37	1.470
@@ -2817,7 +2817,7 @@
 
 (defun debug-in-emacs (condition)
   (let ((*swank-debugger-condition* condition)
-        (*sldb-restarts* (compute-restarts condition))
+        (*sldb-restarts* (compute-sane-restarts condition))
         (*package* (or (and (boundp '*buffer-package*)
                             (symbol-value '*buffer-package*))
                        *package*))
@@ -2826,14 +2826,14 @@
         (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
     (force-user-output)
     (call-with-debugging-environment
-     (lambda () 
+     (lambda ()
        (with-bindings *sldb-printer-bindings*
          (sldb-loop *sldb-level*))))))
 
 (defun sldb-loop (level)
   (unwind-protect
        (catch 'sldb-enter-default-debugger
-         (send-to-emacs 
+         (send-to-emacs
           (list* :debug (current-thread) level
                  (debugger-info-for-emacs 0 *sldb-initial-frames*)))
          (loop (catch 'sldb-loop-catcher
--- /project/slime/cvsroot/slime/swank-clisp.lisp	2007/01/12 15:12:23	1.62
+++ /project/slime/cvsroot/slime/swank-clisp.lisp	2007/04/08 14:02:37	1.63
@@ -1,3 +1,5 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
 ;;;; SWANK support for CLISP.
 
 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
@@ -47,20 +49,20 @@
     (and (find-package :clos)
          (eql :external
               (nth-value 1 (find-symbol (string ':standard-slot-definition)
-					:clos))))
+                                        :clos))))
     "True in those CLISP images which have a complete MOP implementation."))
 
 #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
 (progn
   (import-swank-mop-symbols :clos '(:slot-definition-documentation))
-  
+
   (defun swank-mop:slot-definition-documentation (slot)
     (clos::slot-definition-documentation slot)))
 
 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
 (defclass swank-mop:standard-slot-definition ()
   ()
-  (:documentation 
+  (:documentation
    "Dummy class created so that swank.lisp will compile and load."))
 
 ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
@@ -68,15 +70,15 @@
 ;;   (defmacro with-blocked-signals ((&rest signals) &body body)
 ;;     (ext:with-gensyms ("SIGPROCMASK" ret mask)
 ;;       `(multiple-value-bind (,ret ,mask)
-;; 	   (linux:sigprocmask-set-n-save
-;; 	    ,linux:SIG_BLOCK
-;; 	    ,(do ((sigset (linux:sigset-empty)
-;; 			  (linux:sigset-add sigset (the fixnum (pop signals)))))
-;; 		 ((null signals) sigset)))
-;; 	 (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
-;; 	 (unwind-protect
-;; 	      (progn , at body)
-;; 	   (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
+;;            (linux:sigprocmask-set-n-save
+;;             ,linux:SIG_BLOCK
+;;             ,(do ((sigset (linux:sigset-empty)
+;;                           (linux:sigset-add sigset (the fixnum (pop signals)))))
+;;                  ((null signals) sigset)))
+;;          (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
+;;          (unwind-protect
+;;               (progn , at body)
+;;            (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
 
 ;;   (defimplementation call-without-interrupts (fn)
 ;;     (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
@@ -86,11 +88,11 @@
   (funcall fn))
 
 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
-		  ;; old name prior to 2005-03-01, clisp <= 2.33.2
-		  (find-symbol "PROGRAM-ID" :system)
-		  #+win32 ; integrated into the above since 2005-02-24
-		  (and (find-package :win32) ; optional modules/win32
-		       (find-symbol "GetCurrentProcessId" :win32)))))
+                  ;; old name prior to 2005-03-01, clisp <= 2.33.2
+                  (find-symbol "PROGRAM-ID" :system)
+                  #+win32 ; integrated into the above since 2005-02-24
+                  (and (find-package :win32) ; optional modules/win32
+                       (find-symbol "GetCurrentProcessId" :win32)))))
   (defimplementation getpid () ; a required interface
     (cond
       (getpid (funcall getpid))
@@ -104,8 +106,7 @@
   (setf (ext:default-directory) directory)
   (namestring (setf *default-pathname-defaults* (ext:default-directory))))
 
-
-;;; TCP Server
+;;;; TCP Server
 
 (defimplementation create-socket (host port)
   (declare (ignore host))
@@ -116,21 +117,21 @@
 
 (defimplementation close-socket (socket)
   (socket:socket-server-close socket))
-  
+
 (defimplementation accept-connection (socket
-				      &key external-format buffering timeout)
+                                      &key external-format buffering timeout)
   (declare (ignore buffering timeout))
   (socket:socket-accept socket
-			:buffered nil ;; XXX should be t
-			:element-type 'character
-			:external-format external-format))
+                        :buffered nil ;; XXX should be t
+                        :element-type 'character
+                        :external-format external-format))
 
-;;; Coding systems
+;;;; Coding systems
 
 (defvar *external-format-to-coding-system*
-  '(((:charset "iso-8859-1" :line-terminator :unix) 
+  '(((:charset "iso-8859-1" :line-terminator :unix)
      "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
-    ((:charset "iso-8859-1":latin-1) 
+    ((:charset "iso-8859-1":latin-1)
      "latin-1" "iso-latin-1" "iso-8859-1")
     ((:charset "utf-8") "utf-8")
     ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
@@ -140,22 +141,22 @@
     ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
 
 (defimplementation find-external-format (coding-system)
-  (let ((args (car (rassoc-if (lambda (x) 
-				(member coding-system x :test #'equal))
-			      *external-format-to-coding-system*))))
+  (let ((args (car (rassoc-if (lambda (x)
+                                (member coding-system x :test #'equal))
+                              *external-format-to-coding-system*))))
     (and args (apply #'ext:make-encoding args))))
 
 
-;;; Swank functions
+;;;; Swank functions
 
 (defimplementation arglist (fname)
   (block nil
     (or (ignore-errors
-	  (let ((exp (function-lambda-expression fname)))
-	    (and exp (return (second exp)))))
-	(ignore-errors 
-	  (return (ext:arglist fname)))
-	:not-available)))
+          (let ((exp (function-lambda-expression fname)))
+            (and exp (return (second exp)))))
+        (ignore-errors
+          (return (ext:arglist fname)))
+        :not-available)))
 
 (defimplementation macroexpand-all (form)
   (ext:expand-form form))
@@ -165,43 +166,43 @@
 Return NIL if the symbol is unbound."
   (let ((result ()))
     (flet ((doc (kind)
-	     (or (documentation symbol kind) :not-documented))
-	   (maybe-push (property value)
-	     (when value
-	       (setf result (list* property value result)))))
+             (or (documentation symbol kind) :not-documented))
+           (maybe-push (property value)
+             (when value
+               (setf result (list* property value result)))))
       (maybe-push :variable (when (boundp symbol) (doc 'variable)))
       (when (fboundp symbol)
-	(maybe-push
-	 ;; Report WHEN etc. as macros, even though they may be
-	 ;; implemented as special operators.
-	 (if (macro-function symbol) :macro
-	     (typecase (fdefinition symbol)
-	       (generic-function :generic-function)
-	       (function         :function)
-	       ;; (type-of 'progn) -> ext:special-operator
-	       (t                :special-operator)))
-	 (doc 'function)))
+        (maybe-push
+         ;; Report WHEN etc. as macros, even though they may be
+         ;; implemented as special operators.
+         (if (macro-function symbol) :macro
+             (typecase (fdefinition symbol)
+               (generic-function :generic-function)
+               (function         :function)
+               ;; (type-of 'progn) -> ext:special-operator
+               (t                :special-operator)))
+         (doc 'function)))
       (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
-		(get symbol 'system::setf-expander)); defsetf
-	(maybe-push :setf (doc 'setf)))
+                (get symbol 'system::setf-expander)); defsetf
+        (maybe-push :setf (doc 'setf)))
       (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
-		(get symbol 'system::defstruct-description)
-		(get symbol 'system::deftype-expander))
-	(maybe-push :type (doc 'type))) ; even for 'structure
+                (get symbol 'system::defstruct-description)
+                (get symbol 'system::deftype-expander))
+        (maybe-push :type (doc 'type))) ; even for 'structure
       (when (find-class symbol nil)
-	(maybe-push :class (doc 'type)))
+        (maybe-push :class (doc 'type)))
       ;; Let this code work compiled in images without FFI
       (let ((types (load-time-value
-		    (and (find-package "FFI")
-			 (symbol-value 
-			  (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
-	;; Use ffi::*c-type-table* so as not to suffer the overhead of
-	;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
-	;; which are not FFI type names.
-	(when (and types (nth-value 1 (gethash symbol types)))
-	  ;; Maybe use (case (head (ffi:deparse-c-type)))
-	  ;; to distinguish struct and union types?
-	  (maybe-push :alien-type :not-documented)))
+                    (and (find-package "FFI")
+                         (symbol-value
+                          (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
+        ;; Use ffi::*c-type-table* so as not to suffer the overhead of
+        ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
+        ;; which are not FFI type names.
+        (when (and types (nth-value 1 (gethash symbol types)))
+          ;; Maybe use (case (head (ffi:deparse-c-type)))
+          ;; to distinguish struct and union types?
+          (maybe-push :alien-type :not-documented)))
       result)))
 
 (defimplementation describe-definition (symbol namespace)
@@ -213,32 +214,32 @@
 
 (defun fspec-pathname (symbol)
   (let ((path (documentation symbol 'sys::file))
-	lines)
+        lines)
     (when (consp path)
       (psetq path (car path)
-	     lines (cdr path)))
+             lines (cdr path)))
     (when (and path
-	       (member (pathname-type path)
-		       custom:*compiled-file-types* :test #'equal))
+               (member (pathname-type path)
+                       custom:*compiled-file-types* :test #'equal))
       (setq path
-	    (loop for suffix in custom:*source-file-types*
-	       thereis (probe-file (make-pathname :defaults path
-						  :type suffix)))))
+            (loop for suffix in custom:*source-file-types*
+               thereis (probe-file (make-pathname :defaults path
+                                                  :type suffix)))))
     (values path lines)))
 
 (defun fspec-location (fspec)
   (multiple-value-bind (file lines)
       (fspec-pathname fspec)
     (cond (file
-	   (multiple-value-bind (truename c) (ignore-errors (truename file))
-	     (cond (truename
-		    (make-location (list :file (namestring truename))
-				   (if (consp lines)
-				       (list* :line lines)
-				       (list :function-name (string fspec)))))
-		   (t (list :error (princ-to-string c))))))
-	  (t (list :error (format nil "No source information available for: ~S"
-				  fspec))))))
+           (multiple-value-bind (truename c) (ignore-errors (truename file))
+             (cond (truename
+                    (make-location (list :file (namestring truename))
+                                   (if (consp lines)
+                                       (list* :line lines)
+                                       (list :function-name (string fspec)))))
+                   (t (list :error (princ-to-string c))))))
+          (t (list :error (format nil "No source information available for: ~S"
+                                  fspec))))))
 
 (defimplementation find-definitions (name)
   (list (list name (fspec-location name))))
@@ -250,13 +251,13 @@
 
 (defimplementation call-with-debugging-environment (debugger-loop-fn)
   (let* (;;(sys::*break-count* (1+ sys::*break-count*))
-	 ;;(sys::*driver* debugger-loop-fn)
-	 ;;(sys::*fasoutput-stream* nil)
-	 (*sldb-backtrace* 
-	  (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
+         ;;(sys::*driver* debugger-loop-fn)
+         ;;(sys::*fasoutput-stream* nil)
+         (*sldb-backtrace*
+          (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
     (funcall debugger-loop-fn)))
 
-(defun nth-frame (index) 
+(defun nth-frame (index)
   (nth index *sldb-backtrace*))
 
 (defun sldb-backtrace ()
@@ -272,7 +273,7 @@
   (member (frame-type frame) '(stack-value bind-var bind-env)))
 
 (defun frame-to-string (frame)
-  (with-output-to-string (s) 
+  (with-output-to-string (s)
     (sys::describe-frame s frame)))
 
 (defun frame-type (frame)
@@ -304,47 +305,54 @@
 
 (defun frame-string-type (string)
   (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
-		  *frame-prefixes*)))
+                  *frame-prefixes*)))
 
 (defimplementation compute-backtrace (start end)
   (let* ((bt *sldb-backtrace*)
-	 (len (length bt)))
+         (len (length bt)))
     (subseq bt start (min (or end len) len))))
 
+;;; CLISP's REPL sets up an ABORT restart that kills SWANK.  Here we
+;;; can omit that restart so that users don't select it by mistake.
+(defimplementation compute-sane-restarts (condition)
+  ;; The outermost restart is specified to be the last element of the
+  ;; list, hopefully that's our unwanted ABORT restart.
+  (butlast (compute-restarts condition)))
+
 (defimplementation print-frame (frame stream)
   (let ((str (frame-to-string frame)))
-    ;;(format stream "~a " (frame-string-type str))
-    (write-string (extract-frame-line str) 
-		  stream)))
+    ;; (format stream "~A " (frame-string-type str))
+    (write-string (extract-frame-line str)
+                  stream)))
 
 (defun extract-frame-line (frame-string)
   (let ((s frame-string))
     (trim-whitespace
      (case (frame-string-type s)
        ((eval special-op)
-	(string-match "EVAL frame .*for form \\(.*\\)" s 1))
+        (string-match "EVAL frame .*for form \\(.*\\)" s 1))
        (apply
-	(string-match "APPLY frame for call \\(.*\\)" s 1))
+        (string-match "APPLY frame for call \\(.*\\)" s 1))
        ((compiled-fun sys-fun fun)
-	(extract-function-name s))
+        (extract-function-name s))
        (t s)))))
 
 (defun extract-function-name (string)
   (let ((1st (car (split-frame-string string))))
     (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
-		      1st
-		      1)
-	(string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
-	1st)))
+                      1st
+                      1)
+        (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
+        1st)))
 
 (defun split-frame-string (string)
-  (let ((rx (format nil "~%\\(~{~a~^\\|~}\\)"
-		    (mapcar #'car *frame-prefixes*))))
+  (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
+                    (mapcar #'car *frame-prefixes*))))
     (loop for pos = 0 then (1+ (regexp:match-start match))
-	  for match = (regexp:match rx string :start pos)
-	  if match collect (subseq string pos (regexp:match-start match))
-	  else collect (subseq string pos)
-	  while match)))
+          for match = (regexp:match rx string :start pos)
+          if match collect (subseq string pos (regexp:match-start match))
+          else collect (subseq string pos)
+          while match)))
 
 (defun string-match (pattern string n)
   (let* ((match (nth-value n (regexp:match pattern string))))
@@ -356,44 +364,44 @@
 (defimplementation eval-in-frame (form frame-number)
   (sys::eval-at (nth-frame frame-number) form))
 
-(defimplementation frame-locals (frame-number) 
+(defimplementation frame-locals (frame-number)
   (let ((frame (nth-frame frame-number)))
     (loop for i below (%frame-count-vars frame)
-	  collect (list :name (%frame-var-name frame i)
-			:value (%frame-var-value frame i)
-			:id 0))))
+          collect (list :name (%frame-var-name frame i)
+                        :value (%frame-var-value frame i)
+                        :id 0))))
 
 (defimplementation frame-var-value (frame var)
   (%frame-var-value (nth-frame frame) var))
 
-;; Interpreter-Variablen-Environment has the shape
-;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
+;;; Interpreter-Variablen-Environment has the shape
+;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
 
 (defun %frame-count-vars (frame)
   (cond ((sys::eval-frame-p frame)
-	 (do ((venv (frame-venv frame) (next-venv venv))
-	      (count 0 (+ count (/ (1- (length venv)) 2))))
-	     ((not venv) count)))
-	((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
-	 (length (%parse-stack-values frame)))

[345 lines skipped]
--- /project/slime/cvsroot/slime/swank-backend.lisp	2007/04/08 11:21:45	1.115
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2007/04/08 14:02:37	1.116
@@ -601,6 +601,13 @@
 debugger.  If END is nil, return the frames from START to the end of
 the stack.")
 
+(definterface compute-sane-restarts (condition)
+  "This is an opportunity for Lisps such as CLISP to remove
+unwanted restarts from the output of CL:COMPUTE-RESTARTS,
+otherwise it should simply call CL:COMPUTE-RESTARTS, which is
+what the default implementation does."
+  (compute-restarts condition))
+
 (definterface print-frame (frame stream)
   "Print frame to stream.")
 
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 13:29:13	1.1099
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 14:02:37	1.1100
@@ -1,3 +1,9 @@
+2007-03-31  Lu?s Oliveira <loliveira at common-lisp.net>
+
+	* swank-backend.lisp (compute-sane-restarts): New interface.
+	* swank-clisp.lisp: Fix tabs and trailing whitespace.
+	(compute-sane-restarts): Implement new interface.
+
 2007-04-08 Takehiko Abe <keke at gol.com>
 
 	* swank-openmcl.lisp (xref-locations):



From mbaringer at common-lisp.net  Sun Apr  8 16:52:30 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 12:52:30 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408165230.F02BA2E1B7@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 14:02:37	1.1100
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 16:52:30	1.1101
@@ -1,4 +1,4 @@
-2007-03-31  Lu?s Oliveira <loliveira at common-lisp.net>
+2007-04-08  Lu?s Oliveira <loliveira at common-lisp.net>
 
 	* swank-backend.lisp (compute-sane-restarts): New interface.
 	* swank-clisp.lisp: Fix tabs and trailing whitespace.
@@ -7,10 +7,6 @@
 2007-04-08 Takehiko Abe <keke at gol.com>
 
 	* swank-openmcl.lisp (xref-locations):
-	
-2007-04-07 Harald Hanche-Olsen <hanche at math.ntnu.no>
-
-	* slime.el (sldb-mode-map): Added key definition for follow-link.
 
 2007-04-08  Marco Baringer <mb at bese.it>
 
@@ -18,6 +14,10 @@
 	instead of a place like (values limit time-limit-in-msec). While
 	sbcl seems to accept this form openmcl doesn't and it's not clear
 	from the spec that this is allowed.
+	
+2007-04-07 Harald Hanche-Olsen <hanche at math.ntnu.no>
+
+	* slime.el (sldb-mode-map): Added key definition for follow-link.
 
 2007-04-06  Tobias C. Rittweiler <tcr at freebits.de>
 



From mbaringer at common-lisp.net  Sun Apr  8 18:24:03 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 14:24:03 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408182403.DB1663E054@common-lisp.net>

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

Modified Files:
	swank.lisp ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 14:02:37	1.470
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 18:24:03	1.471
@@ -3270,13 +3270,6 @@
           (push symbol completions))))
     (remove-duplicates completions)))
 
-(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
-  "True if SYMBOL is external in PACKAGE.
-If PACKAGE is not specified, the home package of SYMBOL is used."
-  (and package
-       (eq (nth-value 1 (find-symbol (symbol-name symbol) package))
-           :external)))
-
 (defun find-matching-packages (name matcher)
   "Return a list of package names matching NAME with MATCHER.
 MATCHER is a two-argument predicate."
@@ -3288,6 +3281,77 @@
                                  collect (package-name package)
                                  append (package-nicknames package))))))
 
+
+(defun symbol-status (symbol &optional (package (symbol-package symbol)))
+  "Returns one of 
+
+  :INTERNAL  if the symbol is _present_ in PACKAGE as an _internal_ symbol,
+
+  :EXTERNAL  if the symbol is _present_ in PACKAGE as an _external_ symbol,
+
+  :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
+             but is not _present_ in PACKAGE,
+
+  or NIL     if SYMBOL is not _accessible_ in PACKAGE.
+
+
+Be aware not to get confused with :INTERNAL and how \"internal
+symbols\" are defined in the spec; there is a slight mismatch of
+definition with the Spec and what's commonly meant when talking
+about internal symbols most times. As the spec says:
+
+  In a package P, a symbol S is
+  
+     _accessible_  if S is either _present_ in P itself or was
+                   inherited from another package Q (which implies
+                   that S is _external_ in Q.)
+  
+        You can check that with: (AND (SYMBOL-STATUS S P) T)
+  
+  
+     _present_     if either P is the /home package/ of S or S has been
+                   imported into P or exported from P by IMPORT, or
+                   EXPORT respectively.
+  
+                   Or more simply, if S is not _inherited_.
+  
+        You can check that with: (NOT (EQ (SYMBOL-STATUS S P) :INHERITED))
+  
+  
+     _external_    if S is going to be inherited into any package that
+                   /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
+                   DEFPACKAGE.
+  
+                   Note that _external_ implies _present_, since to
+                   make a symbol _external_, you'd have to use EXPORT
+                   which will automatically make the symbol _present_.
+  
+        You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
+  
+  
+     _internal_    if S is _accessible_ but not _external_.
+  
+Notice that the definition of _internal_ is the definition of the
+respective glossary entry in the spec; *However*, most times,
+when you speak about \"internal symbols\", you're not talking
+about the symbols inherited from other packages, but only about
+the symbols specific to the package in question.
+
+Thus SYMBOL-STATUS splits this up into two explicit pieces: 
+:INTERNAL, and :INHERITED.  Just as CL:FIND-SYMBOL does.
+"
+  (when package     ; may be NIL when symbol is completely uninterned.
+    (check-type symbol symbol) (check-type package package)
+    (multiple-value-bind (present-symbol status)
+        (find-symbol (symbol-name symbol) package)
+      (and (eq symbol present-symbol) status))))
+
+(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
+  "True if SYMBOL is external in PACKAGE.
+If PACKAGE is not specified, the home package of SYMBOL is used."
+  (eq (symbol-status symbol package) :external))
+
+
 ;; PARSE-COMPLETION-ARGUMENTS return table:
 ;; 
 ;;  user behaviour |  NAME  | PACKAGE-NAME | PACKAGE 
@@ -3614,6 +3678,16 @@
       (push :generic-function result))
     result))
 
+(defun symbol-classification->string (flags)
+  (format nil "~A~A~A~A~A~A~A"
+          (if (member :boundp flags) "b" "-")
+          (if (member :fboundp flags) "f" "-")
+          (if (member :generic-function flags) "g" "-")
+          (if (member :class flags) "c" "-")
+          (if (member :macro flags) "m" "-")
+          (if (member :special-operator flags) "s" "-")
+          (if (member :package flags) "p" "-")))
+
 
 (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec)
   "Returns two values: an array of completion objects, sorted by
@@ -4856,49 +4930,148 @@
             (:newline)
             ,@(all-slots-for-inspector slot inspector))))
 
+
+;; Wrapper structure over the list of symbols of a package that should
+;; be displayed with their respective classification flags. This is
+;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS.
+;; Used by the Inspector for packages.
+(defstruct %package-symbols-container
+  title       ;; A string; the title of the inspector page in Emacs.   
+  description ;; A list of renderable objects; used as description.
+  symbols)    ;; The actual symbol list.
+
+(defmethod inspect-for-emacs ((%container %package-symbols-container) inspector)
+  (declare (ignore inspector))
+  (with-struct (%package-symbols-container- title description symbols) %container
+    (let ((max-length (loop for s in symbols maximizing (length (symbol-name s))))
+          (distance 10)) ; empty distance between name and classification
+      (flet ((string-representations (symbol)
+               (let* ((name (symbol-name symbol))
+                      (length (length name))
+                      (padding (- max-length length))                    
+                      (classification (classify-symbol symbol)))
+                 (values
+                  (concatenate 'string
+                               name
+                               (make-string (+ padding distance) :initial-element #\Space))
+                  (symbol-classification->string classification)))))
+        (values
+         
+         title
+         
+         `(, at description (:newline)
+                                        ; 8 is (length "Symbols:")
+           "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:"
+           (:newline)
+           ,(concatenate 'string        ; underlining dashes
+                         (make-string (+ max-length distance -1) :initial-element #\-)
+                         " "
+                         (let* ((dummy (classify-symbol (gensym)))
+                                (dummy (symbol-classification->string dummy))
+                                (classification-length (length dummy)))
+                           (make-string classification-length :initial-element #\-)))
+           (:newline)
+           
+           ,@(loop for symbol in symbols appending
+                  (multiple-value-bind (symbol-string classification-string)
+                      (string-representations symbol)
+                    `((:value ,symbol ,symbol-string) ,classification-string (:newline))))))))))
+
+
 (defmethod inspect-for-emacs ((package package) inspector)
   (declare (ignore inspector))
-  (let ((internal-symbols '())
-        (external-symbols '()))
-    (do-symbols (sym package)
-      (when (eq package (symbol-package sym))
-        (push sym internal-symbols)
-        (multiple-value-bind (symbol status)
-            (find-symbol (symbol-name sym) package)
-          (declare (ignore symbol))
-          (when (eql :external status)
-            (push sym external-symbols)))))
-    (setf internal-symbols (sort internal-symbols #'string-lessp)
-          external-symbols (sort external-symbols #'string-lessp))
-    (values "A package."
-            `("Name: " (:value ,(package-name package))
-              (:newline)
-              "Nick names: " ,@(common-seperated-spec (sort (copy-seq (package-nicknames package))
-                                                            #'string-lessp))
-              (:newline)
-              ,@(when (documentation package t)
-                  `("Documentation:" (:newline)
-                    ,(documentation package t) (:newline)))
-              "Use list: " ,@(common-seperated-spec (sort (copy-seq (package-use-list package)) #'string-lessp :key #'package-name)
-                                                    (lambda (pack)
-                                                      `(:value ,pack ,(inspector-princ (package-name pack)))))
-              (:newline)
-              "Used by list: " ,@(common-seperated-spec (sort (copy-seq (package-used-by-list package)) #'string-lessp :key #'package-name)
-                                                        (lambda (pack)
-                                                          `(:value ,pack ,(inspector-princ (package-name pack)))))
-              (:newline)
-              ,(if (null external-symbols)
-                   "0 external symbols."
-                   `(:value ,external-symbols ,(format nil "~D external symbol~:P." (length external-symbols))))
-              (:newline)
-              ,(if (null internal-symbols)
-                   "0 internal symbols."
-                   `(:value ,internal-symbols ,(format nil "~D internal symbol~:P." (length internal-symbols))))
-              (:newline)
-              ,(if (null (package-shadowing-symbols package))
-                   "0 shadowed symbols."
-                   `(:value ,(package-shadowing-symbols package)
-                            ,(format nil "~D shadowed symbol~:P." (length (package-shadowing-symbols package)))))))))
+  (let ((package-name         (package-name package))
+        (package-nicknames    (package-nicknames package))
+        (package-use-list     (mapcar #'package-name (package-use-list package)))
+        (package-used-by-list (mapcar #'package-name (package-used-by-list package)))
+        (shadowed-symbols     (package-shadowing-symbols package))
+        (present-symbols      '()) (present-symbols-length  0)
+        (internal-symbols     '()) (internal-symbols-length 0)
+        (external-symbols     '()) (external-symbols-length 0))
+
+    (do-symbols* (sym package)
+      (let ((status (symbol-status sym package)))
+        (when (not (eq status :inherited))
+          (push sym present-symbols) (incf present-symbols-length)
+          (if (eq status :internal)
+              (progn (push sym internal-symbols) (incf internal-symbols-length))                
+              (progn (push sym external-symbols) (incf external-symbols-length))))))
+    
+    (setf package-nicknames    (sort (copy-list package-nicknames)    #'string<)
+          package-use-list     (sort (copy-list package-use-list)     #'string<)
+          package-used-by-list (sort (copy-list package-used-by-list) #'string<)
+          shadowed-symbols     (sort (copy-list shadowed-symbols)     #'string<))
+    
+    (setf present-symbols      (sort present-symbols  #'string<)  ; SORT + STRING-LESSP
+          internal-symbols     (sort internal-symbols #'string<)  ; conses on at least
+          external-symbols     (sort external-symbols #'string<)) ; SBCL 0.9.18.
+
+    
+    (values
+     "A package."
+     `(""                               ; dummy to preserve indentation.
+       "Name: " (:value ,package-name) (:newline)
+                       
+       "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline)
+              
+       ,@(when (documentation package t)
+               `("Documentation:" (:newline) ,(documentation package t) (:newline)))
+              
+       "Use list: " ,@(common-seperated-spec
+                       package-use-list
+                       (lambda (package)
+                         `(:value ,package ,(package-name package))))
+       (:newline)
+              
+       "Used by list: " ,@(common-seperated-spec
+                           package-used-by-list
+                           (lambda (package)
+                             `(:value ,package ,(package-name package))))
+       (:newline)
+
+       ,@     ; ,@(flet ((...)) ...) would break indentation in Emacs.
+       (flet ((display-link (type symbols length &key title description)
+                (if (null symbols)
+                    (format nil "0 ~A symbols." type)
+                    `(:value ,(make-%package-symbols-container :title title
+                                                               :description description
+                                                               :symbols symbols)
+                             ,(format nil "~D ~A symbol~P." length type length)))))
+         
+         `(,(display-link "present" present-symbols  present-symbols-length
+                          :title (format nil "All present symbols of package \"~A\"" package-name)
+                          :description
+                          '("A symbol is considered present in a package if it's" (:newline)
+                            "\"accessible in that package directly, rather than"  (:newline)
+                            "being inherited from another package.\""             (:newline)
+                            "(CLHS glossary entry for `present')"                 (:newline)))
+            
+            (:newline)
+            ,(display-link "external" external-symbols external-symbols-length
+                           :title (format nil "All external symbols of package \"~A\"" package-name)
+                           :description
+                           '("A symbol is considered external of a package if it's"  (:newline)
+                             "\"part of the `external interface' to the package and" (:newline)
+                             "[is] inherited by any other package that uses the"     (:newline)
+                             "package.\" (CLHS glossary entry of `external')"        (:newline)))
+            (:newline)
+            ,(display-link "internal" internal-symbols internal-symbols-length
+                           :title (format nil "All internal symbols of package \"~A\"" package-name)
+                           :description
+                           '("A symbol is considered internal of a package if it's"   (:newline)
+                             "present and not external---that is if the package is"   (:newline)
+                             "the home package of the symbol, or if the symbol has"   (:newline)
+                             "been explicitly imported into the package."             (:newline)
+                             (:newline)
+                             "Notice that inherited symbols will thus not be listed," (:newline)
+                             "which deliberately deviates from the CLHS glossary"     (:newline)
+                             "entry of `internal' because it's assumed to be more"    (:newline)
+                             "useful this way."                                       (:newline)))
+            (:newline)
+            ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
+                           :title (format nil "All shadowed symbols of package \"~A\"" package-name)
+                           :description nil)))))))
+
 
 (defmethod inspect-for-emacs ((pathname pathname) inspector)
   (declare (ignore inspector))
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 16:52:30	1.1101
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 18:24:03	1.1102
@@ -1,3 +1,36 @@
+2007-04-08  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp: Implemented a new special inspector page for
+	displaying internal (external, &c) symbols that display
+	classification flags additionally to each symbol, similiar to the
+	content of a *Fuzzy Completion* buffer.  Furthermore, added the
+	possibility to display all symbols that are /present/ in a
+	package. Combined with cleanup of the code parts in question.
+
+	(symbol-status): New function. Returns the status of a symbol in a
+	given package (:internal, :external &c.)
+
+	(symbol-external-p): Adapted to use new function SYMBOL-STATUS.
+
+	(symbol-classification->string): New function. Converts a list of
+	classification flags into a concise string representation.
+
+	(%package-symbols-container): New struct. We need a unique type to
+	dispatch in INSPECT-FOR-EMACS for the new inspector page, use this
+	as a wrapper structure.
+
+	(inspect-for-emacs package): Reorganized to not cause too much eye
+	cancer; now with a saner maximum column width. Changed to make use
+	of new SYMBOL-STATUS, for code reuse. Also changed to make use of
+	new %PACKAGE-SYMBOLS-CONTAINER to let a new page pop up in Emacs
+	if the user wants to access the list of symbols of the package.
+	Added such a possibility to access all `present' symbols.
+	
+	(inspect-for-emacs %package-symbols-container): New method.
+	Displays all symbols wrapped up in the container structure
+	combined with their classification flags as determined by
+	CLASSIFY-SYMBOL.
+	
 2007-04-08  Lu?s Oliveira <loliveira at common-lisp.net>
 
 	* swank-backend.lisp (compute-sane-restarts): New interface.



From mbaringer at common-lisp.net  Sun Apr  8 18:55:52 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 14:55:52 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408185552.D15E1680FC@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(inspect-for-emacs): Added 'jump to source' action
for symbols in the new package-symbol browser.


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 18:24:03	1.471
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 18:55:52	1.472
@@ -4975,7 +4975,28 @@
            ,@(loop for symbol in symbols appending
                   (multiple-value-bind (symbol-string classification-string)
                       (string-representations symbol)
-                    `((:value ,symbol ,symbol-string) ,classification-string (:newline))))))))))
+                    `((:value ,symbol ,symbol-string) ,classification-string
+                      " "
+                      (:action "[jump to source]"
+                               , (let ((symbol symbol))
+                                   (lambda ()
+                                     ;; it would be nice to be a
+                                     ;; little smarter here and not
+                                     ;; convert the symbol to a string
+                                     ;; and have slime-edit-definition
+                                     ;; return to the same symbol
+                                     ;; again. however we already have
+                                     ;; this machinery in place and
+                                     ;; not using it would require
+                                     ;; updating this code whenever
+                                     ;; the find-definitions code
+                                     ;; changes.
+                                     (eval-in-emacs `(progn
+                                                       (slime-edit-definition
+                                                        ,(let ((*package* (find-package :common-lisp))) (format nil "~S" symbol)))
+                                                       t)))))
+                      (:newline)
+                      )))))))))
 
 
 (defmethod inspect-for-emacs ((package package) inspector)



From mbaringer at common-lisp.net  Sun Apr  8 18:56:04 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 14:56:04 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408185604.EB8FE74311@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 18:24:03	1.1102
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 18:56:04	1.1103
@@ -1,3 +1,8 @@
+2007-04-08  Marco Baringer  <mb at bese.it>
+
+	* swank.lisp (inspect-for-emacs): Added 'jump to source' action
+	for symbols in the new package-symbol browser.
+
 2007-04-08  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp: Implemented a new special inspector page for



From mbaringer at common-lisp.net  Sun Apr  8 19:23:57 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 15:23:57 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408192357.7F86F60038@common-lisp.net>

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

Modified Files:
	.cvsignore 
Log Message:
Added *.lx64fsl (openmcl on linux fasls).


--- /project/slime/cvsroot/slime/.cvsignore	2006/12/11 12:44:02	1.4
+++ /project/slime/cvsroot/slime/.cvsignore	2007/04/08 19:23:57	1.5
@@ -1,5 +1,6 @@
 *.x86f
 *.fasl
 *.dfsl
+*.lx64fsl
 *.elc
 _darcs



From mbaringer at common-lisp.net  Sun Apr  8 19:24:23 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 15:24:23 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408192423.4A91F6003A@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:



--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 18:56:04	1.1103
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 19:24:22	1.1104
@@ -1,4 +1,8 @@
 2007-04-08  Marco Baringer  <mb at bese.it>
+	
+	* .cvsignore: Added *.lx64fsl (openmcl on linux fasls).
+
+2007-04-08  Marco Baringer  <mb at bese.it>
 
 	* swank.lisp (inspect-for-emacs): Added 'jump to source' action
 	for symbols in the new package-symbol browser.



From mbaringer at common-lisp.net  Sun Apr  8 22:56:01 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 18:56:01 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408225601.1F1501E007@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
(slime-inspector-operate-on-point): Allow the action
calls to return nil.


--- /project/slime/cvsroot/slime/slime.el	2007/04/08 12:52:18	1.779
+++ /project/slime/cvsroot/slime/slime.el	2007/04/08 22:56:00	1.780
@@ -9349,7 +9349,8 @@
         (action-number (get-text-property (point) 'slime-action-number))
         (opener (lexical-let ((point (slime-inspector-position)))
                   (lambda (parts)
-                    (slime-open-inspector parts :point point)))))
+                    (when parts
+                      (slime-open-inspector parts :point point))))))
     (cond (part-number
            (slime-eval-async `(swank:inspect-nth-part ,part-number)
                              opener)



From mbaringer at common-lisp.net  Sun Apr  8 22:56:08 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 18:56:08 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408225608.433F720016@common-lisp.net>

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

Modified Files:
	swank-backend.lisp 
Log Message:
(inspect-for-emacs): Docstring update.


--- /project/slime/cvsroot/slime/swank-backend.lisp	2007/04/08 14:02:37	1.116
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2007/04/08 22:56:08	1.117
@@ -858,8 +858,10 @@
 
  (:newline) - Render a \\n
 
- (:action label lambda) - Render LABEL (a text string) which when
- clicked will call LAMBDA.
+ (:action label lambda &key (refresh t)) - Render LABEL (a text
+ string) which when clicked will call LAMBDA. If REFRESH is
+ non-NIL the currently inspected object will be re-inspected
+ after calling the lambda.
 
  NIL - do nothing."))
 



From mbaringer at common-lisp.net  Sun Apr  8 22:56:18 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 18:56:18 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408225618.9EC342E1BA@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(inspector-content-for-emacs): Look for refresh
keyword argument in :action links.
(inspect-whole-thing-action, inspect-show-more-action): Update for
new :action argument handling.
(inspect-for-emacs stream, inspect-for-emacs stream-error): Pass
:refresh nil on :action links.
(action-part-for-emacs): Set both lambda and refresh in the
*inspectee-actions* array.
(inspector-call-nth-action): *inspectee-actions* now holds both
the function and the boolean specifying whether to refresh or not.


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 18:55:52	1.472
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 22:56:18	1.473
@@ -4544,9 +4544,7 @@
 		      size)
 	    ,(lambda() 
 	       (let ((*slime-inspect-contents-limit* nil))
-		 (values
-		  (swank::inspect-object thing)
-		  :replace)))))
+		 (swank::inspect-object thing)))))
 
 (defmethod inspect-show-more-action (thing)
   `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..." 
@@ -4554,9 +4552,7 @@
 	    ,(lambda() 
 	       (let ((*slime-inspect-contents-limit* 
 		      (progn (format t "How many elements should be shown? ") (read))))
-		 (values
-		  (swank::inspect-object thing)
-		  :replace)))))
+		 (swank::inspect-object thing)))))
 
 (defmethod inspect-for-emacs ((array array) inspector)
   (declare (ignore inspector))
@@ -5219,7 +5215,8 @@
                         ,(let ((pathname (pathname stream))
                                (position (file-position stream)))
                            (lambda ()
-                             (ed-in-emacs `(,pathname :charpos ,position)))))
+                             (ed-in-emacs `(,pathname :charpos ,position))))
+                        :refresh nil)
                (:newline))
              content))))
 
@@ -5238,7 +5235,8 @@
                               ,(let ((pathname (pathname stream))
                                      (position (file-position stream)))
                                     (lambda ()
-                                      (ed-in-emacs `(,pathname :charpos ,position)))))
+                                      (ed-in-emacs `(,pathname :charpos ,position))))
+                              :refresh nil)
                      (:newline))
                    content))
           (values title content)))))
@@ -5342,8 +5340,8 @@
                    (string #\newline))
                   ((:value obj &optional str) 
                    (value-part-for-emacs obj str))
-                  ((:action label lambda) 
-                   (action-part-for-emacs label lambda)))))))
+                  ((:action label lambda &key (refreshp t)) 
+                   (action-part-for-emacs label lambda refreshp)))))))
 
 (defun assign-index (object vector)
   (let ((index (fill-pointer vector)))
@@ -5355,8 +5353,9 @@
         (or string (print-part-to-string object))
         (assign-index object *inspectee-parts*)))
 
-(defun action-part-for-emacs (label lambda)
-  (list :action label (assign-index lambda *inspectee-actions*)))
+(defun action-part-for-emacs (label lambda refreshp)
+  (list :action label (assign-index (list lambda refreshp)
+                                    *inspectee-actions*)))
   
 (defun inspect-object (object &optional (inspector (make-default-inspector)))
   (push (setq *inspectee* object) *inspector-stack*)
@@ -5380,10 +5379,13 @@
     (inspect-object (inspector-nth-part index))))
 
 (defslimefun inspector-call-nth-action (index &rest args)
-  (multiple-value-bind (value replace) (apply (aref *inspectee-actions* index) args)
-      (if (eq replace :replace)
-	  value
-	  (inspect-object (pop *inspector-stack*)))))
+  (destructuring-bind (action-lambda refreshp)
+      (aref *inspectee-actions* index)
+    (apply action-lambda args)
+    (if refreshp
+        (inspect-object (pop *inspector-stack*))
+        ;; tell emacs that we don't want to refresh the inspector buffer
+        nil)))
 
 (defslimefun inspector-pop ()
   "Drop the inspector stack and inspect the second element.  Return



From mbaringer at common-lisp.net  Sun Apr  8 22:56:32 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 18:56:32 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408225632.9194D36008@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 19:24:22	1.1104
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 22:56:32	1.1105
@@ -1,3 +1,21 @@
+2007-04-09  Marco Baringer  <mb at bese.it>
+
+	* swank.lisp (inspector-content-for-emacs): Look for refresh
+	keyword argument in :action links.
+	(inspect-whole-thing-action, inspect-show-more-action): Update for
+	new :action argument handling.
+	(inspect-for-emacs stream, inspect-for-emacs stream-error): Pass
+	:refresh nil on :action links.
+	(action-part-for-emacs): Set both lambda and refresh in the
+	*inspectee-actions* array.
+	(inspector-call-nth-action): *inspectee-actions* now holds both
+	the function and the boolean specifying whether to refresh or not.
+
+	* swank-backend.lisp (inspect-for-emacs): Docstring update.
+
+	* slime.el (slime-inspector-operate-on-point): Allow the action
+	calls to return nil.
+
 2007-04-08  Marco Baringer  <mb at bese.it>
 	
 	* .cvsignore: Added *.lx64fsl (openmcl on linux fasls).



From mbaringer at common-lisp.net  Sun Apr  8 23:07:53 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Sun,  8 Apr 2007 19:07:53 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070408230753.4BB4472093@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 22:56:18	1.473
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/08 23:07:53	1.474
@@ -4975,22 +4975,7 @@
                       " "
                       (:action "[jump to source]"
                                , (let ((symbol symbol))
-                                   (lambda ()
-                                     ;; it would be nice to be a
-                                     ;; little smarter here and not
-                                     ;; convert the symbol to a string
-                                     ;; and have slime-edit-definition
-                                     ;; return to the same symbol
-                                     ;; again. however we already have
-                                     ;; this machinery in place and
-                                     ;; not using it would require
-                                     ;; updating this code whenever
-                                     ;; the find-definitions code
-                                     ;; changes.
-                                     (eval-in-emacs `(progn
-                                                       (slime-edit-definition
-                                                        ,(let ((*package* (find-package :common-lisp))) (format nil "~S" symbol)))
-                                                       t)))))
+                                   (lambda () (ed-in-emacs symbol))))
                       (:newline)
                       )))))))))
 



From nsiivola at common-lisp.net  Thu Apr 12 19:00:10 2007
From: nsiivola at common-lisp.net (nsiivola)
Date: Thu, 12 Apr 2007 15:00:10 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070412190010.4D09D140B1@common-lisp.net>

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
Accept :emacs-direcory in emacs-buffer-source-location plist.

--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 22:56:32	1.1105
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/12 19:00:09	1.1106
@@ -1,3 +1,9 @@
+2007-04-12  Nikodemus Siivola <nikodemus at random-state.net>
+
+	* swank-sbcl.lisp (emacs-buffer-source-location): Add &allow-other-keys
+	to the descructuring of the source location plist in order to accept
+	:emacs-directory.
+
 2007-04-09  Marco Baringer  <mb at bese.it>
 
 	* swank.lisp (inspector-content-for-emacs): Look for refresh
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2007/03/29 17:12:38	1.176
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2007/04/12 19:00:09	1.177
@@ -783,7 +783,9 @@
 
 (defun emacs-buffer-source-location (code-location plist)
   (if (code-location-has-debug-block-info-p code-location)
-      (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
+      (destructuring-bind (&key emacs-buffer emacs-position emacs-string
+                                &allow-other-keys)
+          plist
         (let* ((pos (string-source-position code-location emacs-string))
                (snipped (with-input-from-string (s emacs-string)
                           (read-snippet s pos))))



From mbaringer at common-lisp.net  Mon Apr 16 14:24:08 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:24:08 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416142408.7F10D2D079@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
(slime-compilation-finished): Don't use
MULTIPLE-VALUE-BIND for list destructuring, only because multiple
values happen to be implemented via lists in elisp!
(slime-fuzzy-completions-mode): Added an detailed explanation to
the docstring of how Fuzzy Completion works and how it'ss supposed
to be worked with.
(slime-fuzzy-explanation): Shortened to reference to
SLIME-FUZZY-COMPLETIONS-MODE for help on fuzzy completion.
(slime-fuzzy-choices-buffer): Set BUFFER-QUIT-FUNCTION to
SLIME-FUZZY-ABORT to make it correctly exit fuzzy completion when
pressing `Esc Esc Esc' (`M-Esc Esc').


--- /project/slime/cvsroot/slime/slime.el	2007/04/08 22:56:00	1.780
+++ /project/slime/cvsroot/slime/slime.el	2007/04/16 14:24:07	1.781
@@ -4755,7 +4755,7 @@
   (let ((notes (slime-compiler-notes)))
     (with-current-buffer buffer
       (setf slime-compilation-just-finished t)
-      (multiple-value-bind (result secs) result
+      (destructuring-bind (result secs) result
         (slime-show-note-counts notes secs)
         (when slime-highlight-compiler-notes
           (slime-highlight-notes notes))))
@@ -4763,7 +4763,7 @@
 
 (defun slime-compilation-finished-continuation ()
   (lexical-let ((buffer (current-buffer)))
-    (lambda (result) 
+    (lambda (result)
       (slime-compilation-finished result buffer))))
 
 (defun slime-highlight-notes (notes)
@@ -6389,6 +6389,43 @@
   fundamental-mode "Fuzzy Completions"
   "Major mode for presenting fuzzy completion results.
 
+When you run `slime-fuzzy-complete-symbol', the symbol token at
+point is completed using the Fuzzy Completion algorithm; this
+means that the token is taken as a sequence of characters and all
+the various possibilities that this sequence could meaningfully
+represent are offered as selectable choices, sorted by how well
+they deem to be a match for the token. (For instance, the first
+choice of completing on \"mvb\" would be \"multiple-value-bind\".)
+
+Therefore, a new buffer (*Fuzzy Completions*) will pop up that
+contains the different completion choices. Simultaneously, a
+special minor-mode will be temporarily enabled in the original
+buffer where you initiated fuzzy completion (also called the
+``target buffer'') in order to navigate through the *Fuzzy
+Completions* buffer without leaving.
+
+With focus in *Fuzzy Completions*:
+  Type `n' and `p' (`UP', `DOWN') to navigate between completions.
+  Type `RET' or `TAB' to select the completion near point. 
+  Type `q' to abort.
+
+With focus in the target buffer:
+  Type `UP' and `DOWN' to navigate between completions.
+  Type a character that does not constitute a symbol name
+  to insert the current choice and then that character (`(', `)',
+  `SPACE', `RET'.) Use `TAB' to simply insert the current choice.
+  Use C-g to abort.
+
+Alternatively, you can click <mouse-2> on a completion to select it.
+
+
+Complete listing of keybindings within the target buffer:
+
+\\<slime-target-buffer-fuzzy-completions-map>\
+\\{slime-target-buffer-fuzzy-completions-map}
+
+Complete listing of keybindings with *Fuzzy Completions*:
+
 \\<slime-fuzzy-completions-map>\
 \\{slime-fuzzy-completions-map}"
   (use-local-map slime-fuzzy-completions-map))
@@ -6495,9 +6532,8 @@
   (get-buffer-create "*Fuzzy Completions*"))
 
 (defvar slime-fuzzy-explanation
-  "Click <mouse-2> on a completion to select it.
-In this buffer, type n and p to navigate between completions.
-Type RET to select the completion near point.  Type q to abort.
+  "For help on how the use this buffer, see `slime-fuzzy-completions-mode'.
+
 Flags: boundp fboundp generic-function class macro special-operator package
 \n"
   "The explanation that gets inserted at the beginning of the
@@ -6574,7 +6610,8 @@
     (slime-fuzzy-fill-completions-buffer completions interrupted-p)
     (pop-to-buffer (slime-get-fuzzy-buffer))
     (when new-completion-buffer
-      (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort))
+      (add-local-hook 'kill-buffer-hook 'slime-fuzzy-abort)
+      (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
     (when slime-fuzzy-completion-in-place
       ;; switch back to the original buffer
       (switch-to-buffer-other-window slime-fuzzy-target-buffer))))



From mbaringer at common-lisp.net  Mon Apr 16 14:24:36 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:24:36 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416142436.839693201A@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(fuzzy-find-matching-packages): Fix a small typo that
prevented interpreting NIL as the argument TIME-LIMIT-IN-MEC to
mean an infinite time limit. This bug propagated up to explicit
calls to FUZZY-COMPLETIONS, like 
   (swank:fuzzy-completions "mvb" "COMMON-LISP") => (NIL, T)

(format-fuzzy-completions): Renamed to FORMAT-FUZZY-COMPLETION-SET

(format-fuzzy-completion-set): Accomodated to recent changes of
the return value of FUZZY-COMPLETIONS; changed the docstring to
make it explicit that this function is supposed to take the return
value of FUZZY-COMPLETION-SET.


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/08 23:07:53	1.474
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/16 14:24:35	1.475
@@ -3863,7 +3863,7 @@
     (declare (type boolean time-limit-p))
     (declare (type integer time-limit rtime-at-start))
     (declare (type function converter))
-    (if (and time-limit (<= time-limit 0))
+    (if (and time-limit-p (<= time-limit 0))
         (values #() time-limit)
         (loop for package in (list-all-packages)
               for package-name   = (package-name package)
@@ -4103,9 +4103,10 @@
                                             (length (second chunk))))))
     highlit))
 
-(defun format-fuzzy-completions (winners)
+(defun format-fuzzy-completion-set (winners)
   "Given a list of completion objects such as on returned by
-FUZZY-COMPLETIONS, format the list into user-readable output."
+FUZZY-COMPLETION-SET, format the list into user-readable output
+for interactive debugging purpose."
   (let ((max-len 
          (loop for winner in winners maximizing (length (first winner)))))
     (loop for (sym score result) in winners do



From mbaringer at common-lisp.net  Mon Apr 16 14:24:59 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:24:59 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416142459.5576736141@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/12 19:00:09	1.1106
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:24:56	1.1107
@@ -1,3 +1,30 @@
+2007-04-11  Tobias C. Rittweiler <tcr at freebits.de>
+
+	* swank.lisp (fuzzy-find-matching-packages): Fix a small typo that
+	prevented interpreting NIL as the argument TIME-LIMIT-IN-MEC to
+	mean an infinite time limit. This bug propagated up to explicit
+	calls to FUZZY-COMPLETIONS, like 
+	   (swank:fuzzy-completions "mvb" "COMMON-LISP") => (NIL, T)
+
+	(format-fuzzy-completions): Renamed to FORMAT-FUZZY-COMPLETION-SET
+	
+	(format-fuzzy-completion-set): Accomodated to recent changes of
+	the return value of FUZZY-COMPLETIONS; changed the docstring to
+	make it explicit that this function is supposed to take the return
+	value of FUZZY-COMPLETION-SET.
+
+	* slime.el (slime-compilation-finished): Don't use
+	MULTIPLE-VALUE-BIND for list destructuring, only because multiple
+	values happen to be implemented via lists in elisp!
+	(slime-fuzzy-completions-mode): Added an detailed explanation to
+	the docstring of how Fuzzy Completion works and how it'ss supposed
+	to be worked with.
+	(slime-fuzzy-explanation): Shortened to reference to
+	SLIME-FUZZY-COMPLETIONS-MODE for help on fuzzy completion.
+	(slime-fuzzy-choices-buffer): Set BUFFER-QUIT-FUNCTION to
+	SLIME-FUZZY-ABORT to make it correctly exit fuzzy completion when
+	pressing `Esc Esc Esc' (`M-Esc Esc').
+
 2007-04-12  Nikodemus Siivola <nikodemus at random-state.net>
 
 	* swank-sbcl.lisp (emacs-buffer-source-location): Add &allow-other-keys



From mbaringer at common-lisp.net  Mon Apr 16 14:26:09 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:26:09 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416142609.B6F714508F@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:24:56	1.1107
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:26:09	1.1108
@@ -1,4 +1,8 @@
-2007-04-11  Tobias C. Rittweiler <tcr at freebits.de>
+2007-04-16  Tobias C. Rittweiler <INSERT-EMAIL-HERE>
+
+	* slime.el (slime-easy-menu): Add entry for SLIME-UNTRACE-ALL.
+
+2007-04-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (fuzzy-find-matching-packages): Fix a small typo that
 	prevented interpreting NIL as the argument TIME-LIMIT-IN-MEC to



From mbaringer at common-lisp.net  Mon Apr 16 14:26:24 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:26:24 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416142624.10FB74D048@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
(slime-easy-menu): Add entry for SLIME-UNTRACE-ALL.


--- /project/slime/cvsroot/slime/slime.el	2007/04/16 14:24:07	1.781
+++ /project/slime/cvsroot/slime/slime.el	2007/04/16 14:26:23	1.782
@@ -837,6 +837,7 @@
        [ "Macroexpand Once..."     slime-macroexpand-1 ,C ]
        [ "Macroexpand All..."      slime-macroexpand-all ,C ]
        [ "Toggle Trace..."         slime-toggle-trace-fdefinition ,C ]
+       [ "Untrace All"             slime-untrace-all ,C]
        [ "Disassemble..."          slime-disassemble-symbol ,C ]
        [ "Inspect..."              slime-inspect ,C ])
       ("Compilation"



From mbaringer at common-lisp.net  Mon Apr 16 14:28:47 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:28:47 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416142847.791F55200B@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
Pressing `q' in *compiler notes* after a `C-c C-k' or
`C-c M-k' would not probably restore the original window
configuration. Fix that.

(slime-get-temp-buffer-create): New &key arg WINDOW-CONFIGURATION.
(slime-with-xref-buffer): Likewise.

(slime-compilation-finished): New &optional arg WINDOW-CONFIG.
(slime-maybe-show-xrefs-for-notes): Likewise.
(slime-show-xrefs) Likewise.
(slime-maybe-list-compiler-notes): Likewise.
(slime-list-compiler-notes): Likewise.

(slime-compilation-finished-continuation): Renamed to
SLIME-MAKE-COMPILATION-FINISHED-CONTINUATION.

(slime-make-compilation-finished-continuation): Now takes two
args, the current buffer and optionally the current window config
to be restored.

(slime-compile-file): Save current window configuration before
popping up the REPL for compilation output, pass it down.
(slime-easy-menu): Add entry for SLIME-UNTRACE-ALL.


--- /project/slime/cvsroot/slime/slime.el	2007/04/16 14:26:23	1.782
+++ /project/slime/cvsroot/slime/slime.el	2007/04/16 14:28:46	1.783
@@ -254,7 +254,7 @@
   :group 'slime-mode
   :type 'hook
   :options '(slime-maybe-list-compiler-notes
-             slime-list-compiler-notes 
+             slime-list-compiler-notes
              slime-maybe-show-xrefs-for-notes))
 
 (defcustom slime-goto-first-note-after-compilation nil
@@ -1201,7 +1201,8 @@
    "The window config \"fingerprint\" after displaying the buffer."))
 
 ;; Interface
-(defun* slime-get-temp-buffer-create (name &key mode noselectp reusep)
+(defun* slime-get-temp-buffer-create (name &key mode noselectp reusep 
+                                           window-configuration)
   "Return a fresh temporary buffer called NAME in MODE.
 The buffer also uses the minor-mode `slime-temp-buffer-mode'. Pressing
 `q' in the buffer will restore the window configuration to the way it
@@ -1211,8 +1212,14 @@
 otherwise it is shown and selected by `pop-to-buffer'.
 
 If REUSEP is true and a buffer does already exist with name NAME,
-then the buffer will be reused instead of being killed."
-  (let ((window-config (current-window-configuration))
+then the buffer will be reused instead of being killed.
+
+If WINDOW-CONFIGURATION is non-NIL, it's used to restore the
+original window configuration after closing the temporary
+buffer. Otherwise, the current configuration will be saved and
+that one used for restoration then.
+"
+  (let ((window-config (or window-configuration (current-window-configuration)))
         (buffer (get-buffer name)))
     (when (and buffer (not reusep))
       (kill-buffer name)
@@ -4465,7 +4472,7 @@
               (slime-eval-async 
                `(swank:compile-file-if-needed 
                  ,(slime-to-lisp-filename filename) t)
-               (slime-compilation-finished-continuation))))
+               (slime-make-compilation-finished-continuation (current-buffer)))))
   (:one-liner "Compile (if neccessary) and load a lisp file."))
 
 (defslime-repl-shortcut slime-repl-load/force-system ("force-load-system")
@@ -4621,15 +4628,18 @@
              (y-or-n-p (format "Save file %s? " (buffer-file-name))))
     (save-buffer))
   (run-hook-with-args 'slime-before-compile-functions (point-min) (point-max))
-  (let ((lisp-filename (slime-to-lisp-filename (buffer-file-name))))
+  (let ((lisp-filename (slime-to-lisp-filename (buffer-file-name)))
+        (window-config (current-window-configuration)))
     (slime-insert-transcript-delimiter
      (format "Compile file %s" lisp-filename))
+    ;; The following may alter the current window-config, so we saved
+    ;; it, to pass it on for it to be restored!
     (when slime-display-compilation-output
       (slime-display-output-buffer))
     (slime-eval-async
      `(swank:compile-file-for-emacs 
        ,lisp-filename ,(if load t nil))
-     (slime-compilation-finished-continuation))
+     (slime-make-compilation-finished-continuation (current-buffer) window-config))
     (message "Compiling %s.." lisp-filename)))
 
 (defun slime-find-asd (system-names)
@@ -4676,7 +4686,7 @@
            system)
   (slime-eval-async
    `(swank:operate-on-system-for-emacs ,system ,operation , at keyword-args)
-   (slime-compilation-finished-continuation)))
+   (slime-make-compilation-finished-continuation (current-buffer))))
 
 (defun slime-compile-defun ()
   "Compile the current toplevel form."
@@ -4696,7 +4706,7 @@
      ,(buffer-name)
      ,start-offset
      ,(if (buffer-file-name) (file-name-directory (buffer-file-name))))
-   (slime-compilation-finished-continuation)))
+   (slime-make-compilation-finished-continuation (current-buffer))))
 
 (defun slime-note-count-string (severity count &optional suppress-if-zero)
   (cond ((and (zerop count) suppress-if-zero)
@@ -4752,7 +4762,7 @@
     (decf n))
   list)
 
-(defun slime-compilation-finished (result buffer)
+(defun slime-compilation-finished (result buffer &optional window-config)
   (let ((notes (slime-compiler-notes)))
     (with-current-buffer buffer
       (setf slime-compilation-just-finished t)
@@ -4760,12 +4770,12 @@
         (slime-show-note-counts notes secs)
         (when slime-highlight-compiler-notes
           (slime-highlight-notes notes))))
-    (run-hook-with-args 'slime-compilation-finished-hook notes)))
+    (run-hook-with-args 'slime-compilation-finished-hook notes window-config)))
 
-(defun slime-compilation-finished-continuation ()
-  (lexical-let ((buffer (current-buffer)))
+(defun slime-make-compilation-finished-continuation (current-buffer &optional window-config)
+  (lexical-let ((buffer current-buffer) (config window-config))
     (lambda (result)
-      (slime-compilation-finished result buffer))))
+      (slime-compilation-finished result buffer config))))
 
 (defun slime-highlight-notes (notes)
   "Highlight compiler notes, warnings, and errors in the buffer."
@@ -4847,31 +4857,33 @@
 
 ;;;;; Compiler notes list
 
-(defun slime-maybe-show-xrefs-for-notes (&optional notes)
+(defun slime-maybe-show-xrefs-for-notes (&optional notes window-config)
   "Show the compiler notes NOTES if they come from more than one file."
   (let* ((notes (or notes (slime-compiler-notes))) 
          (xrefs (slime-xrefs-for-notes notes)))
     (when (> (length xrefs) 1)          ; >1 file
       (slime-show-xrefs
-       xrefs 'definition "Compiler notes" (slime-current-package)))))
+       xrefs 'definition "Compiler notes" (slime-current-package)
+       window-config))))
 
 (defun slime-note-has-location-p (note)
   (not (eq ':error (car (slime-note.location note)))))
 
-(defun slime-maybe-list-compiler-notes (notes)
+(defun slime-maybe-list-compiler-notes (notes &optional window-config)
   "Show the compiler notes if appropriate."
   ;; don't pop up a buffer if all notes will are already annotated in
   ;; the buffer itself
   (unless (every #'slime-note-has-location-p notes)
-    (slime-list-compiler-notes notes)))
+    (slime-list-compiler-notes notes window-config)))
 
-(defun slime-list-compiler-notes (notes)
+(defun slime-list-compiler-notes (notes &optional window-config)
   "Show the compiler notes NOTES in tree view."
   (interactive (list (slime-compiler-notes)))
   (with-temp-message "Preparing compiler note tree..."
     (with-current-buffer
         (slime-get-temp-buffer-create "*compiler notes*"
-                                      :mode 'slime-compiler-notes-mode)
+                                      :mode 'slime-compiler-notes-mode
+                                      :window-configuration window-config)
       (let ((inhibit-read-only t))
         (erase-buffer)
         (when (null notes)
@@ -7741,7 +7753,8 @@
       (select-window (display-buffer buffer t))
       (shrink-window-if-larger-than-buffer))))
 
-(defmacro* slime-with-xref-buffer ((package ref-type symbol) &body body)
+(defmacro* slime-with-xref-buffer ((package ref-type symbol &key window-configuration) 
+                                   &body body)
   "Execute BODY in a xref buffer, then show that buffer."
   (let ((type (gensym)) (sym (gensym)) (pkg (gensym)))
     `(let ((,type ,ref-type) (,sym ,symbol) (,pkg ,package))
@@ -7751,7 +7764,7 @@
                   (slime-init-xref-buffer ,pkg ,type ,sym)
                   (make-local-variable 'slime-xref-saved-window-configuration)
                   (setq slime-xref-saved-window-configuration
-                        (current-window-configuration)))
+                        (or window-configuration (current-window-configuration))))
              (progn , at body)
            (setq buffer-read-only t)
            (select-window (or (get-buffer-window (current-buffer) t)
@@ -7783,12 +7796,12 @@
   (backward-char 1)
   (delete-char 1))
 
-(defun slime-show-xrefs (xrefs type symbol package)
+(defun slime-show-xrefs (xrefs type symbol package &optional window-config)
   "Show the results of an XREF query."
   (if (null xrefs)
       (message "No references found for %s." symbol)
     (setq slime-next-location-function 'slime-goto-next-xref)
-    (slime-with-xref-buffer (package type symbol)
+    (slime-with-xref-buffer (package type symbol :window-configuration window-config)
       (slime-insert-xrefs xrefs)
       (goto-char (point-min))
       (forward-line)



From mbaringer at common-lisp.net  Mon Apr 16 14:29:04 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:29:04 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416142904.919AD54162@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:26:09	1.1108
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:29:04	1.1109
@@ -1,6 +1,28 @@
-2007-04-16  Tobias C. Rittweiler <INSERT-EMAIL-HERE>
+2007-04-16  Tobias C. Rittweiler <tcr at freebits.de>
 
-	* slime.el (slime-easy-menu): Add entry for SLIME-UNTRACE-ALL.
+	* slime.el: Pressing `q' in *compiler notes* after a `C-c C-k' or
+	`C-c M-k' would not probably restore the original window
+	configuration. Fix that.
+
+	(slime-get-temp-buffer-create): New &key arg WINDOW-CONFIGURATION.
+	(slime-with-xref-buffer): Likewise.
+	
+	(slime-compilation-finished): New &optional arg WINDOW-CONFIG.
+	(slime-maybe-show-xrefs-for-notes): Likewise.
+	(slime-show-xrefs) Likewise.
+	(slime-maybe-list-compiler-notes): Likewise.
+	(slime-list-compiler-notes): Likewise.
+
+	(slime-compilation-finished-continuation): Renamed to
+	SLIME-MAKE-COMPILATION-FINISHED-CONTINUATION.
+
+	(slime-make-compilation-finished-continuation): Now takes two
+	args, the current buffer and optionally the current window config
+	to be restored.
+	
+	(slime-compile-file): Save current window configuration before
+	popping up the REPL for compilation output, pass it down.
+	(slime-easy-menu): Add entry for SLIME-UNTRACE-ALL.
 
 2007-04-16  Tobias C. Rittweiler <tcr at freebits.de>
 



From mbaringer at common-lisp.net  Mon Apr 16 14:42:34 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:42:34 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416144234.3D3E41A09F@common-lisp.net>

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

Modified Files:
	slime.el 
Log Message:
(slime-with-xref-buffer): Added missing ,


--- /project/slime/cvsroot/slime/slime.el	2007/04/16 14:28:46	1.783
+++ /project/slime/cvsroot/slime/slime.el	2007/04/16 14:42:33	1.784
@@ -7764,7 +7764,7 @@
                   (slime-init-xref-buffer ,pkg ,type ,sym)
                   (make-local-variable 'slime-xref-saved-window-configuration)
                   (setq slime-xref-saved-window-configuration
-                        (or window-configuration (current-window-configuration))))
+                        (or ,window-configuration (current-window-configuration))))
              (progn , at body)
            (setq buffer-read-only t)
            (select-window (or (get-buffer-window (current-buffer) t)



From mbaringer at common-lisp.net  Mon Apr 16 14:42:50 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:42:50 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416144250.CD55421053@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:29:04	1.1109
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:42:50	1.1110
@@ -1,3 +1,7 @@
+2007-04-16  Marco Baringer <mb at bese.it>
+
+	* slime.el (slime-with-xref-buffer): Added missing ,
+
 2007-04-16  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* slime.el: Pressing `q' in *compiler notes* after a `C-c C-k' or



From mbaringer at common-lisp.net  Mon Apr 16 14:47:34 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:47:34 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416144734.A20BB330AE@common-lisp.net>

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

Modified Files:
	swank-openmcl.lisp 
Log Message:
(accept-connection, find-external-format):
UNICODE support.


--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/04/08 13:29:13	1.117
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/04/16 14:47:34	1.118
@@ -167,11 +167,29 @@
 (defimplementation close-socket (socket)
   (close socket))
 
-(defimplementation accept-connection (socket
-                                      &key external-format buffering timeout)
-  (declare (ignore buffering timeout external-format))
+(defimplementation accept-connection (socket &key external-format
+                                             buffering timeout)
+  (declare (ignore buffering timeout
+                   #-openmcl-unicode-strings external-format))
+  #+openmcl-unicode-strings
+  (when external-format
+    (let ((keys (ccl::socket-keys socket)))
+      (setf (getf keys :external-format) external-format
+            (slot-value socket 'ccl::keys) keys)))
   (ccl:accept-connection socket :wait t))
 
+#+openmcl-unicode-strings
+(defvar *external-format-to-coding-system*
+  '((:iso-8859-1 
+     "latin-1" "latin-1-unix" "iso-latin-1-unix" 
+     "iso-8859-1" "iso-8859-1-unix")
+    (:utf-8 "utf-8" "utf-8-unix")))
+
+#+openmcl-unicode-strings
+(defimplementation find-external-format (coding-system)
+  (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
+                  *external-format-to-coding-system*)))
+
 (defimplementation emacs-connected ()
   (setq ccl::*interactive-abort-process* ccl::*current-process*))
 



From mbaringer at common-lisp.net  Mon Apr 16 14:48:15 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 16 Apr 2007 10:48:15 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070416144815.2EA5A34063@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:42:50	1.1110
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:48:14	1.1111
@@ -1,3 +1,8 @@
+2007-04-16  Takehiko Abe <keke at gol.com>
+
+	* swank-openmcl.lisp (accept-connection, find-external-format):
+	utf-8 support.
+
 2007-04-16  Marco Baringer <mb at bese.it>
 
 	* slime.el (slime-with-xref-buffer): Added missing ,



From mbaringer at common-lisp.net  Tue Apr 17 20:06:22 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Tue, 17 Apr 2007 16:06:22 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070417200622.ED4E16B2C2@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(swank-compiler): Fix the return value to always be a
list of two elements even if the abort restart is invoked which
originally just returned NIL. (Which wouldn't play with the recent
change to use DESTRUCTURING-BIND in SLIME-COMPILATION-FINISHED.)

(inspect-for-emacs %package-symbols-container): Revert Marco's change
from 2007-04-08; he had the good idea of adding a facility to jump to
the relevant source line of a symbol, but `M-.' is already bound to
SLIME-FIND-DEFINITION in the inspector, which is a nicer way of doing
this alltogether.


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/16 14:24:35	1.475
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/17 20:06:22	1.476
@@ -3055,12 +3055,17 @@
 
 (defun swank-compiler (function)
   (clear-compiler-notes)
-  (with-simple-restart (abort "Abort SLIME compilation.")
-    (multiple-value-bind (result usecs)
+  (multiple-value-bind (result usecs)
+      (with-simple-restart (abort "Abort SLIME compilation.")
         (handler-bind ((compiler-condition #'record-note-for-condition))
-          (measure-time-interval function))
-      (list (to-string result)
-            (format nil "~,2F" (/ usecs 1000000.0))))))
+          (measure-time-interval function)))
+    ;; WITH-SIMPLE-RESTART returns (values nil t) if its restart is invoked;
+    ;; unfortunately the SWANK protocol doesn't support returning multiple
+    ;; values, so we gotta convert it explicitely to a list in either case.
+    (if (and (not result) (eq usecs 't))
+        (list nil nil)
+        (list (to-string result)
+              (format nil "~,2F" (/ usecs 1000000.0))))))
 
 (defslimefun compile-file-for-emacs (filename load-p)
   "Compile FILENAME and, when LOAD-P, load the result.
@@ -4973,10 +4978,6 @@
                   (multiple-value-bind (symbol-string classification-string)
                       (string-representations symbol)
                     `((:value ,symbol ,symbol-string) ,classification-string
-                      " "
-                      (:action "[jump to source]"
-                               , (let ((symbol symbol))
-                                   (lambda () (ed-in-emacs symbol))))
                       (:newline)
                       )))))))))
 



From mbaringer at common-lisp.net  Tue Apr 17 20:06:37 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Tue, 17 Apr 2007 16:06:37 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070417200637.A67011120@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/16 14:48:14	1.1111
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/17 20:06:37	1.1112
@@ -1,3 +1,18 @@
+2007-04-17  Takehiko Abe <keke at gol.com>
+
+	* swank.lisp (swank-compiler): Fix the return value to always be a
+	list of two elements even if the abort restart is invoked which
+	originally just returned NIL. (Which wouldn't play with the recent
+	change to use DESTRUCTURING-BIND in SLIME-COMPILATION-FINISHED.)
+
+2007-04-17  Takehiko Abe <keke at gol.com>
+
+ 	* swank.lisp (inspect-for-emacs %package-symbols-container):
+	Revert Marco's change from 2007-04-08; he had the good idea of
+	adding a facility to jump to the relevant source line of a symbol,
+	but `M-.' is already bound to SLIME-FIND-DEFINITION in the
+	inspector, which is a nicer way of doing this alltogether.
+	
 2007-04-16  Takehiko Abe <keke at gol.com>
 
 	* swank-openmcl.lisp (accept-connection, find-external-format):



From mbaringer at common-lisp.net  Tue Apr 17 20:26:46 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Tue, 17 Apr 2007 16:26:46 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070417202646.1407F5600B@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/17 20:06:37	1.1112
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/17 20:26:45	1.1113
@@ -1,11 +1,11 @@
-2007-04-17  Takehiko Abe <keke at gol.com>
+2007-04-17  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp (swank-compiler): Fix the return value to always be a
 	list of two elements even if the abort restart is invoked which
 	originally just returned NIL. (Which wouldn't play with the recent
 	change to use DESTRUCTURING-BIND in SLIME-COMPILATION-FINISHED.)
 
-2007-04-17  Takehiko Abe <keke at gol.com>
+2007-04-17  Tobias C. Rittweiler <tcr at freebits.de>
 
  	* swank.lisp (inspect-for-emacs %package-symbols-container):
 	Revert Marco's change from 2007-04-08; he had the good idea of



From mbaringer at common-lisp.net  Tue Apr 17 21:04:47 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Tue, 17 Apr 2007 17:04:47 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070417210447.A58A834055@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/17 20:26:45	1.1113
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/17 21:04:47	1.1114
@@ -1,5 +1,27 @@
 2007-04-17  Tobias C. Rittweiler <tcr at freebits.de>
 
+	* swank.lisp: Instead of just having all the symbols of a package
+	listed alphabetically in the inspector page recently introduced
+	for that purpose, add a button to that page to group them by their
+	classification.
+
+	(%package-symbols-container): New slot GROUPING-KIND.
+	(%make-package-symbols-container): New function; wraps around
+	%%MAKE-PACKAGE-SYMBOLS-CONTAINER, which will actually create the
+	structure. We need this, to make GROUPING-KIND an entirely
+	internal affair.
+
+	(make-symbols-listing): New generic function to dispatch on
+	GROUPING-KIND.
+	(make-symbols-listing :symbol): Just the stuff that was priorly
+	wired into INSPECT-FOR-EMACS (%PACKAGE-SYMBOLS-CONTAINER).
+	(make-symbols-listing :classification): New; returns the passed
+	symbols grouped by their classification.
+	(inspect-for-emacs %package-symbols-container): Most code split
+	off into MAKE-SYMBOLS-LISTING.
+
+2007-04-17  Tobias C. Rittweiler <tcr at freebits.de>
+
 	* swank.lisp (swank-compiler): Fix the return value to always be a
 	list of two elements even if the abort restart is invoked which
 	originally just returned NIL. (Which wouldn't play with the recent



From mbaringer at common-lisp.net  Tue Apr 17 21:04:55 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Tue, 17 Apr 2007 17:04:55 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070417210455.99F0F3A028@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
Instead of just having all the symbols of a package
listed alphabetically in the inspector page recently introduced
for that purpose, add a button to that page to group them by their
classification.


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/17 20:06:22	1.476
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/17 21:04:54	1.477
@@ -4937,49 +4937,107 @@
 ;; be displayed with their respective classification flags. This is
 ;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS.
 ;; Used by the Inspector for packages.
-(defstruct %package-symbols-container
-  title       ;; A string; the title of the inspector page in Emacs.   
-  description ;; A list of renderable objects; used as description.
-  symbols)    ;; The actual symbol list.
+(defstruct (%package-symbols-container (:conc-name   %container.)
+                                       (:constructor %%make-package-symbols-container))
+  title          ;; A string; the title of the inspector page in Emacs.   
+  description    ;; A list of renderable objects; used as description.
+  symbols        ;; A list of symbols. Supposed to be sorted alphabetically.
+  grouping-kind  ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING.
+  )
+
+(defun %make-package-symbols-container (&key title description symbols)
+  (%%make-package-symbols-container :title title :description description
+                                    :symbols symbols :grouping-kind :symbol))
+
+
+(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols)
+  "Returns an object renderable by Emacs' inspector side that
+alphabetically lists all the symbols in SYMBOLS together with a
+concise string representation of what each symbol
+represents (cf. CLASSIFY-SYMBOL & Fuzzy Completion.)"
+  (let ((max-length (loop for s in symbols maximizing (length (symbol-name s))))
+        (distance 10)) ; empty distance between name and classification
+    (flet ((string-representations (symbol)
+             (let* ((name (symbol-name symbol))
+                    (length (length name))
+                    (padding (- max-length length))                    
+                    (classification (classify-symbol symbol)))
+               (values
+                (concatenate 'string
+                             name
+                             (make-string (+ padding distance) :initial-element #\Space))
+                (symbol-classification->string classification)))))
+      `(""                           ; 8 is (length "Symbols:")
+        "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:"
+        (:newline)
+        ,(concatenate 'string        ; underlining dashes
+                      (make-string (+ max-length distance -1) :initial-element #\-)
+                      " "
+                      (let* ((dummy (classify-symbol (gensym)))
+                             (dummy (symbol-classification->string dummy))
+                             (classification-length (length dummy)))
+                        (make-string classification-length :initial-element #\-)))
+        (:newline)          
+        ,@(loop for symbol in symbols appending
+               (multiple-value-bind (symbol-string classification-string)
+                   (string-representations symbol)
+                 `((:value ,symbol ,symbol-string) ,classification-string
+                   (:newline)
+                   )))))))
+
+(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols)
+  "For each possible classification (cf. CLASSIFY-SYMBOL), group
+all the symbols in SYMBOLS to all of their respective
+classifications. (If a symbol is, for instance, boundp and a
+generic-function, it'll appear both below the BOUNDP group and
+the GENERIC-FUNCTION group.) As macros and special-operators are
+specified to be FBOUNDP, there is no general FBOUNDP group,
+instead there are the three explicit FUNCTION, MACRO and
+SPECIAL-OPERATOR groups."
+  (let ((table (make-hash-table :test #'eq)))
+    (flet ((maybe-convert-fboundps (classifications)
+             ;; Convert an :FBOUNDP in CLASSIFICATION to :FUNCTION if possible.
+             (if (and (member :fboundp classifications)
+                      (not (member :macro classifications))
+                      (not (member :special-operator classifications)))
+                 (substitute :function :fboundp classifications)
+                 (remove :fboundp classifications))))
+      (loop for symbol in symbols do
+            (loop for classification in (maybe-convert-fboundps (classify-symbol symbol))
+                  ;; SYMBOLS are supposed to be sorted alphabetically;
+                  ;; this property is preserved here expect for reversing.
+                  do (push symbol (gethash classification table)))))
+    (let* ((classifications (loop for k being the hash-key in table collect k))
+           (classifications (sort classifications #'string<)))
+      (loop for classification in classifications
+            for symbols = (gethash classification table)
+            appending`(,(symbol-name classification)
+                        (:newline)
+                        ,(make-string 64 :initial-element #\-)
+                        (:newline)
+                        ,@(mapcan #'(lambda (symbol)
+                                      (list `(:value ,symbol ,(symbol-name symbol)) '(:newline)))
+                                  (nreverse symbols)) ; restore alphabetic orderness.
+                        (:newline)
+                        )))))
 
 (defmethod inspect-for-emacs ((%container %package-symbols-container) inspector)
   (declare (ignore inspector))
-  (with-struct (%package-symbols-container- title description symbols) %container
-    (let ((max-length (loop for s in symbols maximizing (length (symbol-name s))))
-          (distance 10)) ; empty distance between name and classification
-      (flet ((string-representations (symbol)
-               (let* ((name (symbol-name symbol))
-                      (length (length name))
-                      (padding (- max-length length))                    
-                      (classification (classify-symbol symbol)))
-                 (values
-                  (concatenate 'string
-                               name
-                               (make-string (+ padding distance) :initial-element #\Space))
-                  (symbol-classification->string classification)))))
-        (values
-         
-         title
-         
-         `(, at description (:newline)
-                                        ; 8 is (length "Symbols:")
-           "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:"
-           (:newline)
-           ,(concatenate 'string        ; underlining dashes
-                         (make-string (+ max-length distance -1) :initial-element #\-)
-                         " "
-                         (let* ((dummy (classify-symbol (gensym)))
-                                (dummy (symbol-classification->string dummy))
-                                (classification-length (length dummy)))
-                           (make-string classification-length :initial-element #\-)))
-           (:newline)
-           
-           ,@(loop for symbol in symbols appending
-                  (multiple-value-bind (symbol-string classification-string)
-                      (string-representations symbol)
-                    `((:value ,symbol ,symbol-string) ,classification-string
-                      (:newline)
-                      )))))))))
+  (with-struct (%container. title description symbols grouping-kind) %container
+    (values title
+            `(, at description
+              (:newline)
+              "  " ,(ecase grouping-kind
+                           (:symbol
+                            `(:action "[Group by classification]"
+                                      ,(lambda () (setf grouping-kind :classification))
+                                      :refreshp t))
+                           (:classification
+                            `(:action "[Group by symbol]"
+                                      ,(lambda () (setf grouping-kind :symbol))
+                                      :refreshp t)))
+              (:newline) (:newline)
+              ,@(make-symbols-listing grouping-kind symbols)))))
 
 
 (defmethod inspect-for-emacs ((package package) inspector)
@@ -5037,7 +5095,7 @@
        (flet ((display-link (type symbols length &key title description)
                 (if (null symbols)
                     (format nil "0 ~A symbols." type)
-                    `(:value ,(make-%package-symbols-container :title title
+                    `(:value ,(%make-package-symbols-container :title title
                                                                :description description
                                                                :symbols symbols)
                              ,(format nil "~D ~A symbol~P." length type length)))))



From mbaringer at common-lisp.net  Wed Apr 18 12:35:59 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Wed, 18 Apr 2007 08:35:59 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070418123559.042D46B2C2@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(log-event): Setup the printer so that, no matter
what the global values of the *print-XYZ* variables, this function
works as expected.
(*debug-on-swank-error*): New variable.
(defpackage :swank): Export *debug-on-swank-error*.
(with-reader-error-handler): When *debug-on-swank-error* is
non-nil drop into a debugger.
(dispatch-loop): Idem.


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/17 21:04:54	1.477
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/18 12:35:59	1.478
@@ -41,6 +41,7 @@
            #:*macroexpand-printer-bindings*
            #:*record-repl-results*
            #:*inspector-dwim-lookup-hooks*
+           #:*debug-on-swank-error*
            ;; These are re-exported directly from the backend:
            #:buffer-first-change
            #:frame-source-location-for-emacs
@@ -346,14 +347,18 @@
 (defun log-event (format-string &rest args)
   "Write a message to *terminal-io* when *log-events* is non-nil.
 Useful for low level debugging."
-  (when *enable-event-history*
-    (setf (aref *event-history* *event-history-index*) 
-          (format nil "~?" format-string args))
-    (setf *event-history-index* 
-          (mod (1+ *event-history-index*) (length *event-history*))))
-  (when *log-events*
-    (apply #'format *log-output* format-string args)
-    (force-output *log-output*)))
+  (with-standard-io-syntax
+    (let ((*print-readably* nil)
+          (*print-pretty* nil)
+          (*package* *swank-io-package*))
+      (when *enable-event-history*
+        (setf (aref *event-history* *event-history-index*) 
+              (format nil "~?" format-string args))
+        (setf *event-history-index* 
+              (mod (1+ *event-history-index*) (length *event-history*))))
+      (when *log-events*
+        (apply #'format *log-output* format-string args)
+        (force-output *log-output*)))))
 
 (defun event-history-to-list ()
   "Return the list of events (older events first)."
@@ -639,15 +644,25 @@
             *use-dedicated-output-stream*)
     (finish-output *debug-io*)))
 
+(defvar *debug-on-swank-error* nil
+  "When non-nil internal swank errors will drop to a
+  debugger (not an sldb buffer). Do not set this to T unless you
+  want to debug swank internals.")
+
 (defmacro with-reader-error-handler ((connection) &body body)
-  (let ((con (gensym)))
+  (let ((con (gensym))
+        (block (gensym)))
     `(let ((,con ,connection))
-       (handler-case 
-           (progn , at body)
-         (swank-error (e)
-           (close-connection ,con 
-                             (swank-error.condition e)
-                             (swank-error.backtrace e)))))))
+       (block ,block
+         (handler-bind ((swank-error
+                         (lambda (e)
+                           (if *debug-on-swank-error*
+                               (invoke-debugger e)
+                               (return-from ,block
+                                 (close-connection ,con 
+                                                   (swank-error.condition e)
+                                                   (swank-error.backtrace e)))))))
+           (progn , at body))))))
 
 (defslimefun simple-break ()
   (with-simple-restart  (continue "Continue from interrupt.")
@@ -669,10 +684,12 @@
 
 (defun dispatch-loop (socket-io connection)
   (let ((*emacs-connection* connection))
-    (handler-case
-        (loop (dispatch-event (receive) socket-io))
-      (error (e)
-        (close-connection connection e)))))
+    (handler-bind ((error (lambda (e)
+                            (if *debug-on-swank-error*
+                                (invoke-debugger e)
+                                (return-from dispatch-loop
+                                  (close-connection connection e))))))
+      (loop (dispatch-event (receive) socket-io)))))
 
 (defun repl-thread (connection)
   (let ((thread (connection.repl-thread connection)))



From mbaringer at common-lisp.net  Wed Apr 18 12:36:12 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Wed, 18 Apr 2007 08:36:12 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070418123612.235EE30FD@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/17 21:04:47	1.1114
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/18 12:36:11	1.1115
@@ -1,3 +1,14 @@
+2007-04-18  Marco Baringer  <mb at bese.it>
+
+	* swank.lisp (log-event): Setup the printer so that, no matter
+	what the global values of the *print-XYZ* variables, this function
+	works as expected.
+	(*debug-on-swank-error*): New variable.
+	(defpackage :swank): Export *debug-on-swank-error*.
+	(with-reader-error-handler): When *debug-on-swank-error* is
+	non-nil drop into a debugger.
+	(dispatch-loop): Idem.
+
 2007-04-17  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank.lisp: Instead of just having all the symbols of a package



From mbaringer at common-lisp.net  Thu Apr 19 16:32:21 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Thu, 19 Apr 2007 12:32:21 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070419163221.95D203D010@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/18 12:36:11	1.1115
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/19 16:32:20	1.1116
@@ -1,3 +1,11 @@
+2007-04-19  Tobias C. Rittweiler <INSERT-EMAIL-HERE>
+
+	* swank-backend.lisp (label-value-line): Add :newline as &key
+	argument; if true (the default) inserts a newline.
+
+	* swank.lisp (inspect-for-emacs-list): Don't add a newline after
+	the last value of the list.
+	
 2007-04-18  Marco Baringer  <mb at bese.it>
 
 	* swank.lisp (log-event): Setup the printer so that, no matter



From mbaringer at common-lisp.net  Thu Apr 19 16:36:12 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Thu, 19 Apr 2007 12:36:12 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070419163612.8C6524B006@common-lisp.net>

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

Modified Files:
	swank-backend.lisp 
Log Message:
(label-value-line): Add :newline as &key
argument; if true (the default) inserts a newline.


--- /project/slime/cvsroot/slime/swank-backend.lisp	2007/04/08 22:56:08	1.117
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2007/04/19 16:36:12	1.118
@@ -880,9 +880,11 @@
 
 ;;; Utilities for inspector methods.
 ;;; 
-(defun label-value-line (label value)
-  "Create a control list which prints \"LABEL: VALUE\" in the inspector."
-  (list (princ-to-string label) ": " `(:value ,value) '(:newline)))
+(defun label-value-line (label value &key (newline t))
+  "Create a control list which prints \"LABEL: VALUE\" in the inspector.
+If NEWLINE is non-NIL a `(:newline)' is added to the result."
+  (list* (princ-to-string label) ": " `(:value ,value)
+         (if newline '((:newline)) nil)))
 
 (defmacro label-value-line* (&rest label-values)
   ` (append ,@(loop for (label value) in label-values



From mbaringer at common-lisp.net  Thu Apr 19 16:36:36 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Thu, 19 Apr 2007 12:36:36 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070419163636.AF8FD50035@common-lisp.net>

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

Modified Files:
	swank.lisp 
Log Message:
(inspect-for-emacs-list): Don't add a newline after
the last value of the list.


--- /project/slime/cvsroot/slime/swank.lisp	2007/04/18 12:35:59	1.478
+++ /project/slime/cvsroot/slime/swank.lisp	2007/04/19 16:36:36	1.479
@@ -4482,15 +4482,18 @@
   (let ((maxlen 40))
     (multiple-value-bind (length tail) (safe-length list)
       (flet ((frob (title list)
-               (let ((lines 
-                      (do ((i 0 (1+ i))
-                           (l list (cdr l))
-                           (a '() (cons (label-value-line i (car l)) a)))
-                          ((not (consp l))
-                           (let ((a (if (null l)
-                                        a
-                                        (cons (label-value-line :tail l) a))))
-                             (reduce #'append (reverse a) :from-end t))))))
+               (let (lines)
+                 (loop for i from 0 for rest on list do
+                       (if (consp (cdr rest))     ; e.g. (A . (B . ...))
+                           (push (label-value-line i (car rest)) lines)
+                           (progn                 ; e.g. (A . NIL) or (A . B)
+                             (push (label-value-line i (car rest) :newline nil) lines)
+                             (when (cdr rest)
+                               (push '((:newline)) lines)
+                               (push (label-value-line ':tail () :newline nil) lines))
+                             (loop-finish)))
+                       finally
+                       (setf lines (reduce #'append (nreverse lines) :from-end t)))
                  (values title (append '("Elements:" (:newline)) lines)))))
                                
         (cond ((not length)             ; circular



From mbaringer at common-lisp.net  Mon Apr 23 17:10:13 2007
From: mbaringer at common-lisp.net (mbaringer)
Date: Mon, 23 Apr 2007 13:10:13 -0400 (EDT)
Subject: [slime-cvs] CVS slime
Message-ID: <20070423171013.5BC6B8307D@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/ChangeLog	2007/04/19 16:32:20	1.1116
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/23 17:10:12	1.1117
@@ -1,4 +1,4 @@
-2007-04-19  Tobias C. Rittweiler <INSERT-EMAIL-HERE>
+2007-04-19  Tobias C. Rittweiler <tcr at freebits.de>
 
 	* swank-backend.lisp (label-value-line): Add :newline as &key
 	argument; if true (the default) inserts a newline.