Skip to content

GitLab

emacs
emacs
Commit 3bace969 authored by Aaron S. Hawley's avatar Aaron S. Hawley Committed by Stefan Monnier
Browse files
Options

* 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.
parent 1c851e98
Hide whitespace changes
Inline Side-by-side
Showing with 379 additions and 212 deletions
lisp/ChangeLog
View file @ 3bace969
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'.
......
lisp/simple.el
View file @ 3bace969
......@@ -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."
......
src/ChangeLog
View file @ 3bace969
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.
......
src/undo.c
View file @ 3bace969
......@@ -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,
......
test/ChangeLog
View file @ 3bace969
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
......
test/automated/undo-tests.el 0 → 100644
View file @ 3bace969
;;; 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment