undo.lisp

   1 ;;; undo code from undo.c
   2
   3 (in-package "LICE")
   4
   5 (defvar *last-undo-buffer* nil
   6   "Last buffer for which undo information was recorded.")
   7
   8 ;; FIXME: a global used in these functions is probably bad wrt concurrency
   9 (defvar *pending-boundary* nil
  10   "The first time a command records something for undo.
  11 it also allocates the undo-boundary object
  12 which will be added to the list at the end of the command.
  13 This ensures we can't run out of space while trying to make
  14 an undo-boundary.")
  15
  16 (defun undo-boundary (&optional (buffer (current-buffer)))
  17   "Mark a boundary between units of undo.
  18 An undo command will stop at this point,
  19 but another undo command will undo to the previous boundary."
  20   (when (eq (buffer-undo-list buffer) t)
  21     (return-from undo-boundary nil))
  22   (when (car (buffer-undo-list buffer))
  23     ;; One way or another, cons nil onto the front of the undo list.
  24     (if *pending-boundary*
  25         ;; If we have preallocated the cons cell to use here, use that one. ; why the little dance? -sabetts
  26         (setf (cdr *pending-boundary*) (buffer-undo-list buffer)
  27               (buffer-undo-list buffer) *pending-boundary*
  28               *pending-boundary* nil)
  29         (push nil (buffer-undo-list buffer)))
  30     nil))
  31
  32 (defun ensure-pending-boundary ()
  33   "Allocate a cons cell to be the undo boundary after this command."
  34   (when (null *pending-boundary*)
  35     (setf *pending-boundary* (cons nil nil))))
  36
  37 (defun ensure-last-undo-buffer (&optional (buffer (current-buffer)))
  38   (unless (eq buffer *last-undo-buffer*)
  39     (undo-boundary buffer))
  40   (setf *last-undo-buffer* buffer))
  41
  42 (defun record-point (pt &optional (buffer (current-buffer)))
  43   "Record point as it was at beginning of this command (if necessary)
  44 And prepare the undo info for recording a change.
  45 PT is the position of point that will naturally occur as a result of the
  46 undo record that will be added just after this command terminates."
  47   (let (at-boundary)
  48     (ensure-pending-boundary)
  49     (ensure-last-undo-buffer buffer)
  50     (if (consp (buffer-undo-list buffer))
  51         ;; Set AT_BOUNDARY to 1 only when we have nothing other than
  52         ;; marker adjustment before undo boundary.
  53         (setf at-boundary (loop
  54                              for elt in (buffer-undo-list buffer)
  55                              while (typep elt 'undo-entry-marker)
  56                              finally (return (null elt))))
  57         (setf at-boundary t))
  58     ;; FIXME
  59     ;;   if (MODIFF <= SAVE_MODIFF)
  60     ;;     record_first_change ();
  61     (when (and at-boundary
  62                ;; If we're called from batch mode, this could be nil.
  63                (eq buffer *last-point-position-buffer*))
  64       ;; If we have switched windows, use the point value
  65       ;; from the window we are in.
  66       (unless (eq *last-point-position-window* (selected-window))
  67         (setf *last-point-position* (marker-position (window-point (selected-window)))))
  68       (when (/= *last-point-position* pt)
  69         (push *last-point-position* (buffer-undo-list buffer))))))
  70
  71 (defun record-insert (beg length &optional (buffer (current-buffer)))
  72   "Record an insertion that just happened or is about to happen, for
  73 LENGTH characters at position BEG.  (It is possible to record an
  74 insertion before or after the fact because we don't need to record
  75 the contents.)"
  76   (when (eq (buffer-undo-list buffer) t)
  77     (return-from record-insert nil))
  78   (record-point beg buffer)
  79   ;; If this is following another insertion and consecutive with it
  80   ;; in the buffer, combine the two.
  81   (when (consp (buffer-undo-list buffer))
  82     (let ((elt (car (buffer-undo-list buffer))))
  83       (when (and (typep elt 'undo-entry-insertion)
  84                  (= (undo-entry-insertion-end elt) beg))
  85         (setf (undo-entry-insertion-end elt) (+ beg length))
  86         (return-from record-insert nil))))
  87
  88   (push (make-undo-entry-insertion :beg beg :end (+ beg length)) (buffer-undo-list buffer)))
  89
  90 (defun record-delete (beg string &optional (buffer (current-buffer)))
  91   "Record that a deletion is about to take place, of the
  92 characters in STRING, at location BEG."
  93   (when (eq (buffer-undo-list buffer) t)
  94     (return-from record-delete nil))
  95   (if (= (point) (+ beg (length string)))
  96       (progn
  97         (setf beg (- beg))
  98         (record-point (point)))
  99       (record-point beg))
 100   (push (make-undo-entry-delete :position beg :text string)
 101         (buffer-undo-list buffer)))
 102
 103 (defun record-marker-adjustment (marker adjustment &optional (buffer (current-buffer)))
 104   "Record the fact that MARKER is about to be adjusted by ADJUSTMENT.
 105 This is done only when a marker points within text being deleted,
 106 because that's the only case where an automatic marker adjustment
 107 won't be inverted automatically by undoing the buffer modification."
 108   (when (eq (buffer-undo-list buffer) t)
 109     (return-from record-marker-adjustment nil))
 110   (unless *pending-boundary*
 111     (setf *pending-boundary* (cons nil nil)))
 112   (unless (eq buffer *last-undo-buffer*)
 113     (undo-boundary buffer))
 114   (setf *last-undo-buffer* buffer)
 115   (push (make-undo-entry-marker :marker marker :adjustment adjustment)
 116         (buffer-undo-list buffer)))
 117
 118 (defun record-change (beg length &optional (buffer (current-buffer)))
 119   "Record that a replacement is about to take place,
 120 for LENGTH characters at location BEG.
 121 The replacement must not change the number of characters."
 122   (record-delete beg (buffer-substring beg (+ beg length) buffer))
 123   (record-insert beg length))
 124
 125 (defun record-first-change (&optional (buffer (current-buffer)))
 126   "Record that an unmodified buffer is about to be changed.
 127 Record the file modification date so that when undoing this entry
 128 we can tell whether it is obsolete because the file was saved again."
 129   (when (eq (buffer-undo-list buffer) t)
 130     (return-from record-first-change nil))
 131
 132   (unless (eq buffer *last-undo-buffer*)
 133     (undo-boundary buffer))
 134   (setf *last-undo-buffer* buffer)
 135
 136   ;; FIXME
 137   ;;     if (base_buffer->base_buffer)
 138   ;;     base_buffer = base_buffer->base_buffer;
 139
 140   ;; FIXME: implement modtime
 141   (push (make-undo-entry-modified :time nil)
 142         (buffer-undo-list buffer)))
 143
 144 (defun record-property-change (beg length prop value buffer)
 145   "Record a change in property PROP (whose old value was VAL)
 146 for LENGTH characters starting at position BEG in BUFFER."
 147   (let (boundary)
 148     (when (eq (buffer-undo-list buffer) t)
 149       (return-from record-property-change nil))
 150
 151     (ensure-pending-boundary)
 152     (unless (eq buffer *last-undo-buffer*)
 153       (setf boundary t))
 154     (setf *last-undo-buffer* buffer)
 155     (when boundary
 156       (undo-boundary buffer))
 157     ;; FIXME
 158     ;;   if (MODIFF <= SAVE_MODIFF)
 159     ;;     record_first_change ();
 160
 161     (push (make-undo-entry-property :prop prop :value value :beg beg :end (+ beg length))
 162           (buffer-undo-list buffer))))
 163
 164 (defgeneric primitive-undo-elt (undo-elt)
 165   )
 166
 167 (defmethod primitive-undo-elt ((elt integer))
 168   "Handle an integer by setting point to that value."
 169   (set-point (clip-to-bounds (begv) elt (zv))))
 170
 171 (defmethod primitive-undo-elt ((elt undo-entry-insertion))
 172   (when (or (< (undo-entry-insertion-beg elt) (begv))
 173             (> (undo-entry-insertion-end elt) (zv)))
 174     (error "Changes to be undone are outside visible portion of buffer"))
 175   (goto-char (undo-entry-insertion-beg elt))
 176   (delete-region (undo-entry-insertion-beg elt)
 177                  (undo-entry-insertion-end elt)))
 178
 179 (defmethod primitive-undo-elt ((elt undo-entry-delete))
 180   (let ((pos (undo-entry-delete-position elt))
 181         (text (undo-entry-delete-text elt)))
 182     (if (minusp pos)
 183         (progn
 184           (when (or (< (- pos) (begv))
 185                     (> (- pos) (zv)))
 186             (error "Changes to be undone are outside visible portion of buffer"))
 187           (set-point (- pos))
 188           (insert text))
 189         (progn
 190           (when (or (< pos (begv))
 191                     (> pos (zv)))
 192             (error "Changes to be undone are outside visible portion of buffer"))
 193           (set-point pos)
 194           (insert text)
 195           (set-point pos)))))
 196
 197 (defmethod primitive-undo-elt ((undo-elt undo-entry-modified))
 198   (error "unimplented"))
 199
 200 (defmethod primitive-undo-elt ((elt undo-entry-property))
 201   (put-text-property (undo-entry-property-beg elt)
 202                      (undo-entry-property-end elt)
 203                      (undo-entry-property-prop elt)
 204                      (undo-entry-property-value elt)
 205                      nil))
 206
 207 (defmethod primitive-undo-elt ((undo-elt undo-entry-apply))
 208   (error "unimplented"))
 209
 210 (defmethod primitive-undo-elt ((undo-elt undo-entry-selective))
 211   (error "unimplented"))
 212
 213 (defmethod primitive-undo-elt ((elt undo-entry-marker))
 214   (let ((marker (undo-entry-marker-marker elt)))
 215     (when (marker-buffer marker)
 216       (set-marker marker (- (marker-position marker)
 217                             (undo-entry-marker-distance elt))
 218                   (marker-buffer marker)))))
 219
 220 (defun primitive-undo (n list)
 221   "Undo N records from the front of the list LIST.
 222 Return what remains of the list."
 223   (check-type n integer)
 224   (let ( ;; Don't let `intangible' properties interfere with undo.
 225         (*inhibit-point-motion-hooks* t)
 226         ;; In a writable buffer, enable undoing read-only text that is so
 227         ;; because of text properties.
 228         (*inhibit-read-only* t))
 229     (dotimes (arg n)
 230       (while (consp list)
 231         (let ((elt (pop list)))
 232           ;; Exit inner loop at undo boundary.
 233           (when (null elt)
 234             (return nil))
 235           (primitive-undo-elt elt))))
 236     ;; Make sure an apply entry produces at least one undo entry,
 237     ;; so the test in `undo' for continuing an undo series
 238     ;; will work right.
 239     list))