comparison lisp/simple.el @ 83397:693e794b57bf

Merged from [e-mail]--gnu-2005 (patch 149-151, 629-641) Patches applied: * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-629 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-630 Merge from gnus--rel--5.10 * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-631 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-632 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-633 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-634 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-635 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-636 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-637 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-638 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-639 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-640 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-641 Update from CVS * [e-mail]--gnu-2005/gnus--rel--5.10--patch-149 Merge from emacs--cvs-trunk--0 * [e-mail]--gnu-2005/gnus--rel--5.10--patch-150 Update from CVS * [e-mail]--gnu-2005/gnus--rel--5.10--patch-151 Update from CVS git-archimport-id: [e-mail]--2004/emacs--multi-tty--0--patch-437

83396:201f610eb492

      (let ((char-string
             (if (or (if (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)

  ;; If we get to the end of the undo history and get an error,
  ;; another undo command will find the undo history empty
  ;; and will get another error.  To begin undoing the undos,
  ;; you must type some other command.
  (let ((modified (buffer-modified-p))
	(recent-save (recent-auto-save-p)))
    ;; If we get an error in undo-start,
    ;; the next command should not be a "consecutive undo".
    ;; So set `this-command' to something other than `undo'.
    (setq this-command 'undo-start)

    (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))
	  (message (if undo-in-region
		       (if equiv "Redo in region!" "Undo in region!")
		     (if equiv "Redo!" "Undo!"))))
      (when (and (consp equiv) undo-no-redo)
	;; The equiv entry might point to another redo record if we have done
	;; undo-redo-undo-redo-... so skip to the very last equiv.
	(while (let ((next (gethash equiv undo-equiv-table)))
		 (if next (setq equiv next))))

	    (setq tail nil)))
	(setq prev tail tail (cdr tail))))
    ;; Record what the current undo list says,
    ;; so the next command can tell if the buffer was modified in between.
    (and modified (not (buffer-modified-p))
	 (delete-auto-save-file-if-necessary recent-save))))

(defun buffer-disable-undo (&optional buffer)
  "Make BUFFER stop keeping undo information.
No argument or nil as argument means do this for the current buffer."
  (interactive)

		(list string "yank-handler specified for empty string"))))
  (if (fboundp 'menu-bar-update-yank-menu)
      (menu-bar-update-yank-menu string (and replace (car kill-ring))))
  (if (and replace kill-ring)
      (setcar kill-ring string)
    (setq kill-ring (cons string kill-ring))
    (if (> (length kill-ring) kill-ring-max)
	(setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))
  (setq kill-ring-yank-pointer kill-ring)
  (if interprogram-cut-function
      (funcall interprogram-cut-function string (not replace))))

When calling from a program, give three arguments:
BUFFER (or buffer name), START and END.
START and END specify the portion of the current buffer to be copied."
  (interactive "BCopy to buffer: \nr")
  (let ((oldbuf (current-buffer)))
    (save-excursion
      (set-buffer (get-buffer-create buffer))
      (barf-if-buffer-read-only)
      (erase-buffer)
      (save-excursion
	(insert-buffer-substring oldbuf start end)))))


      (setq mark-active t)
      (run-hooks 'activate-mark-hook)
      (unless nomsg
	(message "Mark activated")))))

