emacs: lisp/simple.el comparison

comparison lisp/simple.el @ 89943:4c90ffeb71c5

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

author	Miles Bader <miles@gnu.org>
date	Mon, 28 Jun 2004 07:56:49 +0000
parents	68c22ea6027c a72ee0aaa7f9
children	029a652ac817

comparison

equal deleted inserted replaced

-:9cb747ae49af
+:4c90ffeb71c5
 ;;; 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
 ;; Keywords: internal
 (autoload 'widget-convert "wid-edit")
 (autoload 'shell-mode "shell"))
 (defgroup killing nil
-"Killing and yanking commands"
+"Killing and yanking commands."
 :group 'editing)
 (defgroup paren-matching nil
 "Highlight (un)matching of parens and expressions."
 :group 'matching)
 	(if (and (not (get-buffer-window buffer))
 		 (not (string-match "\\` " (buffer-name buffer))))
 	    (setq found buffer)))
 (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."
 (interactive)
 ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
 (if (and (listp sticky) (not (memq 'hard sticky)))
 	(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.
 With arg N, insert N newlines."
 (interactive "*p")
 (let* ((do-fill-prefix (and fill-prefix (bolp)))
 	 (do-left-margin (and (bolp) (> (current-left-margin) 0)))
 	 (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))
 	 (pos (point))
 	 ;; What prefix should we check for (nil means don't).
 If nil, don't change the value of `debug-on-error'."
 :group 'lisp
 :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
 			&optional eval-expression-insert-value)
 "Evaluate EVAL-EXPRESSION-ARG and print value in the echo area.
 	(print-level eval-expression-print-level))
 (if eval-expression-insert-value
 	(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.
 COMMAND is a Lisp expression.  Let user edit that expression in
 the minibuffer, then read and evaluate the result."
 (let* ((enable-recursive-minibuffers t)
 	  (regexp (read-from-minibuffer "Previous element matching (regexp): "
 					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
 		   (car minibuffer-history-search-history)
 		 (error "No previous history search regexp"))
 (if undo-in-region
 	  (undo-start (region-beginning) (region-end))
 	(undo-start))
 ;; get rid of initial undo boundary
 (undo-more 1))
 ;; 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.
 (let ((equiv (gethash pending-undo-list undo-equiv-table)))
 (or (eq (selected-window) (minibuffer-window))
 If the buffer is read-only, Emacs will beep and refrain from deleting
 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,
 the text killed this time appends to the text killed last time
 to make one entry in the kill ring.
 	    (opoint (point))
 	    ;; Inhibit quitting so we can make a quit here
 	    ;; 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)
 	      ;; If user quit, deactivate the mark
 	      ;; as C-g would as a command.
 yank-handler)
 "*Text properties to discard when yanking.
 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)
 (defvar yank-undo-function nil
 "If non-nil, function used by `yank-pop' to delete last stretch of yanked text.
 "Kill current line.
 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")
+(interactive "p")
-(setq arg (prefix-numeric-value arg))
 (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)))
 (signal 'beginning-of-buffer nil))
 (unless (eq last-command 'kill-region)
 ;; when Auto-Fill mode is enabled.
 ;; It returns t if it really did any work.
 ;; (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)
+	    (and auto-fill-inhibit-regexp
-			    (setq bol (point))
+		 (save-excursion (beginning-of-line)
-			    (and auto-fill-inhibit-regexp
 				 (looking-at auto-fill-inhibit-regexp))))
 	nil ;; Auto-filling not required
 (if (memq justify '(full center right))
 	  (save-excursion (unjustify-current-line)))
 (while (and (not give-up) (> (current-column) fc))
 	;; Determine where to split the line.
 	(let* (after-prefix
 	       (fill-point
-		(let ((opoint (point)))
+		(save-excursion
-		  (save-excursion
+		  (beginning-of-line)
-		    (beginning-of-line)
+		  (setq after-prefix (point))
-		    (setq after-prefix (point))
+		  (and fill-prefix
-		    (and fill-prefix
+		       (looking-at (regexp-quote fill-prefix))
-			 (looking-at (regexp-quote fill-prefix))
+		       (setq after-prefix (match-end 0)))
-			 (setq after-prefix (match-end 0)))
+		  (move-to-column (1+ fc))
-		    (move-to-column (1+ fc))
+		  (fill-move-to-break-point after-prefix)
-		    (fill-move-to-break-point after-prefix)
+		  (point))))
-		    (point)))))
 	  ;; See whether the place we found is any good.
 	  (if (save-excursion
 		(goto-char fill-point)
 		(or (bolp)
 command to display the completion list buffer was run.
 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))
-(let ((mainbuf (current-buffer))
+	(mbuf-contents (minibuffer-contents)))
-	  (mbuf-contents (minibuffer-contents)))
+;; When reading a file name in the minibuffer,
-;; When reading a file name in the minibuffer,
+;; set default-directory in the minibuffer
-;; set default-directory in the minibuffer
+;; so it will get copied into the completion list buffer.
-;; so it will get copied into the completion list buffer.
+(if minibuffer-completing-file-name
-(if minibuffer-completing-file-name
+	(with-current-buffer mainbuf
-	  (with-current-buffer mainbuf
+	  (setq default-directory (file-name-directory mbuf-contents))))
-	    (setq default-directory (file-name-directory mbuf-contents))))
+(with-current-buffer standard-output
-(set-buffer standard-output)
 (completion-list-mode)
 (make-local-variable 'completion-reference-buffer)
 (setq completion-reference-buffer mainbuf)
 (if minibuffer-completing-file-name
 	  ;; For file name completion,
 	  ;; use the number of chars before the start of the
 	  ;; last file name component.
 	  (setq completion-base-size
-		(save-excursion
+		(with-current-buffer mainbuf
-		  (set-buffer mainbuf)
+		  (save-excursion
-		  (goto-char (point-max))
+		    (goto-char (point-max))
-		  (skip-chars-backward "^/")
+		    (skip-chars-backward "^/")
-		  (- (point) (minibuffer-prompt-end))))
+		    (- (point) (minibuffer-prompt-end)))))
 	;; Otherwise, in minibuffer, the whole input is being completed.
-	(save-match-data
+	(if (minibufferp mainbuf)
-	  (if (minibufferp mainbuf)
+	    (setq completion-base-size 0)))
-	      (setq completion-base-size 0))))
+;; Put faces on first uncommon characters and common parts.
-;; Put emphasis and de-emphasis faces on completions.
 (when completion-base-size
-	(let ((common-string-length (length
+	(let* ((common-string-length
-				     (substring mbuf-contents
+		(- (length mbuf-contents) completion-base-size))
-						completion-base-size)))
+	       (element-start (next-single-property-change
-	      (element-start (next-single-property-change
+			       (point-min)
-			      (point-min)
+			       'mouse-face))
-			      'mouse-face))
+	       (element-common-end
-	      element-common-end)
+		(+ (or element-start nil) common-string-length))
-	  (while element-start
+	       (maxp (point-max)))
-	    (setq element-common-end  (+ element-start common-string-length))
+	  (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))
+				 '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)
 	  (insert (substitute-command-keys
 		   "Click \\[mouse-choose-completion] on a completion to select it.\n")))
 ;	'insert-in-front-hooks '(minibuffer-prompt-insertion)))
 ;
 (provide 'simple)
-;;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
+;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
 ;;; simple.el ends here

Mercurial > emacs

comparison lisp/simple.el @ 89943:4c90ffeb71c5