Mercurial > hg > xemacs-beta
annotate lisp/regexp-opt.el @ 5574:d4f334808463
Support inlining labels, bytecomp.el.
lisp/ChangeLog addition:
2011-10-02 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
Add #'declare to this, so it doesn't need to rely on
#'cl-compiling file to determine when we're byte-compiling.
Update #'labels to support declaring labels inline, as Common Lisp
requires.
* bytecomp.el (byte-compile-function-form):
Don't error if FUNCTION is quoting a non-lambda, non-symbol, just
return it.
* cl-extra.el (cl-macroexpand-all):
If a label name has been quoted, expand to the label placeholder
quoted with 'function. This allows the byte compiler to
distinguish between uses of the placeholder as data and uses in
contexts where it should be inlined.
* cl-macs.el:
* cl-macs.el (cl-do-proclaim):
When proclaming something as inline, if it is bound as a label,
don't modify the symbol's plist; instead, treat the first element
of its placeholder constant vector as a place to store compile
information.
* cl-macs.el (declare):
Leave processing declarations while compiling to the
implementation of #'declare in
byte-compile-initial-macro-environment.
tests/ChangeLog addition:
2011-10-02 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
* automated/lisp-tests.el (+):
Test #'labels and inlining.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 02 Oct 2011 15:32:16 +0100 |
| parents | ac37a5f7e5be |
| children |
| rev | line source |
|---|---|
| 2548 | 1 ;;; regexp-opt.el --- generate efficient regexps to match strings |
| 2 | |
| 3 ;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc. | |
| 4 | |
| 5 ;; Author: Simon Marshall <simon@gnu.org> | |
| 6 ;; Maintainer: FSF | |
| 7 ;; Keywords: strings, regexps, extensions | |
| 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:
2550
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:
2550
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:
2550
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:
2550
diff
changeset
|
14 ;; option) any later version. |
| 2548 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
2550
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:
2550
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:
2550
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:
2550
diff
changeset
|
19 ;; for more details. |
| 2548 | 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:
2550
diff
changeset
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 2548 | 23 |
| 2550 | 24 ;;; Synched up with: GNU Emacs 21.3 + paren-in-char-set fix from CVS |
| 25 ;;; revision 1.25. Some implementation differences in | |
| 26 ;;; regexp-opt-group and regexp-opt-charset but the APIs | |
| 27 ;;; are compatible and should return compatible (if not | |
| 28 ;;; exactly the same) regexps. | |
| 29 | |
| 2548 | 30 ;;; Commentary: |
| 31 | |
| 2550 | 32 ;; The "opt" in "regexp-opt" stands for "optim\\(?:al\\|i\\(?:se\\|ze\\)\\)". |
| 2548 | 33 ;; |
| 34 ;; This package generates a regexp from a given list of strings (which matches | |
| 35 ;; one of those strings) so that the regexp generated by: | |
| 36 ;; | |
| 37 ;; (regexp-opt strings) | |
| 38 ;; | |
| 39 ;; is equivalent to, but more efficient than, the regexp generated by: | |
| 40 ;; | |
| 41 ;; (mapconcat 'regexp-quote strings "\\|") | |
| 42 ;; | |
| 43 ;; For example: | |
| 44 ;; | |
| 45 ;; (let ((strings '("cond" "if" "when" "unless" "while" | |
| 46 ;; "let" "let*" "progn" "prog1" "prog2" | |
| 47 ;; "save-restriction" "save-excursion" "save-window-excursion" | |
| 48 ;; "save-current-buffer" "save-match-data" | |
| 49 ;; "catch" "throw" "unwind-protect" "condition-case"))) | |
| 50 ;; (concat "(" (regexp-opt strings t) "\\>")) | |
| 2550 | 51 ;; => "(\\(c\\(?:atch\\|ond\\(?:ition-case\\)?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\\(?:current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\\)\\|throw\\|un\\(?:less\\|wind-protect\\)\\|wh\\(?:en\\|ile\\)\\)\\>" |
| 2548 | 52 ;; |
| 53 ;; Searching using the above example `regexp-opt' regexp takes approximately | |
| 54 ;; two-thirds of the time taken using the equivalent `mapconcat' regexp. | |
| 55 | |
| 56 ;; Since this package was written to produce efficient regexps, not regexps | |
| 57 ;; efficiently, it is probably not a good idea to in-line too many calls in | |
| 58 ;; your code, unless you use the following trick with `eval-when-compile': | |
| 59 ;; | |
| 60 ;; (defvar definition-regexp | |
| 61 ;; (eval-when-compile | |
| 62 ;; (concat "^(" | |
| 63 ;; (regexp-opt '("defun" "defsubst" "defmacro" "defalias" | |
| 64 ;; "defvar" "defconst") t) | |
| 65 ;; "\\>"))) | |
| 66 ;; | |
| 67 ;; The `byte-compile' code will be as if you had defined the variable thus: | |
| 68 ;; | |
| 69 ;; (defvar definition-regexp | |
| 70 ;; "^(\\(def\\(alias\\|const\\|macro\\|subst\\|un\\|var\\)\\)\\>") | |
| 71 ;; | |
| 72 ;; Note that if you use this trick for all instances of `regexp-opt' and | |
| 73 ;; `regexp-opt-depth' in your code, regexp-opt.el would only have to be loaded | |
| 74 ;; at compile time. But note also that using this trick means that should | |
| 75 ;; regexp-opt.el be changed, perhaps to fix a bug or to add a feature to | |
| 76 ;; improve the efficiency of `regexp-opt' regexps, you would have to recompile | |
| 77 ;; your code for such changes to have effect in your code. | |
| 78 | |
| 79 ;; Originally written for font-lock.el, from an idea from Stig's hl319.el, with | |
| 2550 | 80 ;; thanks for ideas also to Michael Ernst, Bob Glickstein, Dan Nicolaescu and |
| 81 ;; Stefan Monnier. | |
| 82 ;; No doubt `regexp-opt' doesn't always produce optimal regexps, so code, ideas | |
| 83 ;; or any other information to improve things are welcome. | |
| 84 ;; | |
| 85 ;; One possible improvement would be to compile '("aa" "ab" "ba" "bb") | |
| 86 ;; into "[ab][ab]" rather than "a[ab]\\|b[ab]". I'm not sure it's worth | |
| 87 ;; it but if someone knows how to do it without going through too many | |
| 88 ;; contortions, I'm all ears. | |
| 2548 | 89 |
| 90 ;;; Code: | |
| 91 | |
| 92 ;;;###autoload | |
| 2550 | 93 (defun regexp-opt (strings &optional paren) |
| 2548 | 94 "Return a regexp to match a string in STRINGS. |
| 95 Each string should be unique in STRINGS and should not contain any regexps, | |
| 96 quoted or not. If optional PAREN is non-nil, ensure that the returned regexp | |
| 2550 | 97 is enclosed by at least one regexp grouping construct. |
| 2548 | 98 The returned regexp is typically more efficient than the equivalent regexp: |
| 99 | |
| 2550 | 100 (let ((open (if PAREN \"\\\\(\" \"\")) (close (if PAREN \"\\\\)\" \"\"))) |
| 101 (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close)) | |
| 2548 | 102 |
| 103 If PAREN is `words', then the resulting regexp is additionally surrounded | |
| 104 by \\=\\< and \\>." | |
| 105 (save-match-data | |
| 106 ;; Recurse on the sorted list. | |
| 107 (let* ((max-lisp-eval-depth (* 1024 1024)) | |
| 108 (completion-ignore-case nil) | |
| 109 (words (eq paren 'words)) | |
| 2550 | 110 (open (cond ((stringp paren) paren) (paren "\\("))) |
| 2548 | 111 (sorted-strings (sort (copy-sequence strings) 'string-lessp)) |
| 2550 | 112 (re (regexp-opt-group sorted-strings open))) |
| 2548 | 113 (if words (concat "\\<" re "\\>") re)))) |
| 114 | |
| 2550 | 115 (defconst regexp-opt-not-groupie*-re |
| 116 (let* ((harmless-ch "[^\\\\[]") | |
| 117 (esc-pair-not-lp "\\\\[^(]") | |
| 118 (class-harmless-ch "[^][]") | |
| 119 (class-lb-harmless "[^]:]") | |
| 120 (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?") | |
| 121 (class-lb (concat "\\[\\(" class-lb-harmless | |
| 122 "\\|" class-lb-colon-maybe-charclass "\\)")) | |
| 123 (class | |
| 124 (concat "\\[^?]?" | |
| 125 "\\(" class-harmless-ch | |
| 126 "\\|" class-lb "\\)*" | |
| 127 "\\[?]")) ; special handling for bare [ at end of re | |
| 128 (shy-lp "\\\\(\\?:")) | |
| 129 (concat "\\(" harmless-ch "\\|" esc-pair-not-lp | |
| 130 "\\|" class "\\|" shy-lp "\\)*")) | |
| 131 "Matches any part of a regular expression EXCEPT for non-shy \"\\\\(\"s") | |
| 132 | |
| 2548 | 133 ;;;###autoload |
| 2550 | 134 (defun regexp-opt-depth (regexp) |
| 2548 | 135 "Return the depth of REGEXP. |
| 2550 | 136 This means the number of regexp grouping constructs (parenthesised expressions) |
| 137 in REGEXP." | |
| 2548 | 138 (save-match-data |
| 139 ;; Hack to signal an error if REGEXP does not have balanced parentheses. | |
| 140 (string-match regexp "") | |
| 141 ;; Count the number of open parentheses in REGEXP. | |
| 2550 | 142 (let ((count 0) start) |
| 143 (while | |
| 144 (progn | |
| 145 (string-match regexp-opt-not-groupie*-re regexp start) | |
| 146 (setq start ( + (match-end 0) 2)) ; +2 for "\\(" after match-end. | |
| 147 (<= start (length regexp))) | |
| 148 (setq count (1+ count))) | |
| 2548 | 149 count))) |
| 150 | |
| 151 ;;; Workhorse functions. | |
| 152 | |
| 153 (eval-when-compile | |
| 154 (require 'cl)) | |
| 155 | |
| 2550 | 156 (defun regexp-opt-group (strings &optional paren lax) |
| 2548 | 157 "Return a regexp to match a string in STRINGS. |
| 158 If PAREN non-nil, output regexp parentheses around returned regexp. | |
| 159 If LAX non-nil, don't output parentheses if it doesn't require them. | |
| 160 Merges keywords to avoid backtracking in Emacs' regexp matcher. | |
| 161 | |
| 2550 | 162 The basic idea is to find the shortest common prefix or suffix, remove it |
| 2548 | 163 and recurse. If there is no prefix, we divide the list into two so that |
| 164 \(at least) one half will have at least a one-character common prefix. | |
| 165 | |
| 166 Also we delay the addition of grouping parenthesis as long as possible | |
| 167 until we're sure we need them, and try to remove one-character sequences | |
| 168 so we can use character sets rather than grouping parenthesis." | |
| 2550 | 169 (let* ((open-group (cond ((stringp paren) paren) (paren "\\(?:") (t ""))) |
| 2548 | 170 (close-group (if paren "\\)" "")) |
| 171 (open-charset (if lax "" open-group)) | |
| 172 (close-charset (if lax "" close-group))) | |
| 173 (cond | |
| 174 ;; | |
| 175 ;; If there are no strings, just return the empty string. | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
2550
diff
changeset
|
176 ((eql (length strings) 0) |
| 2548 | 177 "") |
| 178 ;; | |
| 179 ;; If there is only one string, just return it. | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
2550
diff
changeset
|
180 ((eql (length strings) 1) |
|
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
2550
diff
changeset
|
181 (if (eql (length (car strings)) 1) |
| 2548 | 182 (concat open-charset (regexp-quote (car strings)) close-charset) |
| 183 (concat open-group (regexp-quote (car strings)) close-group))) | |
| 184 ;; | |
| 185 ;; If there is an empty string, remove it and recurse on the rest. | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
2550
diff
changeset
|
186 ((eql (length (car strings)) 0) |
| 2548 | 187 (concat open-charset |
| 2550 | 188 (regexp-opt-group (cdr strings) t t) "?" |
| 2548 | 189 close-charset)) |
| 190 ;; | |
| 191 ;; If all are one-character strings, just return a character set. | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
2550
diff
changeset
|
192 ((eql (length strings) (apply '+ (mapcar 'length strings))) |
| 2548 | 193 (concat open-charset |
| 194 (regexp-opt-charset strings) | |
| 195 close-charset)) | |
| 196 ;; | |
| 197 ;; We have a list of different length strings. | |
| 198 (t | |
| 199 (let ((prefix (try-completion "" (mapcar 'list strings))) | |
| 200 (letters (let ((completion-regexp-list '("^.$"))) | |
| 201 (all-completions "" (mapcar 'list strings))))) | |
| 202 (cond | |
| 203 ;; | |
| 204 ;; If there is a common prefix, remove it and recurse on the suffixes. | |
| 205 ((> (length prefix) 0) | |
| 206 (let* ((length (length prefix)) | |
| 207 (suffixes (mapcar (lambda (s) (substring s length)) strings))) | |
| 208 (concat open-group | |
| 2550 | 209 (regexp-quote prefix) (regexp-opt-group suffixes t t) |
| 2548 | 210 close-group))) |
| 211 ;; | |
| 212 ;; If there are several one-character strings, remove them and recurse | |
| 213 ;; on the rest (first so the final regexp finds the longest match). | |
| 214 ((> (length letters) 1) | |
| 215 (let ((rest (let ((completion-regexp-list '("^..+$"))) | |
| 216 (all-completions "" (mapcar 'list strings))))) | |
| 217 (concat open-group | |
| 2550 | 218 (regexp-opt-group rest) "\\|" (regexp-opt-charset letters) |
| 2548 | 219 close-group))) |
| 220 ;; | |
| 221 ;; Otherwise, divide the list into those that start with a particular | |
| 222 ;; letter and those that do not, and recurse on them. | |
| 223 (t | |
| 224 (let* ((char (substring (car strings) 0 1)) | |
| 225 (half1 (all-completions char (mapcar 'list strings))) | |
| 226 (half2 (nthcdr (length half1) strings))) | |
| 227 (concat open-group | |
| 2550 | 228 (regexp-opt-group half1) "\\|" (regexp-opt-group half2) |
| 2548 | 229 close-group))))))))) |
| 230 | |
| 231 (defun regexp-opt-charset (chars) | |
| 232 ;; | |
| 233 ;; Return a regexp to match a character in CHARS. | |
| 234 ;; | |
| 235 ;; The basic idea is to find character ranges. Also we take care in the | |
| 236 ;; position of character set meta characters in the character set regexp. | |
| 237 ;; | |
| 238 (let* ((charwidth 256) ; Yeah, right. | |
| 239 ;; XEmacs: use bit-vectors instead of bool-vectors | |
| 240 (charmap (make-bit-vector charwidth 0)) | |
| 241 (charset "") | |
| 242 (bracket "") (dash "") (caret "")) | |
| 243 ;; | |
| 244 ;; Make a character map but extract character set meta characters. | |
| 245 (dolist (char (mapcar 'string-to-char chars)) | |
| 246 (case char | |
| 247 (?\] | |
| 248 (setq bracket "]")) | |
| 249 (?^ | |
| 250 (setq caret "^")) | |
| 251 (?- | |
| 252 (setq dash "-")) | |
| 253 (otherwise | |
| 254 ;; XEmacs: 1 | |
| 255 (aset charmap char 1)))) | |
| 256 ;; | |
| 257 ;; Make a character set from the map using ranges where applicable. | |
| 258 (dotimes (char charwidth) | |
| 259 (let ((start char)) | |
| 260 (while (and (< char charwidth) | |
| 261 ;; XEmacs: (not (zerop ...)) | |
| 262 (not (zerop (aref charmap char)))) | |
| 263 (incf char)) | |
| 264 (cond ((> char (+ start 3)) | |
| 265 (setq charset (format "%s%c-%c" charset start (1- char)))) | |
| 266 ((> char start) | |
| 267 (setq charset (format "%s%c" charset (setq char start))))))) | |
| 268 ;; | |
| 269 ;; Make sure a caret is not first and a dash is first or last. | |
| 270 (if (and (string-equal charset "") (string-equal bracket "")) | |
| 271 (concat "[" dash caret "]") | |
| 272 (concat "[" bracket charset caret dash "]")))) | |
| 273 | |
| 274 (provide 'regexp-opt) | |
| 275 | |
| 276 ;;; regexp-opt.el ends here |