  -*- Mode : LISP ; Syntax : COMMON - LISP ; Package : CL - PPCRE ; Base : 10 -*-
  $ Header : /usr / local / cvsrep / cl - ppcre / convert.lisp , v 1.57 2009/09/17 19:17:31 edi Exp $

;;; Here the parse tree is converted into its internal representation
;;; using REGEX objects.  At the same time some optimizations are
;;; already applied.

  Copyright ( c ) 2002 - 2009 , Dr.   . 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)

;;; The flags that represent the "ism" modifiers are always kept
  together in a three - element list . We use the following macros to
;;; access individual elements.

(defmacro case-insensitive-mode-p (flags)
  "Accessor macro to extract the first flag out of a three-element flag list."
  `(first ,flags))

(defmacro multi-line-mode-p (flags)
  "Accessor macro to extract the second flag out of a three-element flag list."
  `(second ,flags))

(defmacro single-line-mode-p (flags)
  "Accessor macro to extract the third flag out of a three-element flag list."
  `(third ,flags))

(defun set-flag (token)
  "Reads a flag token and sets or unsets the corresponding entry in
the special FLAGS list."
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  (case token
    ((:case-insensitive-p)
      (setf (case-insensitive-mode-p flags) t))
    ((:case-sensitive-p)
      (setf (case-insensitive-mode-p flags) nil))
    ((:multi-line-mode-p)
      (setf (multi-line-mode-p flags) t))
    ((:not-multi-line-mode-p)
      (setf (multi-line-mode-p flags) nil))
    ((:single-line-mode-p)
      (setf (single-line-mode-p flags) t))
    ((:not-single-line-mode-p)
      (setf (single-line-mode-p flags) nil))
    (otherwise
      (signal-syntax-error "Unknown flag token ~A." token))))

(defgeneric resolve-property (property)
  (:documentation "Resolves PROPERTY to a unary character test
function.  PROPERTY can either be a function designator or it can be a
string which is resolved using *PROPERTY-RESOLVER*.")
  (:method ((property-name string))
   (funcall *property-resolver* property-name))
  (:method ((function-name symbol))
   function-name)
  (:method ((test-function function))
   test-function))

(defun convert-char-class-to-test-function (list invertedp case-insensitive-p)
  "Combines all items in LIST into test function and returns a
logical-OR combination of these functions.  Items can be single
characters, character ranges like \(:RANGE #\\A #\\E), or special
character classes like :DIGIT-CLASS.  Does the right thing with
respect to case-\(in)sensitivity as specified by the special variable
FLAGS."
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  (let ((test-functions
         (loop for item in list
               collect (cond ((characterp item)
  rebind so closure captures the right one
                              (let ((this-char item))
                                (lambda (char)
                                  (declare (character char this-char))
                                  (char= char this-char))))
                             ((symbolp item)
                              (case item
                                ((:digit-class) #'digit-char-p)
                                ((:non-digit-class) (complement* #'digit-char-p))
                                ((:whitespace-char-class) #'whitespacep)
                                ((:non-whitespace-char-class) (complement* #'whitespacep))
                                ((:word-char-class) #'word-char-p)
                                ((:non-word-char-class) (complement* #'word-char-p))
                                (otherwise
                                 (signal-syntax-error "Unknown symbol ~A in character class." item))))
                             ((and (consp item)
                                   (eq (first item) :property))
                              (resolve-property (second item)))
                             ((and (consp item)
                                   (eq (first item) :inverted-property))
                              (complement* (resolve-property (second item))))
                             ((and (consp item)
                                   (eq (first item) :range))
                              (let ((from (second item))
                                    (to (third item)))
                                (when (char> from to)
                                  (signal-syntax-error "Invalid range from ~S to ~S in char-class." from to))
                                (lambda (char)
                                  (declare (character char from to))
                                  (char<= from char to))))
                             (t (signal-syntax-error "Unknown item ~A in char-class list." item))))))
    (unless test-functions
      (signal-syntax-error "Empty character class."))
    (cond ((cdr test-functions)           
           (cond ((and invertedp case-insensitive-p)
                  (lambda (char)
                    (declare (character char))
                    (loop with both-case-p = (both-case-p char)
                          with char-down = (if both-case-p (char-downcase char) char)
                          with char-up = (if both-case-p (char-upcase char) nil)
                          for test-function in test-functions
                          never (or (funcall test-function char-down)
                                    (and char-up (funcall test-function char-up))))))
                 (case-insensitive-p
                  (lambda (char)
                    (declare (character char))
                    (loop with both-case-p = (both-case-p char)
                          with char-down = (if both-case-p (char-downcase char) char)
                          with char-up = (if both-case-p (char-upcase char) nil)
                          for test-function in test-functions
                          thereis (or (funcall test-function char-down)
                                      (and char-up (funcall test-function char-up))))))
                 (invertedp
                  (lambda (char)
                    (loop for test-function in test-functions
                          never (funcall test-function char))))
                 (t
                  (lambda (char)
                    (loop for test-function in test-functions
                          thereis (funcall test-function char))))))
  there 's only one test - function
          (t (let ((test-function (first test-functions)))
               (cond ((and invertedp case-insensitive-p)
                      (lambda (char)
                        (declare (character char))
                        (not (or (funcall test-function (char-downcase char))
                                 (and (both-case-p char)
                                      (funcall test-function (char-upcase char)))))))
                     (case-insensitive-p
                      (lambda (char)
                        (declare (character char))
                        (or (funcall test-function (char-downcase char))
                            (and (both-case-p char)
                                 (funcall test-function (char-upcase char))))))
                     (invertedp (complement* test-function))
                     (t test-function)))))))

(defun maybe-split-repetition (regex
                               greedyp
                               minimum
                               maximum
                               min-len
                               length
                               reg-seen)
  "Splits a REPETITION object into a constant and a varying part if
applicable, i.e. something like
  a{3,} -> a{3}a*
The arguments to this function correspond to the REPETITION slots of
the same name."
  (declare #.*standard-optimize-settings*)
  (declare (fixnum minimum)
           (type (or fixnum null) maximum))
  ;; note the usage of COPY-REGEX here; we can't use the same REGEX
  ;; object in both REPETITIONS because they will have different
  ;; offsets
  (when maximum
    (when (zerop maximum)
      ;; trivial case: don't repeat at all
      (return-from maybe-split-repetition
        (make-instance 'void)))
    (when (= 1 minimum maximum)
      ;; another trivial case: "repeat" exactly once
      (return-from maybe-split-repetition
        regex)))
  first set up the constant part of the repetition
  ;; maybe that's all we need
  (let ((constant-repetition (if (plusp minimum)
                               (make-instance 'repetition
                                              :regex (copy-regex regex)
                                              :greedyp greedyp
                                              :minimum minimum
                                              :maximum minimum
                                              :min-len min-len
                                              :len length
                                              :contains-register-p reg-seen)
                               ;; don't create garbage if minimum is 0
                               nil)))
    (when (and maximum
               (= maximum minimum))
      (return-from maybe-split-repetition
  no varying part needed because min = 
        constant-repetition))
    ;; now construct the varying part
    (let ((varying-repetition
            (make-instance 'repetition
                           :regex regex
                           :greedyp greedyp
                           :minimum 0
                           :maximum (if maximum (- maximum minimum) nil)
                           :min-len min-len
                           :len length
                           :contains-register-p reg-seen)))
      (cond ((zerop minimum)
              ;; min = 0, no constant part needed
              varying-repetition)
            ((= 1 minimum)
  min = 1 , constant part needs no REPETITION wrapped around
              (make-instance 'seq
                             :elements (list (copy-regex regex)
                                             varying-repetition)))
            (t
              ;; general case
              (make-instance 'seq
                             :elements (list constant-repetition
                                             varying-repetition)))))))

;; During the conversion of the parse tree we keep track of the start
;; of the parse tree in the special variable STARTS-WITH which'll
;; either hold a STR object or an EVERYTHING object. The latter is the
;; case if the regex starts with ".*" which implicitly anchors the
;; regex at the start (perhaps modulo #\Newline).

(defun maybe-accumulate (str)
  "Accumulate STR into the special variable STARTS-WITH if
ACCUMULATE-START-P (also special) is true and STARTS-WITH is either
NIL or a STR object of the same case mode. Always returns NIL."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p starts-with))
  (declare (ftype (function (t) fixnum) len))
  (when accumulate-start-p
    (etypecase starts-with
      (str
  STARTS - WITH already holds a STR , so we check if we can
        ;; concatenate
        (cond ((eq (case-insensitive-p starts-with)
                   (case-insensitive-p str))
                ;; we modify STARTS-WITH in place
                (setf (len starts-with)
                        (+ (len starts-with) (len str)))
  note that we use SLOT - VALUE because the accessor
  STR has a declared FTYPE which does n't fit here
                (adjust-array (slot-value starts-with 'str)
                              (len starts-with)
                              :fill-pointer t)
                (setf (subseq (slot-value starts-with 'str)
                              (- (len starts-with) (len str)))
                        (str str)
  STR objects that are parts of STARTS - WITH
                      ;; always have their SKIP slot set to true
                      ;; because the SCAN function will take care of
                      ;; them, i.e. the matcher can ignore them
                      (skip str) t))
              (t (setq accumulate-start-p nil))))
      (null
  STARTS - WITH is still empty , so we create a new STR object
        (setf starts-with
                (make-instance 'str
                               :str ""
                               :case-insensitive-p (case-insensitive-p str))
  INITIALIZE - INSTANCE will coerce the STR to a simple
              ;; string, so we have to fill it afterwards
              (slot-value starts-with 'str)
                (make-array (len str)
                            :initial-contents (str str)
                            :element-type 'character
                            :fill-pointer t
                            :adjustable t)
              (len starts-with)
                (len str)
              ;; see remark about SKIP above
              (skip str) t))
      (everything
        ;; STARTS-WITH already holds an EVERYTHING object - we can't
        ;; concatenate
        (setq accumulate-start-p nil))))
  nil)

(declaim (inline convert-aux))
(defun convert-aux (parse-tree)
  "Converts the parse tree PARSE-TREE into a REGEX object and returns
it.  Will also

  - split and optimize repetitions,
  - accumulate strings or EVERYTHING objects into the special variable
    STARTS-WITH,
  - keep track of all registers seen in the special variable REG-NUM,
  - keep track of all named registers seen in the special variable REG-NAMES
  - keep track of the highest backreference seen in the special
    variable MAX-BACK-REF,
  - maintain and adher to the currently applicable modifiers in the special
    variable FLAGS, and
  - maybe even wash your car..."
  (declare #.*standard-optimize-settings*)
  (if (consp parse-tree)
    (convert-compound-parse-tree (first parse-tree) parse-tree)
    (convert-simple-parse-tree parse-tree)))

(defgeneric convert-compound-parse-tree (token parse-tree &key)
  (declare #.*standard-optimize-settings*)
  (:documentation "Helper function for CONVERT-AUX which converts
parse trees which are conses and dispatches on TOKEN which is the
first element of the parse tree.")
  (:method ((token t) parse-tree &key)
   (signal-syntax-error "Unknown token ~A in parse-tree." token)))

(defmethod convert-compound-parse-tree ((token (eql :sequence)) parse-tree &key)
  "The case for parse trees like \(:SEQUENCE {<regex>}*)."
  (declare #.*standard-optimize-settings*)
  (cond ((cddr parse-tree)
         ;; this is essentially like
  ( MAPCAR ' CONVERT - AUX ( REST PARSE - TREE ) )
         ;; but we don't cons a new list
         (loop for parse-tree-rest on (rest parse-tree)
               while parse-tree-rest
               do (setf (car parse-tree-rest)
                        (convert-aux (car parse-tree-rest))))
         (make-instance 'seq :elements (rest parse-tree)))
        (t (convert-aux (second parse-tree)))))

(defmethod convert-compound-parse-tree ((token (eql :group)) parse-tree &key)
  "The case for parse trees like \(:GROUP {<regex>}*).

This is a syntactical construct equivalent to :SEQUENCE intended to
keep the effect of modifiers local."
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  make a local copy of FLAGS and shadow the global value while we
  ;; descend into the enclosed regexes
  (let ((flags (copy-list flags)))
    (declare (special flags))
    (cond ((cddr parse-tree)
           (loop for parse-tree-rest on (rest parse-tree)
                 while parse-tree-rest
                 do (setf (car parse-tree-rest)
                          (convert-aux (car parse-tree-rest))))
           (make-instance 'seq :elements (rest parse-tree)))
          (t (convert-aux (second parse-tree))))))

(defmethod convert-compound-parse-tree ((token (eql :alternation)) parse-tree &key)
  "The case for \(:ALTERNATION {<regex>}*)."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p))
  ;; we must stop accumulating objects into STARTS-WITH once we reach
  ;; an alternation
  (setq accumulate-start-p nil)
  (loop for parse-tree-rest on (rest parse-tree)
        while parse-tree-rest
        do (setf (car parse-tree-rest)
                 (convert-aux (car parse-tree-rest))))
  (make-instance 'alternation :choices (rest parse-tree)))

(defmethod convert-compound-parse-tree ((token (eql :branch)) parse-tree &key)
  "The case for \(:BRANCH <test> <regex>).

Here, <test> must be look-ahead, look-behind or number; if <regex> is
an alternation it must have one or two choices."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p))
  (setq accumulate-start-p nil)
  (let* ((test-candidate (second parse-tree))
         (test (cond ((numberp test-candidate)
                      (when (zerop (the fixnum test-candidate))
                        (signal-syntax-error "Register 0 doesn't exist: ~S." parse-tree))
                      (1- (the fixnum test-candidate)))
                     (t (convert-aux test-candidate))))
         (alternations (convert-aux (third parse-tree))))
    (when (and (not (numberp test))
               (not (typep test 'lookahead))
               (not (typep test 'lookbehind)))
      (signal-syntax-error "Branch test must be look-ahead, look-behind or number: ~S." parse-tree))
    (typecase alternations
      (alternation
       (case (length (choices alternations))
         ((0)
          (signal-syntax-error "No choices in branch: ~S." parse-tree))
         ((1)
          (make-instance 'branch
                         :test test
                         :then-regex (first
                                      (choices alternations))))
         ((2)
          (make-instance 'branch
                         :test test
                         :then-regex (first
                                      (choices alternations))
                         :else-regex (second
                                      (choices alternations))))
         (otherwise
          (signal-syntax-error "Too much choices in branch: ~S." parse-tree))))
      (t
       (make-instance 'branch
                      :test test
                      :then-regex alternations)))))

(defmethod convert-compound-parse-tree ((token (eql :positive-lookahead)) parse-tree &key)
  "The case for \(:POSITIVE-LOOKAHEAD <regex>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  ;; keep the effect of modifiers local to the enclosed regex and stop
  ;; accumulating into STARTS-WITH
  (setq accumulate-start-p nil)
  (let ((flags (copy-list flags)))
    (declare (special flags))
    (make-instance 'lookahead
                   :regex (convert-aux (second parse-tree))
                   :positivep t)))

(defmethod convert-compound-parse-tree ((token (eql :negative-lookahead)) parse-tree &key)
  "The case for \(:NEGATIVE-LOOKAHEAD <regex>)."
  (declare #.*standard-optimize-settings*)
  ;; do the same as for positive look-aheads and just switch afterwards
  (let ((regex (convert-compound-parse-tree :positive-lookahead parse-tree)))
    (setf (slot-value regex 'positivep) nil)
    regex))

(defmethod convert-compound-parse-tree ((token (eql :positive-lookbehind)) parse-tree &key)
  "The case for \(:POSITIVE-LOOKBEHIND <regex>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  ;; keep the effect of modifiers local to the enclosed regex and stop
  ;; accumulating into STARTS-WITH
  (setq accumulate-start-p nil)
  (let* ((flags (copy-list flags))
         (regex (convert-aux (second parse-tree)))
         (len (regex-length regex)))
    (declare (special flags))
    ;; lookbehind assertions must be of fixed length
    (unless len
      (signal-syntax-error "Variable length look-behind not implemented \(yet): ~S." parse-tree))
    (make-instance 'lookbehind
                   :regex regex
                   :positivep t
                   :len len)))

(defmethod convert-compound-parse-tree ((token (eql :negative-lookbehind)) parse-tree &key)
  "The case for \(:NEGATIVE-LOOKBEHIND <regex>)."
  (declare #.*standard-optimize-settings*)
  ;; do the same as for positive look-behinds and just switch afterwards
  (let ((regex (convert-compound-parse-tree :positive-lookbehind parse-tree)))
    (setf (slot-value regex 'positivep) nil)
    regex))

(defmethod convert-compound-parse-tree ((token (eql :greedy-repetition)) parse-tree &key (greedyp t))
  "The case for \(:GREEDY-REPETITION|:NON-GREEDY-REPETITION <min> <max> <regex>).

This function is also used for the non-greedy case in which case it is
called with GREEDYP set to NIL as you would expect."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p starts-with))
  ;; remember the value of ACCUMULATE-START-P upon entering
  (let ((local-accumulate-start-p accumulate-start-p))
    (let ((minimum (second parse-tree))
          (maximum (third parse-tree)))
      (declare (fixnum minimum))
      (declare (type (or null fixnum) maximum))
      (unless (and maximum
                   (= 1 minimum maximum))
        ;; set ACCUMULATE-START-P to NIL for the rest of
        ;; the conversion because we can't continue to
        ;; accumulate inside as well as after a proper
        ;; repetition
        (setq accumulate-start-p nil))
      (let* (reg-seen
             (regex (convert-aux (fourth parse-tree)))
             (min-len (regex-min-length regex))
             (length (regex-length regex)))
        ;; note that this declaration already applies to
  the call to CONVERT - AUX above
        (declare (special reg-seen))
        (when (and local-accumulate-start-p
                   (not starts-with)
                   (zerop minimum)
                   (not maximum))
          ;; if this repetition is (equivalent to) ".*"
          ;; and if we're at the start of the regex we
  remember it for ADVANCE - FN ( see the SCAN
          ;; function)
          (setq starts-with (everythingp regex)))
        (if (or (not reg-seen)
                (not greedyp)
                (not length)
                (zerop length)
                (and maximum (= minimum maximum)))
          ;; the repetition doesn't enclose a register, or
          ;; it's not greedy, or we can't determine it's
  ( inner ) length , or the length is zero , or the
          ;; number of repetitions is fixed; in all of
          ;; these cases we don't bother to optimize
          (maybe-split-repetition regex
                                  greedyp
                                  minimum
                                  maximum
                                  min-len
                                  length
                                  reg-seen)
          ;; otherwise we make a transformation that looks
          ;; roughly like one of
          ;;   <regex>* -> (?:<regex'>*<regex>)?
          ;;   <regex>+ -> <regex'>*<regex>
          ;; where the trick is that as much as possible
          ;; registers from <regex> are removed in
          ;; <regex'>
          (let* (reg-seen ; new instance for REMOVE-REGISTERS
                 (remove-registers-p t)
                 (inner-regex (remove-registers regex))
                 (inner-repetition
                  ;; this is the "<regex'>" part
                  (maybe-split-repetition inner-regex
                                          ;; always greedy
                                          t
  reduce minimum by 1
                                          ;; unless it's already 0
                                          (if (zerop minimum)
                                            0
                                            (1- minimum))
  reduce maximum by 1
                                          ;; unless it's NIL
                                          (and maximum
                                               (1- maximum))
                                          min-len
                                          length
                                          reg-seen))
                 (inner-seq
                  ;; this is the "<regex'>*<regex>" part
                  (make-instance 'seq
                                 :elements (list inner-repetition
                                                 regex))))
            ;; note that this declaration already applies
            ;; to the call to REMOVE-REGISTERS above
            (declare (special remove-registers-p reg-seen))
  wrap INNER - SEQ with a greedy
            ;; {0,1}-repetition (i.e. "?") if necessary
            (if (plusp minimum)
              inner-seq
              (maybe-split-repetition inner-seq
                                      t
                                      0
                                      1
                                      min-len
                                      nil
                                      t))))))))

(defmethod convert-compound-parse-tree ((token (eql :non-greedy-repetition)) parse-tree &key)
  "The case for \(:NON-GREEDY-REPETITION <min> <max> <regex>)."
  (declare #.*standard-optimize-settings*)
  just dispatch to the method above with  explicitly set to NIL
  (convert-compound-parse-tree :greedy-repetition parse-tree :greedyp nil))

(defmethod convert-compound-parse-tree ((token (eql :register)) parse-tree &key name)
  "The case for \(:REGISTER <regex>).  Also used for named registers
when NAME is not NIL."
  (declare #.*standard-optimize-settings*)
  (declare (special flags reg-num reg-names))
  ;; keep the effect of modifiers local to the enclosed regex; also,
  assign the current value of REG - NUM to the corresponding slot of
  the REGISTER object and increase this counter afterwards ; for
  named register update REG - NAMES and set the corresponding name
  slot of the REGISTER object too
  (let ((flags (copy-list flags))
        (stored-reg-num reg-num))
    (declare (special flags reg-seen named-reg-seen))
    (setq reg-seen t)
    (when name (setq named-reg-seen t))
    (incf (the fixnum reg-num))
    (push name reg-names)
    (make-instance 'register
                   :regex (convert-aux (if name (third parse-tree) (second parse-tree)))
                   :num stored-reg-num
                   :name name)))

(defmethod convert-compound-parse-tree ((token (eql :named-register)) parse-tree &key)
  "The case for \(:NAMED-REGISTER <regex>)."
  (declare #.*standard-optimize-settings*)
  ;; call the method above and use the :NAME keyword argument
  (convert-compound-parse-tree :register parse-tree :name (copy-seq (second parse-tree))))

(defmethod convert-compound-parse-tree ((token (eql :filter)) parse-tree &key)
  "The case for \(:FILTER <function> &optional <length>)."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p))
  ;; stop accumulating into STARTS-WITH
  (setq accumulate-start-p nil)
  (make-instance 'filter
                 :fn (second parse-tree)
                 :len (third parse-tree)))

(defmethod convert-compound-parse-tree ((token (eql :standalone)) parse-tree &key)
  "The case for \(:STANDALONE <regex>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  ;; stop accumulating into STARTS-WITH
  (setq accumulate-start-p nil)
  ;; keep the effect of modifiers local to the enclosed regex
  (let ((flags (copy-list flags)))
    (declare (special flags))
    (make-instance 'standalone :regex (convert-aux (second parse-tree)))))

(defmethod convert-compound-parse-tree ((token (eql :back-reference)) parse-tree &key)
  "The case for \(:BACK-REFERENCE <number>|<name>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p reg-num reg-names max-back-ref))
  (let* ((backref-name (and (stringp (second parse-tree))
                            (second parse-tree)))
         (referred-regs
          (when backref-name
            ;; find which register corresponds to the given name
            ;; we have to deal with case where several registers share
            ;; the same name and collect their respective numbers
            (loop for name in reg-names
                  for reg-index from 0
                  when (string= name backref-name)
                  ;; NOTE: REG-NAMES stores register names in reversed
  order REG - NUM contains number of ( any ) registers
                  ;; seen so far; 1- will be done later
                  collect (- reg-num reg-index))))
         ;; store the register number for the simple case
         (backref-number (or (first referred-regs) (second parse-tree))))
    (declare (type (or fixnum null) backref-number))
    (when (or (not (typep backref-number 'fixnum))
              (<= backref-number 0))
      (signal-syntax-error "Illegal back-reference: ~S." parse-tree))
  stop accumulating into STARTS - WITH and increase MAX - BACK - REF if
    ;; necessary
    (setq accumulate-start-p nil
          max-back-ref (max (the fixnum max-back-ref)
                            backref-number))
    (flet ((make-back-ref (backref-number)
             (make-instance 'back-reference
                            ;; we start counting from 0 internally
                            :num (1- backref-number)
                            :case-insensitive-p (case-insensitive-mode-p flags)
  backref - name is NIL or string , safe to copy
                            :name (copy-seq backref-name))))
      (cond
       ((cdr referred-regs)
        ;; several registers share the same name we will try to match
  any of them , starting with the most recent first
        ;; alternation is used to accomplish matching
        (make-instance 'alternation
                       :choices (loop
                                 for reg-index in referred-regs
                                 collect (make-back-ref reg-index))))
  simple case - backref corresponds to only one register
       (t
        (make-back-ref backref-number))))))

(defmethod convert-compound-parse-tree ((token (eql :regex)) parse-tree &key)
  "The case for \(:REGEX <string>)."
  (declare #.*standard-optimize-settings*)
  (convert-aux (parse-string (second parse-tree))))

(defmethod convert-compound-parse-tree ((token (eql :char-class)) parse-tree &key invertedp)
  "The case for \(:CHAR-CLASS {<item>}*) where item is one of

- a character,
- a character range: \(:RANGE <char1> <char2>), or
- a special char class symbol like :DIGIT-CHAR-CLASS.

Also used for inverted char classes when INVERTEDP is true."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  (let ((test-function
         (create-optimized-test-function
          (convert-char-class-to-test-function (rest parse-tree)
                                               invertedp
                                               (case-insensitive-mode-p flags)))))
    (setq accumulate-start-p nil)
    (make-instance 'char-class :test-function test-function)))

(defmethod convert-compound-parse-tree ((token (eql :inverted-char-class)) parse-tree &key)
  "The case for \(:INVERTED-CHAR-CLASS {<item>}*)."
  (declare #.*standard-optimize-settings*)
  ;; just dispatch to the "real" method
  (convert-compound-parse-tree :char-class parse-tree :invertedp t))

(defmethod convert-compound-parse-tree ((token (eql :property)) parse-tree &key)
  "The case for \(:PROPERTY <name>) where <name> is a string."
  (declare #.*standard-optimize-settings*)
  (make-instance 'char-class :test-function (resolve-property (second parse-tree))))

(defmethod convert-compound-parse-tree ((token (eql :inverted-property)) parse-tree &key)
  "The case for \(:INVERTED-PROPERTY <name>) where <name> is a string."
  (declare #.*standard-optimize-settings*)
  (make-instance 'char-class :test-function (complement* (resolve-property (second parse-tree)))))

(defmethod convert-compound-parse-tree ((token (eql :flags)) parse-tree &key)
  "The case for \(:FLAGS {<flag>}*) where flag is a modifier symbol
like :CASE-INSENSITIVE-P."
  (declare #.*standard-optimize-settings*)
  ;; set/unset the flags corresponding to the symbols
  following : 
  (mapc #'set-flag (rest parse-tree))
  ;; we're only interested in the side effect of
  ;; setting/unsetting the flags and turn this syntactical
  ;; construct into a VOID object which'll be optimized
  ;; away when creating the matcher
  (make-instance 'void))

(defgeneric convert-simple-parse-tree (parse-tree)
  (declare #.*standard-optimize-settings*)
  (:documentation "Helper function for CONVERT-AUX which converts
parse trees which are atoms.")
  (:method ((parse-tree (eql :void)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'void))
  (:method ((parse-tree (eql :word-boundary)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'word-boundary :negatedp nil))
  (:method ((parse-tree (eql :non-word-boundary)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'word-boundary :negatedp t))
  (:method ((parse-tree (eql :everything)))
   (declare #.*standard-optimize-settings*)
   (declare (special flags accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'everything :single-line-p (single-line-mode-p flags)))
  (:method ((parse-tree (eql :digit-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function #'digit-char-p))
  (:method ((parse-tree (eql :word-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function #'word-char-p))
  (:method ((parse-tree (eql :whitespace-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function #'whitespacep))
  (:method ((parse-tree (eql :non-digit-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function (complement* #'digit-char-p)))
  (:method ((parse-tree (eql :non-word-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function (complement* #'word-char-p)))
  (:method ((parse-tree (eql :non-whitespace-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function (complement* #'whitespacep)))
  (:method ((parse-tree (eql :start-anchor)))
   ;; Perl's "^"
   (declare #.*standard-optimize-settings*)
   (declare (special flags))
   (make-instance 'anchor :startp t :multi-line-p (multi-line-mode-p flags)))
  (:method ((parse-tree (eql :end-anchor)))
   ;; Perl's "$"
   (declare #.*standard-optimize-settings*)
   (declare (special flags))
   (make-instance 'anchor :startp nil :multi-line-p (multi-line-mode-p flags)))
  (:method ((parse-tree (eql :modeless-start-anchor)))
   ;; Perl's "\A"
   (declare #.*standard-optimize-settings*)
   (make-instance 'anchor :startp t))
  (:method ((parse-tree (eql :modeless-end-anchor)))
   ;; Perl's "$\Z"
   (declare #.*standard-optimize-settings*)
   (make-instance 'anchor :startp nil))
  (:method ((parse-tree (eql :modeless-end-anchor-no-newline)))
   ;; Perl's "$\z"
   (declare #.*standard-optimize-settings*)
   (make-instance 'anchor :startp nil :no-newline-p t))
  (:method ((parse-tree (eql :case-insensitive-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :case-sensitive-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :multi-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :not-multi-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :single-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :not-single-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void)))

(defmethod convert-simple-parse-tree ((parse-tree string))
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  turn strings into STR objects and try to accumulate into
  ;; STARTS-WITH
  (let ((str (make-instance 'str
                            :str parse-tree
                            :case-insensitive-p (case-insensitive-mode-p flags))))
    (maybe-accumulate str)
    str))

(defmethod convert-simple-parse-tree ((parse-tree character))
  (declare #.*standard-optimize-settings*)
  ;; dispatch to the method for strings
  (convert-simple-parse-tree (string parse-tree)))
        
(defmethod convert-simple-parse-tree (parse-tree)
  "The default method - check if there's a translation."
  (declare #.*standard-optimize-settings*)
  (let ((translation (and (symbolp parse-tree) (parse-tree-synonym parse-tree))))
    (if translation
      (convert-aux (copy-tree translation))
      (signal-syntax-error "Unknown token ~A in parse tree." parse-tree))))

(defun convert (parse-tree)
  "Converts the parse tree PARSE-TREE into an equivalent REGEX object
and returns three values: the REGEX object, the number of registers
seen and an object the regex starts with which is either a STR object
or an EVERYTHING object \(if the regex starts with something like
\".*\") or NIL."
  (declare #.*standard-optimize-settings*)
  ;; this function basically just initializes the special variables
  and then calls CONVERT - AUX to do all the work
  (let* ((flags (list nil nil nil))
         (reg-num 0)
         reg-names
         named-reg-seen
         (accumulate-start-p t)
         starts-with
         (max-back-ref 0)
         (converted-parse-tree (convert-aux parse-tree)))
    (declare (special flags reg-num reg-names named-reg-seen
                      accumulate-start-p starts-with max-back-ref))
    ;; make sure we don't reference registers which aren't there
    (when (> (the fixnum max-back-ref)
             (the fixnum reg-num))
      (signal-syntax-error "Backreference to register ~A which has not been defined." max-back-ref))
    (when (typep starts-with 'str)
      (setf (slot-value starts-with 'str)
              (coerce (slot-value starts-with 'str)
                      #+:lispworks 'lw:simple-text-string
                      #-:lispworks 'simple-string)))
    (values converted-parse-tree reg-num starts-with
            ;; we can't simply use *ALLOW-NAMED-REGISTERS*
            ;; since parse-tree syntax ignores it
            (when named-reg-seen
              (nreverse reg-names)))))

 Syntax : COMMON - LISP ; Package : CL - PPCRE ; Base : 10 -*-
 Here the parse tree is converted into its internal representation
 using REGEX objects.  At the same time some optimizations are
 already applied.
 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
 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
 GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 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.
 The flags that represent the "ism" modifiers are always kept
 access individual elements.
 note the usage of COPY-REGEX here; we can't use the same REGEX
 object in both REPETITIONS because they will have different
 offsets
 trivial case: don't repeat at all
 another trivial case: "repeat" exactly once
 maybe that's all we need
 don't create garbage if minimum is 0
 now construct the varying part
 min = 0, no constant part needed
 general case
 During the conversion of the parse tree we keep track of the start
 of the parse tree in the special variable STARTS-WITH which'll
 either hold a STR object or an EVERYTHING object. The latter is the
 case if the regex starts with ".*" which implicitly anchors the
 regex at the start (perhaps modulo #\Newline).
 concatenate
 we modify STARTS-WITH in place
 always have their SKIP slot set to true
 because the SCAN function will take care of
 them, i.e. the matcher can ignore them
 string, so we have to fill it afterwards
 see remark about SKIP above
 STARTS-WITH already holds an EVERYTHING object - we can't
 concatenate
 this is essentially like
 but we don't cons a new list
 descend into the enclosed regexes
 we must stop accumulating objects into STARTS-WITH once we reach
 an alternation
 if <regex> is
 keep the effect of modifiers local to the enclosed regex and stop
 accumulating into STARTS-WITH
 do the same as for positive look-aheads and just switch afterwards
 keep the effect of modifiers local to the enclosed regex and stop
 accumulating into STARTS-WITH
 lookbehind assertions must be of fixed length
 do the same as for positive look-behinds and just switch afterwards
 remember the value of ACCUMULATE-START-P upon entering
 set ACCUMULATE-START-P to NIL for the rest of
 the conversion because we can't continue to
 accumulate inside as well as after a proper
 repetition
 note that this declaration already applies to
 if this repetition is (equivalent to) ".*"
 and if we're at the start of the regex we
 function)
 the repetition doesn't enclose a register, or
 it's not greedy, or we can't determine it's
 number of repetitions is fixed; in all of
 these cases we don't bother to optimize
 otherwise we make a transformation that looks
 roughly like one of
   <regex>* -> (?:<regex'>*<regex>)?
   <regex>+ -> <regex'>*<regex>
 where the trick is that as much as possible
 registers from <regex> are removed in
 <regex'>
 new instance for REMOVE-REGISTERS
 this is the "<regex'>" part
 always greedy
 unless it's already 0
 unless it's NIL
 this is the "<regex'>*<regex>" part
 note that this declaration already applies
 to the call to REMOVE-REGISTERS above
 {0,1}-repetition (i.e. "?") if necessary
 keep the effect of modifiers local to the enclosed regex; also,
 for
 call the method above and use the :NAME keyword argument
 stop accumulating into STARTS-WITH
 stop accumulating into STARTS-WITH
 keep the effect of modifiers local to the enclosed regex
 find which register corresponds to the given name
 we have to deal with case where several registers share
 the same name and collect their respective numbers
 NOTE: REG-NAMES stores register names in reversed
 seen so far; 1- will be done later
 store the register number for the simple case
 necessary
 we start counting from 0 internally
 several registers share the same name we will try to match
 alternation is used to accomplish matching
 just dispatch to the "real" method
 set/unset the flags corresponding to the symbols
 we're only interested in the side effect of
 setting/unsetting the flags and turn this syntactical
 construct into a VOID object which'll be optimized
 away when creating the matcher
 Perl's "^"
 Perl's "$"
 Perl's "\A"
 Perl's "$\Z"
 Perl's "$\z"
 STARTS-WITH
 dispatch to the method for strings
 this function basically just initializes the special variables
 make sure we don't reference registers which aren't there
 we can't simply use *ALLOW-NAMED-REGISTERS*
 since parse-tree syntax ignores it
  $ Header : /usr / local / cvsrep / cl - ppcre / convert.lisp , v 1.57 2009/09/17 19:17:31 edi Exp $


  Copyright ( c ) 2002 - 2009 , Dr.   . All rights reserved .




  DIRECT , INDIRECT , INCIDENTAL , SPECIAL , EXEMPLARY , OR CONSEQUENTIAL
  INTERRUPTION ) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY ,

(in-package :cl-ppcre)

  together in a three - element list . We use the following macros to

(defmacro case-insensitive-mode-p (flags)
  "Accessor macro to extract the first flag out of a three-element flag list."
  `(first ,flags))

