* lisp/simple.el (primitive-undo): Move from undo.c.

* src/undo.c (Fprimitive_undo): Move to simple.el.
(syms_of_undo): Remove declaration for Sprimitive_undo.
* test/automated/undo-tests.el: New file.

6 files changed, 379 insertions, 212 deletions

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  <aaron.s.hawley@gmail.com>
+
+        * simple.el (primitive-undo): Move from undo.c.
+
 2013-01-08  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * 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  <aaron.s.hawley@gmail.com>
+
+        * undo.c (Fprimitive_undo): Move to simple.el.
+        (syms_of_undo): Remove declarations for Sprimitive_undo.
+
 2013-01-08  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * 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
@@ -452,217 +452,6 @@ user_error (const char *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  <aaron.s.hawley@gmail.com>
+
+        * automated/undo-tests.el: New file.
+
 2012-12-27  Dmitry Gutov  <dgutov@yandex.ru>
 
         * 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 <aaron.s.hawley@gmail.com>
+
+;; 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