diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 18481cb5aa5..72390d1ff67 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2013-01-08 Aaron S. Hawley + + * simple.el (primitive-undo): Move from undo.c. + 2013-01-08 Stefan Monnier * vc/pcvs.el (cvs-cleanup-collection): Extend meaning of `rm-handled'. diff --git a/lisp/simple.el b/lisp/simple.el index 19140cba496..86c71cd2130 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1979,6 +1979,141 @@ then call `undo-more' one or more times to undo them." (if (null pending-undo-list) (setq pending-undo-list t)))) +(defun primitive-undo (n list) + "Undo N records from the front of the list LIST. +Return what remains of the list." + + ;; This is a good feature, but would make undo-start + ;; unable to do what is expected. + ;;(when (null (car (list))) + ;; ;; If the head of the list is a boundary, it is the boundary + ;; ;; preceding this command. Get rid of it and don't count it. + ;; (setq list (cdr list)))) + + (let ((arg n) + ;; In a writable buffer, enable undoing read-only text that is + ;; so because of text properties. + (inhibit-read-only t) + ;; Don't let `intangible' properties interfere with undo. + (inhibit-point-motion-hooks t) + ;; We use oldlist only to check for EQ. ++kfs + (oldlist buffer-undo-list) + (did-apply nil) + (next nil)) + (while (> arg 0) + (while (and (consp list) + (progn + (setq next (car list)) + (setq list (cdr list)) + ;; Exit inner loop at undo boundary. + (not (null next)))) + ;; Handle an integer by setting point to that value. + (cond + ((integerp next) (goto-char next)) + ((consp next) + (let ((car (car next)) + (cdr (cdr next))) + (cond + ;; Element (t . TIME) records previous modtime. + ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or + ;; UNKNOWN_MODTIME_NSECS. + ((eq t car) + ;; If this records an obsolete save + ;; (not matching the actual disk file) + ;; then don't mark unmodified. + (when (or (equal cdr (visited-file-modtime)) + (and (consp cdr) + (equal (list (car cdr) (cdr cdr)) + (visited-file-modtime)))) + (when (fboundp 'unlock-buffer) + (unlock-buffer)) + (set-buffer-modified-p nil))) + ;; Element (nil PROP VAL BEG . END) is property change. + ((eq nil car) + (let ((beg (nth 2 cdr)) + (end (nthcdr 3 cdr)) + (prop (car cdr)) + (val (cadr cdr))) + (when (or (> (point-min) beg) + (< (point-max) end)) + (error "Changes to be undone are outside visible portion of buffer")) + (put-text-property beg end prop val))) + ((and (integerp car) (integerp cdr)) + ;; Element (BEG . END) means range was inserted. + (when (or (< car (point-min)) + (> cdr (point-max))) + (error "Changes to be undone are outside visible portion of buffer")) + ;; Set point first thing, so that undoing this undo + ;; does not send point back to where it is now. + (goto-char car) + (delete-region car cdr)) + ((eq car 'apply) + ;; Element (apply FUN . ARGS) means call FUN to undo. + (let ((currbuff (current-buffer)) + (car (car cdr)) + (cdr (cdr cdr))) + (if (integerp car) + ;; Long format: (apply DELTA START END FUN . ARGS). + (let* ((delta car) + (start (car cdr)) + (end (cadr cdr)) + (start-mark (copy-marker start nil)) + (end-mark (copy-marker end t)) + (cdr (cddr cdr)) + (fun (car cdr)) + (args (cdr cdr))) + (apply fun args) ;; Use `save-current-buffer'? + ;; Check that the function did what the entry + ;; said it would do. + (unless (and (eq start + (marker-position start-mark)) + (eq (+ delta end) + (marker-position end-mark))) + (error "Changes to be undone by function different than announced")) + (set-marker start-mark nil) + (set-marker end-mark nil)) + (apply car cdr)) + (unless (eq currbuff (current-buffer)) + (error "Undo function switched buffer")) + (setq did-apply t))) + ((and (stringp car) (integerp cdr)) + ;; Element (STRING . POS) means STRING was deleted. + (let ((membuf car) + (pos cdr)) + (when (or (< (abs pos) (point-min)) + (> (abs pos) (point-max))) + (error "Changes to be undone are outside visible portion of buffer")) + (if (< pos 0) + (progn + (goto-char (- pos)) + (insert membuf)) + (goto-char pos) + ;; Now that we record marker adjustments + ;; (caused by deletion) for undo, + ;; we should always insert after markers, + ;; so that undoing the marker adjustments + ;; put the markers back in the right place. + (insert membuf) + (goto-char pos)))) + ((and (markerp car) (integerp cdr)) + ;; (MARKER . INTEGER) means a marker MARKER + ;; was adjusted by INTEGER. + (when (marker-buffer car) + (set-marker car + (- (marker-position car) cdr) + (marker-buffer car)))) + (t (error "Unrecognized entry in undo list %S" next))))) + (t (error "Unrecognized entry in undo list %S" next)))) + (setq arg (1- arg))) + ;; Make sure an apply entry produces at least one undo entry, + ;; so the test in `undo' for continuing an undo series + ;; will work right. + (if (and did-apply + (eq oldlist buffer-undo-list)) + (setq buffer-undo-list + (cons (list 'apply 'cdr nil) buffer-undo-list)))) + list) + ;; Deep copy of a list (defun undo-copy-list (list) "Make a copy of undo list LIST." diff --git a/src/ChangeLog b/src/ChangeLog index f5dacabd130..9ab201c8be4 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2013-01-08 Aaron S. Hawley + + * undo.c (Fprimitive_undo): Move to simple.el. + (syms_of_undo): Remove declarations for Sprimitive_undo. + 2013-01-08 Stefan Monnier * keyboard.c (echo_add_key): Rename from echo_add_char. diff --git a/src/undo.c b/src/undo.c index 2626fd4ccfe..63edc8e9b8d 100644 --- a/src/undo.c +++ b/src/undo.c @@ -451,217 +451,6 @@ user_error (const char *msg) xsignal1 (Quser_error, build_string (msg)); } - -DEFUN ("primitive-undo", Fprimitive_undo, Sprimitive_undo, 2, 2, 0, - doc: /* Undo N records from the front of the list LIST. -Return what remains of the list. */) - (Lisp_Object n, Lisp_Object list) -{ - struct gcpro gcpro1, gcpro2; - Lisp_Object next; - ptrdiff_t count = SPECPDL_INDEX (); - register EMACS_INT arg; - Lisp_Object oldlist; - int did_apply = 0; - -#if 0 /* This is a good feature, but would make undo-start - unable to do what is expected. */ - Lisp_Object tem; - - /* If the head of the list is a boundary, it is the boundary - preceding this command. Get rid of it and don't count it. */ - tem = Fcar (list); - if (NILP (tem)) - list = Fcdr (list); -#endif - - CHECK_NUMBER (n); - arg = XINT (n); - next = Qnil; - GCPRO2 (next, list); - /* I don't think we need to gcpro oldlist, as we use it only - to check for EQ. ++kfs */ - - /* In a writable buffer, enable undoing read-only text that is so - because of text properties. */ - if (NILP (BVAR (current_buffer, read_only))) - specbind (Qinhibit_read_only, Qt); - - /* Don't let `intangible' properties interfere with undo. */ - specbind (Qinhibit_point_motion_hooks, Qt); - - oldlist = BVAR (current_buffer, undo_list); - - while (arg > 0) - { - while (CONSP (list)) - { - next = XCAR (list); - list = XCDR (list); - /* Exit inner loop at undo boundary. */ - if (NILP (next)) - break; - /* Handle an integer by setting point to that value. */ - if (INTEGERP (next)) - SET_PT (clip_to_bounds (BEGV, XINT (next), ZV)); - else if (CONSP (next)) - { - Lisp_Object car, cdr; - - car = XCAR (next); - cdr = XCDR (next); - if (EQ (car, Qt)) - { - /* Element (t . TIME) records previous modtime. - Preserve any flag of NONEXISTENT_MODTIME_NSECS or - UNKNOWN_MODTIME_NSECS. */ - struct buffer *base_buffer = current_buffer; - EMACS_TIME mod_time; - - if (CONSP (cdr) - && CONSP (XCDR (cdr)) - && CONSP (XCDR (XCDR (cdr))) - && CONSP (XCDR (XCDR (XCDR (cdr)))) - && INTEGERP (XCAR (XCDR (XCDR (XCDR (cdr))))) - && XINT (XCAR (XCDR (XCDR (XCDR (cdr))))) < 0) - mod_time = - (make_emacs_time - (0, XINT (XCAR (XCDR (XCDR (XCDR (cdr))))) / 1000)); - else - mod_time = lisp_time_argument (cdr); - - if (current_buffer->base_buffer) - base_buffer = current_buffer->base_buffer; - - /* If this records an obsolete save - (not matching the actual disk file) - then don't mark unmodified. */ - if (EMACS_TIME_NE (mod_time, base_buffer->modtime)) - continue; -#ifdef CLASH_DETECTION - Funlock_buffer (); -#endif /* CLASH_DETECTION */ - Fset_buffer_modified_p (Qnil); - } - else if (EQ (car, Qnil)) - { - /* Element (nil PROP VAL BEG . END) is property change. */ - Lisp_Object beg, end, prop, val; - - prop = Fcar (cdr); - cdr = Fcdr (cdr); - val = Fcar (cdr); - cdr = Fcdr (cdr); - beg = Fcar (cdr); - end = Fcdr (cdr); - - if (XINT (beg) < BEGV || XINT (end) > ZV) - user_error ("Changes to be undone are outside visible portion of buffer"); - Fput_text_property (beg, end, prop, val, Qnil); - } - else if (INTEGERP (car) && INTEGERP (cdr)) - { - /* Element (BEG . END) means range was inserted. */ - - if (XINT (car) < BEGV - || XINT (cdr) > ZV) - user_error ("Changes to be undone are outside visible portion of buffer"); - /* Set point first thing, so that undoing this undo - does not send point back to where it is now. */ - Fgoto_char (car); - Fdelete_region (car, cdr); - } - else if (EQ (car, Qapply)) - { - /* Element (apply FUN . ARGS) means call FUN to undo. */ - struct buffer *save_buffer = current_buffer; - - car = Fcar (cdr); - cdr = Fcdr (cdr); - if (INTEGERP (car)) - { - /* Long format: (apply DELTA START END FUN . ARGS). */ - Lisp_Object delta = car; - Lisp_Object start = Fcar (cdr); - Lisp_Object end = Fcar (Fcdr (cdr)); - Lisp_Object start_mark = Fcopy_marker (start, Qnil); - Lisp_Object end_mark = Fcopy_marker (end, Qt); - - cdr = Fcdr (Fcdr (cdr)); - apply1 (Fcar (cdr), Fcdr (cdr)); - - /* Check that the function did what the entry said it - would do. */ - if (!EQ (start, Fmarker_position (start_mark)) - || (XINT (delta) + XINT (end) - != marker_position (end_mark))) - error ("Changes to be undone by function different than announced"); - Fset_marker (start_mark, Qnil, Qnil); - Fset_marker (end_mark, Qnil, Qnil); - } - else - apply1 (car, cdr); - - if (save_buffer != current_buffer) - error ("Undo function switched buffer"); - did_apply = 1; - } - else if (STRINGP (car) && INTEGERP (cdr)) - { - /* Element (STRING . POS) means STRING was deleted. */ - Lisp_Object membuf; - EMACS_INT pos = XINT (cdr); - - membuf = car; - if (pos < 0) - { - if (-pos < BEGV || -pos > ZV) - user_error ("Changes to be undone are outside visible portion of buffer"); - SET_PT (-pos); - Finsert (1, &membuf); - } - else - { - if (pos < BEGV || pos > ZV) - user_error ("Changes to be undone are outside visible portion of buffer"); - SET_PT (pos); - - /* Now that we record marker adjustments - (caused by deletion) for undo, - we should always insert after markers, - so that undoing the marker adjustments - put the markers back in the right place. */ - Finsert (1, &membuf); - SET_PT (pos); - } - } - else if (MARKERP (car) && INTEGERP (cdr)) - { - /* (MARKER . INTEGER) means a marker MARKER - was adjusted by INTEGER. */ - if (XMARKER (car)->buffer) - Fset_marker (car, - make_number (marker_position (car) - XINT (cdr)), - Fmarker_buffer (car)); - } - } - } - arg--; - } - - - /* Make sure an apply entry produces at least one undo entry, - so the test in `undo' for continuing an undo series - will work right. */ - if (did_apply - && EQ (oldlist, BVAR (current_buffer, undo_list))) - bset_undo_list - (current_buffer, - Fcons (list3 (Qapply, Qcdr, Qnil), BVAR (current_buffer, undo_list))); - - UNGCPRO; - return unbind_to (count, list); -} void syms_of_undo (void) @@ -675,7 +464,6 @@ syms_of_undo (void) last_undo_buffer = NULL; last_boundary_buffer = NULL; - defsubr (&Sprimitive_undo); defsubr (&Sundo_boundary); DEFVAR_INT ("undo-limit", undo_limit, diff --git a/test/ChangeLog b/test/ChangeLog index 43c783857f3..b7b628cce69 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,7 @@ +2013-01-08 Aaron S. Hawley + + * automated/undo-tests.el: New file. + 2012-12-27 Dmitry Gutov * automated/ruby-mode-tests.el diff --git a/test/automated/undo-tests.el b/test/automated/undo-tests.el new file mode 100644 index 00000000000..3e71d974e5b --- /dev/null +++ b/test/automated/undo-tests.el @@ -0,0 +1,231 @@ +;;; undo-tests.el --- Tests of primitive-undo + +;; Copyright (C) 2012 Aaron S. Hawley + +;; Author: Aaron S. Hawley + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Profiling when the code was translate from C to Lisp on 2012-12-24. + +;;; C + +;; (elp-instrument-function 'primitive-undo) +;; (load-file "undo-test.elc") +;; (benchmark 100 '(let ((undo-test5-error nil)) (undo-test-all))) +;; Elapsed time: 305.218000s (104.841000s in 14804 GCs) +;; M-x elp-results +;; Function Name Call Count Elapsed Time Average Time +;; primitive-undo 2600 3.4889999999 0.0013419230 + +;;; Lisp + +;; (load-file "primundo.elc") +;; (elp-instrument-function 'primitive-undo) +;; (benchmark 100 '(undo-test-all)) +;; Elapsed time: 295.974000s (104.582000s in 14704 GCs) +;; M-x elp-results +;; Function Name Call Count Elapsed Time Average Time +;; primitive-undo 2700 3.6869999999 0.0013655555 + +;;; Code: + +(require 'ert) + +(ert-deftest undo-test0 () + "Test basics of \\[undo]." + (with-temp-buffer + (buffer-enable-undo) + (condition-case err + (undo) + (error + (unless (string= "No further undo information" + (cadr err)) + (error err)))) + (undo-boundary) + (insert "This") + (undo-boundary) + (erase-buffer) + (undo-boundary) + (insert "That") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (insert "With ") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (kill-word 1) + (undo-boundary) + (put-text-property (point-min) (point-max) 'face 'bold) + (undo-boundary) + (remove-text-properties (point-min) (point-max) '(face default)) + (undo-boundary) + (set-buffer-multibyte (not enable-multibyte-characters)) + (undo-boundary) + (undo) + (should + (equal (should-error (undo-more nil)) + '(wrong-type-argument integerp nil))) + (undo-more 7) + (should (string-equal "" (buffer-string))))) + +(ert-deftest undo-test1 () + "Test undo of \\[undo] command (redo)." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "This") + (undo-boundary) + (erase-buffer) + (undo-boundary) + (insert "That") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (insert "With ") + (undo-boundary) + (forward-word -1) + (undo-boundary) + (kill-word 1) + (undo-boundary) + (facemenu-add-face 'bold (point-min) (point-max)) + (undo-boundary) + (set-buffer-multibyte (not enable-multibyte-characters)) + (undo-boundary) + (should + (string-equal (buffer-string) + (progn + (undo) + (undo-more 4) + (undo) + ;(undo-more -4) + (buffer-string)))))) + +(ert-deftest undo-test2 () + "Test basic redoing with \\[undo] command." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "One") + (undo-boundary) + (insert " Zero") + (undo-boundary) + (push-mark) + (delete-region (save-excursion + (forward-word -1) + (point)) (point)) + (undo-boundary) + (beginning-of-line) + (insert "Zero") + (undo-boundary) + (undo) + (should + (string-equal (buffer-string) + (progn + (undo-more 2) + (undo) + (buffer-string)))))) + +(ert-deftest undo-test3 () + "Test modtime with \\[undo] command." + (let ((tmpfile (make-temp-file "undo-test3"))) + (with-temp-file tmpfile + (let ((buffer-file-name tmpfile)) + (buffer-enable-undo) + (set (make-local-variable 'make-backup-files) nil) + (undo-boundary) + (insert ?\s) + (undo-boundary) + (basic-save-buffer) + (insert ?\t) + (undo) + (should + (string-equal (buffer-string) + (progn + (undo) + (buffer-string))))) + (delete-file tmpfile)))) + +(ert-deftest undo-test4 () + "Test \\[undo] of \\[flush-lines]." + (with-temp-buffer + (buffer-enable-undo) + (dotimes (i 1048576) + (if (zerop (% i 2)) + (insert "Evenses") + (insert "Oddses"))) + (undo-boundary) + (should + ;; Avoid string-equal because ERT will save the `buffer-string' + ;; to the explanation. Using `not' will record nil or non-nil. + (not + (null + (string-equal (buffer-string) + (progn + (flush-lines "oddses" (point-min) (point-max)) + (undo-boundary) + (undo) + (undo) + (buffer-string)))))))) + +(ert-deftest undo-test5 () + "Test basic redoing with \\[undo] command." + (with-temp-buffer + (buffer-enable-undo) + (undo-boundary) + (insert "AYE") + (undo-boundary) + (insert " BEE") + (undo-boundary) + (setq buffer-undo-list (cons '(0.0 bogus) buffer-undo-list)) + (push-mark) + (delete-region (save-excursion + (forward-word -1) + (point)) (point)) + (undo-boundary) + (beginning-of-line) + (insert "CEE") + (undo-boundary) + (undo) + (setq buffer-undo-list (cons "bogus" buffer-undo-list)) + (should + (string-equal + (buffer-string) + (progn + (if (and (boundp 'undo-test5-error) (not undo-test5-error)) + (progn + (should (null (undo-more 2))) + (should (undo))) + ;; Errors are generated by new Lisp version of + ;; `primitive-undo' not by built-in C version. + (should + (equal (should-error (undo-more 2)) + '(error "Unrecognized entry in undo list (0.0 bogus)"))) + (should + (equal (should-error (undo)) + '(error "Unrecognized entry in undo list \"bogus\"")))) + (buffer-string)))))) + +(defun undo-test-all (&optional interactive) + "Run all tests for \\[undo]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^undo-") + (ert-run-tests-batch "^undo-"))) + +(provide 'undo-tests) +;;; undo-tests.el ends here