Mercurial > hg > xemacs-beta
annotate lisp/undo-stack.el @ 5652:cc6f0266bc36
Avoid #'delq in core Lisp, for the sake of style, a very slightly smaller binary
lisp/ChangeLog addition:
2012-05-01 Aidan Kehoe <kehoea@parhasard.net>
Avoid #'delq in core code, for the sake of style and a (very
slightly) smaller binary.
* behavior.el (disable-behavior):
* behavior.el (compute-behavior-group-children):
* buff-menu.el (buffers-tab-items):
* byte-optimize.el (byte-optimize-delay-constants-math):
* byte-optimize.el (byte-optimize-logmumble):
* byte-optimize.el (byte-decompile-bytecode-1):
* byte-optimize.el (byte-optimize-lapcode):
* bytecomp.el:
* bytecomp.el (byte-compile-arglist-warn):
* bytecomp.el (byte-compile-warn-about-unresolved-functions):
* bytecomp.el (byte-compile-lambda):
* bytecomp.el (byte-compile-out-toplevel):
* bytecomp.el (byte-compile-insert):
* bytecomp.el (byte-compile-defalias-warn):
* cl-macs.el (cl-upcase-arg):
* cl-macs.el (cl-transform-lambda):
* cl-macs.el (cl-do-proclaim):
* cl-macs.el (defstruct):
* cl-macs.el (cl-make-type-test):
* cl-macs.el (define-compiler-macro):
* cl-macs.el (delete-duplicates):
* cus-edit.el (widget-face-value-delete):
* cus-edit.el (face-history):
* easymenu.el (easy-menu-remove):
* files.el (files-fetch-hook-value):
* files.el (file-expand-wildcards):
* font-lock.el (font-lock-update-removed-keyword-alist):
* font-lock.el (font-lock-remove-keywords):
* frame.el (frame-initialize):
* frame.el (frame-notice-user-settings):
* frame.el (set-frame-font):
* frame.el (delete-other-frames):
* frame.el (get-frame-for-buffer-noselect):
* gnuserv.el (gnuserv-kill-buffer-function):
* gnuserv.el (gnuserv-check-device):
* gnuserv.el (gnuserv-kill-client):
* gnuserv.el (gnuserv-buffer-done-1):
* gtk-font-menu.el (gtk-reset-device-font-menus):
* gutter-items.el (buffers-tab-items):
* gutter.el (set-gutter-element-visible-p):
* info.el (Info-find-file-node):
* info.el (Info-history-add):
* info.el (Info-build-annotation-completions):
* info.el (Info-index):
* info.el (Info-reannotate-node):
* itimer.el (delete-itimer):
* itimer.el (start-itimer):
* lib-complete.el (lib-complete:cache-completions):
* loadhist.el (unload-feature):
* menubar-items.el (build-buffers-menu-internal):
* menubar.el (delete-menu-item):
* menubar.el (relabel-menu-item):
* msw-font-menu.el (mswindows-reset-device-font-menus):
* mule/make-coding-system.el (fixed-width-generate-helper):
* next-error.el (next-error-find-buffer):
* obsolete.el:
* obsolete.el (find-non-ascii-charset-string):
* obsolete.el (find-non-ascii-charset-region):
* occur.el (multi-occur-by-filename-regexp):
* occur.el (occur-1):
* packages.el (packages-package-hierarchy-directory-names):
* packages.el (package-get-key-1):
* process.el (setenv):
* simple.el (undo):
* simple.el (handle-pre-motion-command-current-command-is-motion):
* sound.el (load-sound-file):
* wid-edit.el (widget-field-value-delete):
* wid-edit.el (widget-checklist-match-inline):
* wid-edit.el (widget-checklist-match-find):
* wid-edit.el (widget-editable-list-delete-at):
* wid-edit.el (widget-editable-list-entry-create):
* window.el (quit-window):
* x-font-menu.el (x-reset-device-font-menus-core):
1. Replace (delq nil (mapcar ....)) with analogous (mapcan ...)
forms; this is in non-dumped files, it was done previously in
dumped files.
2. Replace (delq FOO (copy-sequence BAR)) with (remove* FOO BAR),
where #'eq and #'eql are equivalent
3. Replace (delq FOO BAR) with (delete* FOO BAR), where FOO is not
a non-fixnum number. Saves a little space in the dumped file
(since the compiler macro adds :test #'eq to the delete* call if
it's not clear that FOO is not a non-fixnum number).
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Tue, 01 May 2012 16:17:42 +0100 |
parents | 308d34e9f07d |
children |
rev | line source |
---|---|
428 | 1 ;;; undo-stack.el --- An "undoable stack" object. |
2 | |
3 ;; Copyright (C) 1997 Free Software Foundation, Inc. | |
4 ;; Copyright (C) 1996 Ben Wing. | |
5 | |
6 ;; Maintainer: XEmacs Development Team | |
7 ;; Keywords: extensions, dumped | |
8 | |
9 ;; This file is part of XEmacs. | |
10 | |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
11 ;; XEmacs is free software: you can redistribute it and/or modify it |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
12 ;; under the terms of the GNU General Public License as published by the |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
13 ;; Free Software Foundation, either version 3 of the License, or (at your |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
14 ;; option) any later version. |
428 | 15 |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
16 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
18 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
19 ;; for more details. |
428 | 20 |
21 ;; You should have received a copy of the GNU General Public License | |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
428
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
428 | 23 |
24 ;;; Synched up with: Not in FSF. | |
25 | |
26 ;;; Commentary: | |
27 | |
28 ;; This file is dumped with XEmacs. | |
29 | |
30 ;; An "undoable stack" is an object that can be used to implement | |
31 ;; a history of positions, with undo and redo. Conceptually, it | |
32 ;; is the kind of data structure used to keep track of (e.g.) | |
33 ;; visited Web pages, so that the "Back" and "Forward" operations | |
34 ;; in the browser work. Basically, I can successively visit a | |
35 ;; number of Web pages through links, and then hit "Back" a | |
36 ;; few times to go to previous positions, and then "Forward" a | |
37 ;; few times to reverse this process. This is similar to an | |
38 ;; "undo" and "redo" mechanism. | |
39 | |
40 ;; Note that Emacs does not standardly contain structures like | |
41 ;; this. Instead, it implements history using either a ring | |
42 ;; (the kill ring, the mark ring), or something like the undo | |
43 ;; stack, where successive "undo" operations get recorded as | |
44 ;; normal modifications, so that if you do a bunch of successive | |
45 ;; undo's, then something else, then start undoing, you will | |
46 ;; be redoing all your undo's back to the point before you did | |
47 ;; the undo's, and then further undo's will act like the previous | |
48 ;; round of undo's. I think that both of these paradigms are | |
49 ;; inferior to the "undoable-stack" paradigm because they're | |
50 ;; confusing and difficult to keep track of. | |
51 | |
52 ;; Conceptually, imagine a position history like this: | |
53 | |
54 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
55 ;; ^^ | |
56 | |
57 ;; where the arrow indicates where you currently are. "Going back" | |
58 ;; and "going forward" just amount to moving the arrow. However, | |
59 ;; what happens if the history state is this: | |
60 | |
61 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
62 ;; ^^ | |
63 | |
64 ;; and then I visit new positions (7) and (8)? In the most general | |
65 ;; implementation, you've just caused a new branch like this: | |
66 | |
67 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
68 ;; | | |
69 ;; | | |
70 ;; 7 -> 8 | |
71 ;; ^^ | |
72 | |
73 ;; But then you can end up with a whole big tree, and you need | |
74 ;; more sophisticated ways of navigating ("Forward" might involve | |
75 ;; a choice of paths to follow) and managing its size (if you don't | |
76 ;; want to keep unlimited history, you have to truncate at some point, | |
77 ;; and how do you truncate a tree?) | |
78 | |
79 ;; My solution to this is just to insert the new positions like | |
80 ;; this: | |
81 | |
82 ;; 1 -> 2 -> 3 -> 4 -> 7 -> 8 -> 5 -> 6 | |
83 ;; ^^ | |
84 | |
85 ;; (Netscape, I think, would just truncate 5 and 6 completely, | |
86 ;; but that seems a bit drastic. In the Emacs-standard "ring" | |
87 ;; structure, this problem is avoided by simply moving 5 and 6 | |
88 ;; to the beginning of the ring. However, it doesn't seem | |
89 ;; logical to me to have "going back past 1" get you to 6.) | |
90 | |
91 ;; Now what if we have a "maximum" size of (say) 7 elements? | |
92 ;; When we add 8, we could truncate either 1 or 6. Since 5 and | |
93 ;; 6 are "undone" positions, we should presumably truncate | |
94 ;; them before 1. So, adding 8 truncates 6, adding 9 truncates | |
95 ;; 5, and adding 10 truncates 1 because there is nothing more | |
96 ;; that is forward of the insertion point. | |
97 | |
98 ;; Interestingly, this method of truncation is almost like | |
99 ;; how a ring would truncate. A ring would move 5 and 6 | |
100 ;; around to the back, like this: | |
101 | |
102 ;; 5 -> 6 -> 1 -> 2 -> 3 -> 4 -> 7 -> 8 | |
103 ;; ^^ | |
104 | |
105 ;; However, when 8 is added, the ring truncates 5 instead of | |
106 ;; 6, which is less than optimal. | |
107 | |
108 ;; Conceptually, we can implement the "undoable stack" using | |
109 ;; two stacks of a sort called "truncatable stack", which are | |
110 ;; just simple stacks, but where you can truncate elements | |
111 ;; off of the bottom of the stack. Then, the undoable stack | |
112 | |
113 ;; 1 -> 2 -> 3 -> 4 -> 5 -> 6 | |
114 ;; ^^ | |
115 | |
116 ;; is equivalent to two truncatable stacks: | |
117 | |
118 ;; 4 <- 3 <- 2 <- 1 | |
119 ;; 5 <- 6 | |
120 | |
121 ;; where I reversed the direction to accord with the probable | |
122 ;; implementation of a standard list. To do another undo, | |
123 ;; I pop 4 off of the first stack and move it to the top of | |
124 ;; the second stack. A redo operation does the opposite. | |
125 ;; To truncate to the proper size, first chop off 6, then 5, | |
126 ;; then 1 -- in all cases, truncating off the bottom. | |
127 | |
128 ;;; Code: | |
129 | |
130 (define-error 'trunc-stack-bottom "Bottom of stack reached") | |
131 | |
132 (defsubst trunc-stack-stack (stack) | |
133 ;; return the list representing the trunc-stack's elements. | |
134 ;; the head of the list is the most recent element. | |
135 (aref stack 1)) | |
136 | |
137 (defsubst trunc-stack-length (stack) | |
138 ;; return the number of elements in the trunc-stack. | |
139 (aref stack 2)) | |
140 | |
141 (defsubst set-trunc-stack-stack (stack new) | |
142 ;; set the list representing the trunc-stack's elements. | |
143 (aset stack 1 new)) | |
144 | |
145 (defsubst set-trunc-stack-length (stack new) | |
146 ;; set the length of the trunc-stack. | |
147 (aset stack 2 new)) | |
148 | |
149 ;; public functions: | |
150 | |
151 (defun make-trunc-stack () | |
152 ;; make an empty trunc-stack. | |
153 (vector 'trunc-stack nil 0)) | |
154 | |
155 (defun trunc-stack-push (stack el) | |
156 ;; push a new element onto the head of the trunc-stack. | |
157 (set-trunc-stack-stack stack (cons el (trunc-stack-stack stack))) | |
158 (set-trunc-stack-length stack (1+ (trunc-stack-length stack)))) | |
159 | |
160 (defun trunc-stack-top (stack &optional n) | |
161 ;; return the nth topmost element from the trunc-stack. | |
162 ;; signal an error if the stack doesn't have that many elements. | |
163 (or n (setq n 0)) | |
164 (if (>= n (trunc-stack-length stack)) | |
165 (signal-error 'trunc-stack-bottom (list stack)) | |
166 (nth n (trunc-stack-stack stack)))) | |
167 | |
168 (defun trunc-stack-pop (stack) | |
169 ;; pop and return the topmost element from the stack. | |
170 (prog1 (trunc-stack-top stack) | |
171 (set-trunc-stack-stack stack (cdr (trunc-stack-stack stack))) | |
172 (set-trunc-stack-length stack (1- (trunc-stack-length stack))))) | |
173 | |
174 (defun trunc-stack-truncate (stack &optional n) | |
175 ;; truncate N items off the bottom of the stack. If the stack is | |
176 ;; not that big, it just becomes empty. | |
177 (or n (setq n 1)) | |
178 (if (> n 0) | |
179 (let ((len (trunc-stack-length stack))) | |
180 (if (>= n len) | |
181 (progn | |
182 (set-trunc-stack-length stack 0) | |
183 (set-trunc-stack-stack stack nil)) | |
184 (setcdr (nthcdr (1- (- len n)) (trunc-stack-stack stack)) nil) | |
185 (set-trunc-stack-length stack (- len n)))))) | |
186 | |
187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
188 | |
189 ;;; FMH! FMH! FMH! This object-oriented stuff doesn't really work | |
190 ;;; properly without built-in structures (vectors suck) and without | |
191 ;;; public and private functions and fields. | |
192 | |
193 (defsubst undoable-stack-max (stack) | |
194 (aref stack 1)) | |
195 | |
196 (defsubst undoable-stack-a (stack) | |
197 (aref stack 2)) | |
198 | |
199 (defsubst undoable-stack-b (stack) | |
200 (aref stack 3)) | |
201 | |
202 ;; public functions: | |
203 | |
204 (defun make-undoable-stack (max) | |
205 ;; make an empty undoable stack of max size MAX. | |
206 (vector 'undoable-stack max (make-trunc-stack) (make-trunc-stack))) | |
207 | |
208 (defsubst set-undoable-stack-max (stack new) | |
209 ;; change the max size of an undoable stack. | |
210 (aset stack 1 new)) | |
211 | |
212 (defun undoable-stack-a-top (stack) | |
213 ;; return the topmost element off the "A" stack of an undoable stack. | |
214 ;; this is the most recent position pushed on the undoable stack. | |
215 (trunc-stack-top (undoable-stack-a stack))) | |
216 | |
217 (defun undoable-stack-a-length (stack) | |
218 (trunc-stack-length (undoable-stack-a stack))) | |
219 | |
220 (defun undoable-stack-b-top (stack) | |
221 ;; return the topmost element off the "B" stack of an undoable stack. | |
222 ;; this is the position that will become the most recent position, | |
223 ;; after a redo operation. | |
224 (trunc-stack-top (undoable-stack-b stack))) | |
225 | |
226 (defun undoable-stack-b-length (stack) | |
227 (trunc-stack-length (undoable-stack-b stack))) | |
228 | |
229 (defun undoable-stack-push (stack el) | |
230 ;; push an element onto the stack. | |
231 (let* | |
232 ((lena (trunc-stack-length (undoable-stack-a stack))) | |
233 (lenb (trunc-stack-length (undoable-stack-b stack))) | |
234 (max (undoable-stack-max stack)) | |
235 (len (+ lena lenb))) | |
236 ;; maybe truncate some elements. We have to deal with the | |
237 ;; possibility that we have more elements than our max | |
238 ;; (someone might have reduced the max). | |
239 (if (>= len max) | |
240 (let ((must-nuke (1+ (- len max)))) | |
241 ;; chop off must-nuke elements from the B stack. | |
242 (trunc-stack-truncate (undoable-stack-b stack) must-nuke) | |
243 ;; but if there weren't that many elements to chop, | |
244 ;; take the rest off the A stack. | |
245 (if (< lenb must-nuke) | |
246 (trunc-stack-truncate (undoable-stack-a stack) | |
247 (- must-nuke lenb))))) | |
248 (trunc-stack-push (undoable-stack-a stack) el))) | |
249 | |
250 (defun undoable-stack-pop (stack) | |
251 ;; pop an element off the stack. | |
252 (trunc-stack-pop (undoable-stack-a stack))) | |
253 | |
254 (defun undoable-stack-undo (stack) | |
255 ;; transfer an element from the top of A to the top of B. | |
256 ;; return value is undefined. | |
257 (trunc-stack-push (undoable-stack-b stack) | |
258 (trunc-stack-pop (undoable-stack-a stack)))) | |
259 | |
260 (defun undoable-stack-redo (stack) | |
261 ;; transfer an element from the top of B to the top of A. | |
262 ;; return value is undefined. | |
263 (trunc-stack-push (undoable-stack-a stack) | |
264 (trunc-stack-pop (undoable-stack-b stack)))) | |
265 | |
266 | |
267 ;;; undo-stack.el ends here |