--- lisp/ChangeLog	2012-12-24 12:14:04 +0000
+++ lisp/ChangeLog	2012-12-24 18:12:24 +0000
@@ -1,3 +1,8 @@
+2012-12-24  Aaron S. Hawley  <aaron.s.hawley@gmail.com>
+
+	* simple.el (primitive-undo): Translate Fprimitive_undo in undo.c
+	to Lisp.
+
 2012-12-24  Lars Ingebrigtsen  <larsi@gnus.org>
 
 	* mail/smtpmail.el (smtpmail-try-auth-method): Refactored out into

--- lisp/simple.el	2012-12-21 08:10:26 +0000
+++ lisp/simple.el	2012-12-24 17:54:20 +0000
@@ -1979,6 +1979,144 @@
     (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 (not 'ever)
+    ;; 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.
+    (when (null (car (list)))
+      (setq list (cdr list))))
+
+  (when (not (numberp n))
+    (signal 'wrong-type-argument (list 'integerp n)))
+  (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."

--- src/ChangeLog	2012-12-24 12:21:42 +0000
+++ src/ChangeLog	2012-12-24 18:12:11 +0000
@@ -1,3 +1,10 @@
+2012-12-24  Aaron S. Hawley  <aaron.s.hawley@gmail.com>
+
+	* undo.c (Fprimitive_undo): Remove and translated to Lisp as
+	primitive-undo.
+	(syms_of_undo): Remove declaratations for Sprimitive_undo,
+	Qinhibit_read_only, and Qapply.
+
 2012-12-24  Dmitry Antipov  <dmantipov@yandex.ru>
 
 	* buffer.h (BUF_COMPACT): New macro to follow the common style.

--- src/undo.c	2012-09-15 07:06:56 +0000
+++ src/undo.c	2012-12-24 17:52:41 +0000
@@ -451,230 +451,15 @@
 }
 
 
-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)
 {
-  DEFSYM (Qinhibit_read_only, "inhibit-read-only");
-  DEFSYM (Qapply, "apply");
-
   pending_boundary = Qnil;
   staticpro (&pending_boundary);
 
   last_undo_buffer = NULL;
   last_boundary_buffer = NULL;
 
-  defsubr (&Sprimitive_undo);
   defsubr (&Sundo_boundary);
 
   DEFVAR_INT ("undo-limit", undo_limit,

--- test/ChangeLog	2012-12-14 06:58:15 +0000
+++ test/ChangeLog	2012-12-24 18:12:03 +0000
@@ -1,3 +1,7 @@
+2012-12-24  Aaron S. Hawley  <aaron.s.hawley@gmail.com>
+
+	* automated/undo-tests.el: New file.
+
 2012-12-14  Dmitry Gutov  <dgutov@yandex.ru>
 
 	* automated/ruby-mode-tests.el

--- test/automated/undo-tests.el	1970-01-01 00:00:00 +0000
+++ test/automated/undo-tests.el	2012-12-24 18:00:01 +0000
@@ -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

