3 files changed, 79 insertions, 64 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ab373f14766..2dd575ec3f8 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,16 @@
+2008-04-29  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * minibuffer.el (completion-common-substring): Mark obsolete.
+        (completions-first-difference, completions-common-part):
+        Move from simple.el.
+        (completion-hilit-commonality): New fun.
+        (display-completion-list, completion-emacs21-all-completions)
+        (completion-emacs22-all-completions): Use it.
+        * simple.el (completions-first-difference, completions-common-part):
+        Move to minibuffer.el.
+        (choose-completion-string): Use field functions and minibufferp.
+        (completion-setup-function): Don't set completions faces.
+
 2008-04-29  Glenn Morris  <rgm@gnu.org>
 
         * calendar/calendar.el (calendar-nth-named-absday)
@@ -29,8 +42,8 @@
 
 2008-04-29  Nick Roberts  <nickrob@snap.net.nz>
 
-        * progmodes/gdb-ui.el (gdb-info-stack-custom): Use
-        gud-tool-bar-item-visible-no-fringe.
+        * progmodes/gdb-ui.el (gdb-info-stack-custom):
+        Use gud-tool-bar-item-visible-no-fringe.
         (gdb-display-buffer): Don't pop new buffer if gud-comint-buffer
         is already visible in frame.  Remove optional size parameter
         and add optional frame parameter.
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index f6fe6f849aa..51749ba5501 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -621,15 +621,54 @@ It also eliminates runs of equal strings."
             (put-text-property (point) (progn (insert (cadr str)) (point))
                                'mouse-face nil)))))))
 
-(defvar completion-common-substring)
+(defvar completion-common-substring nil)
+(make-obsolete-variable 'completion-common-substring nil "23.1")
 
 (defvar completion-setup-hook nil
   "Normal hook run at the end of setting up a completion list buffer.
 When this hook is run, the current buffer is the one in which the
 command to display the completion list buffer was run.
 The completion list buffer is available as the value of `standard-output'.
-The common prefix substring for completion may be available as the value
-of `completion-common-substring'.  See also `display-completion-list'.")
+See also `display-completion-list'.")
+
+(defface completions-first-difference
+  '((t (:inherit bold)))
+  "Face put on the first uncommon character in completions in *Completions* buffer."
+  :group 'completion)
+
+(defface completions-common-part
+  '((t (:inherit default)))
+  "Face put on the common prefix substring in completions in *Completions* buffer.
+The idea of `completions-common-part' is that you can use it to
+make the common parts less visible than normal, so that the rest
+of the differing parts is, by contrast, slightly highlighted."
+  :group 'completion)
+
+(defun completion-hilit-commonality (completions prefix-len)
+  (when completions
+    (let* ((last (last completions))
+           (base-size (cdr last))
+           (com-str-len (- prefix-len (or base-size 0))))
+      ;; Remove base-size during mapcar, and add it back later.
+      (setcdr last nil)
+      (nconc
+       (mapcar
+        (lambda (elem)
+          (let ((str
+                 (if (consp elem)
+                     (car (setq elem (cons (copy-sequence (car elem))
+                                           (cdr elem))))
+                   (setq elem (copy-sequence elem)))))
+            (put-text-property 0 com-str-len
+                               'font-lock-face 'completions-common-part
+                               str)
+            (if (> (length str) com-str-len)
+                (put-text-property com-str-len (1+ com-str-len)
+                                   'font-lock-face 'completions-first-difference
+                                   str)))
+          elem)
+        completions)
+       base-size))))
 
 (defun display-completion-list (completions &optional common-substring)
   "Display the list of completions, COMPLETIONS, using `standard-output'.
@@ -642,14 +681,14 @@ The actual completion alternatives, as inserted, are given `mouse-face'
 properties of `highlight'.
 At the end, this runs the normal hook `completion-setup-hook'.
 It can find the completion buffer in `standard-output'.
-The optional second arg COMMON-SUBSTRING is a string.
+The obsolete optional second arg COMMON-SUBSTRING is a string.
 It is used to put faces, `completions-first-difference' and
 `completions-common-part' on the completion buffer.  The
 `completions-common-part' face is put on the common substring
-specified by COMMON-SUBSTRING.  If COMMON-SUBSTRING is nil
-and the current buffer is not the minibuffer, the faces are not put.
-Internally, COMMON-SUBSTRING is bound to `completion-common-substring'
-during running `completion-setup-hook'."
+specified by COMMON-SUBSTRING."
+  (if common-substring
+      (setq completions (completion-hilit-commonality
+                         completions (length common-substring))))
   (if (not (bufferp standard-output))
       ;; This *never* (ever) happens, so there's no point trying to be clever.
       (with-temp-buffer
@@ -670,6 +709,8 @@ during running `completion-setup-hook'."
           (setcdr last nil)) ;Make completions a properly nil-terminated list.
         (completion--insert-strings completions))))
 
