Fixes: debbugs:13316

[gnu-emacs] / lisp / subr.el

diff --git a/lisp/subr.el b/lisp/subr.el
index 2fd322dc77e6d81d056abbc884a6397759e7e304..aeaab20bd474e720ff5cbbf7112795a066e1cd0d 100644 (file)
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -80,6 +80,7 @@ For more information, see Info node `(elisp)Declaring Functions'."
 (defmacro noreturn (form)
   "Evaluate FORM, expecting it not to return.
 If FORM does return, signal an error."
 (defmacro noreturn (form)
   "Evaluate FORM, expecting it not to return.
 If FORM does return, signal an error."

+  (declare (debug t))

   `(prog1 ,form
      (error "Form marked with `noreturn' did return")))
 
   `(prog1 ,form
      (error "Form marked with `noreturn' did return")))
 


@@ -87,6 +88,7 @@ If FORM does return, signal an error."
   "Evaluate FORM, expecting a constant return value.
 This is the global do-nothing version.  There is also `testcover-1value'
 that complains if FORM ever does return differing values."
   "Evaluate FORM, expecting a constant return value.
 This is the global do-nothing version.  There is also `testcover-1value'
 that complains if FORM ever does return differing values."

+  (declare (debug t))

   form)
 
 (defmacro def-edebug-spec (symbol spec)
   form)
 
 (defmacro def-edebug-spec (symbol spec)


@@ -269,16 +271,23 @@ the return value (nil if RESULT is omitted).
          ,@(cdr (cdr spec))))))
 
 (defmacro declare (&rest _specs)
          ,@(cdr (cdr spec))))))
 
 (defmacro declare (&rest _specs)

-  "Do not evaluate any arguments and return nil.
-Treated as a declaration when used at the right place in a
-`defmacro' form.  \(See Info anchor `(elisp)Definition of declare'.)"
+  "Do not evaluate any arguments, and return nil.
+If a `declare' form appears as the first form in the body of a
+`defun' or `defmacro' form, SPECS specifies various additional
+information about the function or macro; these go into effect
+during the evaluation of the `defun' or `defmacro' form.
+
+The possible values of SPECS are specified by
+`defun-declarations-alist' and `macro-declarations-alist'."

   ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
   nil)
 ))
 
 (defmacro ignore-errors (&rest body)
   "Execute BODY; if an error occurs, return nil.
   ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
   nil)
 ))
 
 (defmacro ignore-errors (&rest body)
   "Execute BODY; if an error occurs, return nil.

-Otherwise, return result of last form in BODY."
+Otherwise, return result of last form in BODY.
+See also `with-demoted-errors' that does something similar
+without silencing all errors."

   (declare (debug t) (indent 0))
   `(condition-case nil (progn ,@body) (error nil)))
 \f
   (declare (debug t) (indent 0))
   `(condition-case nil (progn ,@body) (error nil)))
 \f


@@ -457,18 +466,18 @@ If TEST is omitted or nil, `equal' is used."
       (setq tail (cdr tail)))
     value))
 
       (setq tail (cdr tail)))
     value))
 

-(make-obsolete 'assoc-ignore-case 'assoc-string "22.1")

 (defun assoc-ignore-case (key alist)
   "Like `assoc', but ignores differences in case and text representation.
 KEY must be a string.  Upper-case and lower-case letters are treated as equal.
 Unibyte strings are converted to multibyte for comparison."
 (defun assoc-ignore-case (key alist)
   "Like `assoc', but ignores differences in case and text representation.
 KEY must be a string.  Upper-case and lower-case letters are treated as equal.
 Unibyte strings are converted to multibyte for comparison."

+  (declare (obsolete assoc-string "22.1"))

   (assoc-string key alist t))
 
   (assoc-string key alist t))
 

