Mercurial > hg > xemacs-beta
annotate lisp/regexp-opt.el @ 5893:d3d073aceaea
Merge.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 18 Apr 2015 23:10:40 +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 |