Mercurial > hg > xemacs-beta
annotate lisp/undo-stack.el @ 5882:bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
lisp/ChangeLog addition:
2015-04-01 Aidan Kehoe <kehoea@parhasard.net>
When calling #'string-match with a REGEXP without regular
expression special characters, call #'search, #'mismatch, #'find,
etc. instead, making our code less likely to side-effect other
functions' match data and a little faster.
* apropos.el (apropos-command):
* apropos.el (apropos):
Call (position ?\n ...) rather than (string-match "\n" ...) here.
* buff-menu.el:
* buff-menu.el (buffers-menu-omit-invisible-buffers):
Don't fire up the regexp engine just to check if a string starts
with a space.
* buff-menu.el (select-buffers-tab-buffers-by-mode):
Don't fire up the regexp engine just to compare mode basenames.
* buff-menu.el (format-buffers-tab-line):
* buff-menu.el (build-buffers-tab-internal): Moved to being a
label within the following.
* buff-menu.el (buffers-tab-items): Use the label.
* bytecomp.el (byte-compile-log-1):
Don't fire up the regexp engine just to look for a newline.
* cus-edit.el (get):
Ditto.
* cus-edit.el (custom-variable-value-create):
Ditto, but for a colon.
* descr-text.el (describe-text-sexp):
Ditto.
* descr-text.el (describe-char-unicode-data):
Use #'split-string-by-char given that we're just looking for a
semicolon.
* descr-text.el (describe-char):
Don't fire up the regexp engine just to look for a newline.
* disass.el (disassemble-internal):
Ditto.
* files.el (file-name-sans-extension):
Implement this using #'position.
* files.el (file-name-extension):
Correct this function's docstring, implement it in terms of
#'position.
* files.el (insert-directory):
Don't fire up the regexp engine to split a string by space; don't
reverse the list of switches, this is actually a longstand bug as
far as I can see.
* gnuserv.el (gnuserv-process-filter):
Use #'position here, instead of consing inside #'split-string
needlessly.
* gtk-file-dialog.el (gtk-file-dialog-update-dropdown):
Use #'split-string-by-char here, don't fire up #'split-string for
directory-sep-char.
* gtk-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* hyper-apropos.el (hyper-apropos-grok-functions):
* hyper-apropos.el (hyper-apropos-grok-variables):
Look for a newline using #'position rather than #'string-match in
these functions.
* info.el (Info-insert-dir):
* info.el (Info-insert-file-contents):
* info.el (Info-follow-reference):
* info.el (Info-extract-menu-node-name):
* info.el (Info-menu):
Look for fixed strings using #'position or #'search as appropriate
in this file.
* ldap.el (ldap-decode-string):
* ldap.el (ldap-encode-string):
#'encode-coding-string, #'decode-coding-string are always
available, don't check if they're fboundp.
* ldap.el (ldap-decode-address):
* ldap.el (ldap-encode-address):
Use #'split-string-by-char in these functions.
* lisp-mnt.el (lm-creation-date):
* lisp-mnt.el (lm-last-modified-date):
Don't fire up the regexp engine just to look for spaces in this file.
* menubar-items.el (default-menubar):
Use (not (mismatch ...)) rather than #'string-match here, for
simple regexp.
Use (search "beta" ...) rather than (string-match "beta" ...)
* menubar-items.el (sort-buffers-menu-alphabetically):
* menubar-items.el (sort-buffers-menu-by-mode-then-alphabetically):
* menubar-items.el (group-buffers-menu-by-mode-then-alphabetically):
Don't fire up the regexp engine to check if a string starts with
a space or an asterisk.
Use the more fine-grained results of #'compare-strings; compare
case-insensitively for the buffer menu.
* menubar-items.el (list-all-buffers):
* menubar-items.el (tutorials-menu-filter):
Use #'equal rather than #'string-equal, which, in this context,
has the drawback of not having a bytecode, and no redeeming
features.
* minibuf.el:
* minibuf.el (un-substitute-in-file-name):
Use #'count, rather than counting the occurences of $ using the
regexp engine.
* minibuf.el (read-file-name-internal-1):
Don't fire up the regexp engine to search for ?=.
* mouse.el (mouse-eval-sexp):
Check for newline with #'find.
* msw-font-menu.el (mswindows-reset-device-font-menus):
Split a string by newline with #'split-string-by-char.
* mule/japanese.el:
* mule/japanese.el ("Japanese"):
Use #'search rather than #'string-match; canoncase before
comparing; fix a bug I had introduced where I had been making case
insensitive comparisons where the case mattered.
* mule/korea-util.el (default-korean-keyboard):
Look for ?3 using #'find, not #'string-march.
* mule/korea-util.el (quail-hangul-switch-hanja):
Search for a fixed string using #'search.
* mule/mule-cmds.el (set-locale-for-language-environment):
#'position, #'substitute rather than #'string-match,
#'replace-in-string.
* newcomment.el (comment-make-extra-lines):
Use #'search rather than #'string-match for a simple string.
* package-get.el (package-get-remote-filename):
Use #'position when looking for ?@
* process.el (setenv):
* process.el (read-envvar-name):
Use #'position when looking for ?=.
* replace.el (map-query-replace-regexp):
Use #'split-string-by-char instead of using an inline
implementation of it.
* select.el (select-convert-from-cf-text):
* select.el (select-convert-from-cf-unicodetext):
Use #'position rather than #'string-match in these functions.
* setup-paths.el (paths-emacs-data-root-p):
Use #'search when looking for simple string.
* sound.el (load-sound-file):
Use #'split-string-by-char rather than an inline reimplementation
of same.
* startup.el (splash-screen-window-body):
* startup.el (splash-screen-tty-body):
Search for simple strings using #'search.
* version.el (emacs-version):
Ditto.
* x-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* x-font-menu.el (x-reset-device-font-menus-core):
Use #'split-string-by-char here.
* x-init.el (x-initialize-keyboard):
Search for a simple string using #'search.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 01 Apr 2015 14:28:20 +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 |