Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-15

Merge from emacs--cvs-trunk--0

Patches applied:

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-218
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-220
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-221
   Restore deleted tagline in etc/TUTORIAL.ru

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-222
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-228
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-229
   Remove TeX output files from the archive

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-230
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-247
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-248
   src/lisp.h (CYCLE_CHECK): Macro moved from xfaces.c

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-249
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-256
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-258
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-263
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-264
   Update from CVS: lispref/display.texi: emacs -> Emacs.

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-265
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-274
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-275
   Update from CVS: man/makefile.w32-in: Revert last change

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-276
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-295
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-296
   Allow restarting an existing debugger session that's exited

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-297
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-299
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-300
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-327
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-328
   Update from CVS: src/.gdbinit (xsymbol): Fix last change.

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-329
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-344
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-345
   Tweak source regexps so that building in place won't cause problems

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-346
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-351
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-352
   Update from CVS: lisp/flymake.el: New file.

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-353
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-361
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-362
   Support " [...]" style defaults in minibuffer-electric-default-mode

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-363
   (read-number): Use canonical format for default in prompt.

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-364
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-367
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-368
   Improve display-supports-face-attributes-p on non-ttys

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-369
   Rewrite face-differs-from-default-p

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-370
   Move `display-supports-face-attributes-p' entirely into C code

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-371
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-372
   Simplify face-differs-from-default-p; don't consider :stipple.

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-373
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-374
   (tty_supports_face_attributes_p): Ensure attributes differ from default

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-375
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-376
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-377
   (Fdisplay_supports_face_attributes_p): Work around bootstrapping problem

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-378
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-380
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-381
   Face merging cleanups

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-382
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-384
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-385
   src/xfaces.c (push_named_merge_point): Return 0 if a cycle is detected

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-386
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-395
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-396
   Tweak arch tagging to make build/install-in-place less annoying

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-397
   Work around vc-arch problems when building eshell

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-398
   Tweak permissions

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-399
   Tweak directory permissions

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-400
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-401
   More build-in-place tweaking of arch tagging

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-402
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-403
   Yet more build-in-place tweaking of arch tagging

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-404
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-409
   Update from CVS

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-410
   Make sure image types are initialized for lookup too

 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-411
 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-416
   Update from CVS

1 files changed, 237 insertions, 67 deletions

diff --git a/lisp/simple.el b/lisp/simple.el
index 2d0a176de0c..8da9e8028f0 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -1,7 +1,7 @@
 ;;; simple.el --- basic editing commands for Emacs
 
 ;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99,
-;;               2000, 2001, 2002, 2003
+;;               2000, 01, 02, 03, 04
 ;;        Free Software Foundation, Inc.
 
 ;; Maintainer: FSF
@@ -37,7 +37,7 @@
 
 
 (defgroup killing nil
-  "Killing and yanking commands"
+  "Killing and yanking commands."
   :group 'editing)
 
 (defgroup paren-matching nil
@@ -66,6 +66,154 @@
       (setq list (cdr list)))
     (switch-to-buffer found)))
 
+;;; next-error support framework
+(defvar next-error-last-buffer nil
+  "The most recent next-error buffer.
+A buffer becomes most recent when its compilation, grep, or
+similar mode is started, or when it is used with \\[next-error]
+or \\[compile-goto-error].")
+
+(defvar next-error-function nil
+  "Function to use to find the next error in the current buffer.
+The function is called with 2 parameters:
+ARG is an integer specifying by how many errors to move.
+RESET is a boolean which, if non-nil, says to go back to the beginning
+of the errors before moving.
+Major modes providing compile-like functionality should set this variable
+to indicate to `next-error' that this is a candidate buffer and how
+to navigate in it.")
+
+(make-variable-buffer-local 'next-error-function)
+
+(defsubst next-error-buffer-p (buffer &optional extra-test)
+  "Test if BUFFER is a next-error capable buffer."
+  (with-current-buffer buffer
+    (or (and extra-test (funcall extra-test))
+        next-error-function)))
+
+;; Return a next-error capable buffer according to the following rules:
+;; 1. If the current buffer is a next-error capable buffer, return it.
+;; 2. If one window on the selected frame displays such buffer, return it.
+;; 3. If next-error-last-buffer is set to a live buffer, use that.
+;; 4. Otherwise, look for a next-error capable buffer in a buffer list.
+;; 5. Signal an error if there are none.
+(defun next-error-find-buffer (&optional other-buffer extra-test)
+  (if (and (not other-buffer)
+           (next-error-buffer-p (current-buffer) extra-test))
+      ;; The current buffer is a next-error capable buffer.
+      (current-buffer)
+    (or
+     (let ((window-buffers
+            (delete-dups
+             (delq nil
+              (mapcar (lambda (w)
+                        (and (next-error-buffer-p (window-buffer w) extra-test)
+                             (window-buffer w)))
+                      (window-list))))))
+       (if other-buffer
+           (setq window-buffers (delq (current-buffer) window-buffers)))
+       (if (eq (length window-buffers) 1)
+           (car window-buffers)))
+     (if (and next-error-last-buffer (buffer-name next-error-last-buffer)
+              (next-error-buffer-p next-error-last-buffer extra-test)
+              (or (not other-buffer) (not (eq next-error-last-buffer
+                                              (current-buffer)))))
+         next-error-last-buffer
+       (let ((buffers (buffer-list)))
+         (while (and buffers (or (not (next-error-buffer-p (car buffers) extra-test))
+                                 (and other-buffer
+                                      (eq (car buffers) (current-buffer)))))
+           (setq buffers (cdr buffers)))
+         (if buffers
+             (car buffers)
+           (or (and other-buffer
+                    (next-error-buffer-p (current-buffer) extra-test)
+                    ;; The current buffer is a next-error capable buffer.
+                    (progn
+                      (if other-buffer
+                          (message "This is the only next-error capable buffer."))
+                      (current-buffer)))
+               (error "No next-error capable buffer found"))))))))
+
+(defun next-error (arg &optional reset)
+  "Visit next next-error message and corresponding source code.
+
+If all the error messages parsed so far have been processed already,
+the message buffer is checked for new ones.
+
+A prefix ARG specifies how many error messages to move;
+negative means move back to previous error messages.
+Just \\[universal-argument] as a prefix means reparse the error message buffer
+and start at the first error.
+
+The RESET argument specifies that we should restart from the beginning.
+
+\\[next-error] normally uses the most recently started
+compilation, grep, or occur buffer.  It can also operate on any
+buffer with output from the \\[compile], \\[grep] commands, or,
+more generally, on any buffer in Compilation mode or with
+Compilation Minor mode enabled, or any buffer in which
+`next-error-function' is bound to an appropriate
+function.  To specify use of a particular buffer for error
+messages, type \\[next-error] in that buffer.
+
+Once \\[next-error] has chosen the buffer for error messages,
+it stays with that buffer until you use it in some other buffer which
+uses Compilation mode or Compilation Minor mode.
+
+See variables `compilation-parse-errors-function' and
+\`compilation-error-regexp-alist' for customization ideas."
+  (interactive "P")
+  (if (consp arg) (setq reset t arg nil))
+  (when (setq next-error-last-buffer (next-error-find-buffer))
+    ;; we know here that next-error-function is a valid symbol we can funcall
+    (with-current-buffer next-error-last-buffer
+      (funcall next-error-function (prefix-numeric-value arg) reset))))
+
+(defalias 'goto-next-locus 'next-error)
+(defalias 'next-match 'next-error)
+
+(define-key ctl-x-map "`" 'next-error)
+
+(defun previous-error (n)
+  "Visit previous next-error message and corresponding source code.
+
+Prefix arg N says how many error messages to move backwards (or
+forwards, if negative).
+
+This operates on the output from the \\[compile] and \\[grep] commands."
+  (interactive "p")
+  (next-error (- n)))
+
+(defun first-error (n)
+  "Restart at the first error.
+Visit corresponding source code.
+With prefix arg N, visit the source code of the Nth error.
+This operates on the output from the \\[compile] command, for instance."
+  (interactive "p")
+  (next-error n t))
+
+(defun next-error-no-select (n)
+  "Move point to the next error in the next-error buffer and highlight match.
+Prefix arg N says how many error messages to move forwards (or
+backwards, if negative).
+Finds and highlights the source line like \\[next-error], but does not
+select the source buffer."
+  (interactive "p")
+  (next-error n)
+  (pop-to-buffer next-error-last-buffer))
+
+(defun previous-error-no-select (n)
+  "Move point to the previous error in the next-error buffer and highlight match.
+Prefix arg N says how many error messages to move backwards (or
+forwards, if negative).
+Finds and highlights the source line like \\[previous-error], but does not
+select the source buffer."
+  (interactive "p")
+  (next-error-no-select (- n)))
+
+;;;
+
 (defun fundamental-mode ()
   "Major mode not specialized for anything in particular.
 Other major modes are defined by comparison with this one."
@@ -159,7 +307,7 @@ than the value of `fill-column' and ARG is nil."
         (put-text-property from (point) 'rear-nonsticky
                            (cons 'hard sticky)))))
 
-(defun open-line (arg)
+(defun open-line (n)
   "Insert a newline and leave point before it.
 If there is a fill prefix and/or a left-margin, insert them on the new line
 if the line would have been blank.
@@ -170,23 +318,23 @@ With arg N, insert N newlines."
          (loc (point))
          ;; Don't expand an abbrev before point.
          (abbrev-mode nil))
-    (newline arg)
+    (newline n)
     (goto-char loc)
-    (while (> arg 0)
+    (while (> n 0)
       (cond ((bolp)
              (if do-left-margin (indent-to (current-left-margin)))
              (if do-fill-prefix (insert-and-inherit fill-prefix))))
       (forward-line 1)
-      (setq arg (1- arg)))
+      (setq n (1- n)))
     (goto-char loc)
     (end-of-line)))
 
 (defun split-line (&optional arg)
   "Split current line, moving portion beyond point vertically down.
 If the current line starts with `fill-prefix', insert it on the new
-line as well.  With prefix arg, don't insert fill-prefix on new line.
+line as well.  With prefix ARG, don't insert fill-prefix on new line.
 
-When called from Lisp code, the arg may be a prefix string to copy."
+When called from Lisp code, ARG may be a prefix string to copy."
   (interactive "*P")
   (skip-chars-forward " \t")
   (let* ((col (current-column))
@@ -637,6 +785,23 @@ If nil, don't change the value of `debug-on-error'."
   :type 'boolean
   :version "21.1")
 
+(defun eval-expression-print-format (value)
+  "Format VALUE as a result of evaluated expression.
+Return a formatted string which is displayed in the echo area
+in addition to the value printed by prin1 in functions which
+display the result of expression evaluation."
+  (if (and (integerp value)
+           (or (not (memq this-command '(eval-last-sexp eval-print-last-sexp)))
+               (eq this-command last-command)
+               (and (boundp 'edebug-active) edebug-active)))
+      (let ((char-string
+             (if (or (and (boundp 'edebug-active) edebug-active)
+                     (memq this-command '(eval-last-sexp eval-print-last-sexp)))
+                 (prin1-char value))))
+        (if char-string
+            (format " (0%o, 0x%x) = %s" value value char-string)
+          (format " (0%o, 0x%x)" value value)))))
+
 ;; We define this, rather than making `eval' interactive,
 ;; for the sake of completion of names like eval-region, eval-current-buffer.
 (defun eval-expression (eval-expression-arg
@@ -671,7 +836,10 @@ the echo area."
         (with-no-warnings
          (let ((standard-output (current-buffer)))
            (eval-last-sexp-print-value (car values))))
-      (prin1 (car values) t))))
+      (prog1
+          (prin1 (car values) t)
+        (let ((str (eval-expression-print-format (car values))))
+          (if str (princ str t)))))))
 
 (defun edit-and-eval-command (prompt command)
   "Prompting with PROMPT, let user edit COMMAND and eval result.
@@ -785,7 +953,8 @@ See also `minibuffer-history-case-insensitive-variables'."
                                         nil
                                         minibuffer-local-map
                                         nil
-                                        'minibuffer-history-search-history)))
+                                        'minibuffer-history-search-history
+                                        (car minibuffer-history-search-history))))
      ;; Use the last regexp specified, by default, if input is empty.
      (list (if (string= regexp "")
                (if minibuffer-history-search-history
@@ -987,7 +1156,7 @@ as an argument limits undo to changes within the current region."
         (undo-start))
       ;; get rid of initial undo boundary
       (undo-more 1))
-    ;; If we got this far, the next command should be a consecutive undo. 
+    ;; If we got this far, the next command should be a consecutive undo.
     (setq this-command 'undo)
     ;; Check to see whether we're hitting a redo record, and if
     ;; so, ask the user whether she wants to skip the redo/undo pair.
@@ -1935,7 +2104,7 @@ the text, but put the text in the kill ring anyway.  This means that
 you can use the killing commands to copy text from a read-only buffer.
 
 This is the primitive for programs to kill text (as opposed to deleting it).
-Supply two arguments, character numbers indicating the stretch of text
+Supply two arguments, character positions indicating the stretch of text
  to be killed.
 Any command that calls this function is a \"kill command\".
 If the previous command was also a kill command,
@@ -2009,11 +2178,12 @@ visual feedback indicating the extent of the region being copied."
             ;; look like a C-g typed as a command.
             (inhibit-quit t))
         (if (pos-visible-in-window-p other-end (selected-window))
-            (unless transient-mark-mode
+            (unless (and transient-mark-mode
+                         (face-background 'region))
               ;; Swap point and mark.
               (set-marker (mark-marker) (point) (current-buffer))
               (goto-char other-end)
-              (sit-for 1)
+              (sit-for blink-matching-delay)
               ;; Swap back.
               (set-marker (mark-marker) other-end (current-buffer))
               (goto-char opoint)
@@ -2051,7 +2221,7 @@ The argument is used for internal purposes; do not supply one."
 The value should be a list of text properties to discard or t,
 which means to discard all text properties."
   :type '(choice (const :tag "All" t) (repeat symbol))
-  :group 'editing
+  :group 'killing
   :version "21.4")
 
 (defvar yank-window-start nil)
@@ -2261,8 +2431,7 @@ With prefix arg, kill that many lines starting from the current line.
 If arg is negative, kill backward.  Also kill the preceding newline.
 \(This is meant to make C-x z work well with negative arguments.\)
 If arg is zero, kill current line but exclude the trailing newline."
-  (interactive "P")
-  (setq arg (prefix-numeric-value arg))
+  (interactive "p")
   (if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp)))
       (signal 'end-of-buffer nil))
   (if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp)))
@@ -3257,15 +3426,14 @@ Setting this variable automatically makes it local to the current buffer.")
 ;; (Actually some major modes use a different auto-fill function,
 ;; but this one is the default one.)
 (defun do-auto-fill ()
-  (let (fc justify bol give-up
+  (let (fc justify give-up
            (fill-prefix fill-prefix))
     (if (or (not (setq justify (current-justification)))
             (null (setq fc (current-fill-column)))
             (and (eq justify 'left)
                  (<= (current-column) fc))
-            (save-excursion (beginning-of-line)
-                            (setq bol (point))
-                            (and auto-fill-inhibit-regexp
+            (and auto-fill-inhibit-regexp
+                 (save-excursion (beginning-of-line)
                                  (looking-at auto-fill-inhibit-regexp))))
         nil ;; Auto-filling not required
       (if (memq justify '(full center right))
@@ -3288,16 +3456,15 @@ Setting this variable automatically makes it local to the current buffer.")
         ;; Determine where to split the line.
         (let* (after-prefix
                (fill-point
-                (let ((opoint (point)))
-                  (save-excursion
-                    (beginning-of-line)
-                    (setq after-prefix (point))
-                    (and fill-prefix
-                         (looking-at (regexp-quote fill-prefix))
-                         (setq after-prefix (match-end 0)))
-                    (move-to-column (1+ fc))
-                    (fill-move-to-break-point after-prefix)
-                    (point)))))
+                (save-excursion
+                  (beginning-of-line)
+                  (setq after-prefix (point))
+                  (and fill-prefix
+                       (looking-at (regexp-quote fill-prefix))
+                       (setq after-prefix (match-end 0)))
+                  (move-to-column (1+ fc))
+                  (fill-move-to-break-point after-prefix)
+                  (point))))
 
           ;; See whether the place we found is any good.
           (if (save-excursion
@@ -4116,27 +4283,29 @@ The completion list buffer is available as the value of `standard-output'.")
 
 ;; This function goes in completion-setup-hook, so that it is called
 ;; after the text of the completion list buffer is written.
-(defface completion-emphasis 
+(defface completions-first-difference
   '((t (:inherit bold)))
   "Face put on the first uncommon character in completions in *Completions* buffer."
   :group 'completion)
 
-(defface completion-de-emphasis 
+(defface completions-common-part
   '((t (:inherit default)))
-  "Face put on the common prefix substring in completions in *Completions* buffer."
+  "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-setup-function ()
-  (save-excursion
-    (let ((mainbuf (current-buffer))
-          (mbuf-contents (minibuffer-contents)))
-      ;; When reading a file name in the minibuffer,
-      ;; set default-directory in the minibuffer
-      ;; so it will get copied into the completion list buffer.
-      (if minibuffer-completing-file-name
-          (with-current-buffer mainbuf
-            (setq default-directory (file-name-directory mbuf-contents))))
-      (set-buffer standard-output)
+  (let ((mainbuf (current-buffer))
+        (mbuf-contents (minibuffer-contents)))
+    ;; When reading a file name in the minibuffer,
+    ;; set default-directory in the minibuffer
+    ;; so it will get copied into the completion list buffer.
+    (if minibuffer-completing-file-name
+        (with-current-buffer mainbuf
+          (setq default-directory (file-name-directory mbuf-contents))))
+    (with-current-buffer standard-output
       (completion-list-mode)
       (make-local-variable 'completion-reference-buffer)
       (setq completion-reference-buffer mainbuf)
@@ -4145,35 +4314,36 @@ The completion list buffer is available as the value of `standard-output'.")
           ;; use the number of chars before the start of the
           ;; last file name component.
           (setq completion-base-size
-                (save-excursion
-                  (set-buffer mainbuf)
-                  (goto-char (point-max))
-                  (skip-chars-backward "^/")
-                  (- (point) (minibuffer-prompt-end))))
+                (with-current-buffer mainbuf
+                  (save-excursion
+                    (goto-char (point-max))
+                    (skip-chars-backward "^/")
+                    (- (point) (minibuffer-prompt-end)))))
         ;; Otherwise, in minibuffer, the whole input is being completed.
-        (save-match-data
-          (if (minibufferp mainbuf)
-              (setq completion-base-size 0))))
-       ;; Put emphasis and de-emphasis faces on completions.
+        (if (minibufferp mainbuf)
+            (setq completion-base-size 0)))
+      ;; Put faces on first uncommon characters and common parts.
       (when completion-base-size
-        (let ((common-string-length (length 
-                                     (substring mbuf-contents 
-                                                completion-base-size)))
-              (element-start (next-single-property-change 
-                              (point-min)
-                              'mouse-face))
-              element-common-end)
-          (while element-start
-            (setq element-common-end  (+ element-start common-string-length))
+        (let* ((common-string-length
+                (- (length mbuf-contents) completion-base-size))
+               (element-start (next-single-property-change
+                               (point-min)
+                               'mouse-face))
+               (element-common-end
+                (+ (or element-start nil) common-string-length))
+               (maxp (point-max)))
+          (while (and element-start (< element-common-end maxp))
             (when (and (get-char-property element-start 'mouse-face)
                        (get-char-property element-common-end 'mouse-face))
               (put-text-property element-start element-common-end
-                                 'font-lock-face 'completion-de-emphasis)
+                                 'font-lock-face 'completions-common-part)
               (put-text-property element-common-end (1+ element-common-end)
-                                 'font-lock-face 'completion-emphasis))
-            (setq element-start (next-single-property-change 
+                                 'font-lock-face 'completions-first-difference))
+            (setq element-start (next-single-property-change
                                  element-start
-                                 'mouse-face)))))
+                                 'mouse-face))
+            (if element-start
+                (setq element-common-end  (+ element-start common-string-length))))))
       ;; Insert help string.
       (goto-char (point-min))
       (if (display-mouse-p)
@@ -4624,5 +4794,5 @@ works by saving the value of `buffer-invisibility-spec' and setting it to nil."
 
 (provide 'simple)
 
-;;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
+;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
 ;;; simple.el ends here