/[cmucl]/src/hemlock/undo.lisp
ViewVC logotype

Contents of /src/hemlock/undo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Wed Aug 25 02:11:18 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.2: +2 -2 lines
Fix compiler warnings.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/undo.lisp,v 1.3 1993/08/25 02:11:18 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Written by Bill Chiles
15 ;;;
16 ;;; This file contains the implementation of the undo mechanism.
17
18 (in-package "HEMLOCK")
19
20
21
22 ;;;; -- Constants --
23
24 (defconstant undo-name "Undo")
25
26
27
28 ;;;; -- Variables --
29
30 (defvar *undo-info* nil
31 "Structure containing necessary info to undo last undoable operation.")
32
33
34
35 ;;;; -- Structures --
36
37 (defstruct (undo-info (:print-function %print-undo-info)
38 (:constructor %make-undo-info
39 (name method cleanup method-undo buffer))
40 (:copier nil))
41 name ; string displayed for user to know what's being undone --
42 ; typically a command's name.
43 (hold-name undo-name) ; holds a name for successive invocations of the
44 ; "Undo" command.
45 method ; closure stored by command that undoes the command when invoked.
46 method-undo ; closure stored by command that undoes what method does.
47 cleanup ; closure stored by command that cleans up any data for method,
48 ; such as permanent marks.
49 buffer) ; buffer the command was invoked in.
50
51 (setf (documentation 'undo-info-name 'function)
52 "Return the string indicating what would be undone for given undo info.")
53 (setf (documentation 'undo-info-method 'function)
54 "Return the closure that undoes a command when invoked.")
55 (setf (documentation 'undo-info-cleanup 'function)
56 "Return the closure that cleans up data necessary for an undo method.")
57 (setf (documentation 'undo-info-buffer 'function)
58 "Return the buffer that the last undoable command was invoked in.")
59 (setf (documentation 'undo-info-hold-name 'function)
60 "Return the name being held since the last invocation of \"Undo\"")
61 (setf (documentation 'undo-info-method-undo 'function)
62 "Return the closure that undoes what undo-info-method does.")
63
64
65 (defun %print-undo-info (obj s depth)
66 (declare (ignore depth))
67 (format s "#<Undo Info ~S>" (undo-info-name obj)))
68
69
70
71 ;;;; -- Commands --
72
73 (defcommand "Undo" (p)
74 "Undo last major change, kill, etc.
75 Simple insertions and deletions cannot be undone. If you change the buffer
76 in this way before you undo, you may get slightly wrong results, but this
77 is probably still useful."
78 "This is not intended to be called in Lisp code."
79 (declare (ignore p))
80 (if (not *undo-info*) (editor-error "No currently undoable command."))
81 (let ((buffer (undo-info-buffer *undo-info*))
82 (cleanup (undo-info-cleanup *undo-info*))
83 (method-undo (undo-info-method-undo *undo-info*)))
84 (if (not (eq buffer (current-buffer)))
85 (editor-error "Undo info is for buffer ~S." (buffer-name buffer)))
86 (when (prompt-for-y-or-n :prompt (format nil "Undo the last ~A? "
87 (undo-info-name *undo-info*))
88 :must-exist t)
89 (funcall (undo-info-method *undo-info*))
90 (cond (method-undo
91 (rotatef (undo-info-name *undo-info*)
92 (undo-info-hold-name *undo-info*))
93 (rotatef (undo-info-method *undo-info*)
94 (undo-info-method-undo *undo-info*)))
95 (t (if cleanup (funcall cleanup))
96 (setf *undo-info* nil))))))
97
98
99
100 ;;;; -- Primitives --
101
102 (defun save-for-undo (name method
103 &optional cleanup method-undo (buffer (current-buffer)))
104 "Stashes information for next \"Undo\" command invocation. If there is
105 an undo-info object, it is cleaned up first."
106 (cond (*undo-info*
107 (let ((old-cleanup (undo-info-cleanup *undo-info*)))
108 (if old-cleanup (funcall old-cleanup))
109 (setf (undo-info-name *undo-info*) name)
110 (setf (undo-info-hold-name *undo-info*) undo-name)
111 (setf (undo-info-method *undo-info*) method)
112 (setf (undo-info-method-undo *undo-info*) method-undo)
113 (setf (undo-info-cleanup *undo-info*) cleanup)
114 (setf (undo-info-buffer *undo-info*) buffer)
115 *undo-info*))
116 (t (setf *undo-info*
117 (%make-undo-info name method cleanup method-undo buffer)))))
118
119
120
121 (eval-when (compile eval)
122
123 ;;; MAKE-TWIDDLE-REGION-UNDO sets up an undo method that deletes region1,
124 ;;; saving the deleted region and eventually storing it in region2. After
125 ;;; deleting region1, its start and end are made :right-inserting and
126 ;;; :left-inserting, so it will contain region2 when it is inserted at region1's
127 ;;; end. This results in a method that takes region1 with permanent marks
128 ;;; into some buffer and results with the contents of region2 in region1 (with
129 ;;; permanent marks into a buffer) and the contents of region1 (from the buffer)
130 ;;; in region2 (a region without marks into any buffer).
131 ;;;
132 (defmacro make-twiddle-region-undo (region1 region2)
133 `#'(lambda ()
134 (let* ((tregion (delete-and-save-region ,region1))
135 (mark (region-end ,region1)))
136 (setf (mark-kind (region-start ,region1)) :right-inserting)
137 (setf (mark-kind mark) :left-inserting)
138 (ninsert-region mark ,region2)
139 (setf ,region2 tregion))))
140
141 ;;; MAKE-DELETE-REGION-UNDO sets up an undo method that deletes region with
142 ;;; permanent marks into a buffer, saving the region in region without any
143 ;;; marks into a buffer, deleting one of the permanent marks, and saving one
144 ;;; permanent mark in the variable mark. This is designed to work with
145 ;;; MAKE-INSERT-REGION-UNDO, so mark results in the location in a buffer where
146 ;;; region will be inserted if this method is undone.
147 ;;;
148 (defmacro make-delete-region-undo (region mark)
149 `#'(lambda ()
150 (let ((tregion (delete-and-save-region ,region)))
151 (delete-mark (region-start ,region))
152 (setf ,mark (region-end ,region))
153 (setf ,region tregion))))
154
155 ;;; MAKE-INSERT-REGION-UNDO sets up an undo method that inserts region at mark,
156 ;;; saving in the variable region a region with permanent marks in a buffer.
157 ;;; This is designed to work with MAKE-DELETE-REGION-UNDO, so region can later
158 ;;; be deleted.
159 ;;;
160 (defmacro make-insert-region-undo (region mark)
161 `#'(lambda ()
162 (let ((tregion (region (copy-mark ,mark :right-inserting) ,mark)))
163 (setf (mark-kind ,mark) :left-inserting)
164 (ninsert-region ,mark ,region)
165 (setf ,region tregion))))
166
167 ) ;eval-when
168
169 ;;; MAKE-REGION-UNDO handles three common cases that undo'able commands often
170 ;;; need. This function sets up three closures via SAVE-FOR-UNDO that do
171 ;;; an original undo, undo the original undo, and clean up any permanent marks
172 ;;; the next time SAVE-FOR-UNDO is called. Actually, the original undo and
173 ;;; the undo for the original undo setup here are reversible in that each
174 ;;; invocation of "Undo" switches these, so an undo setup by the function is
175 ;;; undo'able, and the undo of the undo is undo'able, and the ....
176 ;;;
177 ;;; :twiddle
178 ;;; Region has permanent marks into a buffer. Mark-or-region is a region
179 ;;; not connected to any buffer. A first undo deletes region, saving it and
180 ;;; inserting mark-or-region. This also sets region around the inserted
181 ;;; region in the buffer and sets mark-or-region to be the deleted and saved
182 ;;; region. Thus the undo and the undo of the undo are the same action.
183 ;;; :insert
184 ;;; Region is not connected to any buffer. Mark-or-region is a permanent
185 ;;; mark into a buffer where region is to be inserted on a first undo, and
186 ;;; this mark is used to form a region on the first undo that will be
187 ;;; deleted upon a subsequent undo. The cleanup method knows mark-or-region
188 ;;; is a permanent mark into a buffer, but it has to determine if region
189 ;;; has marks into a buffer because if a subsequent undo does occur, region
190 ;;; does point into a buffer.
191 ;;; :delete
192 ;;; Region has permanent marks into a buffer. Mark-or-region should not
193 ;;; have been supplied. A first undo deletes region, saving the deleted
194 ;;; region in region and creating a permanent mark that indicates where to
195 ;;; put region back. The permanent mark is stored in mark-or-region. The
196 ;;; cleanup method has to check that mark-or-region is a mark since it won't
197 ;;; be unless there was a subsequent undo.
198 ;;;
199 (defun make-region-undo (kind name region &optional mark-or-region)
200 (case kind
201 (:twiddle
202 (save-for-undo name
203 (make-twiddle-region-undo region mark-or-region)
204 #'(lambda ()
205 (delete-mark (region-start region))
206 (delete-mark (region-end region)))
207 (make-twiddle-region-undo region mark-or-region)))
208 (:insert
209 (save-for-undo name
210 (make-insert-region-undo region mark-or-region)
211 #'(lambda ()
212 (let ((mark (region-start region)))
213 (delete-mark mark-or-region)
214 (when (line-buffer (mark-line mark))
215 (delete-mark mark)
216 (delete-mark (region-end region)))))
217 (make-delete-region-undo region mark-or-region)))
218 (:delete
219 (save-for-undo name
220 (make-delete-region-undo region mark-or-region)
221 #'(lambda ()
222 (delete-mark (region-start region))
223 (delete-mark (region-end region))
224 (if (markp mark-or-region) (delete-mark mark-or-region)))
225 (make-insert-region-undo region mark-or-region)))))

  ViewVC Help
Powered by ViewVC 1.1.5