(defmacro multi-line-mode-p (flags)
  "Accessor macro to extract the second flag out of a three-element flag list."
  `(second ,flags))

(defmacro single-line-mode-p (flags)
  "Accessor macro to extract the third flag out of a three-element flag list."
  `(third ,flags))

(defun set-flag (token)
  "Reads a flag token and sets or unsets the corresponding entry in
the special FLAGS list."
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  (case token
    ((:case-insensitive-p)
      (setf (case-insensitive-mode-p flags) t))
    ((:case-sensitive-p)
      (setf (case-insensitive-mode-p flags) nil))
    ((:multi-line-mode-p)
      (setf (multi-line-mode-p flags) t))
    ((:not-multi-line-mode-p)
      (setf (multi-line-mode-p flags) nil))
    ((:single-line-mode-p)
      (setf (single-line-mode-p flags) t))
    ((:not-single-line-mode-p)
      (setf (single-line-mode-p flags) nil))
    (otherwise
      (signal-syntax-error "Unknown flag token ~A." token))))

(defgeneric resolve-property (property)
  (:documentation "Resolves PROPERTY to a unary character test
function.  PROPERTY can either be a function designator or it can be a
string which is resolved using *PROPERTY-RESOLVER*.")
  (:method ((property-name string))
   (funcall *property-resolver* property-name))
  (:method ((function-name symbol))
   function-name)
  (:method ((test-function function))
   test-function))

(defun convert-char-class-to-test-function (list invertedp case-insensitive-p)
  "Combines all items in LIST into test function and returns a
logical-OR combination of these functions.  Items can be single
characters, character ranges like \(:RANGE #\\A #\\E), or special
character classes like :DIGIT-CLASS.  Does the right thing with
respect to case-\(in)sensitivity as specified by the special variable
FLAGS."
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  (let ((test-functions
         (loop for item in list
               collect (cond ((characterp item)
  rebind so closure captures the right one
                              (let ((this-char item))
                                (lambda (char)
                                  (declare (character char this-char))
                                  (char= char this-char))))
                             ((symbolp item)
                              (case item
                                ((:digit-class) #'digit-char-p)
                                ((:non-digit-class) (complement* #'digit-char-p))
                                ((:whitespace-char-class) #'whitespacep)
                                ((:non-whitespace-char-class) (complement* #'whitespacep))
                                ((:word-char-class) #'word-char-p)
                                ((:non-word-char-class) (complement* #'word-char-p))
                                (otherwise
                                 (signal-syntax-error "Unknown symbol ~A in character class." item))))
                             ((and (consp item)
                                   (eq (first item) :property))
                              (resolve-property (second item)))
                             ((and (consp item)
                                   (eq (first item) :inverted-property))
                              (complement* (resolve-property (second item))))
                             ((and (consp item)
                                   (eq (first item) :range))
                              (let ((from (second item))
                                    (to (third item)))
                                (when (char> from to)
                                  (signal-syntax-error "Invalid range from ~S to ~S in char-class." from to))
                                (lambda (char)
                                  (declare (character char from to))
                                  (char<= from char to))))
                             (t (signal-syntax-error "Unknown item ~A in char-class list." item))))))
    (unless test-functions
      (signal-syntax-error "Empty character class."))
    (cond ((cdr test-functions)           
           (cond ((and invertedp case-insensitive-p)
                  (lambda (char)
                    (declare (character char))
                    (loop with both-case-p = (both-case-p char)
                          with char-down = (if both-case-p (char-downcase char) char)
                          with char-up = (if both-case-p (char-upcase char) nil)
                          for test-function in test-functions
                          never (or (funcall test-function char-down)
                                    (and char-up (funcall test-function char-up))))))
                 (case-insensitive-p
                  (lambda (char)
                    (declare (character char))
                    (loop with both-case-p = (both-case-p char)
                          with char-down = (if both-case-p (char-downcase char) char)
                          with char-up = (if both-case-p (char-upcase char) nil)
                          for test-function in test-functions
                          thereis (or (funcall test-function char-down)
                                      (and char-up (funcall test-function char-up))))))
                 (invertedp
                  (lambda (char)
                    (loop for test-function in test-functions
                          never (funcall test-function char))))
                 (t
                  (lambda (char)
                    (loop for test-function in test-functions
                          thereis (funcall test-function char))))))
  there 's only one test - function
          (t (let ((test-function (first test-functions)))
               (cond ((and invertedp case-insensitive-p)
                      (lambda (char)
                        (declare (character char))
                        (not (or (funcall test-function (char-downcase char))
                                 (and (both-case-p char)
                                      (funcall test-function (char-upcase char)))))))
                     (case-insensitive-p
                      (lambda (char)
                        (declare (character char))
                        (or (funcall test-function (char-downcase char))
                            (and (both-case-p char)
                                 (funcall test-function (char-upcase char))))))
                     (invertedp (complement* test-function))
                     (t test-function)))))))

(defun maybe-split-repetition (regex
                               greedyp
                               minimum
                               maximum
                               min-len
                               length
                               reg-seen)
  "Splits a REPETITION object into a constant and a varying part if
applicable, i.e. something like
  a{3,} -> a{3}a*
The arguments to this function correspond to the REPETITION slots of
the same name."
  (declare #.*standard-optimize-settings*)
  (declare (fixnum minimum)
           (type (or fixnum null) maximum))
  (when maximum
    (when (zerop maximum)
      (return-from maybe-split-repetition
        (make-instance 'void)))
    (when (= 1 minimum maximum)
      (return-from maybe-split-repetition
        regex)))
  first set up the constant part of the repetition
  (let ((constant-repetition (if (plusp minimum)
                               (make-instance 'repetition
                                              :regex (copy-regex regex)
                                              :greedyp greedyp
                                              :minimum minimum
                                              :maximum minimum
                                              :min-len min-len
                                              :len length
                                              :contains-register-p reg-seen)
                               nil)))
    (when (and maximum
               (= maximum minimum))
      (return-from maybe-split-repetition
  no varying part needed because min = 
        constant-repetition))
    (let ((varying-repetition
            (make-instance 'repetition
                           :regex regex
                           :greedyp greedyp
                           :minimum 0
                           :maximum (if maximum (- maximum minimum) nil)
                           :min-len min-len
                           :len length
                           :contains-register-p reg-seen)))
      (cond ((zerop minimum)
              varying-repetition)
            ((= 1 minimum)
  min = 1 , constant part needs no REPETITION wrapped around
              (make-instance 'seq
                             :elements (list (copy-regex regex)
                                             varying-repetition)))
            (t
              (make-instance 'seq
                             :elements (list constant-repetition
                                             varying-repetition)))))))


(defun maybe-accumulate (str)
  "Accumulate STR into the special variable STARTS-WITH if
ACCUMULATE-START-P (also special) is true and STARTS-WITH is either
NIL or a STR object of the same case mode. Always returns NIL."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p starts-with))
  (declare (ftype (function (t) fixnum) len))
  (when accumulate-start-p
    (etypecase starts-with
      (str
  STARTS - WITH already holds a STR , so we check if we can
        (cond ((eq (case-insensitive-p starts-with)
                   (case-insensitive-p str))
                (setf (len starts-with)
                        (+ (len starts-with) (len str)))
  note that we use SLOT - VALUE because the accessor
  STR has a declared FTYPE which does n't fit here
                (adjust-array (slot-value starts-with 'str)
                              (len starts-with)
                              :fill-pointer t)
                (setf (subseq (slot-value starts-with 'str)
                              (- (len starts-with) (len str)))
                        (str str)
  STR objects that are parts of STARTS - WITH
                      (skip str) t))
              (t (setq accumulate-start-p nil))))
      (null
  STARTS - WITH is still empty , so we create a new STR object
        (setf starts-with
                (make-instance 'str
                               :str ""
                               :case-insensitive-p (case-insensitive-p str))
  INITIALIZE - INSTANCE will coerce the STR to a simple
              (slot-value starts-with 'str)
                (make-array (len str)
                            :initial-contents (str str)
                            :element-type 'character
                            :fill-pointer t
                            :adjustable t)
              (len starts-with)
                (len str)
              (skip str) t))
      (everything
        (setq accumulate-start-p nil))))
  nil)

(declaim (inline convert-aux))
(defun convert-aux (parse-tree)
  "Converts the parse tree PARSE-TREE into a REGEX object and returns
it.  Will also

  - split and optimize repetitions,
  - accumulate strings or EVERYTHING objects into the special variable
    STARTS-WITH,
  - keep track of all registers seen in the special variable REG-NUM,
  - keep track of all named registers seen in the special variable REG-NAMES
  - keep track of the highest backreference seen in the special
    variable MAX-BACK-REF,
  - maintain and adher to the currently applicable modifiers in the special
    variable FLAGS, and
  - maybe even wash your car..."
  (declare #.*standard-optimize-settings*)
  (if (consp parse-tree)
    (convert-compound-parse-tree (first parse-tree) parse-tree)
    (convert-simple-parse-tree parse-tree)))

(defgeneric convert-compound-parse-tree (token parse-tree &key)
  (declare #.*standard-optimize-settings*)
  (:documentation "Helper function for CONVERT-AUX which converts
parse trees which are conses and dispatches on TOKEN which is the
first element of the parse tree.")
  (:method ((token t) parse-tree &key)
   (signal-syntax-error "Unknown token ~A in parse-tree." token)))

(defmethod convert-compound-parse-tree ((token (eql :sequence)) parse-tree &key)
  "The case for parse trees like \(:SEQUENCE {<regex>}*)."
  (declare #.*standard-optimize-settings*)
  (cond ((cddr parse-tree)
  ( MAPCAR ' CONVERT - AUX ( REST PARSE - TREE ) )
         (loop for parse-tree-rest on (rest parse-tree)
               while parse-tree-rest
               do (setf (car parse-tree-rest)
                        (convert-aux (car parse-tree-rest))))
         (make-instance 'seq :elements (rest parse-tree)))
        (t (convert-aux (second parse-tree)))))

(defmethod convert-compound-parse-tree ((token (eql :group)) parse-tree &key)
  "The case for parse trees like \(:GROUP {<regex>}*).

This is a syntactical construct equivalent to :SEQUENCE intended to
keep the effect of modifiers local."
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  make a local copy of FLAGS and shadow the global value while we
  (let ((flags (copy-list flags)))
    (declare (special flags))
    (cond ((cddr parse-tree)
           (loop for parse-tree-rest on (rest parse-tree)
                 while parse-tree-rest
                 do (setf (car parse-tree-rest)
                          (convert-aux (car parse-tree-rest))))
           (make-instance 'seq :elements (rest parse-tree)))
          (t (convert-aux (second parse-tree))))))

(defmethod convert-compound-parse-tree ((token (eql :alternation)) parse-tree &key)
  "The case for \(:ALTERNATION {<regex>}*)."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p))
  (setq accumulate-start-p nil)
  (loop for parse-tree-rest on (rest parse-tree)
        while parse-tree-rest
        do (setf (car parse-tree-rest)
                 (convert-aux (car parse-tree-rest))))
  (make-instance 'alternation :choices (rest parse-tree)))

(defmethod convert-compound-parse-tree ((token (eql :branch)) parse-tree &key)
  "The case for \(:BRANCH <test> <regex>).

an alternation it must have one or two choices."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p))
  (setq accumulate-start-p nil)
  (let* ((test-candidate (second parse-tree))
         (test (cond ((numberp test-candidate)
                      (when (zerop (the fixnum test-candidate))
                        (signal-syntax-error "Register 0 doesn't exist: ~S." parse-tree))
                      (1- (the fixnum test-candidate)))
                     (t (convert-aux test-candidate))))
         (alternations (convert-aux (third parse-tree))))
    (when (and (not (numberp test))
               (not (typep test 'lookahead))
               (not (typep test 'lookbehind)))
      (signal-syntax-error "Branch test must be look-ahead, look-behind or number: ~S." parse-tree))
    (typecase alternations
      (alternation
       (case (length (choices alternations))
         ((0)
          (signal-syntax-error "No choices in branch: ~S." parse-tree))
         ((1)
          (make-instance 'branch
                         :test test
                         :then-regex (first
                                      (choices alternations))))
         ((2)
          (make-instance 'branch
                         :test test
                         :then-regex (first
                                      (choices alternations))
                         :else-regex (second
                                      (choices alternations))))
         (otherwise
          (signal-syntax-error "Too much choices in branch: ~S." parse-tree))))
      (t
       (make-instance 'branch
                      :test test
                      :then-regex alternations)))))

(defmethod convert-compound-parse-tree ((token (eql :positive-lookahead)) parse-tree &key)
  "The case for \(:POSITIVE-LOOKAHEAD <regex>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  (setq accumulate-start-p nil)
  (let ((flags (copy-list flags)))
    (declare (special flags))
    (make-instance 'lookahead
                   :regex (convert-aux (second parse-tree))
                   :positivep t)))

(defmethod convert-compound-parse-tree ((token (eql :negative-lookahead)) parse-tree &key)
  "The case for \(:NEGATIVE-LOOKAHEAD <regex>)."
  (declare #.*standard-optimize-settings*)
  (let ((regex (convert-compound-parse-tree :positive-lookahead parse-tree)))
    (setf (slot-value regex 'positivep) nil)
    regex))

(defmethod convert-compound-parse-tree ((token (eql :positive-lookbehind)) parse-tree &key)
  "The case for \(:POSITIVE-LOOKBEHIND <regex>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  (setq accumulate-start-p nil)
  (let* ((flags (copy-list flags))
         (regex (convert-aux (second parse-tree)))
         (len (regex-length regex)))
    (declare (special flags))
    (unless len
      (signal-syntax-error "Variable length look-behind not implemented \(yet): ~S." parse-tree))
    (make-instance 'lookbehind
                   :regex regex
                   :positivep t
                   :len len)))

(defmethod convert-compound-parse-tree ((token (eql :negative-lookbehind)) parse-tree &key)
  "The case for \(:NEGATIVE-LOOKBEHIND <regex>)."
  (declare #.*standard-optimize-settings*)
  (let ((regex (convert-compound-parse-tree :positive-lookbehind parse-tree)))
    (setf (slot-value regex 'positivep) nil)
    regex))

(defmethod convert-compound-parse-tree ((token (eql :greedy-repetition)) parse-tree &key (greedyp t))
  "The case for \(:GREEDY-REPETITION|:NON-GREEDY-REPETITION <min> <max> <regex>).

This function is also used for the non-greedy case in which case it is
called with GREEDYP set to NIL as you would expect."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p starts-with))
  (let ((local-accumulate-start-p accumulate-start-p))
    (let ((minimum (second parse-tree))
          (maximum (third parse-tree)))
      (declare (fixnum minimum))
      (declare (type (or null fixnum) maximum))
      (unless (and maximum
                   (= 1 minimum maximum))
        (setq accumulate-start-p nil))
      (let* (reg-seen
             (regex (convert-aux (fourth parse-tree)))
             (min-len (regex-min-length regex))
             (length (regex-length regex)))
  the call to CONVERT - AUX above
        (declare (special reg-seen))
        (when (and local-accumulate-start-p
                   (not starts-with)
                   (zerop minimum)
                   (not maximum))
  remember it for ADVANCE - FN ( see the SCAN
          (setq starts-with (everythingp regex)))
        (if (or (not reg-seen)
                (not greedyp)
                (not length)
                (zerop length)
                (and maximum (= minimum maximum)))
  ( inner ) length , or the length is zero , or the
          (maybe-split-repetition regex
                                  greedyp
                                  minimum
                                  maximum
                                  min-len
                                  length
                                  reg-seen)
                 (remove-registers-p t)
                 (inner-regex (remove-registers regex))
                 (inner-repetition
                  (maybe-split-repetition inner-regex
                                          t
  reduce minimum by 1
                                          (if (zerop minimum)
                                            0
                                            (1- minimum))
  reduce maximum by 1
                                          (and maximum
                                               (1- maximum))
                                          min-len
                                          length
                                          reg-seen))
                 (inner-seq
                  (make-instance 'seq
                                 :elements (list inner-repetition
                                                 regex))))
            (declare (special remove-registers-p reg-seen))
  wrap INNER - SEQ with a greedy
            (if (plusp minimum)
              inner-seq
              (maybe-split-repetition inner-seq
                                      t
                                      0
                                      1
                                      min-len
                                      nil
                                      t))))))))

(defmethod convert-compound-parse-tree ((token (eql :non-greedy-repetition)) parse-tree &key)
  "The case for \(:NON-GREEDY-REPETITION <min> <max> <regex>)."
  (declare #.*standard-optimize-settings*)
  just dispatch to the method above with  explicitly set to NIL
  (convert-compound-parse-tree :greedy-repetition parse-tree :greedyp nil))

(defmethod convert-compound-parse-tree ((token (eql :register)) parse-tree &key name)
  "The case for \(:REGISTER <regex>).  Also used for named registers
when NAME is not NIL."
  (declare #.*standard-optimize-settings*)
  (declare (special flags reg-num reg-names))
  assign the current value of REG - NUM to the corresponding slot of
  named register update REG - NAMES and set the corresponding name
  slot of the REGISTER object too
  (let ((flags (copy-list flags))
        (stored-reg-num reg-num))
    (declare (special flags reg-seen named-reg-seen))
    (setq reg-seen t)
    (when name (setq named-reg-seen t))
    (incf (the fixnum reg-num))
    (push name reg-names)
    (make-instance 'register
                   :regex (convert-aux (if name (third parse-tree) (second parse-tree)))
                   :num stored-reg-num
                   :name name)))

(defmethod convert-compound-parse-tree ((token (eql :named-register)) parse-tree &key)
  "The case for \(:NAMED-REGISTER <regex>)."
  (declare #.*standard-optimize-settings*)
  (convert-compound-parse-tree :register parse-tree :name (copy-seq (second parse-tree))))

(defmethod convert-compound-parse-tree ((token (eql :filter)) parse-tree &key)
  "The case for \(:FILTER <function> &optional <length>)."
  (declare #.*standard-optimize-settings*)
  (declare (special accumulate-start-p))
  (setq accumulate-start-p nil)
  (make-instance 'filter
                 :fn (second parse-tree)
                 :len (third parse-tree)))

(defmethod convert-compound-parse-tree ((token (eql :standalone)) parse-tree &key)
  "The case for \(:STANDALONE <regex>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  (setq accumulate-start-p nil)
  (let ((flags (copy-list flags)))
    (declare (special flags))
    (make-instance 'standalone :regex (convert-aux (second parse-tree)))))

(defmethod convert-compound-parse-tree ((token (eql :back-reference)) parse-tree &key)
  "The case for \(:BACK-REFERENCE <number>|<name>)."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p reg-num reg-names max-back-ref))
  (let* ((backref-name (and (stringp (second parse-tree))
                            (second parse-tree)))
         (referred-regs
          (when backref-name
            (loop for name in reg-names
                  for reg-index from 0
                  when (string= name backref-name)
  order REG - NUM contains number of ( any ) registers
                  collect (- reg-num reg-index))))
         (backref-number (or (first referred-regs) (second parse-tree))))
    (declare (type (or fixnum null) backref-number))
    (when (or (not (typep backref-number 'fixnum))
              (<= backref-number 0))
      (signal-syntax-error "Illegal back-reference: ~S." parse-tree))
  stop accumulating into STARTS - WITH and increase MAX - BACK - REF if
    (setq accumulate-start-p nil
          max-back-ref (max (the fixnum max-back-ref)
                            backref-number))
    (flet ((make-back-ref (backref-number)
             (make-instance 'back-reference
                            :num (1- backref-number)
                            :case-insensitive-p (case-insensitive-mode-p flags)
  backref - name is NIL or string , safe to copy
                            :name (copy-seq backref-name))))
      (cond
       ((cdr referred-regs)
  any of them , starting with the most recent first
        (make-instance 'alternation
                       :choices (loop
                                 for reg-index in referred-regs
                                 collect (make-back-ref reg-index))))
  simple case - backref corresponds to only one register
       (t
        (make-back-ref backref-number))))))

(defmethod convert-compound-parse-tree ((token (eql :regex)) parse-tree &key)
  "The case for \(:REGEX <string>)."
  (declare #.*standard-optimize-settings*)
  (convert-aux (parse-string (second parse-tree))))

(defmethod convert-compound-parse-tree ((token (eql :char-class)) parse-tree &key invertedp)
  "The case for \(:CHAR-CLASS {<item>}*) where item is one of

- a character,
- a character range: \(:RANGE <char1> <char2>), or
- a special char class symbol like :DIGIT-CHAR-CLASS.

Also used for inverted char classes when INVERTEDP is true."
  (declare #.*standard-optimize-settings*)
  (declare (special flags accumulate-start-p))
  (let ((test-function
         (create-optimized-test-function
          (convert-char-class-to-test-function (rest parse-tree)
                                               invertedp
                                               (case-insensitive-mode-p flags)))))
    (setq accumulate-start-p nil)
    (make-instance 'char-class :test-function test-function)))

(defmethod convert-compound-parse-tree ((token (eql :inverted-char-class)) parse-tree &key)
  "The case for \(:INVERTED-CHAR-CLASS {<item>}*)."
  (declare #.*standard-optimize-settings*)
  (convert-compound-parse-tree :char-class parse-tree :invertedp t))

(defmethod convert-compound-parse-tree ((token (eql :property)) parse-tree &key)
  "The case for \(:PROPERTY <name>) where <name> is a string."
  (declare #.*standard-optimize-settings*)
  (make-instance 'char-class :test-function (resolve-property (second parse-tree))))

(defmethod convert-compound-parse-tree ((token (eql :inverted-property)) parse-tree &key)
  "The case for \(:INVERTED-PROPERTY <name>) where <name> is a string."
  (declare #.*standard-optimize-settings*)
  (make-instance 'char-class :test-function (complement* (resolve-property (second parse-tree)))))

(defmethod convert-compound-parse-tree ((token (eql :flags)) parse-tree &key)
  "The case for \(:FLAGS {<flag>}*) where flag is a modifier symbol
like :CASE-INSENSITIVE-P."
  (declare #.*standard-optimize-settings*)
  following : 
  (mapc #'set-flag (rest parse-tree))
  (make-instance 'void))

(defgeneric convert-simple-parse-tree (parse-tree)
  (declare #.*standard-optimize-settings*)
  (:documentation "Helper function for CONVERT-AUX which converts
parse trees which are atoms.")
  (:method ((parse-tree (eql :void)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'void))
  (:method ((parse-tree (eql :word-boundary)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'word-boundary :negatedp nil))
  (:method ((parse-tree (eql :non-word-boundary)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'word-boundary :negatedp t))
  (:method ((parse-tree (eql :everything)))
   (declare #.*standard-optimize-settings*)
   (declare (special flags accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'everything :single-line-p (single-line-mode-p flags)))
  (:method ((parse-tree (eql :digit-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function #'digit-char-p))
  (:method ((parse-tree (eql :word-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function #'word-char-p))
  (:method ((parse-tree (eql :whitespace-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function #'whitespacep))
  (:method ((parse-tree (eql :non-digit-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function (complement* #'digit-char-p)))
  (:method ((parse-tree (eql :non-word-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function (complement* #'word-char-p)))
  (:method ((parse-tree (eql :non-whitespace-char-class)))
   (declare #.*standard-optimize-settings*)
   (declare (special accumulate-start-p))
   (setq accumulate-start-p nil)
   (make-instance 'char-class :test-function (complement* #'whitespacep)))
  (:method ((parse-tree (eql :start-anchor)))
   (declare #.*standard-optimize-settings*)
   (declare (special flags))
   (make-instance 'anchor :startp t :multi-line-p (multi-line-mode-p flags)))
  (:method ((parse-tree (eql :end-anchor)))
   (declare #.*standard-optimize-settings*)
   (declare (special flags))
   (make-instance 'anchor :startp nil :multi-line-p (multi-line-mode-p flags)))
  (:method ((parse-tree (eql :modeless-start-anchor)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'anchor :startp t))
  (:method ((parse-tree (eql :modeless-end-anchor)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'anchor :startp nil))
  (:method ((parse-tree (eql :modeless-end-anchor-no-newline)))
   (declare #.*standard-optimize-settings*)
   (make-instance 'anchor :startp nil :no-newline-p t))
  (:method ((parse-tree (eql :case-insensitive-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :case-sensitive-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :multi-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :not-multi-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :single-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void))
  (:method ((parse-tree (eql :not-single-line-mode-p)))
   (declare #.*standard-optimize-settings*)
   (set-flag parse-tree)
   (make-instance 'void)))

(defmethod convert-simple-parse-tree ((parse-tree string))
  (declare #.*standard-optimize-settings*)
  (declare (special flags))
  turn strings into STR objects and try to accumulate into
  (let ((str (make-instance 'str
                            :str parse-tree
                            :case-insensitive-p (case-insensitive-mode-p flags))))
    (maybe-accumulate str)
    str))

(defmethod convert-simple-parse-tree ((parse-tree character))
  (declare #.*standard-optimize-settings*)
  (convert-simple-parse-tree (string parse-tree)))
        
(defmethod convert-simple-parse-tree (parse-tree)
  "The default method - check if there's a translation."
  (declare #.*standard-optimize-settings*)
  (let ((translation (and (symbolp parse-tree) (parse-tree-synonym parse-tree))))
    (if translation
      (convert-aux (copy-tree translation))
      (signal-syntax-error "Unknown token ~A in parse tree." parse-tree))))

(defun convert (parse-tree)
  "Converts the parse tree PARSE-TREE into an equivalent REGEX object
and returns three values: the REGEX object, the number of registers
seen and an object the regex starts with which is either a STR object
or an EVERYTHING object \(if the regex starts with something like
\".*\") or NIL."
  (declare #.*standard-optimize-settings*)
  and then calls CONVERT - AUX to do all the work
  (let* ((flags (list nil nil nil))
         (reg-num 0)
         reg-names
         named-reg-seen
         (accumulate-start-p t)
         starts-with
         (max-back-ref 0)
         (converted-parse-tree (convert-aux parse-tree)))
    (declare (special flags reg-num reg-names named-reg-seen
                      accumulate-start-p starts-with max-back-ref))
    (when (> (the fixnum max-back-ref)
             (the fixnum reg-num))
      (signal-syntax-error "Backreference to register ~A which has not been defined." max-back-ref))
    (when (typep starts-with 'str)
      (setf (slot-value starts-with 'str)
              (coerce (slot-value starts-with 'str)
                      #+:lispworks 'lw:simple-text-string
                      #-:lispworks 'simple-string)))
    (values converted-parse-tree reg-num starts-with
            (when named-reg-seen
              (nreverse reg-names)))))