+  ;; The hilit used to be applied via completion-setup-hook, so there
+  ;; may still be some code that uses completion-common-substring.
   (let ((completion-common-substring common-substring))
     (run-hooks 'completion-setup-hook))
   nil)
@@ -1000,7 +1041,9 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list."
       completion)))
 
 (defun completion-emacs21-all-completions (string table pred point)
-  (all-completions string table pred t))
+  (completion-hilit-commonality
+   (all-completions string table pred t)
+   (length string)))
 
 ;;; Basic completion, used in Emacs-22.
 
@@ -1025,7 +1068,9 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list."
       (cons (concat completion suffix) (length completion)))))
 
 (defun completion-emacs22-all-completions (string table pred point)
-  (all-completions (substring string 0 point) table pred t))
+  (completion-hilit-commonality
+   (all-completions (substring string 0 point) table pred t)
+   point))
 
 (defun completion-basic-try-completion (string table pred point)
   (let ((suffix (substring string point))
diff --git a/lisp/simple.el b/lisp/simple.el
index 4ef352e1cd5..164862c1423 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -5425,11 +5425,15 @@ to decide what to delete."
                'choose-completion-string-functions
                choice buffer mini-p base-size)
         ;; Insert the completion into the buffer where it was requested.
+        ;; FIXME:
+        ;; - There may not be a field at point, or there may be a field but
+        ;;   it's not a "completion field", in which case we have to
+        ;;   call choose-completion-delete-max-match even if base-size is set.
+        ;; - we may need to delete further than (point) to (field-end),
+        ;;   depending on the completion-style, and for that we need to
+        ;;   extra data `completion-extra-size'.
         (if base-size
-            (delete-region (+ base-size (if mini-p
-                                            (minibuffer-prompt-end)
-                                          (point-min)))
-                           (point))
+            (delete-region (+ base-size (field-beginning)) (point))
           (choose-completion-delete-max-match choice))
         (insert choice)
         (remove-text-properties (- (point) (length choice)) (point)
@@ -5439,7 +5443,7 @@ to decide what to delete."
           (set-window-point window (point)))
         ;; If completing for the minibuffer, exit it with this choice.
         (and (not completion-no-auto-exit)
-             (equal buffer (window-buffer (minibuffer-window)))
+             (minibufferp buffer)
              minibuffer-completion-table
              ;; If this is reading a file name, and the file name chosen
              ;; is a directory, don't exit the minibuffer.
@@ -5478,34 +5482,12 @@ Called from `temp-buffer-show-hook'."
   :version "22.1"
   :group 'completion)
 
-(defface completions-first-difference
-  '((t (:inherit bold)))
-  "Face put on the first uncommon character in completions in *Completions* buffer."
-  :group 'completion)
-
-(defface completions-common-part
-  '((t (:inherit default)))
-  "Face put on the common prefix substring in completions in *Completions* buffer.
-The idea of `completions-common-part' is that you can use it to
-make the common parts less visible than normal, so that the rest
-of the differing parts is, by contrast, slightly highlighted."
-  :group 'completion)
-
 ;; This is for packages that need to bind it to a non-default regexp
 ;; in order to make the first-differing character highlight work
 ;; to their liking
 (defvar completion-root-regexp "^/"
   "Regexp to use in `completion-setup-function' to find the root directory.")
 
-(defvar completion-common-substring nil
-  "Common prefix substring to use in `completion-setup-function' to put faces.
-The value is set by `display-completion-list' during running `completion-setup-hook'.
-
-To put faces `completions-first-difference' and `completions-common-part'
-in the `*Completions*' buffer, the common prefix substring in completions
-is needed as a hint.  (The minibuffer is a special case.  The content
-of the minibuffer before point is always the common substring.)")
-
 ;; This function goes in completion-setup-hook, so that it is called
 ;; after the text of the completion list buffer is written.
 (defun completion-setup-function ()
@@ -5539,31 +5521,6 @@ of the minibuffer before point is always the common substring.)")
                (minibuffer-completing-symbol nil)
                ;; Otherwise, in minibuffer, the base size is 0.
                ((minibufferp mainbuf) 0))))
-      (setq common-string-length
-            (cond
-             (completion-common-substring
-              (length completion-common-substring))
-             (completion-base-size
-              (- (length mbuf-contents) completion-base-size))))
-      ;; Put faces on first uncommon characters and common parts.
-      (when (and (integerp common-string-length) (>= common-string-length 0))
-        (let ((element-start (point-min))
-              (maxp (point-max))
-              element-common-end)
-          (while (and (setq element-start
-                            (next-single-property-change
-                             element-start 'mouse-face))
-                      (< (setq element-common-end
-                               (+ element-start common-string-length))
-                         maxp))
-            (when (get-char-property element-start 'mouse-face)
-              (if (and (> common-string-length 0)
-                       (get-char-property (1- element-common-end) 'mouse-face))
-                  (put-text-property element-start element-common-end
-                                     'font-lock-face 'completions-common-part))
-              (if (get-char-property element-common-end 'mouse-face)
-                  (put-text-property element-common-end (1+ element-common-end)
-                                     'font-lock-face 'completions-first-difference))))))
       ;; Maybe insert help string.
       (when completion-show-help
         (goto-char (point-min))