Initial revision
git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-ppcre@12 4281704c-cde7-0310-8518-8e2dc76b1ff0
This commit is contained in:
Hans Huebner
576
closures.lisp
Normal file
576
closures.lisp
Normal file
@ -0,0 +1,576 @@
|
||||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||
;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-ppcre/closures.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
|
||||
|
||||
;;; Here we create the closures which together build the final
|
||||
;;; scanner.
|
||||
|
||||
;;; Copyright (c) 2002-2003, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package #:cl-ppcre)
|
||||
|
||||
(declaim (inline *string*= *string*-equal))
|
||||
|
||||
(defun *string*= (string2 start1 end1 start2 end2)
|
||||
"Like STRING=, i.e. compares the special string *STRING* from START1
|
||||
to END1 with STRING2 from START2 to END2. Note that there's no
|
||||
boundary check - this has to be implemented by the caller."
|
||||
(declare (optimize speed
|
||||
(safety 0)
|
||||
(space 0)
|
||||
(debug 0)
|
||||
(compilation-speed 0)
|
||||
#+:lispworks (hcl:fixnum-safety 0)))
|
||||
(declare (type fixnum start1 end1 start2 end2))
|
||||
(loop for string1-idx of-type fixnum from start1 below end1
|
||||
for string2-idx of-type fixnum from start2 below end2
|
||||
always (char= (schar *string* string1-idx)
|
||||
(schar string2 string2-idx))))
|
||||
|
||||
(defun *string*-equal (string2 start1 end1 start2 end2)
|
||||
"Like STRING-EQUAL, i.e. compares the special string *STRING* from
|
||||
START1 to END1 with STRING2 from START2 to END2. Note that there's no
|
||||
boundary check - this has to be implemented by the caller."
|
||||
(declare (optimize speed
|
||||
(safety 0)
|
||||
(space 0)
|
||||
(debug 0)
|
||||
(compilation-speed 0)
|
||||
#+:lispworks (hcl:fixnum-safety 0)))
|
||||
(declare (type fixnum start1 end1 start2 end2))
|
||||
(loop for string1-idx of-type fixnum from start1 below end1
|
||||
for string2-idx of-type fixnum from start2 below end2
|
||||
always (char-equal (schar *string* string1-idx)
|
||||
(schar string2 string2-idx))))
|
||||
|
||||
(defgeneric create-matcher-aux (regex next-fn)
|
||||
(declare (optimize speed
|
||||
(safety 0)
|
||||
(space 0)
|
||||
(debug 0)
|
||||
(compilation-speed 0)
|
||||
#+:lispworks (hcl:fixnum-safety 0)))
|
||||
(:documentation "Creates a closure which takes one parameter,
|
||||
START-POS, and tests whether REGEX can match *STRING* at START-POS
|
||||
such that the call to NEXT-FN after the match would succeed."))
|
||||
|
||||
(defmethod create-matcher-aux ((seq seq) next-fn)
|
||||
;; the closure for a SEQ is a chain of closures for the elements of
|
||||
;; this sequence which call each other in turn; the last closure
|
||||
;; calls NEXT-FN
|
||||
(loop for element in (reverse (elements seq))
|
||||
for curr-matcher = next-fn then next-matcher
|
||||
for next-matcher = (create-matcher-aux element curr-matcher)
|
||||
finally (return next-matcher)))
|
||||
|
||||
(defmethod create-matcher-aux ((alternation alternation) next-fn)
|
||||
;; first create closures for all alternations of ALTERNATION
|
||||
(let ((all-matchers (mapcar #'(lambda (choice)
|
||||
(create-matcher-aux choice next-fn))
|
||||
(choices alternation))))
|
||||
;; now create a closure which checks if one of the closures
|
||||
;; created above can succeed
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(loop for matcher in all-matchers
|
||||
thereis (funcall (the function matcher) start-pos)))))
|
||||
|
||||
(defmethod create-matcher-aux ((register register) next-fn)
|
||||
;; the position of this REGISTER within the whole regex; we start to
|
||||
;; count at 0
|
||||
(let ((num (num register)))
|
||||
(declare (type fixnum num))
|
||||
;; STORE-END-OF-REG is a thin wrapper around NEXT-FN which will
|
||||
;; update the corresponding values of *REGS-START* and *REGS-END*
|
||||
;; after the inner matcher has succeeded
|
||||
(flet ((store-end-of-reg (start-pos)
|
||||
(declare (type fixnum start-pos)
|
||||
(type function next-fn))
|
||||
(setf (svref *reg-starts* num) (svref *regs-maybe-start* num)
|
||||
(svref *reg-ends* num) start-pos)
|
||||
(funcall next-fn start-pos)))
|
||||
;; the inner matcher is a closure corresponding to the regex
|
||||
;; wrapped by this REGISTER
|
||||
(let ((inner-matcher (create-matcher-aux (regex register)
|
||||
#'store-end-of-reg)))
|
||||
(declare (type function inner-matcher))
|
||||
;; here comes the actual closure for REGISTER
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
;; remember the old values of *REGS-START* and friends in
|
||||
;; case we cannot match
|
||||
(let ((old-*reg-starts* (svref *reg-starts* num))
|
||||
(old-*regs-maybe-start* (svref *regs-maybe-start* num))
|
||||
(old-*reg-ends* (svref *reg-ends* num)))
|
||||
;; we cannot use *REGS-START* here because Perl allows
|
||||
;; regular expressions like /(a|\1x)*/
|
||||
(setf (svref *regs-maybe-start* num) start-pos)
|
||||
(let ((next-pos (funcall inner-matcher start-pos)))
|
||||
(unless next-pos
|
||||
;; restore old values on failure
|
||||
(setf (svref *reg-starts* num) old-*reg-starts*
|
||||
(svref *regs-maybe-start* num) old-*regs-maybe-start*
|
||||
(svref *reg-ends* num) old-*reg-ends*))
|
||||
next-pos)))))))
|
||||
|
||||
(defmethod create-matcher-aux ((lookahead lookahead) next-fn)
|
||||
;; create a closure which just checks for the inner regex and
|
||||
;; doesn't care about NEXT-FN
|
||||
(let ((test-matcher (create-matcher-aux (regex lookahead) #'identity)))
|
||||
(declare (type function next-fn test-matcher))
|
||||
(if (positivep lookahead)
|
||||
;; positive look-ahead: check success of inner regex, then call
|
||||
;; NEXT-FN
|
||||
(lambda (start-pos)
|
||||
(and (funcall test-matcher start-pos)
|
||||
(funcall next-fn start-pos)))
|
||||
;; negative look-ahead: check failure of inner regex, then call
|
||||
;; NEXT-FN
|
||||
(lambda (start-pos)
|
||||
(and (not (funcall test-matcher start-pos))
|
||||
(funcall next-fn start-pos))))))
|
||||
|
||||
(defmethod create-matcher-aux ((lookbehind lookbehind) next-fn)
|
||||
(let ((len (len lookbehind))
|
||||
;; create a closure which just checks for the inner regex and
|
||||
;; doesn't care about NEXT-FN
|
||||
(test-matcher (create-matcher-aux (regex lookbehind) #'identity)))
|
||||
(declare (type function next-fn test-matcher)
|
||||
(type fixnum len))
|
||||
(if (positivep lookbehind)
|
||||
;; positive look-behind: check success of inner regex (if we're
|
||||
;; far enough from the start of *STRING*), then call NEXT-FN
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (>= (- start-pos *start-pos*) len)
|
||||
(funcall test-matcher (- start-pos len))
|
||||
(funcall next-fn start-pos)))
|
||||
;; negative look-behind: check failure of inner regex (if we're
|
||||
;; far enough from the start of *STRING*), then call NEXT-FN
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (or (< start-pos len)
|
||||
(not (funcall test-matcher (- start-pos len))))
|
||||
(funcall next-fn start-pos))))))
|
||||
|
||||
(defmacro insert-char-class-tester ((char-class chr-expr) &body body)
|
||||
"Utility macro to replace each occurence of '(CHAR-CLASS-TEST)
|
||||
within BODY with the correct test (corresponding to CHAR-CLASS)
|
||||
against CHR-EXPR."
|
||||
(with-unique-names (%char-class)
|
||||
;; the actual substitution is done here: replace
|
||||
;; '(CHAR-CLASS-TEST) with NEW
|
||||
(flet ((substitute-char-class-tester (new)
|
||||
(subst new '(char-class-test) body
|
||||
:test #'equalp)))
|
||||
`(let* ((,%char-class ,char-class)
|
||||
(hash (hash ,%char-class))
|
||||
(count (if hash
|
||||
(hash-table-count hash)
|
||||
most-positive-fixnum))
|
||||
;; collect a list of "all" characters in the hash if
|
||||
;; there aren't more than two
|
||||
(key-list (if (<= count 2)
|
||||
(loop for chr being the hash-keys of hash
|
||||
collect chr)
|
||||
nil))
|
||||
downcasedp)
|
||||
(declare (type fixnum count))
|
||||
;; check if we can partition the hash into three ranges (or
|
||||
;; less)
|
||||
(multiple-value-bind (min1 max1 min2 max2 min3 max3)
|
||||
(create-ranges-from-hash hash)
|
||||
;; if that didn't work and CHAR-CLASS is case-insensitive we
|
||||
;; try it again with every character downcased
|
||||
(when (and (not min1)
|
||||
(case-insensitive-p ,%char-class))
|
||||
(multiple-value-setq (min1 max1 min2 max2 min3 max3)
|
||||
(create-ranges-from-hash hash :downcasep t))
|
||||
(setq downcasedp t))
|
||||
(cond ((= count 1)
|
||||
;; hash contains exactly one character so we just
|
||||
;; check for this single character; (note that this
|
||||
;; actually can't happen because this case is
|
||||
;; optimized away in CONVERT already...)
|
||||
(let ((chr1 (first key-list)))
|
||||
,@(substitute-char-class-tester
|
||||
`(char= ,chr-expr chr1))))
|
||||
((= count 2)
|
||||
;; hash contains exactly two characters
|
||||
(let ((chr1 (first key-list))
|
||||
(chr2 (second key-list)))
|
||||
,@(substitute-char-class-tester
|
||||
`(let ((chr ,chr-expr))
|
||||
(or (char= chr chr1)
|
||||
(char= chr chr2))))))
|
||||
((word-char-class-p ,%char-class)
|
||||
;; special-case: hash is \w, \W, [\w], [\W] or
|
||||
;; something equivalent
|
||||
,@(substitute-char-class-tester
|
||||
`(word-char-p ,chr-expr)))
|
||||
((= count *regex-char-code-limit*)
|
||||
;; according to the ANSI standard we might have all
|
||||
;; possible characters in the hash even if it
|
||||
;; doesn't contain CHAR-CODE-LIMIT characters but
|
||||
;; this doesn't seem to be the case for current
|
||||
;; implementations (also note that this optimization
|
||||
;; implies that you must not have characters with
|
||||
;; character codes beyond *REGEX-CHAR-CODE-LIMIT* in
|
||||
;; your regexes if you've changed this limit); we
|
||||
;; expect the compiler to optimize this T "test"
|
||||
;; away
|
||||
,@(substitute-char-class-tester t))
|
||||
((and downcasedp min1 min2 min3)
|
||||
;; three different ranges, downcased
|
||||
,@(substitute-char-class-tester
|
||||
`(let ((chr ,chr-expr))
|
||||
(or (char-not-greaterp min1 chr max1)
|
||||
(char-not-greaterp min2 chr max2)
|
||||
(char-not-greaterp min3 chr max3)))))
|
||||
((and downcasedp min1 min2)
|
||||
;; two ranges, downcased
|
||||
,@(substitute-char-class-tester
|
||||
`(let ((chr ,chr-expr))
|
||||
(or (char-not-greaterp min1 chr max1)
|
||||
(char-not-greaterp min2 chr max2)))))
|
||||
((and downcasedp min1)
|
||||
;; one downcased range
|
||||
,@(substitute-char-class-tester
|
||||
`(char-not-greaterp min1 ,chr-expr max1)))
|
||||
((and min1 min2 min3)
|
||||
;; three ranges
|
||||
,@(substitute-char-class-tester
|
||||
`(let ((chr ,chr-expr))
|
||||
(or (char<= min1 chr max1)
|
||||
(char<= min2 chr max2)
|
||||
(char<= min3 chr max3)))))
|
||||
((and min1 min2)
|
||||
;; two ranges
|
||||
,@(substitute-char-class-tester
|
||||
`(let ((chr ,chr-expr))
|
||||
(or (char<= min1 chr max1)
|
||||
(char<= min2 chr max2)))))
|
||||
(min1
|
||||
;; one range
|
||||
,@(substitute-char-class-tester
|
||||
`(char<= min1 ,chr-expr max1)))
|
||||
(t
|
||||
;; the general case; note that most of the above
|
||||
;; "optimizations" are based on experiences and
|
||||
;; benchmarks with CMUCL - if you're really
|
||||
;; concerned with speed you might find out that the
|
||||
;; general case is almost always the best one for
|
||||
;; other implementations (because the speed of their
|
||||
;; hash-table access in relation to other operations
|
||||
;; might be better than in CMUCL)
|
||||
,@(substitute-char-class-tester
|
||||
`(gethash ,chr-expr hash)))))))))
|
||||
|
||||
(defmethod create-matcher-aux ((char-class char-class) next-fn)
|
||||
(declare (type function next-fn))
|
||||
;; insert a test against the current character within *STRING*
|
||||
(insert-char-class-tester (char-class (schar *string* start-pos))
|
||||
(if (invertedp char-class)
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (< start-pos *end-pos*)
|
||||
(not (char-class-test))
|
||||
(funcall next-fn (1+ start-pos))))
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (< start-pos *end-pos*)
|
||||
(char-class-test)
|
||||
(funcall next-fn (1+ start-pos)))))))
|
||||
|
||||
(defmethod create-matcher-aux ((str str) next-fn)
|
||||
(declare (type fixnum *end-string-pos*)
|
||||
(type function next-fn)
|
||||
;; this special value is set by CREATE-SCANNER when the
|
||||
;; closures are built
|
||||
(special end-string))
|
||||
(let* ((len (len str))
|
||||
(case-insensitive-p (case-insensitive-p str))
|
||||
(start-of-end-string-p (start-of-end-string-p str))
|
||||
(skip (skip str))
|
||||
(str (str str))
|
||||
(chr (schar str 0))
|
||||
(end-string (and end-string (str end-string)))
|
||||
(end-string-len (if end-string
|
||||
(length end-string)
|
||||
nil)))
|
||||
(declare (type fixnum len))
|
||||
(cond ((and start-of-end-string-p case-insensitive-p)
|
||||
;; closure for the first STR which belongs to the constant
|
||||
;; string at the end of the regular expression;
|
||||
;; case-insensitive version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos end-string-len))
|
||||
(let ((test-end-pos (+ start-pos end-string-len)))
|
||||
(declare (type fixnum test-end-pos))
|
||||
;; either we're at *END-STRING-POS* (which means that
|
||||
;; it has already been confirmed that end-string
|
||||
;; starts here) or we really have to test
|
||||
(and (or (= start-pos *end-string-pos*)
|
||||
(and (<= test-end-pos *end-pos*)
|
||||
(*string*-equal end-string start-pos test-end-pos
|
||||
0 end-string-len)))
|
||||
(funcall next-fn (+ start-pos len))))))
|
||||
(start-of-end-string-p
|
||||
;; closure for the first STR which belongs to the constant
|
||||
;; string at the end of the regular expression;
|
||||
;; case-sensitive version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos end-string-len))
|
||||
(let ((test-end-pos (+ start-pos end-string-len)))
|
||||
(declare (type fixnum test-end-pos))
|
||||
;; either we're at *END-STRING-POS* (which means that
|
||||
;; it has already been confirmed that end-string
|
||||
;; starts here) or we really have to test
|
||||
(and (or (= start-pos *end-string-pos*)
|
||||
(and (<= test-end-pos *end-pos*)
|
||||
(*string*= end-string start-pos test-end-pos
|
||||
0 end-string-len)))
|
||||
(funcall next-fn (+ start-pos len))))))
|
||||
(skip
|
||||
;; a STR which can be skipped because some other function
|
||||
;; has already confirmed that it matches
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(funcall next-fn (+ start-pos len))))
|
||||
((and (= len 1) case-insensitive-p)
|
||||
;; STR represent exactly one character; case-insensitive
|
||||
;; version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (< start-pos *end-pos*)
|
||||
(char-equal (schar *string* start-pos) chr)
|
||||
(funcall next-fn (1+ start-pos)))))
|
||||
((= len 1)
|
||||
;; STR represent exactly one character; case-sensitive
|
||||
;; version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (< start-pos *end-pos*)
|
||||
(char= (schar *string* start-pos) chr)
|
||||
(funcall next-fn (1+ start-pos)))))
|
||||
(case-insensitive-p
|
||||
;; general case, case-insensitive version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(let ((next-pos (+ start-pos len)))
|
||||
(declare (type fixnum next-pos))
|
||||
(and (<= next-pos *end-pos*)
|
||||
(*string*-equal str start-pos next-pos 0 len)
|
||||
(funcall next-fn next-pos)))))
|
||||
(t
|
||||
;; general case, case-sensitive version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(let ((next-pos (+ start-pos len)))
|
||||
(declare (type fixnum next-pos))
|
||||
(and (<= next-pos *end-pos*)
|
||||
(*string*= str start-pos next-pos 0 len)
|
||||
(funcall next-fn next-pos))))))))
|
||||
|
||||
(declaim (inline word-boundary-p))
|
||||
|
||||
(defun word-boundary-p (start-pos)
|
||||
"Check whether START-POS is a word-boundary within *STRING*."
|
||||
(declare (optimize speed
|
||||
(safety 0)
|
||||
(space 0)
|
||||
(debug 0)
|
||||
(compilation-speed 0)
|
||||
#+:lispworks (hcl:fixnum-safety 0)))
|
||||
(declare (type fixnum start-pos))
|
||||
(let ((1-start-pos (1- start-pos)))
|
||||
;; either the character before START-POS is a word-constituent and
|
||||
;; the character at START-POS isn't...
|
||||
(or (and (or (= start-pos *end-pos*)
|
||||
(and (< start-pos *end-pos*)
|
||||
(not (word-char-p (schar *string* start-pos)))))
|
||||
(and (< 1-start-pos *end-pos*)
|
||||
(<= *start-pos* 1-start-pos)
|
||||
(word-char-p (schar *string* 1-start-pos))))
|
||||
;; ...or vice versa
|
||||
(and (or (= start-pos *start-pos*)
|
||||
(and (< 1-start-pos *end-pos*)
|
||||
(<= *start-pos* 1-start-pos)
|
||||
(not (word-char-p (schar *string* 1-start-pos)))))
|
||||
(and (< start-pos *end-pos*)
|
||||
(word-char-p (schar *string* start-pos)))))))
|
||||
|
||||
(defmethod create-matcher-aux ((word-boundary word-boundary) next-fn)
|
||||
(declare (type function next-fn))
|
||||
(if (negatedp word-boundary)
|
||||
(lambda (start-pos)
|
||||
(and (not (word-boundary-p start-pos))
|
||||
(funcall next-fn start-pos)))
|
||||
(lambda (start-pos)
|
||||
(and (word-boundary-p start-pos)
|
||||
(funcall next-fn start-pos)))))
|
||||
|
||||
(defmethod create-matcher-aux ((everything everything) next-fn)
|
||||
(declare (type function next-fn))
|
||||
(if (single-line-p everything)
|
||||
;; closure for single-line-mode: we really match everything, so we
|
||||
;; just advance the index into *STRING* by one and carry on
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (< start-pos *end-pos*)
|
||||
(funcall next-fn (1+ start-pos))))
|
||||
;; not single-line-mode, so we have to make sure we don't match
|
||||
;; #\Newline
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (< start-pos *end-pos*)
|
||||
(char/= (schar *string* start-pos) #\Newline)
|
||||
(funcall next-fn (1+ start-pos))))))
|
||||
|
||||
(defmethod create-matcher-aux ((anchor anchor) next-fn)
|
||||
(declare (type function next-fn))
|
||||
(let ((startp (startp anchor))
|
||||
(multi-line-p (multi-line-p anchor)))
|
||||
(cond ((no-newline-p anchor)
|
||||
;; this must be and end-anchor and it must be modeless, so
|
||||
;; we just have to check whether START-POS equals
|
||||
;; *END-POS*
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (= start-pos *end-pos*)
|
||||
(funcall next-fn start-pos))))
|
||||
((and startp multi-line-p)
|
||||
;; a start-anchor in multi-line-mode: check if we're at
|
||||
;; *START-POS* or if the last character was #\Newline
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(let ((*start-pos* (or *real-start-pos* *start-pos*)))
|
||||
(and (or (= start-pos *start-pos*)
|
||||
(and (<= start-pos *end-pos*)
|
||||
(> start-pos *start-pos*)
|
||||
(char= #\Newline
|
||||
(schar *string* (1- start-pos)))))
|
||||
(funcall next-fn start-pos)))))
|
||||
(startp
|
||||
;; a start-anchor which is not in multi-line-mode, so just
|
||||
;; check whether we're at *START-POS*
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (= start-pos (or *real-start-pos* *start-pos*))
|
||||
(funcall next-fn start-pos))))
|
||||
(multi-line-p
|
||||
;; an end-anchor in multi-line-mode: check if we're at
|
||||
;; *END-POS* or if the character we're looking at is
|
||||
;; #\Newline
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (or (= start-pos *end-pos*)
|
||||
(and (< start-pos *end-pos*)
|
||||
(char= #\Newline
|
||||
(schar *string* start-pos))))
|
||||
(funcall next-fn start-pos))))
|
||||
(t
|
||||
;; an end-anchor which is not in multi-line-mode, so just
|
||||
;; check if we're at *END-POS* or if we're looking at
|
||||
;; #\Newline and there's nothing behind it
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(and (or (= start-pos *end-pos*)
|
||||
(and (= start-pos (1- *end-pos*))
|
||||
(char= #\Newline
|
||||
(schar *string* start-pos))))
|
||||
(funcall next-fn start-pos)))))))
|
||||
|
||||
(defmethod create-matcher-aux ((back-reference back-reference) next-fn)
|
||||
(declare (type function next-fn))
|
||||
;; the position of the corresponding REGISTER within the whole
|
||||
;; regex; we start to count at 0
|
||||
(let ((num (num back-reference)))
|
||||
(if (case-insensitive-p back-reference)
|
||||
;; the case-insensitive version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(let ((reg-start (svref *reg-starts* num))
|
||||
(reg-end (svref *reg-ends* num)))
|
||||
;; only bother to check if the corresponding REGISTER as
|
||||
;; matched successfully already
|
||||
(and reg-start
|
||||
(let ((next-pos (+ start-pos (- (the fixnum reg-end)
|
||||
(the fixnum reg-start)))))
|
||||
(declare (type fixnum next-pos))
|
||||
(and
|
||||
(<= next-pos *end-pos*)
|
||||
(*string*-equal *string* start-pos next-pos
|
||||
reg-start reg-end)
|
||||
(funcall next-fn next-pos))))))
|
||||
;; the case-sensitive version
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum start-pos))
|
||||
(let ((reg-start (svref *reg-starts* num))
|
||||
(reg-end (svref *reg-ends* num)))
|
||||
;; only bother to check if the corresponding REGISTER as
|
||||
;; matched successfully already
|
||||
(and reg-start
|
||||
(let ((next-pos (+ start-pos (- (the fixnum reg-end)
|
||||
(the fixnum reg-start)))))
|
||||
(declare (type fixnum next-pos))
|
||||
(and
|
||||
(<= next-pos *end-pos*)
|
||||
(*string*= *string* start-pos next-pos
|
||||
reg-start reg-end)
|
||||
(funcall next-fn next-pos)))))))))
|
||||
|
||||
(defmethod create-matcher-aux ((branch branch) next-fn)
|
||||
(let* ((test (test branch))
|
||||
(then-matcher (create-matcher-aux (then-regex branch) next-fn))
|
||||
(else-matcher (create-matcher-aux (else-regex branch) next-fn)))
|
||||
(declare (type function then-matcher else-matcher))
|
||||
(cond ((numberp test)
|
||||
(lambda (start-pos)
|
||||
(declare (type fixnum test))
|
||||
(if (and (< test (length *reg-starts*))
|
||||
(svref *reg-starts* test))
|
||||
(funcall then-matcher start-pos)
|
||||
(funcall else-matcher start-pos))))
|
||||
(t
|
||||
(let ((test-matcher (create-matcher-aux test #'identity)))
|
||||
(declare (type function test-matcher))
|
||||
(lambda (start-pos)
|
||||
(if (funcall test-matcher start-pos)
|
||||
(funcall then-matcher start-pos)
|
||||
(funcall else-matcher start-pos))))))))
|
||||
|
||||
(defmethod create-matcher-aux ((standalone standalone) next-fn)
|
||||
(let ((inner-matcher (create-matcher-aux (regex standalone) #'identity)))
|
||||
(declare (type function next-fn inner-matcher))
|
||||
(lambda (start-pos)
|
||||
(let ((next-pos (funcall inner-matcher start-pos)))
|
||||
(and next-pos
|
||||
(funcall next-fn next-pos))))))
|
||||
|
||||
(defmethod create-matcher-aux ((void void) next-fn)
|
||||
;; optimize away VOIDs: don't create a closure, just return NEXT-FN
|
||||
next-fn)
|
||||
Reference in New Issue
Block a user