OSCL/cl-ppcre
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #5 from stassats/master

Browse Source 
Rewrite SEQ without using recursion.
This commit is contained in:
Hans Hübner
2013-04-13 05:49:58 -07:00
parent 7ad13f568e 792c82fc39
commit 54e4bc54c1
5 changed files with 69 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
lexer.lisp
View File

@ -290,8 +290,7 @@ handled elsewhere."
(return))
(write-char char out))))))
(list (if (char= first-char #\p) :property :inverted-property)
;; we must reverse here because of what PARSE-STRING does
(nreverse name))))
name)))
(defun collect-char-class (lexer)
"Reads and consumes characters from regex string until a right
@ -571,7 +570,7 @@ closing #\> will also be consumed."
;; back-referencing a named register
(incf (lexer-pos lexer))
(list :back-reference
(nreverse (parse-register-name-aux lexer))))
(parse-register-name-aux lexer)))
(t
;; false alarm, just unescape \k
#\k)))

2
optimize.lisp
View File

@ -367,7 +367,7 @@ zero-length assertion."))
ends with wrapped into a STR object, otherwise NIL.
OLD-CASE-INSENSITIVE-P is the CASE-INSENSITIVE-P slot of the last STR
collected or :VOID if no STR has been collected yet. (This is a helper
function called by END-STRIN.)"))
function called by END-STRING.)"))
(defmethod end-string-aux ((str str)
&optional (old-case-insensitive-p :void))

83
parser.lisp
View File

@ -128,10 +128,7 @@ Will return <parse-tree> or \(<grouping-type> <parse-tree>) where
;; have been the "(?:"<regex>")" production
(cons :group (nconc flags (list reg-expr)))
(if (eq open-token :open-paren-less-letter)
(list :named-register
;; every string was reversed, so we have to
;; reverse it back to get the name
(nreverse register-name)
(list :named-register register-name
reg-expr)
(list (case open-token
((:open-paren)
@ -201,52 +198,40 @@ Will return <parse-tree> or (:SEQUENCE <parse-tree> <parse-tree>)."
;; to parse a <seq> or <quant> in order to catch empty regular
;; expressions
(if (start-of-subexpr-p lexer)
(let ((quant (quant lexer)))
(if (start-of-subexpr-p lexer)
(let* ((seq (seq lexer))
(quant-is-char-p (characterp quant))
(seq-is-sequence-p (and (consp seq)
(eq (first seq) :sequence))))
(cond ((and quant-is-char-p
(characterp seq))
(loop with seq-is-sequence-p = nil
with last-cdr
for quant = (quant lexer)
for quant-is-char-p = (characterp quant)
for seq = quant
then
(cond ((and quant-is-char-p (characterp seq))
(make-array-from-two-chars seq quant))
((and quant-is-char-p
(stringp seq))
((and quant-is-char-p (stringp seq))
(vector-push-extend quant seq)
seq)
((not seq-is-sequence-p)
(setf last-cdr (list quant)
seq-is-sequence-p t)
(list* :sequence seq last-cdr))
((and quant-is-char-p
seq-is-sequence-p
(characterp (second seq)))
(cond ((cddr seq)
(setf (cdr seq)
(cons
(make-array-from-two-chars (second seq)
quant)
(cddr seq)))
(characterp (car last-cdr)))
(setf (car last-cdr)
(make-array-from-two-chars (car last-cdr)
quant))
seq)
(t (make-array-from-two-chars (second seq) quant))))
((and quant-is-char-p
seq-is-sequence-p
(stringp (second seq)))
(cond ((cddr seq)
(setf (cdr seq)
(cons
(progn
(vector-push-extend quant (second seq))
(second seq))
(cddr seq)))
(stringp (car last-cdr)))
(vector-push-extend quant (car last-cdr))
seq)
(t
(vector-push-extend quant (second seq))
(second seq))))
(seq-is-sequence-p
;; if <seq> is also a :SEQUENCE parse tree we merge
;; both lists into one to avoid unnecessary consing
(setf (cdr seq)
(cons quant (cdr seq)))
seq)
(t (list :sequence quant seq))))
quant))
;; both lists into one
(let ((cons (list quant)))
(psetf last-cdr cons
(cdr last-cdr) cons))
seq))
while (start-of-subexpr-p lexer)
finally (return seq))
:void)))
(defun reg-expr (lexer)
@ -294,25 +279,11 @@ Will return <parse-tree> or (:ALTERNATION <parse-tree> <parse-tree>)."
(setf (lexer-pos lexer) pos)
seq)))))))
(defun reverse-strings (parse-tree)
"Recursively walks through PARSE-TREE and destructively reverses all
strings in it."
(declare #.*standard-optimize-settings*)
(cond ((stringp parse-tree)
(nreverse parse-tree))
((consp parse-tree)
(loop for parse-tree-rest on parse-tree
while parse-tree-rest
do (setf (car parse-tree-rest)
(reverse-strings (car parse-tree-rest))))
parse-tree)
(t parse-tree)))
(defun parse-string (string)
"Translate the regex string STRING into a parse tree."
(declare #.*standard-optimize-settings*)
(let* ((lexer (make-lexer string))
(parse-tree (reverse-strings (reg-expr lexer))))
(parse-tree (reg-expr lexer)))
;; check whether we've consumed the whole regex string
(if (end-of-string-p lexer)
parse-tree

12
regex-class.lisp
View File

@ -108,6 +108,10 @@ must appear after this repetition.")
register."))
(:documentation "REPETITION objects represent repetitions of regexes."))
(defmethod print-object ((repetition repetition) stream)
(print-unreadable-object (repetition stream :type t :identity t)
(princ (regex repetition) stream)))
(defclass register (regex)
((regex :initarg :regex
:accessor regex
@ -122,6 +126,10 @@ This is the index into *REGS-START* and *REGS-END*.")
:documentation "Name of this register or NIL."))
(:documentation "REGISTER objects represent register groups."))
(defmethod print-object ((register register) stream)
(print-unreadable-object (register stream :type t :identity t)
(princ (regex register) stream)))
(defclass standalone (regex)
((regex :initarg :regex
:accessor regex
@ -181,6 +189,10 @@ string because the SCAN function has done this already.")
STR which starts END-STRING (a slot of MATCHER)."))
(:documentation "STR objects represent string."))
(defmethod print-object ((str str) stream)
(print-unreadable-object (str stream :type t :identity t)
(princ (str str) stream)))
(defclass anchor (regex)
((startp :initarg :startp
:reader startp

16
test/simple
View File

@ -347,3 +347,19 @@ characters if there's a match."
for s = (create-scanner "(([a-c])+)x")
always (equalp (multiple-value-list (scan s "abcxy"))
(list 0 4 #(0 2) #(3 3))))
(labels ((char-code-odd-p (char)
(oddp (char-code char)))
(char-code-even-p (char)
(evenp (char-code char)))
(resolver (name)
(cond ((string= name "odd") #'char-code-odd-p)
((string= name "even") #'char-code-even-p)
((string= name "true") (constantly t))
(t (error "Can't resolve ~S." name)))))
(equalp
(let ((*property-resolver* #'resolver))
(list (regex-replace-all (create-scanner "\\p{odd}") "abcd" "+")
(regex-replace-all (create-scanner "\\p{even}") "abcd" "+")
(regex-replace-all (create-scanner "\\p{true}") "abcd" "+")))
'("+b+d" "a+c+" "++++")))