(defun set-mark-command (arg)
  "Set mark at where point is, or jump to mark.
With no prefix argument, set mark, and push old mark position on local
mark ring; also push mark on global mark ring if last mark was set in
another buffer.  Immediately repeating the command activates

    (push-mark-command nil))
   ((not (eq this-command 'set-mark-command))
    (if arg
	(pop-to-mark-command)
      (push-mark-command t)))
   ((eq last-command 'pop-to-mark-command)
    (setq this-command 'pop-to-mark-command)
    (pop-to-mark-command))
   ((and (eq last-command 'pop-global-mark) (not arg))
    (setq this-command 'pop-global-mark)
    (pop-global-mark))
   (arg
    (setq this-command 'pop-to-mark-command)
    (pop-to-mark-command))

is the substring.)")

;; This function goes in completion-setup-hook, so that it is called
;; after the text of the completion list buffer is written.
(defun completion-setup-function ()
  (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

    ;; If partial-completion-mode is on, point might not be after the
    ;; last character in the minibuffer.
    ;; FIXME: This still doesn't work if the text to be completed
    ;; starts with a `-'.
    (when (and partial-completion-mode (not (eobp)))
      (setq mbuf-contents
	    (substring mbuf-contents 0 (- (point) (point-max)))))
    (with-current-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

		(setq completion-base-size
		      (funcall (get minibuffer-completion-table 'completion-base-size-function)))
	      (setq completion-base-size 0))))
      ;; Put faces on first uncommon characters and common parts.
      (when (or completion-common-substring completion-base-size)
	(let* ((common-string-length
		(if completion-common-substring
		    (length completion-common-substring)
		  (- (length mbuf-contents) completion-base-size)))
	       (element-start (next-single-property-change
			       (point-min)
			       'mouse-face))
	       (element-common-end
		(and element-start
		     (+ (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 'completions-common-part)
	      (put-text-property element-common-end (1+ element-common-end)
				 'font-lock-face 'completions-first-difference))
	    (setq element-start (next-single-property-change
				 element-start
				 '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")))

	       "In this buffer, type \\[choose-completion] to \
select the completion near point.\n\n")))))

(add-hook 'completion-setup-hook 'completion-setup-function)

(define-key minibuffer-local-completion-map [prior]
  'switch-to-completions)
(define-key minibuffer-local-must-match-map [prior]
  'switch-to-completions)
(define-key minibuffer-local-completion-map "\M-v"
  'switch-to-completions)
(define-key minibuffer-local-must-match-map "\M-v"
  'switch-to-completions)

(defun switch-to-completions ()
  "Select the completion list window."
  (interactive)
  ;; Make sure we have a completions window.

83397:693e794b57bf

      (let ((char-string
             (if (or (if (boundp 'edebug-active) edebug-active)
                     (memq this-command '(eval-last-sexp eval-print-last-sexp)))
                 (prin1-char value))))
        (if char-string
            (format " (#o%o, #x%x, %s)" value value char-string)
          (format " (#o%o, #x%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)

  ;; If we get to the end of the undo history and get an error,
  ;; another undo command will find the undo history empty
  ;; and will get another error.  To begin undoing the undos,
  ;; you must type some other command.
  (let ((modified (buffer-modified-p))
	(recent-save (recent-auto-save-p))
	message)
    ;; If we get an error in undo-start,
    ;; the next command should not be a "consecutive undo".
    ;; So set `this-command' to something other than `undo'.
    (setq this-command 'undo-start)

    (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))
	  (setq message (if undo-in-region
			    (if equiv "Redo in region!" "Undo in region!")
			  (if equiv "Redo!" "Undo!"))))
      (when (and (consp equiv) undo-no-redo)
	;; The equiv entry might point to another redo record if we have done
	;; undo-redo-undo-redo-... so skip to the very last equiv.
	(while (let ((next (gethash equiv undo-equiv-table)))
		 (if next (setq equiv next))))

	    (setq tail nil)))
	(setq prev tail tail (cdr tail))))
    ;; Record what the current undo list says,
    ;; so the next command can tell if the buffer was modified in between.
    (and modified (not (buffer-modified-p))
	 (delete-auto-save-file-if-necessary recent-save))
    ;; Display a message announcing success.
    (if message
	(message message))))

(defun buffer-disable-undo (&optional buffer)
  "Make BUFFER stop keeping undo information.
No argument or nil as argument means do this for the current buffer."
  (interactive)

		(list string "yank-handler specified for empty string"))))
  (if (fboundp 'menu-bar-update-yank-menu)
      (menu-bar-update-yank-menu string (and replace (car kill-ring))))
  (if (and replace kill-ring)
      (setcar kill-ring string)
    (push string kill-ring)
    (if (> (length kill-ring) kill-ring-max)
	(setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))
  (setq kill-ring-yank-pointer kill-ring)
  (if interprogram-cut-function
      (funcall interprogram-cut-function string (not replace))))

When calling from a program, give three arguments:
BUFFER (or buffer name), START and END.
START and END specify the portion of the current buffer to be copied."
  (interactive "BCopy to buffer: \nr")
  (let ((oldbuf (current-buffer)))
    (with-current-buffer (get-buffer-create buffer)
      (barf-if-buffer-read-only)
      (erase-buffer)
      (save-excursion
	(insert-buffer-substring oldbuf start end)))))


      (setq mark-active t)
      (run-hooks 'activate-mark-hook)
      (unless nomsg
	(message "Mark activated")))))

