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

Contents of /src/hemlock/undo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +1 -3 lines
Fix headed boilerplate.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/undo.lisp,v 1.4 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Bill Chiles
13 ;;;
14 ;;; This file contains the implementation of the undo mechanism.
15
16 (in-package "HEMLOCK")
17
18
19
20 ;;;; -- Constants --
21
22 (defconstant undo-name "Undo")
23
24
25
26 ;;;; -- Variables --
27
28 (defvar *undo-info* nil
29 "Structure containing necessary info to undo last undoable operation.")
30
31
32
33 ;;;; -- Structures --
34
35 (defstruct (undo-info (:print-function %print-undo-info)
36 (:constructor %make-undo-info
37 (name method cleanup method-undo buffer))
38 (:copier nil))
39 name ; string displayed for user to know what's being undone --
40 ; typically a command's name.
41 (hold-name undo-name) ; holds a name for successive invocations of the
42 ; "Undo" command.
43 method ; closure stored by command that undoes the command when invoked.
44 method-undo ; closure stored by command that undoes what method does.
45 cleanup ; closure stored by command that cleans up any data for method,
46 ; such as permanent marks.
47 buffer) ; buffer the command was invoked in.
48
49 (setf (documentation 'undo-info-name 'function)
50 "Return the string indicating what would be undone for given undo info.")
51 (setf (documentation 'undo-info-method 'function)
52 "Return the closure that undoes a command when invoked.")
53 (setf (documentation 'undo-info-cleanup 'function)
54 "Return the closure that cleans up data necessary for an undo method.")
55 (setf (documentation 'undo-info-buffer 'function)
56 "Return the buffer that the last undoable command was invoked in.")
57 (setf (documentation 'undo-info-hold-name 'function)
58 "Return the name being held since the last invocation of \"Undo\"")
59 (setf (documentation 'undo-info-method-undo 'function)
60 "Return the closure that undoes what undo-info-method does.")
61
62
63 (defun %print-undo-info (obj s depth)
64 (declare (ignore depth))
65 (format s "#<Undo Info ~S>" (undo-info-name obj)))
66
67
68
69 ;;;; -- Commands --
70
71 (defcommand "Undo" (p)
72 "Undo last major change, kill, etc.
73 Simple insertions and deletions cannot be undone. If you change the buffer
74 in this way before you undo, you may get slightly wrong results, but this
75 is probably still useful."
76 "This is not intended to be called in Lisp code."
77 (declare (ignore p))
78 (if (not *undo-info*) (editor-error "No currently undoable command."))
79 (let ((buffer (undo-info-buffer *undo-info*))
80 (cleanup (undo-info-cleanup *undo-info*))
81 (method-undo (undo-info-method-undo *undo-info*)))
82 (if (not (eq buffer (current-buffer)))
83 (editor-error "Undo info is for buffer ~S." (buffer-name buffer)))
84 (when (prompt-for-y-or-n :prompt (format nil "Undo the last ~A? "
85 (undo-info-name *undo-info*))
86 :must-exist t)
87 (funcall (undo-info-method *undo-info*))
88 (cond (method-undo
89 (rotatef (undo-info-name *undo-info*)
90 (undo-info-hold-name *undo-info*))
91 (rotatef (undo-info-method *undo-info*)
92 (undo-info-method-undo *undo-info*)))
93 (t (if cleanup (funcall cleanup))
94 (setf *undo-info* nil))))))
95
96
97
98 ;;;; -- Primitives --
99
100 (defun save-for-undo (name method
101 &optional cleanup method-undo (buffer (current-buffer)))
102 "Stashes information for next \"Undo\" command invocation. If there is
103 an undo-info object, it is cleaned up first."
104 (cond (*undo-info*
105 (let ((old-cleanup (undo-info-cleanup *undo-info*)))
106 (if old-cleanup (funcall old-cleanup))
107 (setf (undo-info-name *undo-info*) name)
108 (setf (undo-info-hold-name *undo-info*) undo-name)
109 (setf (undo-info-method *undo-info*) method)
110 (setf (undo-info-method-undo *undo-info*) method-undo)
111 (setf (undo-info-cleanup *undo-info*) cleanup)
112 (setf (undo-info-buffer *undo-info*) buffer)
113 *undo-info*))
114 (t (setf *undo-info*
115 (%make-undo-info name method cleanup method-undo buffer)))))
116
117
118
119 (eval-when (compile eval)
120
121 ;;; MAKE-TWIDDLE-REGION-UNDO sets up an undo method that deletes region1,
122 ;;; saving the deleted region and eventually storing it in region2. After
123 ;;; deleting region1, its start and end are made :right-inserting and
124 ;;; :left-inserting, so it will contain region2 when it is inserted at region1's
125 ;;; end. This results in a method that takes region1 with permanent marks
126 ;;; into some buffer and results with the contents of region2 in region1 (with
127 ;;; permanent marks into a buffer) and the contents of region1 (from the buffer)
128 ;;; in region2 (a region without marks into any buffer).
129 ;;;
130 (defmacro make-twiddle-region-undo (region1 region2)
131 `#'(lambda ()
132 (let* ((tregion (delete-and-save-region ,region1))
133 (mark (region-end ,region1)))
134 (setf (mark-kind (region-start ,region1)) :right-inserting)
135 (setf (mark-kind mark) :left-inserting)
136 (ninsert-region mark ,region2)
137 (setf ,region2 tregion))))
138
139 ;;; MAKE-DELETE-REGION-UNDO sets up an undo method that deletes region with
140 ;;; permanent marks into a buffer, saving the region in region without any
141 ;;; marks into a buffer, deleting one of the permanent marks, and saving one
142 ;;; permanent mark in the variable mark. This is designed to work with
143 ;;; MAKE-INSERT-REGION-UNDO, so mark results in the location in a buffer where
144 ;;; region will be inserted if this method is undone.
145 ;;;
146 (defmacro make-delete-region-undo (region mark)
147 `#'(lambda ()
148 (let ((tregion (delete-and-save-region ,region)))
149 (delete-mark (region-start ,region))
150 (setf ,mark (region-end ,region))
151 (setf ,region tregion))))
152
153 ;;; MAKE-INSERT-REGION-UNDO sets up an undo method that inserts region at mark,
154 ;;; saving in the variable region a region with permanent marks in a buffer.
155 ;;; This is designed to work with MAKE-DELETE-REGION-UNDO, so region can later
156 ;;; be deleted.
157 ;;;
158 (defmacro make-insert-region-undo (region mark)
159 `#'(lambda ()
160 (let ((tregion (region (copy-mark ,mark :right-inserting) ,mark)))
161 (setf (mark-kind ,mark) :left-inserting)
162 (ninsert-region ,mark ,region)
163 (setf ,region tregion))))
164
165 ) ;eval-when
166
167 ;;; MAKE-REGION-UNDO handles three common cases that undo'able commands often
168 ;;; need. This function sets up three closures via SAVE-FOR-UNDO that do
169 ;;; an original undo, undo the original undo, and clean up any permanent marks
170 ;;; the next time SAVE-FOR-UNDO is called. Actually, the original undo and
171 ;;; the undo for the original undo setup here are reversible in that each
172 ;;; invocation of "Undo" switches these, so an undo setup by the function is
173 ;;; undo'able, and the undo of the undo is undo'able, and the ....
174 ;;;
175 ;;; :twiddle
176 ;;; Region has permanent marks into a buffer. Mark-or-region is a region
177 ;;; not connected to any buffer. A first undo deletes region, saving it and
178 ;;; inserting mark-or-region. This also sets region around the inserted
179 ;;; region in the buffer and sets mark-or-region to be the deleted and saved
180 ;;; region. Thus the undo and the undo of the undo are the same action.
181 ;;; :insert
182 ;;; Region is not connected to any buffer. Mark-or-region is a permanent
183 ;;; mark into a buffer where region is to be inserted on a first undo, and
184 ;;; this mark is used to form a region on the first undo that will be
185 ;;; deleted upon a subsequent undo. The cleanup method knows mark-or-region
186 ;;; is a permanent mark into a buffer, but it has to determine if region
187 ;;; has marks into a buffer because if a subsequent undo does occur, region
188 ;;; does point into a buffer.
189 ;;; :delete
190 ;;; Region has permanent marks into a buffer. Mark-or-region should not
191 ;;; have been supplied. A first undo deletes region, saving the deleted
192 ;;; region in region and creating a permanent mark that indicates where to
193 ;;; put region back. The permanent mark is stored in mark-or-region. The
194 ;;; cleanup method has to check that mark-or-region is a mark since it won't
195 ;;; be unless there was a subsequent undo.
196 ;;;
197 (defun make-region-undo (kind name region &optional mark-or-region)
198 (case kind
199 (:twiddle
200 (save-for-undo name
201 (make-twiddle-region-undo region mark-or-region)
202 #'(lambda ()
203 (delete-mark (region-start region))
204 (delete-mark (region-end region)))
205 (make-twiddle-region-undo region mark-or-region)))
206 (:insert
207 (save-for-undo name
208 (make-insert-region-undo region mark-or-region)
209 #'(lambda ()
210 (let ((mark (region-start region)))
211 (delete-mark mark-or-region)
212 (when (line-buffer (mark-line mark))
213 (delete-mark mark)
214 (delete-mark (region-end region)))))
215 (make-delete-region-undo region mark-or-region)))
216 (:delete
217 (save-for-undo name
218 (make-delete-region-undo region mark-or-region)
219 #'(lambda ()
220 (delete-mark (region-start region))
221 (delete-mark (region-end region))
222 (if (markp mark-or-region) (delete-mark mark-or-region)))
223 (make-insert-region-undo region mark-or-region)))))

  ViewVC Help
Powered by ViewVC 1.1.5