1 ;;; tNFA.el --- Tagged non-deterministic finite-state automata
3 ;; Copyright (C) 2008-2010, 2012, 2014 Free Software Foundation, Inc
5 ;; Author: Toby Cubitt <toby-predictive@dr-qubit.org>
7 ;; Keywords: extensions, matching, data structures
8 ;; tNFA, NFA, DFA, finite state automata, automata, regexp
9 ;; Package-Requires: ((queue "0.1"))
10 ;; URL: http://www.dr-qubit.org/emacs.php
11 ;; Repository: http://www.dr-qubit.org/git/predictive.git
13 ;; This file is part of Emacs.
15 ;; GNU Emacs is free software: you can redistribute it and/or modify it under
16 ;; the terms of the GNU General Public License as published by the Free
17 ;; Software Foundation, either version 3 of the License, or (at your option)
20 ;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT
21 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
22 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
25 ;; You should have received a copy of the GNU General Public License along
26 ;; with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31 ;; A tagged, non-deterministic finite state automata (NFA) is an abstract
32 ;; computing machine that recognises regular languages. In layman's terms,
33 ;; they are used to decide whether a string matches a regular expression. The
34 ;; "tagged" part allows the NFA to do group-capture: it returns information
35 ;; about which parts of a string matched which subgroup of the regular
38 ;; Why re-implement regular expression matching when Emacs comes with
39 ;; extensive built-in support for regexps? Primarily, because some algorithms
40 ;; require access to the NFA states produced part way through the regular
41 ;; expression matching process (see the trie.el package for an
42 ;; example). Secondarily, because Emacs regexps only work on strings, whereas
43 ;; regular expressions can usefully be used in Elisp code to match other
44 ;; sequence types, not just strings.
46 ;; A tagged NFA can be created from a regular expression using
47 ;; `tNFA-from-regexp', and its state can be updated using
48 ;; `tNFA-next-state'. You can discover whether a state is a matching state
49 ;; using `tNFA-match-p', extract subgroup capture data from it using
50 ;; `tNFA-group-data', check whether a state has any wildcard transitions using
51 ;; `tNFA-wildcard-p', and get a list of non-wildcard transitions using
52 ;; `tNFA-transitions'. Finally, `tNFA-regexp-match' uses tagged NFAs to decide
53 ;; whether a regexp matches a given string.
55 ;; Note that Emacs' regexps are not regular expressions in the original
56 ;; meaning of that phrase. Emacs regexps implement additional features (in
57 ;; particular, back-references) that allow them to match far more than just
58 ;; regular languages. This comes at a cost: regexp matching can potentially be
59 ;; very slow (NP-hard in fact, though the hard cases rarely crop up in
60 ;; practise), whereas there are efficient (polynomial-time) algorithms for
61 ;; matching regular expressions (in the original sense). Therefore, this
62 ;; package only supports a subset of the full Emacs regular expression
63 ;; syntax. See the function docstrings for more information.
65 ;; This package essentially implements Laurikari's algorithm, as described in
66 ;; his master's thesis, but it builds the corresponding tagged deterministic
67 ;; finite state automaton (DFA) on-the-fly as needed.
69 ;; This package uses the queue package queue.el.
75 ;; * work-around mysterious byte-compiler bug by defining
76 ;; `tNFA--NFA-state-create' and `tNFA--NFA-state-create-tag' via `defun'
77 ;; instead of directly in `defstruct'
86 (eval-when-compile (require 'cl))
91 ;;; ================================================================
92 ;;; Replcements for CL functions
94 (defun* tNFA--assoc (item alist &key (test 'eq))
95 ;; Return first cons cell in ALIST whose CAR matches ITEM according to
96 ;; :test function (defaulting to `eq')
98 (or (not (consp (car alist)))
99 (not (funcall test item (caar alist)))))
100 (setq alist (cdr alist)))
105 ;;; ================================================================
108 ;;; ----------------------------------------------------------------
109 ;;; tagged NFA states
114 (:constructor tNFA--state-create-initial
115 (NFA-state num-tags min-tags max-tags
117 (tags (tNFA--tags-create num-tags min-tags max-tags))))
118 (:constructor tNFA--state-create (NFA-state tags))
122 (defmacro tNFA--state-id (state)
123 `(tNFA--NFA-state-id (tNFA--state-NFA-state ,state)))
125 (defmacro tNFA--state-type (state)
126 `(tNFA--NFA-state-type (tNFA--state-NFA-state ,state)))
128 (defmacro tNFA--state-label (state)
129 `(tNFA--NFA-state-label (tNFA--state-NFA-state ,state)))
131 (defmacro tNFA--state-in-degree (state)
132 `(tNFA--NFA-state-in-degree (tNFA--state-NFA-state ,state)))
134 (defmacro tNFA--state-next (state)
135 `(tNFA--NFA-state-next (tNFA--state-NFA-state ,state)))
137 (defmacro tNFA--state-count (state)
138 `(tNFA--NFA-state-count (tNFA--state-NFA-state ,state)))
142 ;;; ----------------------------------------------------------------
145 (declare (special NFA--state-id))
151 (:constructor tNFA---NFA-state-create
152 (&optional type label next
156 (id (incf NFA--state-id))
159 ;; (setf (tNFA--NFA-state-count next)
160 ;; (incf (tNFA--NFA-state-in-degree next)))))
162 (:constructor tNFA--NFA-state-create-branch
168 (id (incf NFA--state-id))))
169 (:constructor tNFA---NFA-state-create-tag
176 (id (incf NFA--state-id))
179 ;; (setf (tNFA--NFA-state-count next)
180 ;; (incf (tNFA--NFA-state-in-degree next)))))
183 id type label in-degree
184 count tNFA-state ; used internally in NFA evolution algorithms
188 ;; Define these via defun instead of using the dummy argument in the
189 ;; above defstruct to work around a mysterious byte-compiler bug.
191 (defun tNFA--NFA-state-create (&optional type label next)
193 (setf (tNFA--NFA-state-count next)
194 (incf (tNFA--NFA-state-in-degree next))))
195 (tNFA---NFA-state-create type label next))
197 (defun tNFA--NFA-state-create-tag (tag &optional next)
199 (setf (tNFA--NFA-state-count next)
200 (incf (tNFA--NFA-state-in-degree next))))
201 (tNFA---NFA-state-create-tag tag next))
204 ;; tag number for a tagged epsilon transition is stored in label slot
205 (defalias 'tNFA--NFA-state-tag 'tNFA--NFA-state-label)
207 (defmacro tNFA--NFA-state-tags (state)
208 `(tNFA--state-tags (tNFA--NFA-state-tNFA-state ,state)))
211 (defun tNFA--NFA-state-patch (attach state)
212 ;; patch STATE onto ATTACH. Return value is meaningless
214 (tNFA--NFA-state-type attach)
215 (tNFA--NFA-state-type state)
216 (tNFA--NFA-state-label attach)
217 (tNFA--NFA-state-label state)
218 (tNFA--NFA-state-next attach)
219 (tNFA--NFA-state-next state)
220 (tNFA--NFA-state-count state)
221 (incf (tNFA--NFA-state-in-degree state))))
224 (defun tNFA--NFA-state-make-epsilon (state next)
225 ;; create an epsilon transition from STATE to NEXT
227 (tNFA--NFA-state-type state) 'epsilon
228 (tNFA--NFA-state-label state) nil
229 (tNFA--NFA-state-next state) next
230 (tNFA--NFA-state-count next)
231 (incf (tNFA--NFA-state-in-degree next))))
234 (defun tNFA--NFA-state-make-branch (state next)
235 ;; create a branch from STATE to all states in NEXT list
236 (setf (tNFA--NFA-state-type state) 'branch
237 (tNFA--NFA-state-label state) nil
238 (tNFA--NFA-state-next state) next)
240 (setf (tNFA--NFA-state-count n)
241 (incf (tNFA--NFA-state-in-degree n)))))
244 (defun tNFA--NFA-state-copy (state)
245 ;; Return a copy of STATE. The next link is *not* copied, it is `eq'
246 ;; to the original next link. Use `tNFA--fragment-copy' if you want to
247 ;; recursively copy a chain of states. Note: NFA--state-id must be
248 ;; bound to something appropriate when this function is called.
249 (let ((copy (copy-sequence state)))
250 (setf (tNFA--NFA-state-id copy) (incf NFA--state-id))
255 ;;; ----------------------------------------------------------------
262 (:constructor tNFA--fragment-create (initial final))
267 (defun tNFA--fragment-patch (frag1 frag2)
268 ;; patch FRAG2 onto end of FRAG1; return value is meaningless
269 (tNFA--NFA-state-patch (tNFA--fragment-final frag1)
270 (tNFA--fragment-initial frag2))
271 (setf (tNFA--fragment-final frag1) (tNFA--fragment-final frag2)))
274 (defun tNFA--fragment-copy (fragment)
275 ;; return a copy of FRAGMENT.
276 (declare (special copied-states))
278 (tNFA--fragment-create
279 (tNFA--do-fragment-copy (tNFA--fragment-initial fragment))
280 (cdr (assq (tNFA--fragment-final fragment) copied-states)))))
283 (defun tNFA--do-fragment-copy (state)
284 ;; return a copy of STATE, recursively following and copying links
285 ;; (note: NFA--state-id must be bound to something appropriate when
287 (declare (special copied-states))
288 (let ((copy (tNFA--NFA-state-copy state)))
289 (push (cons state copy) copied-states)
291 ;; if STATE is a branch, copy all links
293 ((eq (tNFA--NFA-state-type copy) 'branch)
294 (setf (tNFA--NFA-state-next copy)
295 (mapcar (lambda (next)
296 (or (cdr (assq next copied-states))
297 (tNFA--do-fragment-copy next)))
298 (tNFA--NFA-state-next copy))))
300 ;; if state doesn't have a next link, return
301 ((or (eq (tNFA--NFA-state-type copy) 'match)
302 (null (tNFA--NFA-state-type copy))))
304 ;; otherwise, copy next link
305 ((tNFA--NFA-state-type copy)
306 ;; for a non-branch STATE, copy next link
307 (setf (tNFA--NFA-state-next copy)
308 ;; if we've already copied next state, set next link to that
309 (or (cdr (assq (tNFA--NFA-state-next copy) copied-states))
310 ;; otherwise, recursively copy next state
311 (tNFA--do-fragment-copy (tNFA--NFA-state-next copy))))))
316 ;;; ----------------------------------------------------------------
323 (:constructor tNFA--DFA-state--create
330 list transitions test wildcard match pool)
333 (defun* tNFA--DFA-state-create (state-list state-pool &key (test 'eq))
334 ;; create DFA state and add it to the state pool
335 (let ((DFA-state (tNFA--DFA-state--create
336 state-list state-pool :test test)))
337 (puthash state-list DFA-state (tNFA--DFA-state-pool DFA-state))
339 (dolist (state state-list)
340 ;; if state in state list is...
342 ;; literal state: add literal transition
343 ((eq (tNFA--state-type state) 'literal)
344 (pushnew (cons (tNFA--state-label state) t)
345 (tNFA--DFA-state-transitions DFA-state)
348 ;; character alternative: add transitions for all alternatives
349 ((eq (tNFA--state-type state) 'char-alt)
350 (dolist (c (tNFA--state-label state))
351 (pushnew (cons c t) (tNFA--DFA-state-transitions DFA-state)
354 ;; wildcard or negated character alternative: add wildcard
356 ((or (eq (tNFA--state-type state) 'wildcard)
357 (eq (tNFA--state-type state) 'neg-char-alt))
358 (setf (tNFA--DFA-state-wildcard DFA-state) t))
360 ;; match state: set match tags
361 ((eq (tNFA--state-type state) 'match)
362 (setf (tNFA--DFA-state-match DFA-state)
363 (tNFA--state-tags state)))))
365 ;; return constructed state
369 (defun* tNFA--DFA-state-create-initial (state-list &key (test 'eq))
370 ;; create initial DFA state from initial tNFA state INITIAL-STATE
371 (tNFA--DFA-state-create state-list
372 (make-hash-table :test 'equal)
376 (defalias 'tNFA-match-p 'tNFA--DFA-state-match
377 "Return non-nil if STATE is a matching state, otherwise return nil.")
380 (defalias 'tNFA-wildcard-p 'tNFA--DFA-state-wildcard
381 "Return non-nil if STATE has a wildcard transition,
382 otherwise return nil.")
385 (defun tNFA-transitions (state)
386 "Return list of literal transitions from tNFA state STATE."
387 (mapcar 'car (tNFA--DFA-state-transitions state)))
391 ;;; ----------------------------------------------------------------
394 (defun tNFA--tags-create (num-tags min-tags max-tags)
395 ;; construct a new tags table
396 (let ((vec (make-vector num-tags nil)))
397 (dolist (tag min-tags)
398 (aset vec tag (cons -1 'min)))
399 (dolist (tag max-tags)
400 (aset vec tag (cons -1 'max)))
404 (defun tNFA--tags-copy (tags)
405 ;; return a copy of TAGS table
406 (let* ((len (length tags))
407 (vec (make-vector len nil)))
409 (aset vec i (cons (car (aref tags i))
410 (cdr (aref tags i)))))
414 (defmacro tNFA--tags-set (tags tag val)
415 ;; set value of TAG in TAGS table to VAL
416 `(setcar (aref ,tags ,tag) ,val))
419 (defmacro tNFA--tags-get (tags tag)
420 ;; get value of TAG in TAGS table
421 `(car (aref ,tags ,tag)))
424 (defmacro tNFA--tags-type (tags tag)
425 ;; return tag type ('min or 'max)
426 `(cdr (aref ,tags ,tag)))
429 (defun tNFA--tags< (val tag tags)
430 ;; return non-nil if VAL takes precedence over the value of TAG in
431 ;; TAGS table, nil otherwise
432 (setq tag (aref tags tag))
433 (or (and (eq (cdr tag) 'min)
435 ;;(and (eq (cdr tag) 'max)
440 (defun tNFA--tags-to-groups (tags)
441 ;; Convert TAGS table to a list of indices of group matches. The n'th
442 ;; element of the list is a cons cell, whose car is the starting index
443 ;; of the nth group and whose cdr is its end index. If a group didn't
444 ;; match, the corresponding list element will be null."
445 (let ((groups (make-list (/ (length tags) 2) nil))
448 (dotimes (i (length tags))
449 (if (eq (tNFA--tags-type tags i) 'max)
450 (unless (= (tNFA--tags-get tags i) -1)
451 (setf (nth (caar group-stack) groups)
452 (cons (cdr (pop group-stack))
453 (tNFA--tags-get tags i))))
454 (unless (= (tNFA--tags-get tags i) -1)
455 (push (cons grp (tNFA--tags-get tags i)) group-stack))
462 ;;; ================================================================
466 (defun* tNFA-from-regexp (regexp &key (test 'eq))
467 "Create a tagged NFA that recognizes the regular expression REGEXP.
468 The return value is the initial state of the tagged NFA.
470 REGEXP can be any sequence type (vector, list, or string); it
471 need not be an actual string. Special characters in REGEXP are
472 still just that: elements of the sequence that are characters
473 which have a special meaning in regexps.
475 The :test keyword argument specifies how to test whether two
476 individual elements of STRING are identical. The default is `eq'.
478 Only a subset of the full Emacs regular expression syntax is
479 supported. There is no support for regexp constructs that are
480 only meaningful for strings (character ranges and character
481 classes inside character alternatives, and syntax-related
482 backslash constructs). Back-references and non-greedy postfix
483 operators are not supported, so `?' after a postfix operator
484 loses its special meaning. Also, matches are always anchored, so
485 `$' and `^' lose their special meanings (use `.*' at the
486 beginning and end of the regexp to get an unanchored match)."
488 ;; convert regexp to list, build NFA, and return initial state
489 (declare (special NFA--state-id))
490 (destructuring-bind (fragment num-tags min-tags max-tags regexp)
491 (let ((NFA--state-id -1))
492 (tNFA--from-regexp (append regexp nil) 0 '() '() 'top-level))
494 (error "Syntax error in regexp: missing \"(\"")
495 (setf (tNFA--NFA-state-type (tNFA--fragment-final fragment))
497 (tNFA--DFA-state-create-initial
498 (tNFA--epsilon-boundary
500 (tNFA--state-create-initial
501 (tNFA--fragment-initial fragment) num-tags min-tags max-tags))
507 (defmacro tNFA--regexp-postfix-p (regexp)
508 ;; return t if next token in REGEXP is a postfix operator, nil
510 `(or (eq (car ,regexp) ?*)
511 (eq (car ,regexp) ?+)
512 (eq (car ,regexp) ??)
513 (and (eq (car ,regexp) ?\\)
515 (eq (cadr ,regexp) ?{))))
518 (defun tNFA--from-regexp (regexp num-tags min-tags max-tags
519 &optional top-level shy-group)
520 ;; Construct a tagged NFA fragment from REGEXP, up to first end-group
521 ;; character or end of REGEXP. The TAGS arguments are used to pass the
522 ;; tags created so far. A non-nil TOP-LEVEL indicates that REGEXP is
523 ;; the complete regexp, so we're constructing the entire tNFA. A
524 ;; non-nil SHY-GROUP indicates that we're constructing a shy subgroup
525 ;; fragment. (Both optional arguments are only used for spotting
526 ;; syntax errors in REGEXP.)
528 ;; Returns a list: (FRAGMENT NUM-TAGS MIN-TAGS MAX-TAGS
529 ;; REGEXP). FRAGMENT is the constructed tNFA fragment, REGEXP is the
530 ;; remaining, unused portion of the regexp, and the TAGS return values
531 ;; give the tags created so far.
533 (let* ((new (tNFA--NFA-state-create))
534 (fragment-stack (list (tNFA--fragment-create new new)))
535 fragment copy attach token type group-end-tag)
539 (setq regexp (tNFA--regexp-next-token regexp)
542 regexp (nth 2 regexp))
546 ;; ----- construct new fragment -----
548 ;; syntax error: missing )
549 ((and (null type) (not top-level))
550 (error "Syntax error in regexp:\
551 extra \"(\" or missing \")\""))
553 ;; syntax error: extra )
554 ((and (eq type 'shy-group-end) top-level)
555 (error "Syntax error in regexp:\
556 extra \")\" or missing \"(\""))
558 ;; syntax error: ) ending a shy group
559 ((and (eq type 'shy-group-end) (not shy-group))
560 (error "Syntax error in regexp: \"(\" matched with \")?\""))
562 ;; syntax error: )? ending a group
563 ((and (eq type 'group-end) shy-group)
564 (error "Syntax error in regexp: \"(?\" matched with \")\""))
566 ;; syntax error: postfix operator not after atom
568 (error "Syntax error in regexp: unexpected \"%s\""
569 (char-to-string token)))
572 ;; regexp atom: construct new literal fragment
573 ((or (eq type 'literal) (eq type 'wildcard)
574 (eq type 'char-alt) (eq type 'neg-char-alt))
575 (setq new (tNFA--NFA-state-create
576 type token (tNFA--NFA-state-create))
577 fragment (tNFA--fragment-create
578 new (tNFA--NFA-state-next new))))
580 ;; shy subgroup start: recursively construct subgroup fragment
581 ((eq type 'shy-group-start)
582 (setq new (tNFA--from-regexp
583 regexp num-tags min-tags max-tags nil t)
588 fragment (nth 0 new)))
590 ;; subgroup start: add minimize tag to current fragment, and
591 ;; recursively construct subgroup fragment
592 ((eq type 'group-start)
593 (setq new (tNFA--NFA-state-create))
595 (tNFA--fragment-create
596 (tNFA--NFA-state-create-tag
597 (car (push (1- (incf num-tags)) min-tags))
600 (tNFA--fragment-patch (car fragment-stack) fragment)
601 ;; reserve next tag number for subgroup end tag
602 (setq group-end-tag num-tags)
604 ;; recursively construct subgroup fragment
605 (setq new (tNFA--from-regexp
606 regexp num-tags min-tags max-tags)
611 fragment (nth 0 new)))
614 ;; end of regexp or subgroup: ...
615 ((or (null type) (eq type 'shy-group-end) (eq type 'group-end))
617 ;; if fragment-stack contains only one fragment, throw
618 ;; fragment up to recursion level above
620 ((null (nth 1 fragment-stack))
622 (list (car fragment-stack)
623 num-tags min-tags max-tags regexp)))
625 ;; if fragment-stack contains multiple alternation fragments,
626 ;; attach them all together
630 ;; /----fragment----\
632 ;; ---o------fragment------o--->
637 ;; create a new fragment containing start and end of
640 (tNFA--fragment-create
641 (tNFA--NFA-state-create-branch)
642 (tNFA--NFA-state-create)))
643 ;; patch alternation fragments into new fragment
644 (dolist (frag fragment-stack)
645 (push (tNFA--fragment-initial frag)
646 (tNFA--NFA-state-next
647 (tNFA--fragment-initial fragment)))
648 (setf (tNFA--NFA-state-count
649 (tNFA--fragment-initial frag))
650 (incf (tNFA--NFA-state-in-degree
651 (tNFA--fragment-initial frag))))
652 (tNFA--NFA-state-make-epsilon (tNFA--fragment-final frag)
653 (tNFA--fragment-final fragment)))
654 ;; throw constructed fragment up to recursion level above
656 (list fragment num-tags min-tags max-tags regexp)))
659 ;; | alternation: start new fragment
660 ((eq type 'alternation)
661 (setq new (tNFA--NFA-state-create))
662 (push (tNFA--fragment-create new new) fragment-stack)))
665 ;; ----- attach new fragment -----
667 ;; if next token is not a postfix operator, attach new
668 ;; fragment onto end of current NFA fragment
669 (if (not (tNFA--regexp-postfix-p regexp))
670 (tNFA--fragment-patch (car fragment-stack) fragment)
672 ;; if next token is a postfix operator, splice new fragment
673 ;; into NFA as appropriate
674 (when (eq type 'alternation)
675 (error "Syntax error in regexp: unexpected \"%s\""
676 (char-to-string token)))
677 (setq regexp (tNFA--regexp-next-token regexp)
680 regexp (nth 2 regexp))
683 (setq attach (tNFA--fragment-final (car fragment-stack)))
684 (setq new (tNFA--NFA-state-create))
687 ;; * postfix = \{0,\}:
693 ;; ---attach-----new---
695 ((and (eq (car token) 0) (null (cdr token)))
696 (tNFA--NFA-state-make-branch
697 attach (list (tNFA--fragment-initial fragment) new))
698 (tNFA--NFA-state-make-epsilon
699 (tNFA--fragment-final fragment) attach)
700 (setf (tNFA--fragment-final (car fragment-stack)) new)
703 ;; + postfix = \{1,\}:
709 ;; ---fragment-----new---
711 ((and (eq (car token) 1) (null (cdr token)))
712 (tNFA--NFA-state-patch
713 attach (tNFA--fragment-initial fragment))
714 (tNFA--NFA-state-make-branch
715 (tNFA--fragment-final fragment) (list attach new))
716 (setf (tNFA--fragment-final (car fragment-stack)) new)
719 ;; \{0,n\} (note: ? postfix = \{0,1\}):
727 ;; ? postfix = \{0,1\}: after this we're done
728 (if (eq (cdr token) 1)
730 (setq copy (tNFA--fragment-copy fragment)))
732 (tNFA--NFA-state-make-branch
733 attach (list (tNFA--fragment-initial fragment) new))
734 (tNFA--NFA-state-make-epsilon
735 (tNFA--fragment-final fragment) new)
736 (setf (tNFA--fragment-final (car fragment-stack)) new)
737 ;; prepare for next iteration
739 (setq fragment copy))
741 ;; \{n,\} or \{n,m\}:
743 ;; ---attach----fragment----new---
746 (setq copy (tNFA--fragment-copy fragment))
747 (tNFA--fragment-patch (car fragment-stack) fragment)
748 ;; prepare for next iteration
750 (when (cdr token) (decf (cdr token)))
751 (if (eq (cdr token) 0)
753 (setq fragment copy)))
757 ;; if ending a group, add a maximize tag to end
759 (setq new (tNFA--NFA-state-create)
760 fragment (tNFA--fragment-create
761 (tNFA--NFA-state-create-tag
764 (push group-end-tag max-tags)
765 (tNFA--fragment-patch (car fragment-stack) fragment)))
766 )) ; end of infinite loop and catch
771 ;; Note: hard-coding the parsing like this is ugly, though sufficient
772 ;; for our purposes. Perhaps it would be more elegant to implement
773 ;; this in terms of a proper parser...
775 (defun tNFA--regexp-next-token (regexp)
776 ;; if regexp is empty, return null values for next token type, token
777 ;; and remaining regexp
781 (let ((token (pop regexp))
782 (type 'literal)) ; assume token is literal initially
785 ;; [: gobble up to closing ]
787 ;; character alternatives are stored in lists
790 ;; gobble ] appearing straight after [
791 ((eq (car regexp) ?\]) (push (pop regexp) token))
792 ;; gobble ] appearing straight after [^
793 ((and (eq (car regexp) ?^) (eq (nth 1 regexp) ?\]))
794 (push (pop regexp) token)
795 (push (pop regexp) token)))
796 ;; gobble everything up to closing ]
797 (while (not (eq (car regexp) ?\]))
798 (push (pop regexp) token)
800 (error "Syntax error in regexp: missing \"]\"")))
801 (pop regexp) ; dump closing ]
802 (if (not (eq (car (last token)) ?^))
803 (setq type 'char-alt)
804 (setq type 'neg-char-alt)
805 (setq token (butlast token))))
807 ;; ]: syntax error (always gobbled when parsing [)
809 (error "Syntax error in regexp: missing \"[\""))
811 ;; . * + ?: set appropriate type
812 ((eq token ?*) (setq type 'postfix token (cons 0 nil)))
813 ((eq token ?+) (setq type 'postfix token (cons 1 nil)))
814 ((eq token ??) (setq type 'postfix token (cons 0 1)))
815 ((eq token ?.) (setq type 'wildcard))
817 ;; \: look at next character
819 (unless (setq token (pop regexp))
820 (error "Syntax error in regexp:\
821 missing character after \"\\\""))
824 ((eq token ?|) (setq type 'alternation))
825 ;; \(?: shy group start
826 ((and (eq token ?\() (eq (car regexp) ??))
827 (setq type 'shy-group-start)
829 ;; \)?: shy group end
830 ((and (eq token ?\)) (eq (car regexp) ??))
831 (setq type 'shy-group-end)
834 ((eq token ?\() (setq type 'group-start))
836 ((eq token ?\)) (setq type 'group-end))
838 ;; \{: postfix repetition operator
840 (setq type 'postfix token (cons nil nil))
841 ;; extract first number from repetition operator
842 (while (if (null regexp)
843 (error "Syntax error in regexp:\
844 malformed \\{...\\}")
845 (not (or (eq (car regexp) ?,)
846 (eq (car regexp) ?\\))))
848 (concat (car token) (char-to-string (pop regexp)))))
849 (if (null (car token))
851 (unless (string-match "[0-9]+" (car token))
852 (error "Syntax error in regexp: malformed \\{...\\}"))
853 (setcar token (string-to-number (car token))))
855 ;; if next character is "\", we expect "}" to follow
856 ((eq (car regexp) ?\\)
858 (unless (eq (car regexp) ?})
859 (error "Syntax error in regexp: expected \"}\""))
862 (error "Syntax error in regexp: malformed \\{...\\}"))
863 (setcdr token (car token)))
864 ;; if next character is ",", we expect a second number to
866 ((eq (car regexp) ?,)
868 (while (if (null regexp)
869 (error "Syntax error in regexp:\
870 malformed \\{...\\}")
871 (not (eq (car regexp) ?\\)))
874 (char-to-string (pop regexp)))))
875 (unless (null (cdr token))
876 (unless (string-match "[0-9]+" (cdr token))
877 (error "Syntax error in regexp: malformed \\{...\\}"))
878 (setcdr token (string-to-number (cdr token))))
880 (unless (eq (car regexp) ?})
881 (error "Syntax error in regexp: expected \"}\""))
886 ;; return first token type, token, and remaining regexp
887 (list type token regexp))))
891 ;;; ================================================================
894 (defun tNFA-next-state (tNFA chr pos)
895 "Evolve tNFA according to CHR, which corresponds to position
898 ;; if there is a transition for character CHR...
900 ((setq elem (tNFA--assoc chr (tNFA--DFA-state-transitions tNFA)
901 :test (tNFA--DFA-state-test tNFA)))
902 ;; if next state has not already been computed, do so
903 (unless (tNFA--DFA-state-p (setq state (cdr elem)))
904 (setq state (tNFA--DFA-next-state tNFA chr pos nil))
905 (setcdr elem state)))
907 ;; if there's a wildcard transition...
908 ((setq state (tNFA--DFA-state-wildcard tNFA))
909 ;; if next state has not already been computed, do so
910 (unless (tNFA--DFA-state-p state)
911 (setq state (tNFA--DFA-next-state tNFA chr pos t))
912 (setf (tNFA--DFA-state-wildcard tNFA) state))))
917 (defun tNFA--DFA-next-state (DFA-state chr pos wildcard)
918 (let (state-list state)
919 ;; add all states reached by a CHR transition from DFA-STATE to
922 (dolist (state (tNFA--DFA-state-list DFA-state))
923 (when (or (eq (tNFA--state-type state) 'wildcard)
924 (and (eq (tNFA--state-type state) 'neg-char-alt)
925 (not (memq chr (tNFA--state-label state)))))
926 (push (tNFA--state-create
927 (tNFA--state-next state)
928 (tNFA--tags-copy (tNFA--state-tags state)))
930 (dolist (state (tNFA--DFA-state-list DFA-state))
931 (when (or (and (eq (tNFA--state-type state) 'literal)
932 (eq chr (tNFA--state-label state)))
933 (and (eq (tNFA--state-type state) 'char-alt)
934 (memq chr (tNFA--state-label state)))
935 (and (eq (tNFA--state-type state) 'neg-char-alt)
936 (not (memq chr (tNFA--state-label state))))
937 (eq (tNFA--state-type state) 'wildcard))
938 (push (tNFA--state-create
939 (tNFA--state-next state)
940 (tNFA--tags-copy (tNFA--state-tags state)))
943 ;; if state list is empty, return empty, failure DFA state
945 ;; otherwise, construct new DFA state and add it to the pool if
946 ;; it's not already there
947 (setq state-list (tNFA--epsilon-boundary state-list (1+ pos)))
949 (or (gethash state-list (tNFA--DFA-state-pool DFA-state))
950 (tNFA--DFA-state-create
952 (tNFA--DFA-state-pool DFA-state)
953 :test (tNFA--DFA-state-test DFA-state))))
959 (defun tNFA--epsilon-boundary (state-set pos)
960 ;; Return the tagged epsilon-boundary of the NFA states listed in
961 ;; STATE-SET, that is the set of all states that can be reached via
962 ;; epsilon transitions from some state in STATE-SET (not including
963 ;; states in STATE-SET itself).
964 (let ((queue (queue-create))
968 ;; temporarily link the NFA states to their corresponding tNFA
969 ;; states, and add them to the queue
970 (dolist (t-state state-set)
971 (setf state (tNFA--state-NFA-state t-state)
972 (tNFA--NFA-state-tNFA-state state) t-state)
974 (queue-enqueue queue state))
976 (while (setq state (queue-dequeue queue))
978 ;; branch or epsilon: add next states as necessary, copying tags
980 ((or (eq (tNFA--NFA-state-type state) 'branch)
981 (eq (tNFA--NFA-state-type state) 'epsilon))
982 (dolist (next (if (eq (tNFA--NFA-state-type state) 'epsilon)
983 (list (tNFA--NFA-state-next state))
984 (tNFA--NFA-state-next state)))
985 (unless (tNFA--NFA-state-tNFA-state next)
986 (setf (tNFA--NFA-state-tNFA-state next)
988 next (tNFA--tags-copy (tNFA--NFA-state-tags state))))
990 ;; if next state hasn't already been seen in-degree times,
991 ;; add it to the end of the queue
992 (if (/= (decf (tNFA--NFA-state-count next)) 0)
993 (queue-enqueue queue next)
994 ;; if it has now been seen in-degree times, reset count
995 ;; and add it back to the front of the queue
996 (setf (tNFA--NFA-state-count next)
997 (tNFA--NFA-state-in-degree next))
998 (queue-prepend queue next)))))
1000 ;; tag: add next state if necessary, updating tags if necessary
1001 ((eq (tNFA--NFA-state-type state) 'tag)
1002 (setq next (tNFA--NFA-state-next state))
1003 ;; if next state is not already in results list, or it is
1004 ;; already in results but new tag value takes precedence...
1005 (when (or (not (tNFA--NFA-state-tNFA-state next))
1006 (tNFA--tags< pos (tNFA--NFA-state-tag state)
1007 (tNFA--NFA-state-tags next)))
1008 ;; if next state is already in results, update tag value
1009 (if (tNFA--NFA-state-tNFA-state next)
1010 (tNFA--tags-set (tNFA--NFA-state-tags next)
1011 (tNFA--NFA-state-tag state) pos)
1012 ;; if state is not already in results, copy tags, updating
1013 ;; tag value, and add next state to results list
1014 (setq tags (tNFA--tags-copy (tNFA--NFA-state-tags state)))
1015 (tNFA--tags-set tags (tNFA--NFA-state-tag state) pos)
1016 (setf (tNFA--NFA-state-tNFA-state next)
1017 (tNFA--state-create next tags))
1019 ;; if next state hasn't already been seen in-degree times, add
1020 ;; it to the end of the queue
1021 (if (/= (decf (tNFA--NFA-state-count next)) 0)
1022 (queue-enqueue queue next)
1023 ;; if it has now been seen in-degree times, reset count and
1024 ;; add it back to the front of the queue
1025 (setf (tNFA--NFA-state-count next)
1026 (tNFA--NFA-state-in-degree next))
1027 (queue-prepend queue next))))
1029 ;; anything else is a non-epsilon-transition state, so add it to
1031 (t (push (tNFA--NFA-state-tNFA-state state) result))
1034 ;; reset temporary NFA state link and count
1035 (dolist (state reset)
1036 (setf (tNFA--NFA-state-tNFA-state state) nil
1037 (tNFA--NFA-state-count state)
1038 (tNFA--NFA-state-in-degree state)))
1039 ;; sort result states
1041 (lambda (a b) (< (tNFA--state-id a) (tNFA--state-id b))))
1046 ;;; ================================================================
1050 (defun* tNFA-regexp-match (regexp string &key (test 'eq))
1051 "Return non-nil if STRING matches REGEXP, nil otherwise.
1052 Sets the match data if there was a match; see `match-beginning',
1053 `match-end' and `match-string'.
1055 REGEXP and STRING can be any sequence type (vector, list, or
1056 string); they need not be actual strings. Special characters in
1057 REGEXP are still just that: elements of the sequence that are
1058 characters which have a special meaning in regexps.
1060 The :test keyword argument specifies how to test whether two
1061 individual elements of STRING are identical. The default is `eq'.
1063 Only a subset of the full Emacs regular expression syntax is
1064 supported. There is no support for regexp constructs that are
1065 only meaningful for strings (character ranges and character
1066 classes inside character alternatives, and syntax-related
1067 backslash constructs). Back-references and non-greedy postfix
1068 operators are not supported, so `?' after a postfix operator
1069 loses its special meaning. Also, matches are always anchored, so
1070 `$' and `^' lose their special meanings (use `.*' at the
1071 beginning and end of the regexp to get an unanchored match)."
1073 (let ((tNFA (tNFA-from-regexp regexp :test test))
1074 (i -1) tags match-data group-stack (grp 0))
1076 ;; evolve tNFA according to characters of STRING
1078 (dolist (chr (append string nil))
1079 (unless (setq tNFA (tNFA-next-state tNFA chr (incf i)))
1082 ;; if REGEXP matched...
1083 (when (setq tags (tNFA--DFA-state-match tNFA))
1084 (setq match-data (make-list (+ (length tags) 2) nil))
1086 (setf (nth 0 match-data) 0
1087 (nth 1 match-data) (length string))
1088 ;; set group match data if there were any groups
1089 (dotimes (i (length tags))
1090 (if (eq (tNFA--tags-type tags i) 'max)
1091 (unless (= (tNFA--tags-get tags i) -1)
1092 (setf (nth (1+ (* 2 (pop group-stack))) match-data)
1093 (tNFA--tags-get tags i)))
1095 (unless (= (tNFA--tags-get tags i) -1)
1096 (push grp group-stack)
1097 (setf (nth (* 2 grp) match-data)
1098 (tNFA--tags-get tags i)))))
1099 (set-match-data match-data)
1103 (defun tNFA-group-data (tNFA)
1104 "Return the group match data associated with a tNFA state."
1105 (tNFA--tags-to-groups (tNFA--DFA-state-match tNFA)))
1111 ;;; tNFA.el ends here