-(make-obsolete 'assoc-ignore-representation 'assoc-string "22.1")

 (defun assoc-ignore-representation (key alist)
   "Like `assoc', but ignores differences in text representation.
 KEY must be a string.
 Unibyte strings are converted to multibyte for comparison."
 (defun assoc-ignore-representation (key alist)
   "Like `assoc', but ignores differences in text representation.
 KEY must be a string.
 Unibyte strings are converted to multibyte for comparison."

+  (declare (obsolete assoc-string "22.1"))

   (assoc-string key alist nil))
 
 (defun member-ignore-case (elt list)
   (assoc-string key alist nil))
 
 (defun member-ignore-case (elt list)


@@ -1169,18 +1178,19 @@ be a list of the form returned by `event-start' and `event-end'."
 (define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
 
 (make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")
 (define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
 
 (make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")

-(make-obsolete 'buffer-has-markers-at nil "24.2")
+(make-obsolete 'buffer-has-markers-at nil "24.3")

 
 (defun insert-string (&rest args)
   "Mocklisp-compatibility insert function.
 Like the function `insert' except that any argument that is a number
 is converted into a string by expressing it in decimal."
 
 (defun insert-string (&rest args)
   "Mocklisp-compatibility insert function.
 Like the function `insert' except that any argument that is a number
 is converted into a string by expressing it in decimal."

+  (declare (obsolete insert "22.1"))

   (dolist (el args)
     (insert (if (integerp el) (number-to-string el) el))))
   (dolist (el args)
     (insert (if (integerp el) (number-to-string el) el))))

-(make-obsolete 'insert-string 'insert "22.1")

 
 

-(defun makehash (&optional test) (make-hash-table :test (or test 'eql)))
-(make-obsolete 'makehash 'make-hash-table "22.1")
+(defun makehash (&optional test)
+  (declare (obsolete make-hash-table "22.1"))
+  (make-hash-table :test (or test 'eql)))

 
 ;; These are used by VM and some old programs
 (defalias 'focus-frame 'ignore "")
 
 ;; These are used by VM and some old programs
 (defalias 'focus-frame 'ignore "")


@@ -1194,7 +1204,7 @@ is converted into a string by expressing it in decimal."
 (set-advertised-calling-convention
  'all-completions '(string collection &optional predicate) "23.1")
 (set-advertised-calling-convention 'unintern '(name obarray) "23.3")
 (set-advertised-calling-convention
  'all-completions '(string collection &optional predicate) "23.1")
 (set-advertised-calling-convention 'unintern '(name obarray) "23.3")

-(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.2")
+(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3")

 \f
 ;;;; Obsolescence declarations for variables, and aliases.
 
 \f
 ;;;; Obsolescence declarations for variables, and aliases.
 


@@ -1246,26 +1256,14 @@ is converted into a string by expressing it in decimal."
 (make-obsolete 'process-filter-multibyte-p nil "23.1")
 (make-obsolete 'set-process-filter-multibyte nil "23.1")
 
 (make-obsolete 'process-filter-multibyte-p nil "23.1")
 (make-obsolete 'set-process-filter-multibyte nil "23.1")
 

-(make-obsolete-variable
- 'mode-line-inverse-video
- "use the appropriate faces instead."
- "21.1")
-(make-obsolete-variable
- 'unread-command-char
- "use `unread-command-events' instead.  That variable is a list of events
-to reread, so it now uses nil to mean `no event', instead of -1."
- "before 19.15")
-

 ;; Lisp manual only updated in 22.1.
 (define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
   "before 19.34")
 
 ;; Lisp manual only updated in 22.1.
 (define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro
   "before 19.34")
 

-(defvaralias 'x-lost-selection-hooks 'x-lost-selection-functions)
-(make-obsolete-variable 'x-lost-selection-hooks
-                       'x-lost-selection-functions "22.1")
-(defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions)
-(make-obsolete-variable 'x-sent-selection-hooks
-                       'x-sent-selection-functions "22.1")
+(define-obsolete-variable-alias 'x-lost-selection-hooks
+  'x-lost-selection-functions "22.1")
+(define-obsolete-variable-alias 'x-sent-selection-hooks
+  'x-sent-selection-functions "22.1")

 
 ;; This was introduced in 21.4 for pre-unicode unification.  That
 ;; usage was rendered obsolete in 23.1 which uses Unicode internally.
 
 ;; This was introduced in 21.4 for pre-unicode unification.  That
 ;; usage was rendered obsolete in 23.1 which uses Unicode internally.


@@ -1548,7 +1546,7 @@ if it is empty or a duplicate."
               (or keep-all
                   (not (equal (car history) newelt))))
       (if history-delete-duplicates
               (or keep-all
                   (not (equal (car history) newelt))))
       (if history-delete-duplicates

-         (delete newelt history))
+         (setq history (delete newelt history)))

       (setq history (cons newelt history))
       (when (integerp maxelt)
        (if (= 0 maxelt)
       (setq history (cons newelt history))
       (when (integerp maxelt)
        (if (= 0 maxelt)


@@ -1912,8 +1910,8 @@ This function is called directly from the C code."
   "Read the following input sexp, and run it whenever FILE is loaded.
 This makes or adds to an entry on `after-load-alist'.
 FILE should be the name of a library, with no directory name."
   "Read the following input sexp, and run it whenever FILE is loaded.
 This makes or adds to an entry on `after-load-alist'.
 FILE should be the name of a library, with no directory name."

+  (declare (obsolete eval-after-load "23.2"))

   (eval-after-load file (read)))
   (eval-after-load file (read)))

-(make-obsolete 'eval-next-after-load `eval-after-load "23.2")

 
 (defun display-delayed-warnings ()
   "Display delayed warnings from `delayed-warnings-list'.
 
 (defun display-delayed-warnings ()
   "Display delayed warnings from `delayed-warnings-list'.


@@ -2143,6 +2141,15 @@ any other non-digit terminates the character code and is then used as input."))
       (setq first nil))
     code))
 
       (setq first nil))
     code))
 

+(defvar read-passwd-map
+  ;; BEWARE: `defconst' would purecopy it, breaking the sharing with
+  ;; minibuffer-local-map along the way!
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map minibuffer-local-map)
+    (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570
+    map)
+  "Keymap used while reading passwords.")
+

 (defun read-passwd (prompt &optional confirm default)
   "Read a password, prompting with PROMPT, and return it.
 If optional CONFIRM is non-nil, read the password twice to make sure.
 (defun read-passwd (prompt &optional confirm default)
   "Read a password, prompting with PROMPT, and return it.
 If optional CONFIRM is non-nil, read the password twice to make sure.


@@ -2179,10 +2186,14 @@ by doing (clear-string STRING)."
           (lambda ()
             (setq minibuf (current-buffer))
             ;; Turn off electricity.
           (lambda ()
             (setq minibuf (current-buffer))
             ;; Turn off electricity.

-            (set (make-local-variable 'post-self-insert-hook) nil)
+            (setq-local post-self-insert-hook nil)
+            (setq-local buffer-undo-list t)
+            (setq-local select-active-regions nil)
+            (use-local-map read-passwd-map)

             (add-hook 'after-change-functions hide-chars-fun nil 'local))
         (unwind-protect
             (add-hook 'after-change-functions hide-chars-fun nil 'local))
         (unwind-protect

-            (read-string prompt nil t default) ; t = "no history"
+            (let ((enable-recursive-minibuffers t))
+              (read-string prompt nil t default)) ; t = "no history"

           (when (buffer-live-p minibuf)
             (with-current-buffer minibuf
               ;; Not sure why but it seems that there might be cases where the
           (when (buffer-live-p minibuf)
             (with-current-buffer minibuf
               ;; Not sure why but it seems that there might be cases where the


@@ -2236,7 +2247,8 @@ keyboard-quit events while waiting for a valid input."
     (error "Called `read-char-choice' without valid char choices"))
   (let (char done show-help (helpbuf " *Char Help*"))
     (let ((cursor-in-echo-area t)
     (error "Called `read-char-choice' without valid char choices"))
   (let (char done show-help (helpbuf " *Char Help*"))
     (let ((cursor-in-echo-area t)

-          (executing-kbd-macro executing-kbd-macro))
+          (executing-kbd-macro executing-kbd-macro)
+         (esc-flag nil))

       (save-window-excursion         ; in case we call help-form-show
        (while (not done)
          (unless (get-text-property 0 'face prompt)
       (save-window-excursion         ; in case we call help-form-show
        (while (not done)
          (unless (get-text-property 0 'face prompt)


@@ -2260,8 +2272,12 @@ keyboard-quit events while waiting for a valid input."
            ;; there are no more events in the macro.  Attempt to
            ;; get an event interactively.
            (setq executing-kbd-macro nil))
            ;; there are no more events in the macro.  Attempt to
            ;; get an event interactively.
            (setq executing-kbd-macro nil))

-          ((and (not inhibit-keyboard-quit) (eq char ?\C-g))
-           (keyboard-quit))))))
+          ((not inhibit-keyboard-quit)
+           (cond
+            ((and (null esc-flag) (eq char ?\e))
+             (setq esc-flag t))
+            ((memq char '(?\C-g ?\e))
+             (keyboard-quit))))))))

     ;; Display the question with the answer.  But without cursor-in-echo-area.
     (message "%s%s" prompt (char-to-string char))
     char))
     ;; Display the question with the answer.  But without cursor-in-echo-area.
     (message "%s%s" prompt (char-to-string char))
     char))


@@ -2313,11 +2329,19 @@ floating point support."
 PROMPT is the string to display to ask the question.  It should
 end in a space; `y-or-n-p' adds \"(y or n) \" to it.
 
 PROMPT is the string to display to ask the question.  It should
 end in a space; `y-or-n-p' adds \"(y or n) \" to it.
 

-No confirmation of the answer is requested; a single character is enough.
-Also accepts Space to mean yes, or Delete to mean no.  \(Actually, it uses
-the bindings in `query-replace-map'; see the documentation of that variable
-for more information.  In this case, the useful bindings are `act', `skip',
-`recenter', and `quit'.\)
+No confirmation of the answer is requested; a single character is
+enough.  SPC also means yes, and DEL means no.
+
+To be precise, this function translates user input into responses
+by consulting the bindings in `query-replace-map'; see the
+documentation of that variable for more information.  In this
+case, the useful bindings are `act', `skip', `recenter',
+`scroll-up', `scroll-down', and `quit'.
+An `act' response means yes, and a `skip' response means no.
+A `quit' response means to invoke `keyboard-quit'.
+If the user enters `recenter', `scroll-up', or `scroll-down'
+responses, perform the requested window recentering or scrolling
+and ask again.

 
 Under a windowing system a dialog box will be used if `last-nonmenu-event'
 is nil and `use-dialog-box' is non-nil."
 
 Under a windowing system a dialog box will be used if `last-nonmenu-event'
 is nil and `use-dialog-box' is non-nil."


@@ -2349,21 +2373,33 @@ is nil and `use-dialog-box' is non-nil."
                                "" " ")
                            "(y or n) "))
       (while
                                "" " ")
                            "(y or n) "))
       (while

-          (let* ((key
+          (let* ((scroll-actions '(recenter scroll-up scroll-down
+                                  scroll-other-window scroll-other-window-down))
+                (key

                   (let ((cursor-in-echo-area t))
                     (when minibuffer-auto-raise
                       (raise-frame (window-frame (minibuffer-window))))
                   (let ((cursor-in-echo-area t))
                     (when minibuffer-auto-raise
                       (raise-frame (window-frame (minibuffer-window))))

-                    (read-key (propertize (if (eq answer 'recenter)
+                    (read-key (propertize (if (memq answer scroll-actions)

                                               prompt
                                             (concat "Please answer y or n.  "
                                                     prompt))
                                           'face 'minibuffer-prompt)))))
             (setq answer (lookup-key query-replace-map (vector key) t))
             (cond
                                               prompt
                                             (concat "Please answer y or n.  "
                                                     prompt))
                                           'face 'minibuffer-prompt)))))
             (setq answer (lookup-key query-replace-map (vector key) t))
             (cond

-             ((memq answer '(skip act)) nil)
-             ((eq answer 'recenter) (recenter) t)
-             ((memq answer '(exit-prefix quit)) (signal 'quit nil) t)
-             (t t)))
+            ((memq answer '(skip act)) nil)
+            ((eq answer 'recenter)
+             (recenter) t)
+            ((eq answer 'scroll-up)
+             (ignore-errors (scroll-up-command)) t)
+            ((eq answer 'scroll-down)
+             (ignore-errors (scroll-down-command)) t)
+            ((eq answer 'scroll-other-window)
+             (ignore-errors (scroll-other-window)) t)
+            ((eq answer 'scroll-other-window-down)
+             (ignore-errors (scroll-other-window-down)) t)
+            ((or (memq answer '(exit-prefix quit)) (eq key ?\e))
+             (signal 'quit nil) t)
+            (t t)))

         (ding)
         (discard-input))))
     (let ((ret (eq answer 'act)))
         (ding)
         (discard-input))))
     (let ((ret (eq answer 'act)))


@@ -2490,7 +2526,7 @@ This finishes the change group by reverting all of its changes."
 
 ;; For compatibility.
 (define-obsolete-function-alias 'redraw-modeline
 
 ;; For compatibility.
 (define-obsolete-function-alias 'redraw-modeline

-  'force-mode-line-update "24.2")
+  'force-mode-line-update "24.3")

 
 (defun force-mode-line-update (&optional all)
   "Force redisplay of the current buffer's mode line and header line.
 
 (defun force-mode-line-update (&optional all)
   "Force redisplay of the current buffer's mode line and header line.


@@ -2596,13 +2632,14 @@ When the hook runs, the temporary buffer is current.
 This hook is normally set up with a function to put the buffer in Help
 mode.")
 
 This hook is normally set up with a function to put the buffer in Help
 mode.")
 

-;; Avoid compiler warnings about this variable,
-;; which has a special meaning on certain system types.
-(defvar buffer-file-type nil
+(defvar-local buffer-file-type nil

   "Non-nil if the visited file is a binary file.
   "Non-nil if the visited file is a binary file.

-This variable is meaningful on MS-DOG and Windows NT.
+This variable is meaningful on MS-DOG and MS-Windows.

 On those systems, it is automatically local in every buffer.
 On those systems, it is automatically local in every buffer.

-On other systems, this variable is normally always nil.")
+On other systems, this variable is normally always nil.
+
+WARNING: This variable is obsolete and will disapper Real Soon Now.
+Don't use it!")

 
 ;; The `assert' macro from the cl package signals
 ;; `cl-assertion-failed' at runtime so always define it.
 
 ;; The `assert' macro from the cl package signals
 ;; `cl-assertion-failed' at runtime so always define it.


@@ -2646,6 +2683,10 @@ directory if it does not exist."
 \f
 ;;;; Misc. useful functions.
 
 \f
 ;;;; Misc. useful functions.
 

+(defsubst buffer-narrowed-p ()
+  "Return non-nil if the current buffer is narrowed."
+  (/= (- (point-max) (point-min)) (buffer-size)))
+

 (defun find-tag-default ()
   "Determine default tag to search for, based on text at point.
 If there is no plausible default, return nil."
 (defun find-tag-default ()
   "Determine default tag to search for, based on text at point.
 If there is no plausible default, return nil."


@@ -2785,50 +2826,43 @@ form."
 
 (defun function-get (f prop &optional autoload)
   "Return the value of property PROP of function F.
 
 (defun function-get (f prop &optional autoload)
   "Return the value of property PROP of function F.

-If AUTOLOAD is non-nil and F is an autoloaded macro, try to autoload
-the macro in the hope that it will set PROP."
+If AUTOLOAD is non-nil and F is autoloaded, try to autoload it
+in the hope that it will set PROP.  If AUTOLOAD is `macro', only do it
+if it's an autoloaded macro."

   (let ((val nil))
     (while (and (symbolp f)
                 (null (setq val (get f prop)))
                 (fboundp f))
       (let ((fundef (symbol-function f)))
         (if (and autoload (autoloadp fundef)
   (let ((val nil))
     (while (and (symbolp f)
                 (null (setq val (get f prop)))
                 (fboundp f))
       (let ((fundef (symbol-function f)))
         (if (and autoload (autoloadp fundef)

-                 (not (equal fundef (autoload-do-load fundef f 'macro))))
+                 (not (equal fundef
+                             (autoload-do-load fundef f
+                                               (if (eq autoload 'macro)
+                                                   'macro)))))

             nil                         ;Re-try `get' on the same `f'.
           (setq f fundef))))
     val))
 \f
 ;;;; Support for yanking and text properties.
 
             nil                         ;Re-try `get' on the same `f'.
           (setq f fundef))))
     val))
 \f
 ;;;; Support for yanking and text properties.
 

+(defvar yank-handled-properties)

 (defvar yank-excluded-properties)
 
 (defun remove-yank-excluded-properties (start end)
 (defvar yank-excluded-properties)
 
 (defun remove-yank-excluded-properties (start end)

-  "Remove `yank-excluded-properties' between START and END positions.
-Replaces `category' properties with their defined properties."
+  "Process text properties between START and END, inserted for a `yank'.
+Perform the handling specified by `yank-handled-properties', then
+remove properties specified by `yank-excluded-properties'."

   (let ((inhibit-read-only t))
   (let ((inhibit-read-only t))

-    ;; Replace any `category' property with the properties it stands
-    ;; for.  This is to remove `mouse-face' properties that are placed
-    ;; on categories in *Help* buffers' buttons.  See
-    ;; http://lists.gnu.org/archive/html/emacs-devel/2002-04/msg00648.html
-    ;; for the details.
-    (unless (memq yank-excluded-properties '(t nil))
-      (save-excursion
-       (goto-char start)
-       (while (< (point) end)
-         (let ((cat (get-text-property (point) 'category))
-               run-end)
-           (setq run-end
-                 (next-single-property-change (point) 'category nil end))
-           (when cat
-             (let (run-end2 original)
-               (remove-list-of-text-properties (point) run-end '(category))
-               (while (< (point) run-end)
-                 (setq run-end2 (next-property-change (point) nil run-end))
-                 (setq original (text-properties-at (point)))
-                 (set-text-properties (point) run-end2 (symbol-plist cat))
-                 (add-text-properties (point) run-end2 original)
-                 (goto-char run-end2))))
-           (goto-char run-end)))))
+    (dolist (handler yank-handled-properties)
+      (let ((prop (car handler))
+           (fun  (cdr handler))
+           (run-start start))
+       (while (< run-start end)
+         (let ((value (get-text-property run-start prop))
+               (run-end (next-single-property-change
+                         run-start prop nil end)))
+           (funcall fun value run-start run-end)
+           (setq run-start run-end)))))

     (if (eq yank-excluded-properties t)
        (set-text-properties start end nil)
       (remove-list-of-text-properties start end yank-excluded-properties))))
     (if (eq yank-excluded-properties t)
        (set-text-properties start end nil)
       (remove-list-of-text-properties start end yank-excluded-properties))))


@@ -2846,29 +2880,31 @@ See `insert-for-yank-1' for more details."
   (insert-for-yank-1 string))
 
 (defun insert-for-yank-1 (string)
   (insert-for-yank-1 string))
 
 (defun insert-for-yank-1 (string)

-  "Insert STRING at point, stripping some text properties.
-
-Strip text properties from the inserted text according to
-`yank-excluded-properties'.  Otherwise just like (insert STRING).
-
-If STRING has a non-nil `yank-handler' property on the first character,
-the normal insert behavior is modified in various ways.  The value of
-the yank-handler property must be a list with one to four elements
-with the following format:  (FUNCTION PARAM NOEXCLUDE UNDO).
-When FUNCTION is present and non-nil, it is called instead of `insert'
- to insert the string.  FUNCTION takes one argument--the object to insert.
-If PARAM is present and non-nil, it replaces STRING as the object
- passed to FUNCTION (or `insert'); for example, if FUNCTION is
- `yank-rectangle', PARAM may be a list of strings to insert as a
- rectangle.
-If NOEXCLUDE is present and non-nil, the normal removal of the
+  "Insert STRING at point for the `yank' command.
+This function is like `insert', except it honors the variables
+`yank-handled-properties' and `yank-excluded-properties', and the
+`yank-handler' text property.
+
+Properties listed in `yank-handled-properties' are processed,
+then those listed in `yank-excluded-properties' are discarded.
+
+If STRING has a non-nil `yank-handler' property on its first
+character, the normal insert behavior is altered.  The value of
+the `yank-handler' property must be a list of one to four
+elements, of the form (FUNCTION PARAM NOEXCLUDE UNDO).
+FUNCTION, if non-nil, should be a function of one argument, an
+ object to insert; it is called instead of `insert'.
+PARAM, if present and non-nil, replaces STRING as the argument to
+ FUNCTION or `insert'; e.g. if FUNCTION is `yank-rectangle', PARAM
+ may be a list of strings to insert as a rectangle.
+If NOEXCLUDE is present and non-nil, the normal removal of

  `yank-excluded-properties' is not performed; instead FUNCTION is
  `yank-excluded-properties' is not performed; instead FUNCTION is

- responsible for removing those properties.  This may be necessary
- if FUNCTION adjusts point before or after inserting the object.
-If UNDO is present and non-nil, it is a function that will be called
+ responsible for the removal.  This may be necessary if FUNCTION
+ adjusts point before or after inserting the object.
+UNDO, if present and non-nil, should be a function to be called

  by `yank-pop' to undo the insertion of the current object.  It is
  by `yank-pop' to undo the insertion of the current object.  It is

- called with two arguments, the start and end of the current region.
- FUNCTION may set `yank-undo-function' to override the UNDO value."
+ given two arguments, the start and end of the region.  FUNCTION
+ may set `yank-undo-function' to override UNDO."

   (let* ((handler (and (stringp string)
                       (get-text-property 0 'yank-handler string)))
         (param (or (nth 1 handler) string))
   (let* ((handler (and (stringp string)
                       (get-text-property 0 'yank-handler string)))
         (param (or (nth 1 handler) string))


@@ -2877,7 +2913,7 @@ If UNDO is present and non-nil, it is a function that will be called
         end)
 
     (setq yank-undo-function t)
         end)
 
     (setq yank-undo-function t)

-    (if (nth 0 handler) ;; FUNCTION
+    (if (nth 0 handler) ; FUNCTION

        (funcall (car handler) param)
       (insert param))
     (setq end (point))
        (funcall (car handler) param)
       (insert param))
     (setq end (point))


@@ -2886,34 +2922,17 @@ If UNDO is present and non-nil, it is a function that will be called
     ;; following text property changes.
     (setq inhibit-read-only t)
 
     ;; following text property changes.
     (setq inhibit-read-only t)
 

-    ;; What should we do with `font-lock-face' properties?
-    (if font-lock-defaults
-       ;; No, just wipe them.
-       (remove-list-of-text-properties opoint end '(font-lock-face))
-      ;; Convert them to `face'.
-      (save-excursion
-       (goto-char opoint)
-       (while (< (point) end)
-         (let ((face (get-text-property (point) 'font-lock-face))
-               run-end)
-           (setq run-end
-                 (next-single-property-change (point) 'font-lock-face nil end))
-           (when face
-             (remove-text-properties (point) run-end '(font-lock-face nil))
-             (put-text-property (point) run-end 'face face))
-           (goto-char run-end)))))
-
-    (unless (nth 2 handler) ;; NOEXCLUDE
-      (remove-yank-excluded-properties opoint (point)))
+    (unless (nth 2 handler) ; NOEXCLUDE
+      (remove-yank-excluded-properties opoint end))

 
     ;; If last inserted char has properties, mark them as rear-nonsticky.
     (if (and (> end opoint)
             (text-properties-at (1- end)))
        (put-text-property (1- end) end 'rear-nonsticky t))
 
 
     ;; If last inserted char has properties, mark them as rear-nonsticky.
     (if (and (> end opoint)
             (text-properties-at (1- end)))
        (put-text-property (1- end) end 'rear-nonsticky t))
 

-    (if (eq yank-undo-function t)                 ;; not set by FUNCTION
-       (setq yank-undo-function (nth 3 handler))) ;; UNDO
-    (if (nth 4 handler)                                   ;; COMMAND
+    (if (eq yank-undo-function t)                 ; not set by FUNCTION
+       (setq yank-undo-function (nth 3 handler))) ; UNDO
+    (if (nth 4 handler)                                   ; COMMAND

        (setq this-command (nth 4 handler)))))
 
 (defun insert-buffer-substring-no-properties (buffer &optional start end)
        (setq this-command (nth 4 handler)))))
 
 (defun insert-buffer-substring-no-properties (buffer &optional start end)


@@ -2931,14 +2950,35 @@ They default to the values of (point-min) and (point-max) in BUFFER."
 BUFFER may be a buffer or a buffer name.
 Arguments START and END are character positions specifying the substring.
 They default to the values of (point-min) and (point-max) in BUFFER.
 BUFFER may be a buffer or a buffer name.
 Arguments START and END are character positions specifying the substring.
 They default to the values of (point-min) and (point-max) in BUFFER.

-Strip text properties from the inserted text according to
-`yank-excluded-properties'."
+Before insertion, process text properties according to
+`yank-handled-properties' and `yank-excluded-properties'."

   ;; Since the buffer text should not normally have yank-handler properties,
   ;; there is no need to handle them here.
   (let ((opoint (point)))
     (insert-buffer-substring buffer start end)
     (remove-yank-excluded-properties opoint (point))))
 
   ;; Since the buffer text should not normally have yank-handler properties,
   ;; there is no need to handle them here.
   (let ((opoint (point)))
     (insert-buffer-substring buffer start end)
     (remove-yank-excluded-properties opoint (point))))
 

+(defun yank-handle-font-lock-face-property (face start end)
+  "If `font-lock-defaults' is nil, apply FACE as a `face' property.
+START and END denote the start and end of the text to act on.
+Do nothing if FACE is nil."
+  (and face
+       (null font-lock-defaults)
+       (put-text-property start end 'face face)))
+
+;; This removes `mouse-face' properties in *Help* buffer buttons:
+;; http://lists.gnu.org/archive/html/emacs-devel/2002-04/msg00648.html
+(defun yank-handle-category-property (category start end)
+  "Apply property category CATEGORY's properties between START and END."
+  (when category
+    (let ((start2 start))
+      (while (< start2 end)
+       (let ((end2     (next-property-change start2 nil end))
+             (original (text-properties-at start2)))
+         (set-text-properties start2 end2 (symbol-plist category))
+         (add-text-properties start2 end2 original)
+         (setq start2 end2))))))
+

 \f
 ;;;; Synchronous shell commands.
 
 \f
 ;;;; Synchronous shell commands.
 


@@ -3023,7 +3063,7 @@ also `with-temp-buffer'."
      (set-buffer ,buffer-or-name)
      ,@body))
 
      (set-buffer ,buffer-or-name)
      ,@body))
 

-(defun internal--before-with-seleted-window (window)
+(defun internal--before-with-selected-window (window)

   (let ((other-frame (window-frame window)))
     (list window (selected-window)
           ;; Selecting a window on another frame also changes that
   (let ((other-frame (window-frame window)))
     (list window (selected-window)
           ;; Selecting a window on another frame also changes that


@@ -3034,7 +3074,7 @@ also `with-temp-buffer'."
           (unless (eq (selected-frame) other-frame)
             (tty-top-frame other-frame)))))
 
           (unless (eq (selected-frame) other-frame)
             (tty-top-frame other-frame)))))
 

-(defun internal--after-with-seleted-window (state)
+(defun internal--after-with-selected-window (state)

   ;; First reset frame-selected-window.
   (when (window-live-p (nth 2 state))
     ;; We don't use set-frame-selected-window because it does not
   ;; First reset frame-selected-window.
   (when (window-live-p (nth 2 state))
     ;; We don't use set-frame-selected-window because it does not


@@ -3044,8 +3084,8 @@ also `with-temp-buffer'."
          (not (eq (tty-top-frame) (nth 3 state)))
          (select-frame (nth 3 state) 'norecord)))
   ;; Then reset the actual selected-window.
          (not (eq (tty-top-frame) (nth 3 state)))
          (select-frame (nth 3 state) 'norecord)))
   ;; Then reset the actual selected-window.

-  (when (window-live-p (nth 2 state))
-    (select-window (nth 2 state) 'norecord)))
+  (when (window-live-p (nth 1 state))
+    (select-window (nth 1 state) 'norecord)))

 
 (defmacro with-selected-window (window &rest body)
   "Execute the forms in BODY with WINDOW as the selected window.
 
 (defmacro with-selected-window (window &rest body)
   "Execute the forms in BODY with WINDOW as the selected window.


@@ -3065,12 +3105,12 @@ potentially make a different buffer current.  It does not alter
 the buffer list ordering."
   (declare (indent 1) (debug t))
   `(let ((save-selected-window--state
 the buffer list ordering."
   (declare (indent 1) (debug t))
   `(let ((save-selected-window--state

-          (internal--before-with-seleted-window ,window)))
+          (internal--before-with-selected-window ,window)))

      (save-current-buffer
        (unwind-protect
            (progn (select-window (car save-selected-window--state) 'norecord)
                  ,@body)
      (save-current-buffer
        (unwind-protect
            (progn (select-window (car save-selected-window--state) 'norecord)
                  ,@body)

-         (internal--after-with-seleted-window save-selected-window--state)))))
+         (internal--after-with-selected-window save-selected-window--state)))))

 
 (defmacro with-selected-frame (frame &rest body)
   "Execute the forms in BODY with FRAME as the selected frame.
 
 (defmacro with-selected-frame (frame &rest body)
   "Execute the forms in BODY with FRAME as the selected frame.


@@ -3110,6 +3150,46 @@ in which case `save-window-excursion' cannot help."
        (unwind-protect (progn ,@body)
          (set-window-configuration ,c)))))
 
        (unwind-protect (progn ,@body)
          (set-window-configuration ,c)))))
 

+(defun internal-temp-output-buffer-show (buffer)
+  "Internal function for `with-output-to-temp-buffer'."
+  (with-current-buffer buffer
+    (set-buffer-modified-p nil)
+    (goto-char (point-min)))
+
+  (if temp-buffer-show-function
+      (funcall temp-buffer-show-function buffer)
+    (with-current-buffer buffer
+      (let* ((window
+             (let ((window-combination-limit
+                  ;; When `window-combination-limit' equals
+                  ;; `temp-buffer' or `temp-buffer-resize' and
+                  ;; `temp-buffer-resize-mode' is enabled in this
+                  ;; buffer bind it to t so resizing steals space
+                  ;; preferably from the window that was split.
+                  (if (or (eq window-combination-limit 'temp-buffer)
+                          (and (eq window-combination-limit
+                                   'temp-buffer-resize)
+                               temp-buffer-resize-mode))
+                      t
+                    window-combination-limit)))
+               (display-buffer buffer)))
+            (frame (and window (window-frame window))))
+       (when window
+         (unless (eq frame (selected-frame))
+           (make-frame-visible frame))
+         (setq minibuffer-scroll-window window)
+         (set-window-hscroll window 0)
+         ;; Don't try this with NOFORCE non-nil!
+         (set-window-start window (point-min) t)
+         ;; This should not be necessary.
+         (set-window-point window (point-min))
+         ;; Run `temp-buffer-show-hook', with the chosen window selected.
+         (with-selected-window window
+           (run-hooks 'temp-buffer-show-hook))))))
+  ;; Return nil.
+  nil)
+
+;; Doc is very similar to with-temp-buffer-window.

 (defmacro with-output-to-temp-buffer (bufname &rest body)
   "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
 
 (defmacro with-output-to-temp-buffer (bufname &rest body)
   "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
 


@@ -3135,7 +3215,9 @@ with the buffer BUFNAME temporarily current.  It runs the hook
 `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
 buffer temporarily current, and the window that was used to display it
 temporarily selected.  But it doesn't run `temp-buffer-show-hook'
 `temp-buffer-show-hook' after displaying buffer BUFNAME, with that
 buffer temporarily current, and the window that was used to display it
 temporarily selected.  But it doesn't run `temp-buffer-show-hook'

-if it uses `temp-buffer-show-function'."
+if it uses `temp-buffer-show-function'.
+
+See the related form `with-temp-buffer-window'."

   (declare (debug t))
   (let ((old-dir (make-symbol "old-dir"))
         (buf (make-symbol "buf")))
   (declare (debug t))
   (let ((old-dir (make-symbol "old-dir"))
         (buf (make-symbol "buf")))


@@ -3728,7 +3810,7 @@ from `standard-syntax-table' otherwise."
     table))
 
 (defun syntax-after (pos)
     table))
 
 (defun syntax-after (pos)

-  "Return the raw syntax of the char after POS.
+  "Return the raw syntax descriptor for the char after POS.

 If POS is outside the buffer's accessible portion, return nil."
   (unless (or (< pos (point-min)) (>= pos (point-max)))
     (let ((st (if parse-sexp-lookup-properties
 If POS is outside the buffer's accessible portion, return nil."
   (unless (or (< pos (point-min)) (>= pos (point-max)))
     (let ((st (if parse-sexp-lookup-properties


@@ -3737,7 +3819,12 @@ If POS is outside the buffer's accessible portion, return nil."
        (aref (or st (syntax-table)) (char-after pos))))))
 
 (defun syntax-class (syntax)
        (aref (or st (syntax-table)) (char-after pos))))))
 
 (defun syntax-class (syntax)

-  "Return the syntax class part of the syntax descriptor SYNTAX.
+  "Return the code for the syntax class described by SYNTAX.
+
+SYNTAX should be a raw syntax descriptor; the return value is a
+integer which encodes the corresponding syntax class.  See Info
+node `(elisp)Syntax Table Internals' for a list of codes.
+

 If SYNTAX is nil, return nil."
   (and syntax (logand (car syntax) 65535)))
 \f
 If SYNTAX is nil, return nil."
   (and syntax (logand (car syntax) 65535)))
 \f


@@ -3877,6 +3964,16 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
   (put symbol 'hookvar (or hookvar 'mail-send-hook)))
 \f
 (defun set-temporary-overlay-map (map &optional keep-pred)
   (put symbol 'hookvar (or hookvar 'mail-send-hook)))
 \f
 (defun set-temporary-overlay-map (map &optional keep-pred)

+  "Set MAP as a temporary keymap taking precedence over most other keymaps.
+Note that this does NOT take precedence over the \"overriding\" maps
+`overriding-terminal-local-map' and `overriding-local-map' (or the
+`keymap' text property).  Unlike those maps, if no match for a key is
+found in MAP, the normal key lookup sequence then continues.
+
+Normally, MAP is used only once.  If the optional argument
+KEEP-PRED is t, MAP stays active if a key from MAP is used.
+KEEP-PRED can also be a function of no arguments: if it returns
+non-nil then MAP stays active."

   (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
          (overlaysym (make-symbol "t"))
          (alist (list (cons overlaysym map)))
   (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
          (overlaysym (make-symbol "t"))
          (alist (list (cons overlaysym map)))


@@ -3889,6 +3986,7 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
                                   (lookup-key ',map
                                               (this-command-keys-vector))))
                             (t `(funcall ',keep-pred)))
                                   (lookup-key ',map
                                               (this-command-keys-vector))))
                             (t `(funcall ',keep-pred)))

+               (set ',overlaysym nil)   ;Just in case.

                (remove-hook 'pre-command-hook ',clearfunsym)
                (setq emulation-mode-map-alists
                      (delq ',alist emulation-mode-map-alists))))))
                (remove-hook 'pre-command-hook ',clearfunsym)
                (setq emulation-mode-map-alists
                      (delq ',alist emulation-mode-map-alists))))))