1 ;;; regexp-opt.el --- generate efficient regexps to match strings
3 ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
4 ;; 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
6 ;; Author: Simon Marshall <simon@gnu.org>
8 ;; Keywords: strings, regexps, extensions
10 ;; This file is part of XEmacs.
12 ;; XEmacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; XEmacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
27 ;;; Synched up with: Revision 1.34 in GNU Emacs CVS, of 2007-01-21.
31 ;; The "opt" in "regexp-opt" stands for "optim\\(al\\|i[sz]e\\)".
33 ;; This package generates a regexp from a given list of strings (which matches
34 ;; one of those strings) so that the regexp generated by:
36 ;; (regexp-opt strings)
38 ;; is equivalent to, but more efficient than, the regexp generated by:
40 ;; (mapconcat 'regexp-quote strings "\\|")
44 ;; (let ((strings '("cond" "if" "when" "unless" "while"
45 ;; "let" "let*" "progn" "prog1" "prog2"
46 ;; "save-restriction" "save-excursion" "save-window-excursion"
47 ;; "save-current-buffer" "save-match-data"
48 ;; "catch" "throw" "unwind-protect" "condition-case")))
49 ;; (concat "(" (regexp-opt strings t) "\\>"))
50 ;; => "(\\(c\\(?:atch\\|ond\\(?:ition-case\\)?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\\(?:current-buffer\\|excursion\\|match-data\\|\\(?:restrict\\|window-excurs\\)ion\\)\\|throw\\|un\\(?:less\\|wind-protect\\)\\|wh\\(?:en\\|ile\\)\\)\\>"
52 ;; Searching using the above example `regexp-opt' regexp takes approximately
53 ;; two-thirds of the time taken using the equivalent `mapconcat' regexp.
55 ;; Since this package was written to produce efficient regexps, not regexps
56 ;; efficiently, it is probably not a good idea to in-line too many calls in
57 ;; your code, unless you use the following trick with `eval-when-compile':
59 ;; (defvar definition-regexp
62 ;; (regexp-opt '("defun" "defsubst" "defmacro" "defalias"
63 ;; "defvar" "defconst") t)
66 ;; The `byte-compile' code will be as if you had defined the variable thus:
68 ;; (defvar definition-regexp
69 ;; "^(\\(def\\(alias\\|const\\|macro\\|subst\\|un\\|var\\)\\)\\>")
71 ;; Note that if you use this trick for all instances of `regexp-opt' and
72 ;; `regexp-opt-depth' in your code, regexp-opt.el would only have to be loaded
73 ;; at compile time. But note also that using this trick means that should
74 ;; regexp-opt.el be changed, perhaps to fix a bug or to add a feature to
75 ;; improve the efficiency of `regexp-opt' regexps, you would have to recompile
76 ;; your code for such changes to have effect in your code.
78 ;; Originally written for font-lock.el, from an idea from Stig's hl319.el, with
79 ;; thanks for ideas also to Michael Ernst, Bob Glickstein, Dan Nicolaescu and
81 ;; No doubt `regexp-opt' doesn't always produce optimal regexps, so code, ideas
82 ;; or any other information to improve things are welcome.
84 ;; One possible improvement would be to compile '("aa" "ab" "ba" "bb")
85 ;; into "[ab][ab]" rather than "a[ab]\\|b[ab]". I'm not sure it's worth
86 ;; it but if someone knows how to do it without going through too many
87 ;; contortions, I'm all ears.
91 ;; XEmacs; correct the docstring, make it clearer.
93 (defun regexp-opt (strings &optional paren)
94 "Return a regexp which matches exactly those strings in STRINGS.
96 Each string in STRINGS should be unique. Regexp special characters in
97 the elements of STRINGS will not be treated specially in matching;
98 they will be escaped as necessary in constructing the regexp.
100 If optional PAREN is non-nil, ensure that the returned regexp is enclosed by
101 at least one regexp grouping construct. The returned regexp is typically
102 more efficient than the equivalent regexp:
104 (let ((open (if PAREN \"\\\\(\" \"\")) (close (if PAREN \"\\\\)\" \"\")))
105 (concat open (mapconcat 'regexp-quote STRINGS \"\\\\|\") close))
107 If PAREN is `words', then the resulting regexp is additionally surrounded
110 ;; Recurse on the sorted list.
111 (let* ((max-lisp-eval-depth (* 1024 1024))
112 (max-specpdl-size (* 1024 1024))
113 (completion-ignore-case nil)
114 (completion-regexp-list nil)
115 (words (eq paren 'words))
116 (open (cond ((stringp paren) paren) (paren "\\(")))
117 ;; XEmacs; 21.4 doesn't have #'delete-dups, but
118 ;; #'delete-duplicates is dumped.
119 (sorted-strings (sort (delete-duplicates
120 (copy-sequence strings) :test #'string=)
122 (re (regexp-opt-group sorted-strings open)))
123 (if words (concat "\\<" re "\\>") re))))
125 ;; XEmacs change; this functionality is in bytecomp.el in GNU Emacs, since
126 ;; regexp-opt.el is in core.
127 (define-compiler-macro regexp-opt (&whole form &rest arguments)
128 (if (and (cl-const-exprs-p (cdr form))
129 (function-allows-args #'regexp-opt (length (cdr form))))
130 (condition-case nil (eval form) (error form))
133 ;; XEmacs; added here. This is in subr.el in GNU; this implementation is
134 ;; from their revision 1.541 of 2007-01-04, under GPL 2.
135 (defun-when-void subregexp-context-p (regexp pos &optional start)
136 "Return non-nil if POS is in a normal subregexp context in REGEXP.
137 A subregexp context is one where a sub-regexp can appear.
138 A non-subregexp context is for example within brackets, or within a
139 repetition bounds operator `\\=\\{...\\}', or right after a `\\'.
140 If START is non-nil, it should be a position in REGEXP, smaller
141 than POS, and known to be in a subregexp context."
142 ;; Here's one possible implementation, with the great benefit that it
143 ;; reuses the regexp-matcher's own parser, so it understands all the
144 ;; details of the syntax. A disadvantage is that it needs to match the
148 (string-match (substring regexp (or start 0) pos) "")
151 (not (member (cadr err) '("Unmatched [ or [^"
153 "Trailing backslash")))))
154 ;; An alternative implementation:
155 ;; (defconst re-context-re
156 ;; (let* ((harmless-ch "[^\\[]")
157 ;; (harmless-esc "\\\\[^{]")
158 ;; (class-harmless-ch "[^][]")
159 ;; (class-lb-harmless "[^]:]")
160 ;; (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
161 ;; (class-lb (concat "\\[\\(" class-lb-harmless
162 ;; "\\|" class-lb-colon-maybe-charclass "\\)"))
165 ;; "\\(" class-harmless-ch
166 ;; "\\|" class-lb "\\)*"
167 ;; "\\[?]")) ; special handling for bare [ at end of re
168 ;; (braces "\\\\{[0-9,]+\\\\}"))
169 ;; (concat "\\`\\(" harmless-ch "\\|" harmless-esc
170 ;; "\\|" class "\\|" braces "\\)*\\'"))
171 ;; "Matches any prefix that corresponds to a normal subregexp context.")
172 ;; (string-match re-context-re (substring regexp (or start 0) pos))
176 (defun regexp-opt-depth (regexp)
177 "Return the depth of REGEXP.
178 This means the number of non-shy regexp grouping constructs
179 \(parenthesized expressions) in REGEXP."
181 ;; Hack to signal an error if REGEXP does not have balanced parentheses.
182 (string-match regexp "")
183 ;; Count the number of open parentheses in REGEXP.
184 (let ((count 0) start last)
185 (while (string-match "\\\\(\\(\\?:\\)?" regexp start)
186 (setq start (match-end 0)) ; Start of next search.
187 (when (and (not (match-beginning 1))
188 (subregexp-context-p regexp (match-beginning 0) last))
189 ;; It's not a shy group and it's not inside brackets or after
190 ;; a backslash: it's really a group-open marker.
191 (setq last start) ; Speed up next regexp-opt-re-context-p.
192 (setq count (1+ count))))
195 ;;; Workhorse functions.
200 (defun regexp-opt-group (strings &optional paren lax)
201 ;; XEmacs; docstring, not just a comment.
202 "Return a regexp to match a string in STRINGS.
203 If PAREN non-nil, output regexp parentheses around returned regexp.
204 If LAX non-nil, don't output parentheses if it doesn't require them.
205 Merges keywords to avoid backtracking in Emacs' regexp matcher.
207 The basic idea is to find the shortest common prefix or suffix, remove it
208 and recurse. If there is no prefix, we divide the list into two so that
209 \(at least) one half will have at least a one-character common prefix.
211 Also we delay the addition of grouping parenthesis as long as possible
212 until we're sure we need them, and try to remove one-character sequences
213 so we can use character sets rather than grouping parenthesis."
214 (let* ((open-group (cond ((stringp paren) paren) (paren "\\(?:") (t "")))
215 (close-group (if paren "\\)" ""))
216 (open-charset (if lax "" open-group))
217 (close-charset (if lax "" close-group)))
220 ;; If there are no strings, just return the empty string.
221 ((= (length strings) 0)
224 ;; If there is only one string, just return it.
225 ((= (length strings) 1)
226 (if (= (length (car strings)) 1)
227 (concat open-charset (regexp-quote (car strings)) close-charset)
228 (concat open-group (regexp-quote (car strings)) close-group)))
230 ;; If there is an empty string, remove it and recurse on the rest.
231 ((= (length (car strings)) 0)
233 (regexp-opt-group (cdr strings) t t) "?"
236 ;; If there are several one-char strings, use charsets
237 ((and (= (length (car strings)) 1)
238 (let ((strs (cdr strings)))
239 (while (and strs (/= (length (car strs)) 1))
243 ;; Collect one-char strings
245 (if (= (length s) 1) (push (string-to-char s) letters) (push s rest)))
248 ;; several one-char strings: take them and recurse
249 ;; on the rest (first so as to match the longest).
251 (regexp-opt-group (nreverse rest))
252 "\\|" (regexp-opt-charset letters)
254 ;; all are one-char strings: just return a character set.
256 (regexp-opt-charset letters)
259 ;; We have a list of different length strings.
261 ;; XEmacs; our #'try-completion requires an alist.
262 (let ((prefix (try-completion "" (mapcar 'list strings))))
263 (if (> (length prefix) 0)
264 ;; common prefix: take it and recurse on the suffixes.
265 (let* ((n (length prefix))
266 (suffixes (mapcar (lambda (s) (substring s n)) strings)))
268 (regexp-quote prefix)
269 (regexp-opt-group suffixes t t)
272 (let* ((sgnirts (mapcar (lambda (s)
273 ;; XEmacs; our #'try-completion requires
276 (concat (nreverse (string-to-list s)))))
278 (xiffus (try-completion "" sgnirts)))
279 (if (> (length xiffus) 0)
280 ;; common suffix: take it and recurse on the prefixes.
281 (let* ((n (- (length xiffus)))
283 ;; Sorting is necessary in cases such as ("ad" "d").
284 (sort (mapcar (lambda (s) (substring s 0 n)) strings)
287 (regexp-opt-group prefixes t t)
289 (concat (nreverse (string-to-list xiffus))))
292 ;; Otherwise, divide the list into those that start with a
293 ;; particular letter and those that do not, and recurse on them.
294 (let* ((char (char-to-string (string-to-char (car strings))))
295 ;; XEmacs; #'all-completions requires an alist.
296 (half1 (all-completions char (mapcar 'list strings)))
297 (half2 (nthcdr (length half1) strings)))
299 (regexp-opt-group half1)
300 "\\|" (regexp-opt-group half2)
301 close-group))))))))))
304 (defun regexp-opt-charset (chars)
306 ;; Return a regexp to match a character in CHARS.
308 ;; The basic idea is to find character ranges. Also we take care in the
309 ;; position of character set meta characters in the character set regexp.
311 (let* ((charmap (make-char-table 'generic)) ;; XEmacs; case-tables not suited.
314 (bracket "") (dash "") (caret ""))
316 ;; Make a character map but extract character set meta characters.
326 (put-char-table char t charmap)))) ;; XEmacs; not a sequence, no aset
328 ;; Make a character set from the map using ranges where applicable.
332 (if (= (1- c) end) (setq end c)
333 (if (> end (+ start 2))
334 (setq charset (format "%s%c-%c" charset start end))
335 (while (>= end start)
336 (setq charset (format "%s%c" charset start))
338 (setq start c end c)))
339 nil) ;; XEmacs; don't end the loop with the first char
342 (if (> end (+ start 2))
343 (setq charset (format "%s%c-%c" charset start end))
344 (while (>= end start)
345 (setq charset (format "%s%c" charset start))
348 ;; Make sure a caret is not first and a dash is first or last.
349 (if (and (string-equal charset "") (string-equal bracket ""))
350 (concat "[" dash caret "]")
351 (concat "[" bracket charset caret dash "]"))))
353 (provide 'regexp-opt)
355 ;; arch-tag: 6c5a66f4-29af-4fd6-8c3b-4b554d5b4370
356 ;;; regexp-opt.el ends here