(defcustom set-mark-command-repeat-pop nil
  "*Non-nil means that repeating \\[set-mark-command] after popping will pop.
This means that if you type C-u \\[set-mark-command] \\[set-mark-command]
will pop twice."
  :type 'boolean
  :group 'editing)

(defun set-mark-command (arg)
  "Set mark at where point is, or jump to mark.
With no prefix argument, set mark, and push old mark position on local
mark ring; also push mark on global mark ring if last mark was set in
another buffer.  Immediately repeating the command activates

    (push-mark-command nil))
   ((not (eq this-command 'set-mark-command))
    (if arg
	(pop-to-mark-command)
      (push-mark-command t)))
   ((and set-mark-command-repeat-pop
	 (eq last-command 'pop-to-mark-command))
    (setq this-command 'pop-to-mark-command)
    (pop-to-mark-command))
   ((and set-mark-command-repeat-pop
	 (eq last-command 'pop-global-mark)
	 (not arg))
    (setq this-command 'pop-global-mark)
    (pop-global-mark))
   (arg
    (setq this-command 'pop-to-mark-command)
    (pop-to-mark-command))

is the substring.)")

;; This function goes in completion-setup-hook, so that it is called
;; after the text of the completion list buffer is written.
(defun completion-setup-function ()
  (let* ((mainbuf (current-buffer))
         (mbuf-contents (minibuffer-contents))
         (common-string-length (length mbuf-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

    ;; If partial-completion-mode is on, point might not be after the
    ;; last character in the minibuffer.
    ;; FIXME: This still doesn't work if the text to be completed
    ;; starts with a `-'.
    (when (and partial-completion-mode (not (eobp)))
      (setq common-string-length
            (- common-string-length (- (point) (point-max)))))
    (with-current-buffer standard-output
      (completion-list-mode)
      (set (make-local-variable '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

		(setq completion-base-size
		      (funcall (get minibuffer-completion-table 'completion-base-size-function)))
	      (setq completion-base-size 0))))
      ;; Put faces on first uncommon characters and common parts.
      (when (or completion-common-substring completion-base-size)
        (setq common-string-length
		(if completion-common-substring
		    (length completion-common-substring)
                  (- common-string-length completion-base-size)))
	(let ((element-start (point-min))
              (maxp (point-max))
              element-common-end)
	  (while (and (setq element-start
                            (next-single-property-change
                             element-start 'mouse-face))
                      (< (setq element-common-end
                               (+ element-start common-string-length))
                         maxp))
	    (when (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 'completions-common-part)
	      (put-text-property element-common-end (1+ element-common-end)
				 'font-lock-face 'completions-first-difference)))))
      ;; 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")))

	       "In this buffer, type \\[choose-completion] to \
select the completion near point.\n\n")))))

(add-hook 'completion-setup-hook 'completion-setup-function)

(define-key minibuffer-local-completion-map [prior] 'switch-to-completions)
(define-key minibuffer-local-completion-map "\M-v"  'switch-to-completions)

(defun switch-to-completions ()
  "Select the completion list window."
  (interactive)
  ;; Make sure we have a completions window.