clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/cl-ppcre/api.lisp

@@ -0,0 +1,1262 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-ppcre/api.lisp,v 1.85 2009/09/17 19:17:30 edi Exp $
+
+;;; The external API for creating and using scanners.
+
+;;; Copyright (c) 2002-2009, 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)
+
+(defgeneric create-scanner (regex &key case-insensitive-mode
+                                       multi-line-mode
+                                       single-line-mode
+                                       extended-mode
+                                       destructive)
+  (:documentation "Accepts a regular expression - either as a
+parse-tree or as a string - and returns a scan closure which will scan
+strings for this regular expression and a list mapping registers to
+their names \(NIL stands for unnamed ones).  The \"mode\" keyboard
+arguments are equivalent to the imsx modifiers in Perl.  If
+DESTRUCTIVE is not NIL, the function is allowed to destructively
+modify its first argument \(but only if it's a parse tree)."))
+
+#-:use-acl-regexp2-engine
+(defmethod create-scanner ((regex-string string) &key case-insensitive-mode
+                                                      multi-line-mode
+                                                      single-line-mode
+                                                      extended-mode
+                                                      destructive)
+  (declare #.*standard-optimize-settings*)
+  (declare (ignore destructive))
+  ;; parse the string into a parse-tree and then call CREATE-SCANNER
+  ;; again
+  (let* ((*extended-mode-p* extended-mode)
+         (quoted-regex-string (if *allow-quoting*
+                                (quote-sections (clean-comments regex-string extended-mode))
+                                regex-string))
+         (*syntax-error-string* (copy-seq quoted-regex-string)))
+    ;; wrap the result with :GROUP to avoid infinite loops for
+    ;; constant strings
+    (create-scanner (cons :group (list (parse-string quoted-regex-string)))
+                    :case-insensitive-mode case-insensitive-mode
+                    :multi-line-mode multi-line-mode
+                    :single-line-mode single-line-mode
+                    :destructive t)))
+
+#-:use-acl-regexp2-engine
+(defmethod create-scanner ((scanner function) &key case-insensitive-mode
+                                                   multi-line-mode
+                                                   single-line-mode
+                                                   extended-mode
+                                                   destructive)
+  (declare #.*standard-optimize-settings*)
+  (declare (ignore destructive))
+  (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode)
+    (signal-invocation-error "You can't use the keyword arguments to modify an existing scanner."))
+  scanner)
+
+#-:use-acl-regexp2-engine
+(defmethod create-scanner ((parse-tree t) &key case-insensitive-mode
+                                               multi-line-mode
+                                               single-line-mode
+                                               extended-mode
+                                               destructive)
+  (declare #.*standard-optimize-settings*)
+  (when extended-mode
+    (signal-invocation-error "Extended mode doesn't make sense in parse trees."))
+  ;; convert parse-tree into internal representation REGEX and at the
+  ;; same time compute the number of registers and the constant string
+  ;; (or anchor) the regex starts with (if any)
+  (unless destructive
+    (setq parse-tree (copy-tree parse-tree)))
+  (let (flags)
+    (if single-line-mode
+      (push :single-line-mode-p flags))
+    (if multi-line-mode
+      (push :multi-line-mode-p flags))
+    (if case-insensitive-mode
+      (push :case-insensitive-p flags))
+    (when flags
+      (setq parse-tree (list :group (cons :flags flags) parse-tree))))
+  (let ((*syntax-error-string* nil))
+    (multiple-value-bind (regex reg-num starts-with reg-names)
+        (convert parse-tree)
+      ;; simplify REGEX by flattening nested SEQ and ALTERNATION
+      ;; constructs and gathering STR objects
+      (let ((regex (gather-strings (flatten regex))))
+        ;; set the MIN-REST slots of the REPETITION objects
+        (compute-min-rest regex 0)
+        ;; set the OFFSET slots of the STR objects
+        (compute-offsets regex 0)
+        (let* (end-string-offset
+               end-anchored-p
+               ;; compute the constant string the regex ends with (if
+               ;; any) and at the same time set the special variables
+               ;; END-STRING-OFFSET and END-ANCHORED-P
+               (end-string (end-string regex))
+               ;; if we found a non-zero-length end-string we create an
+               ;; efficient search function for it
+               (end-string-test (and end-string
+                                     (plusp (len end-string))
+                                     (if (= 1 (len end-string))
+                                       (create-char-searcher
+                                        (schar (str end-string) 0)
+                                        (case-insensitive-p end-string))
+                                       (create-bmh-matcher
+                                        (str end-string)
+                                        (case-insensitive-p end-string)))))
+               ;; initialize the counters for CREATE-MATCHER-AUX
+               (*rep-num* 0)
+               (*zero-length-num* 0)
+               ;; create the actual matcher function (which does all the
+               ;; work of matching the regular expression) corresponding
+               ;; to REGEX and at the same time set the special
+               ;; variables *REP-NUM* and *ZERO-LENGTH-NUM*
+               (match-fn (create-matcher-aux regex #'identity))
+               ;; if the regex starts with a string we create an
+               ;; efficient search function for it
+               (start-string-test (and (typep starts-with 'str)
+                                       (plusp (len starts-with))
+                                       (if (= 1 (len starts-with))
+                                         (create-char-searcher
+                                          (schar (str starts-with) 0)
+                                          (case-insensitive-p starts-with))
+                                         (create-bmh-matcher
+                                          (str starts-with)
+                                          (case-insensitive-p starts-with))))))
+          (declare (special end-string-offset end-anchored-p end-string))
+          ;; now create the scanner and return it
+          (values (create-scanner-aux match-fn
+                                      (regex-min-length regex)
+                                      (or (start-anchored-p regex)
+                                          ;; a dot in single-line-mode also
+                                          ;; implicitly anchors the regex at
+                                          ;; the start, i.e. if we can't match
+                                          ;; from the first position we won't
+                                          ;; match at all
+                                          (and (typep starts-with 'everything)
+                                               (single-line-p starts-with)))
+                                      starts-with
+                                      start-string-test
+                                      ;; only mark regex as end-anchored if we
+                                      ;; found a non-zero-length string before
+                                      ;; the anchor
+                                      (and end-string-test end-anchored-p)
+                                      end-string-test
+                                      (if end-string-test
+                                          (len end-string)
+                                          nil)
+                                      end-string-offset
+                                      *rep-num*
+                                      *zero-length-num*
+                                      reg-num)
+                  reg-names))))))
+
+#+:use-acl-regexp2-engine
+(declaim (inline create-scanner))
+#+:use-acl-regexp2-engine
+(defmethod create-scanner ((scanner regexp::regular-expression) &key case-insensitive-mode
+                                                                     multi-line-mode
+                                                                     single-line-mode
+                                                                     extended-mode
+                                                                     destructive)
+  (declare #.*standard-optimize-settings*)
+  (declare (ignore destructive))
+  (when (or case-insensitive-mode multi-line-mode single-line-mode extended-mode)
+    (signal-invocation-error "You can't use the keyword arguments to modify an existing scanner."))
+  scanner)
+
+#+:use-acl-regexp2-engine
+(defmethod create-scanner ((parse-tree t) &key case-insensitive-mode
+                                               multi-line-mode
+                                               single-line-mode
+                                               extended-mode
+                                               destructive)
+  (declare #.*standard-optimize-settings*)
+  (declare (ignore destructive))
+  (excl:compile-re parse-tree
+                   :case-fold case-insensitive-mode
+                   :ignore-whitespace extended-mode
+                   :multiple-lines multi-line-mode
+                   :single-line single-line-mode
+                   :return :index))
+
+(defgeneric scan (regex target-string &key start end real-start-pos)
+  (:documentation "Searches TARGET-STRING from START to END and tries
+to match REGEX.  On success returns four values - the start of the
+match, the end of the match, and two arrays denoting the beginnings
+and ends of register matches.  On failure returns NIL.  REGEX can be a
+string which will be parsed according to Perl syntax, a parse tree, or
+a pre-compiled scanner created by CREATE-SCANNER.  TARGET-STRING will
+be coerced to a simple string if it isn't one already.  The
+REAL-START-POS parameter should be ignored - it exists only for
+internal purposes."))
+
+#-:use-acl-regexp2-engine
+(defmethod scan ((regex-string string) target-string
+                                       &key (start 0)
+                                            (end (length target-string))
+                                            ((:real-start-pos *real-start-pos*) nil))
+  (declare #.*standard-optimize-settings*)
+  ;; note that the scanners are optimized for simple strings so we
+  ;; have to coerce TARGET-STRING into one if it isn't already
+  (funcall (create-scanner regex-string)
+           (maybe-coerce-to-simple-string target-string)
+           start end))
+
+#-:use-acl-regexp2-engine
+(defmethod scan ((scanner function) target-string
+                                    &key (start 0)
+                                         (end (length target-string))
+                                         ((:real-start-pos *real-start-pos*) nil))
+  (declare #.*standard-optimize-settings*)
+  (funcall scanner
+           (maybe-coerce-to-simple-string target-string)
+           start end))
+
+#-:use-acl-regexp2-engine
+(defmethod scan ((parse-tree t) target-string
+                                &key (start 0)
+                                     (end (length target-string))
+                                     ((:real-start-pos *real-start-pos*) nil))
+  (declare #.*standard-optimize-settings*)
+  (funcall (create-scanner parse-tree)
+           (maybe-coerce-to-simple-string target-string)
+           start end))
+
+#+:use-acl-regexp2-engine
+(declaim (inline scan))
+#+:use-acl-regexp2-engine
+(defmethod scan ((parse-tree t) target-string
+                                &key (start 0)
+                                     (end (length target-string))
+                                     ((:real-start-pos *real-start-pos*) nil))
+  (declare #.*standard-optimize-settings*)
+  (when (< end start)
+    (return-from scan nil))
+  (let ((results (multiple-value-list (excl:match-re parse-tree target-string
+                                                     :start start
+                                                     :end end
+                                                     :return :index))))
+    (declare (dynamic-extent results))
+    (cond ((null (first results)) nil)
+          (t (let* ((no-of-regs (- (length results) 2))
+                    (reg-starts (make-array no-of-regs
+                                            :element-type '(or null fixnum)))
+                    (reg-ends (make-array no-of-regs
+                                          :element-type '(or null fixnum)))
+                    (match (second results)))
+               (loop for (start . end) in (cddr results)
+                     for i from 0
+                     do (setf (aref reg-starts i) start
+                              (aref reg-ends i) end))
+               (values (car match) (cdr match) reg-starts reg-ends))))))
+
+#-:cormanlisp
+(define-compiler-macro scan (&whole form &environment env regex target-string &rest rest)
+  "Make sure that constant forms are compiled into scanners at compile time."
+  (cond ((constantp regex env)
+          `(scan (load-time-value (create-scanner ,regex))
+                 ,target-string ,@rest))
+        (t form)))
+
+(defun scan-to-strings (regex target-string &key (start 0)
+                                                 (end (length target-string))
+                                                 sharedp)
+  "Like SCAN but returns substrings of TARGET-STRING instead of
+positions, i.e. this function returns two values on success: the whole
+match as a string plus an array of substrings (or NILs) corresponding
+to the matched registers.  If SHAREDP is true, the substrings may
+share structure with TARGET-STRING."
+  (declare #.*standard-optimize-settings*)
+  (multiple-value-bind (match-start match-end reg-starts reg-ends)
+      (scan regex target-string :start start :end end)
+    (unless match-start
+      (return-from scan-to-strings nil))
+    (let ((substr-fn (if sharedp #'nsubseq #'subseq)))
+      (values (funcall substr-fn
+                       target-string match-start match-end)
+              (map 'vector
+                   (lambda (reg-start reg-end)
+                     (if reg-start
+                       (funcall substr-fn
+                                target-string reg-start reg-end)
+                       nil))
+                   reg-starts
+                   reg-ends)))))
+
+#-:cormanlisp
+(define-compiler-macro scan-to-strings
+    (&whole form &environment env regex target-string &rest rest)
+  "Make sure that constant forms are compiled into scanners at compile time."
+  (cond ((constantp regex env)
+          `(scan-to-strings (load-time-value (create-scanner ,regex))
+                            ,target-string ,@rest))
+        (t form)))
+
+(defmacro register-groups-bind (var-list (regex target-string
+                                                &key start end sharedp)
+                                &body body)
+  "Executes BODY with the variables in VAR-LIST bound to the
+corresponding register groups after TARGET-STRING has been matched
+against REGEX, i.e. each variable is either bound to a string or to
+NIL.  If there is no match, BODY is _not_ executed. For each element
+of VAR-LIST which is NIL there's no binding to the corresponding
+register group.  The number of variables in VAR-LIST must not be
+greater than the number of register groups.  If SHAREDP is true, the
+substrings may share structure with TARGET-STRING."
+  (with-rebinding (target-string)
+    (with-unique-names (match-start match-end reg-starts reg-ends
+                                    start-index substr-fn)
+      `(multiple-value-bind (,match-start ,match-end ,reg-starts ,reg-ends)
+            (scan ,regex ,target-string :start (or ,start 0)
+                                        :end (or ,end (length ,target-string)))
+          (declare (ignore ,match-end))
+          (when ,match-start            
+            (let* ,(cons
+                    `(,substr-fn (if ,sharedp
+                                   #'nsubseq
+                                   #'subseq))
+                    (loop for (function var) in (normalize-var-list var-list)
+                          for counter from 0
+                          when var
+                            collect `(,var (let ((,start-index
+                                                   (aref ,reg-starts ,counter)))
+                                             (if ,start-index
+                                               (funcall ,function
+                                                        (funcall ,substr-fn
+                                                                 ,target-string
+                                                                 ,start-index
+                                                                 (aref ,reg-ends ,counter)))
+                                               nil)))))
+              ,@body))))))
+
+(defmacro do-scans ((match-start match-end reg-starts reg-ends regex
+                                 target-string
+                                 &optional result-form
+                                 &key start end)
+                    &body body
+                    &environment env)
+  "Iterates over TARGET-STRING and tries to match REGEX as often as
+possible evaluating BODY with MATCH-START, MATCH-END, REG-STARTS, and
+REG-ENDS bound to the four return values of each match in turn.  After
+the last match, returns RESULT-FORM if provided or NIL otherwise. An
+implicit block named NIL surrounds DO-SCANS; RETURN may be used to
+terminate the loop immediately.  If REGEX matches an empty string the
+scan is continued one position behind this match. BODY may start with
+declarations."
+  (with-rebinding (target-string)
+    (with-unique-names (%start %end %regex scanner)
+      (declare (ignorable %regex scanner))
+      ;; the NIL BLOCK to enable exits via (RETURN ...)
+      `(block nil
+         (let* ((,%start (or ,start 0))
+                (,%end (or ,end (length ,target-string)))
+                ,@(unless (constantp regex env)
+                    ;; leave constant regular expressions as they are -
+                    ;; SCAN's compiler macro will take care of them;
+                    ;; otherwise create a scanner unless the regex is
+                    ;; already a function (otherwise SCAN will do this
+                    ;; on each iteration)
+                    `((,%regex ,regex)
+                      (,scanner (typecase ,%regex
+                                  (function ,%regex)
+                                  (t (create-scanner ,%regex)))))))
+           ;; coerce TARGET-STRING to a simple string unless it is one
+           ;; already (otherwise SCAN will do this on each iteration)
+           (setq ,target-string
+                 (maybe-coerce-to-simple-string ,target-string))
+           (loop
+            ;; invoke SCAN and bind the returned values to the
+            ;; provided variables
+            (multiple-value-bind
+                (,match-start ,match-end ,reg-starts ,reg-ends)
+                (scan ,(cond ((constantp regex env) regex)
+                             (t scanner))
+                      ,target-string :start ,%start :end ,%end
+                      :real-start-pos (or ,start 0))
+              ;; declare the variables to be IGNORABLE to prevent the
+              ;; compiler from issuing warnings
+              (declare
+               (ignorable ,match-start ,match-end ,reg-starts ,reg-ends))
+              (unless ,match-start
+                ;; stop iteration on first failure
+                (return ,result-form))
+              ;; execute BODY (wrapped in LOCALLY so it can start with
+              ;; declarations)
+              (locally
+                ,@body)
+              ;; advance by one position if we had a zero-length match
+              (setq ,%start (if (= ,match-start ,match-end)
+                              (1+ ,match-end)
+                              ,match-end)))))))))
+
+(defmacro do-matches ((match-start match-end regex
+                                   target-string
+                                   &optional result-form
+                                   &key start end)
+                      &body body)
+  "Iterates over TARGET-STRING and tries to match REGEX as often as
+possible evaluating BODY with MATCH-START and MATCH-END bound to the
+start/end positions of each match in turn.  After the last match,
+returns RESULT-FORM if provided or NIL otherwise.  An implicit block
+named NIL surrounds DO-MATCHES; RETURN may be used to terminate the
+loop immediately.  If REGEX matches an empty string the scan is
+continued one position behind this match.  BODY may start with
+declarations."
+  ;; this is a simplified form of DO-SCANS - we just provide two dummy
+  ;; vars and ignore them
+  (with-unique-names (reg-starts reg-ends)
+    `(do-scans (,match-start ,match-end
+                ,reg-starts ,reg-ends
+                ,regex ,target-string
+                ,result-form
+                :start ,start :end ,end)
+      ,@body)))
+
+(defmacro do-matches-as-strings ((match-var regex
+                                            target-string
+                                            &optional result-form
+                                            &key start end sharedp)
+                                 &body body)
+  "Iterates over TARGET-STRING and tries to match REGEX as often as
+possible evaluating BODY with MATCH-VAR bound to the substring of
+TARGET-STRING corresponding to each match in turn.  After the last
+match, returns RESULT-FORM if provided or NIL otherwise.  An implicit
+block named NIL surrounds DO-MATCHES-AS-STRINGS; RETURN may be used to
+terminate the loop immediately.  If REGEX matches an empty string the
+scan is continued one position behind this match.  If SHAREDP is true,
+the substrings may share structure with TARGET-STRING.  BODY may start
+with declarations."
+  (with-rebinding (target-string)
+    (with-unique-names (match-start match-end substr-fn)
+      `(let ((,substr-fn (if ,sharedp #'nsubseq #'subseq)))
+        ;; simple use DO-MATCHES to extract the substrings
+        (do-matches (,match-start ,match-end ,regex ,target-string
+                     ,result-form :start ,start :end ,end)
+          (let ((,match-var
+                  (funcall ,substr-fn
+                           ,target-string ,match-start ,match-end)))
+            ,@body))))))
+
+(defmacro do-register-groups (var-list (regex target-string
+                                              &optional result-form
+                                              &key start end sharedp)
+                                       &body body)
+  "Iterates over TARGET-STRING and tries to match REGEX as often as
+possible evaluating BODY with the variables in VAR-LIST bound to the
+corresponding register groups for each match in turn, i.e. each
+variable is either bound to a string or to NIL.  For each element of
+VAR-LIST which is NIL there's no binding to the corresponding register
+group. The number of variables in VAR-LIST must not be greater than
+the number of register groups.  After the last match, returns
+RESULT-FORM if provided or NIL otherwise.  An implicit block named NIL
+surrounds DO-REGISTER-GROUPS; RETURN may be used to terminate the loop
+immediately. If REGEX matches an empty string the scan is continued
+one position behind this match.  If SHAREDP is true, the substrings
+may share structure with TARGET-STRING.  BODY may start with
+declarations."
+  (with-rebinding (target-string)
+    (with-unique-names (substr-fn match-start match-end
+                                  reg-starts reg-ends start-index)
+      `(let ((,substr-fn (if ,sharedp
+                          #'nsubseq
+                          #'subseq)))
+        (do-scans (,match-start ,match-end ,reg-starts ,reg-ends
+                                ,regex ,target-string
+                                ,result-form :start ,start :end ,end)
+          (let ,(loop for (function var) in (normalize-var-list var-list)
+                      for counter from 0
+                      when var
+                        collect `(,var (let ((,start-index
+                                               (aref ,reg-starts ,counter)))
+                                         (if ,start-index
+                                           (funcall ,function
+                                                    (funcall ,substr-fn
+                                                             ,target-string
+                                                             ,start-index
+                                                             (aref ,reg-ends ,counter)))
+                                           nil))))
+            ,@body))))))
+
+(defun all-matches (regex target-string
+                          &key (start 0)
+                               (end (length target-string)))
+  "Returns a list containing the start and end positions of all
+matches of REGEX against TARGET-STRING, i.e. if there are N matches
+the list contains (* 2 N) elements.  If REGEX matches an empty string
+the scan is continued one position behind this match."
+  (declare #.*standard-optimize-settings*)
+  (let (result-list)
+    (do-matches (match-start match-end
+                 regex target-string
+                 (nreverse result-list)
+                 :start start :end end)
+      (push match-start result-list)
+      (push match-end result-list))))
+
+#-:cormanlisp
+(define-compiler-macro all-matches (&whole form &environment env regex &rest rest)
+   "Make sure that constant forms are compiled into scanners at
+compile time."
+   (cond ((constantp regex env)
+           `(all-matches (load-time-value (create-scanner ,regex))
+                         ,@rest))
+         (t form)))
+
+(defun all-matches-as-strings (regex target-string
+                                     &key (start 0)
+                                          (end (length target-string))
+                                          sharedp)
+  "Returns a list containing all substrings of TARGET-STRING which
+match REGEX. If REGEX matches an empty string the scan is continued
+one position behind this match. If SHAREDP is true, the substrings may
+share structure with TARGET-STRING."
+  (declare #.*standard-optimize-settings*)
+  (let (result-list)
+    (do-matches-as-strings (match regex target-string (nreverse result-list)
+                                  :start start :end end :sharedp sharedp)
+      (push match result-list))))
+
+#-:cormanlisp
+(define-compiler-macro all-matches-as-strings (&whole form &environment env regex &rest rest)
+   "Make sure that constant forms are compiled into scanners at
+compile time."
+   (cond ((constantp regex env)
+           `(all-matches-as-strings
+             (load-time-value (create-scanner ,regex))
+             ,@rest))
+         (t form)))
+
+(defun split (regex target-string
+                    &key (start 0)
+                         (end (length target-string))
+                         limit
+                         with-registers-p
+                         omit-unmatched-p
+                         sharedp)
+  "Matches REGEX against TARGET-STRING as often as possible and
+returns a list of the substrings between the matches.  If
+WITH-REGISTERS-P is true, substrings corresponding to matched
+registers are inserted into the list as well.  If OMIT-UNMATCHED-P is
+true, unmatched registers will simply be left out, otherwise they will
+show up as NIL.  LIMIT limits the number of elements returned -
+registers aren't counted.  If LIMIT is NIL \(or 0 which is
+equivalent), trailing empty strings are removed from the result list.
+If REGEX matches an empty string the scan is continued one position
+behind this match.  If SHAREDP is true, the substrings may share
+structure with TARGET-STRING."
+  (declare #.*standard-optimize-settings*)
+  ;; initialize list of positions POS-LIST to extract substrings with
+  ;; START so that the start of the next match will mark the end of
+  ;; the first substring
+  (let ((pos-list (list start))
+        (counter 0))
+    ;; how would Larry Wall do it?
+    (when (eql limit 0)
+      (setq limit nil))
+    (do-scans (match-start match-end
+               reg-starts reg-ends
+               regex target-string nil
+               :start start :end end)
+      (unless (and (= match-start match-end)
+                   (= match-start (car pos-list)))
+        ;; push start of match on list unless this would be an empty
+        ;; string adjacent to the last element pushed onto the list
+        (when (and limit
+                   (>= (incf counter) limit))
+          (return))
+        (push match-start pos-list)
+        (when with-registers-p
+          ;; optionally insert matched registers
+          (loop for reg-start across reg-starts
+                for reg-end across reg-ends
+                if reg-start
+                  ;; but only if they've matched
+                  do (push reg-start pos-list)
+                     (push reg-end pos-list)
+                else unless omit-unmatched-p
+                  ;; or if we're allowed to insert NIL instead
+                  do (push nil pos-list)
+                     (push nil pos-list)))
+        ;; now end of match
+        (push match-end pos-list)))
+    ;; end of whole string
+    (push end pos-list)
+    ;; now collect substrings
+    (nreverse
+     (loop with substr-fn = (if sharedp #'nsubseq #'subseq)
+           with string-seen = nil
+           for (this-end this-start) on pos-list by #'cddr
+           ;; skip empty strings from end of list
+           if (or limit
+                  (setq string-seen
+                          (or string-seen
+                              (and this-start
+                                   (> this-end this-start)))))
+           collect (if this-start
+                     (funcall substr-fn
+                              target-string this-start this-end)
+                     nil)))))
+
+#-:cormanlisp
+(define-compiler-macro split (&whole form &environment env regex target-string &rest rest)
+  "Make sure that constant forms are compiled into scanners at compile time."
+  (cond ((constantp regex env)
+          `(split (load-time-value (create-scanner ,regex))
+                  ,target-string ,@rest))
+        (t form)))
+
+(defun string-case-modifier (str from to start end)
+  (declare #.*standard-optimize-settings*)
+  (declare (fixnum from to start end))
+  "Checks whether all words in STR between FROM and TO are upcased,
+downcased or capitalized and returns a function which applies a
+corresponding case modification to strings.  Returns #'IDENTITY
+otherwise, especially if words in the target area extend beyond FROM
+or TO.  STR is supposed to be bounded by START and END.  It is assumed
+that \(<= START FROM TO END)."
+  (case
+      (if (or (<= to from)
+              (and (< start from)
+                   (alphanumericp (char str (1- from)))
+                   (alphanumericp (char str from)))
+              (and (< to end)
+                   (alphanumericp (char str to))
+                   (alphanumericp (char str (1- to)))))
+        ;; if it's a zero-length string or if words extend beyond FROM
+        ;; or TO we return NIL, i.e. #'IDENTITY
+        nil
+        ;; otherwise we loop through STR from FROM to TO
+        (loop with last-char-both-case
+              with current-result
+              for index of-type fixnum from from below to
+              for chr = (char str index)
+              do (cond ((not #-:cormanlisp (both-case-p chr)
+                             #+:cormanlisp (or (upper-case-p chr)
+                                               (lower-case-p chr)))
+                         ;; this character doesn't have a case so we
+                         ;; consider it as a word boundary (note that
+                         ;; this differs from how \b works in Perl)
+                         (setq last-char-both-case nil))
+                       ((upper-case-p chr)
+                         ;; an uppercase character
+                         (setq current-result
+                                 (if last-char-both-case
+                                   ;; not the first character in a 
+                                   (case current-result
+                                     ((:undecided) :upcase)
+                                     ((:downcase :capitalize) (return nil))
+                                     ((:upcase) current-result))
+                                   (case current-result
+                                     ((nil) :undecided)
+                                     ((:downcase) (return nil))
+                                     ((:capitalize :upcase) current-result)))
+                               last-char-both-case t))
+                       (t
+                         ;; a lowercase character
+                         (setq current-result
+                                 (case current-result
+                                   ((nil) :downcase)
+                                   ((:undecided) :capitalize)
+                                   ((:downcase) current-result)
+                                   ((:capitalize) (if last-char-both-case
+                                                    current-result
+                                                    (return nil)))
+                                   ((:upcase) (return nil)))
+                               last-char-both-case t)))
+              finally (return current-result)))
+    ((nil) #'identity)
+    ((:undecided :upcase) #'string-upcase)
+    ((:downcase) #'string-downcase)
+    ((:capitalize) #'string-capitalize)))
+
+;; first create a scanner to identify the special parts of the
+;; replacement string (eat your own dog food...)
+
+(defgeneric build-replacement-template (replacement-string)
+  (declare #.*standard-optimize-settings*)
+  (:documentation "Converts a replacement string for REGEX-REPLACE or
+REGEX-REPLACE-ALL into a replacement template which is an
+S-expression."))
+
+#-:cormanlisp
+(let* ((*use-bmh-matchers* nil)
+       (reg-scanner (create-scanner "\\\\(?:\\\\|\\{\\d+\\}|\\d+|&|`|')")))
+  (defmethod build-replacement-template ((replacement-string string))
+    (declare #.*standard-optimize-settings*)
+    (let ((from 0)
+          ;; COLLECTOR will hold the (reversed) template
+          (collector '()))
+      ;; scan through all special parts of the replacement string
+      (do-matches (match-start match-end reg-scanner replacement-string)
+        (when (< from match-start)
+          ;; strings between matches are copied verbatim
+          (push (subseq replacement-string from match-start) collector))
+        ;; PARSE-START is true if the pattern matched a number which
+        ;; refers to a register
+        (let* ((parse-start (position-if #'digit-char-p
+                                         replacement-string
+                                         :start match-start
+                                         :end match-end))
+               (token (if parse-start
+                        (1- (parse-integer replacement-string
+                                           :start parse-start
+                                           :junk-allowed t))
+                        ;; if we didn't match a number we convert the
+                        ;; character to a symbol
+                        (case (char replacement-string (1+ match-start))
+                          ((#\&) :match)
+                          ((#\`) :before-match)
+                          ((#\') :after-match)
+                          ((#\\) :backslash)))))
+          (when (and (numberp token) (< token 0))
+            ;; make sure we don't accept something like "\\0"
+            (signal-invocation-error "Illegal substring ~S in replacement string."
+                                     (subseq replacement-string match-start match-end)))
+          (push token collector))
+        ;; remember where the match ended
+        (setq from match-end))
+      (when (< from (length replacement-string))
+        ;; push the rest of the replacement string onto the list
+        (push (subseq replacement-string from) collector))
+      (nreverse collector))))
+
+#-:cormanlisp
+(defmethod build-replacement-template ((replacement-function function))
+  (declare #.*standard-optimize-settings*)
+  (list replacement-function))
+
+#-:cormanlisp
+(defmethod build-replacement-template ((replacement-function-symbol symbol))
+  (declare #.*standard-optimize-settings*)
+  (list replacement-function-symbol))
+        
+#-:cormanlisp
+(defmethod build-replacement-template ((replacement-list list))
+  (declare #.*standard-optimize-settings*)
+  replacement-list)
+
+;;; Corman Lisp's methods can't be closures... :(
+#+:cormanlisp
+(let* ((*use-bmh-matchers* nil)
+       (reg-scanner (create-scanner "\\\\(?:\\\\|\\{\\d+\\}|\\d+|&|`|')")))
+  (defun build-replacement-template (replacement)
+    (declare #.*standard-optimize-settings*)
+    (typecase replacement
+      (string
+        (let ((from 0)
+              ;; COLLECTOR will hold the (reversed) template
+              (collector '()))
+          ;; scan through all special parts of the replacement string
+          (do-matches (match-start match-end reg-scanner replacement)
+            (when (< from match-start)
+              ;; strings between matches are copied verbatim
+              (push (subseq replacement from match-start) collector))
+            ;; PARSE-START is true if the pattern matched a number which
+            ;; refers to a register
+            (let* ((parse-start (position-if #'digit-char-p
+                                             replacement
+                                             :start match-start
+                                             :end match-end))
+                   (token (if parse-start
+                            (1- (parse-integer replacement
+                                               :start parse-start
+                                               :junk-allowed t))
+                            ;; if we didn't match a number we convert the
+                            ;; character to a symbol
+                            (case (char replacement (1+ match-start))
+                              ((#\&) :match)
+                              ((#\`) :before-match)
+                              ((#\') :after-match)
+                              ((#\\) :backslash)))))
+              (when (and (numberp token) (< token 0))
+                ;; make sure we don't accept something like "\\0"
+                (signal-invocation-error "Illegal substring ~S in replacement string."
+                                         (subseq replacement match-start match-end)))
+              (push token collector))
+            ;; remember where the match ended
+            (setq from match-end))
+          (when (< from (length replacement))
+            ;; push the rest of the replacement string onto the list
+            (push (nsubseq replacement from) collector))
+          (nreverse collector)))
+      (list
+        replacement)
+      (t
+        (list replacement)))))
+        
+(defun build-replacement (replacement-template
+                          target-string
+                          start end
+                          match-start match-end
+                          reg-starts reg-ends
+                          simple-calls
+                          element-type)
+  (declare #.*standard-optimize-settings*)
+  "Accepts a replacement template and the current values from the
+matching process in REGEX-REPLACE or REGEX-REPLACE-ALL and returns the
+corresponding string."
+  ;; the upper exclusive bound of the register numbers in the regular
+  ;; expression
+  (let ((reg-bound (if reg-starts
+                     (array-dimension reg-starts 0)
+                     0)))
+    (with-output-to-string (s nil :element-type element-type)
+      (loop for token in replacement-template
+            do (typecase token
+                 (string
+                   ;; transfer string parts verbatim
+                   (write-string token s))
+                 (integer
+                   ;; replace numbers with the corresponding registers
+                   (when (>= token reg-bound)
+                     ;; but only if the register was referenced in the
+                     ;; regular expression
+                     (signal-invocation-error "Reference to non-existent register ~A in replacement string."
+                                              (1+ token)))
+                   (when (svref reg-starts token)
+                     ;; and only if it matched, i.e. no match results
+                     ;; in an empty string
+                     (write-string target-string s
+                                   :start (svref reg-starts token)
+                                   :end (svref reg-ends token))))
+                 (function
+                   (write-string 
+                    (cond (simple-calls
+                           (apply token
+                                  (nsubseq target-string match-start match-end)
+                                  (map 'list
+                                       (lambda (reg-start reg-end)
+                                         (and reg-start
+                                              (nsubseq target-string reg-start reg-end)))
+                                       reg-starts reg-ends)))
+                          (t
+                           (funcall token
+                                    target-string
+                                    start end
+                                    match-start match-end
+                                    reg-starts reg-ends)))
+                    s))
+                 (symbol
+                   (case token
+                     ((:backslash)
+                       ;; just a backslash
+                       (write-char #\\ s))
+                     ((:match)
+                       ;; the whole match
+                       (write-string target-string s
+                                     :start match-start
+                                     :end match-end))
+                     ((:before-match)
+                       ;; the part of the target string before the match
+                       (write-string target-string s
+                                     :start start
+                                     :end match-start))
+                     ((:after-match)
+                       ;; the part of the target string after the match
+                       (write-string target-string s
+                                     :start match-end
+                                     :end end))
+                     (otherwise
+                      (write-string
+                       (cond (simple-calls
+                              (apply token
+                                     (nsubseq target-string match-start match-end)
+                                     (map 'list
+                                          (lambda (reg-start reg-end)
+                                            (and reg-start
+                                                 (nsubseq target-string reg-start reg-end)))
+                                          reg-starts reg-ends)))
+                             (t
+                              (funcall token
+                                       target-string
+                                       start end
+                                       match-start match-end
+                                       reg-starts reg-ends)))
+                       s)))))))))
+
+(defun replace-aux (target-string replacement pos-list reg-list start end
+                                  preserve-case simple-calls element-type)
+  "Auxiliary function used by REGEX-REPLACE and REGEX-REPLACE-ALL.
+POS-LIST contains a list with the start and end positions of all
+matches while REG-LIST contains a list of arrays representing the
+corresponding register start and end positions."
+  (declare #.*standard-optimize-settings*)
+  ;; build the template once before we start the loop
+  (let ((replacement-template (build-replacement-template replacement)))
+    (with-output-to-string (s nil :element-type element-type)
+      ;; loop through all matches and take the start and end of the
+      ;; whole string into account
+      (loop for (from to) on (append (list start) pos-list (list end))
+            ;; alternate between replacement and no replacement
+            for replace = nil then (and (not replace) to)
+            for reg-starts = (if replace (pop reg-list) nil)
+            for reg-ends = (if replace (pop reg-list) nil)
+            for curr-replacement = (if replace
+                                     ;; build the replacement string
+                                     (build-replacement replacement-template
+                                                        target-string
+                                                        start end
+                                                        from to
+                                                        reg-starts reg-ends
+                                                        simple-calls
+                                                        element-type)
+                                     nil)
+            while to
+            if replace
+              do (write-string (if preserve-case
+                                 ;; modify the case of the replacement
+                                 ;; string if necessary
+                                 (funcall (string-case-modifier target-string
+                                                                from to
+                                                                start end)
+                                          curr-replacement)
+                                 curr-replacement)
+                               s)
+            else
+              ;; no replacement
+              do (write-string target-string s :start from :end to)))))
+
+(defun regex-replace (regex target-string replacement &key
+                            (start 0)
+                            (end (length target-string))
+                            preserve-case
+                            simple-calls
+                            (element-type #+:lispworks 'lw:simple-char #-:lispworks 'character))
+  "Try to match TARGET-STRING between START and END against REGEX and
+replace the first match with REPLACEMENT.  Two values are returned;
+the modified string, and T if REGEX matched or NIL otherwise.
+
+  REPLACEMENT can be a string which may contain the special substrings
+\"\\&\" for the whole match, \"\\`\" for the part of TARGET-STRING
+before the match, \"\\'\" for the part of TARGET-STRING after the
+match, \"\\N\" or \"\\{N}\" for the Nth register where N is a positive
+integer.
+
+  REPLACEMENT can also be a function designator in which case the
+match will be replaced with the result of calling the function
+designated by REPLACEMENT with the arguments TARGET-STRING, START,
+END, MATCH-START, MATCH-END, REG-STARTS, and REG-ENDS. (REG-STARTS and
+REG-ENDS are arrays holding the start and end positions of matched
+registers or NIL - the meaning of the other arguments should be
+obvious.)
+
+  Finally, REPLACEMENT can be a list where each element is a string,
+one of the symbols :MATCH, :BEFORE-MATCH, or :AFTER-MATCH -
+corresponding to \"\\&\", \"\\`\", and \"\\'\" above -, an integer N -
+representing register (1+ N) -, or a function designator.
+
+  If PRESERVE-CASE is true, the replacement will try to preserve the
+case (all upper case, all lower case, or capitalized) of the
+match. The result will always be a fresh string, even if REGEX doesn't
+match.
+
+  ELEMENT-TYPE is the element type of the resulting string."
+  (declare #.*standard-optimize-settings*)
+  (multiple-value-bind (match-start match-end reg-starts reg-ends)
+      (scan regex target-string :start start :end end)
+    (if match-start
+      (values (replace-aux target-string replacement
+                           (list match-start match-end)
+                           (list reg-starts reg-ends)
+                           start end preserve-case
+                           simple-calls element-type)
+              t)
+      (values (subseq target-string start end)
+              nil))))
+
+#-:cormanlisp
+(define-compiler-macro regex-replace
+    (&whole form &environment env regex target-string replacement &rest rest)
+  "Make sure that constant forms are compiled into scanners at compile time."
+  (cond ((constantp regex env)
+          `(regex-replace (load-time-value (create-scanner ,regex))
+                          ,target-string ,replacement ,@rest))
+        (t form)))
+
+(defun regex-replace-all (regex target-string replacement &key
+                                (start 0)
+                                (end (length target-string))
+                                preserve-case
+                                simple-calls
+                                (element-type #+:lispworks 'lw:simple-char #-:lispworks 'character))
+  "Try to match TARGET-STRING between START and END against REGEX and
+replace all matches with REPLACEMENT.  Two values are returned; the
+modified string, and T if REGEX matched or NIL otherwise.
+
+  REPLACEMENT can be a string which may contain the special substrings
+\"\\&\" for the whole match, \"\\`\" for the part of TARGET-STRING
+before the match, \"\\'\" for the part of TARGET-STRING after the
+match, \"\\N\" or \"\\{N}\" for the Nth register where N is a positive
+integer.
+
+  REPLACEMENT can also be a function designator in which case the
+match will be replaced with the result of calling the function
+designated by REPLACEMENT with the arguments TARGET-STRING, START,
+END, MATCH-START, MATCH-END, REG-STARTS, and REG-ENDS. (REG-STARTS and
+REG-ENDS are arrays holding the start and end positions of matched
+registers or NIL - the meaning of the other arguments should be
+obvious.)
+
+  Finally, REPLACEMENT can be a list where each element is a string,
+one of the symbols :MATCH, :BEFORE-MATCH, or :AFTER-MATCH -
+corresponding to \"\\&\", \"\\`\", and \"\\'\" above -, an integer N -
+representing register (1+ N) -, or a function designator.
+
+  If PRESERVE-CASE is true, the replacement will try to preserve the
+case (all upper case, all lower case, or capitalized) of the
+match. The result will always be a fresh string, even if REGEX doesn't
+match.
+
+  ELEMENT-TYPE is the element type of the resulting string."
+  (declare #.*standard-optimize-settings*)
+  (let ((pos-list '())
+        (reg-list '()))
+    (do-scans (match-start match-end reg-starts reg-ends regex target-string
+                           nil
+                           :start start :end end)
+      (push match-start pos-list)
+      (push match-end pos-list)
+      (push reg-starts reg-list)
+      (push reg-ends reg-list))
+    (if pos-list
+      (values (replace-aux target-string replacement
+                           (nreverse pos-list)
+                           (nreverse reg-list)
+                           start end preserve-case
+                           simple-calls element-type)
+              t)
+      (values (subseq target-string start end)
+              nil))))
+
+#-:cormanlisp
+(define-compiler-macro regex-replace-all
+    (&whole form &environment env regex target-string replacement &rest rest)
+  "Make sure that constant forms are compiled into scanners at compile time."
+  (cond ((constantp regex env)
+          `(regex-replace-all (load-time-value (create-scanner ,regex))
+                              ,target-string ,replacement ,@rest))
+        (t form)))
+
+#-:cormanlisp
+(defmacro regex-apropos-aux ((regex packages case-insensitive &optional return-form)
+                             &body body)
+  "Auxiliary macro used by REGEX-APROPOS and REGEX-APROPOS-LIST. Loops
+through PACKAGES and executes BODY with SYMBOL bound to each symbol
+which matches REGEX. Optionally evaluates and returns RETURN-FORM at
+the end. If CASE-INSENSITIVE is true and REGEX isn't already a
+scanner, a case-insensitive scanner is used."
+  (with-rebinding (regex)
+    (with-unique-names (scanner %packages next morep hash)
+      `(let* ((,scanner (create-scanner ,regex
+                                        :case-insensitive-mode
+                                        (and ,case-insensitive
+                                             (not (functionp ,regex)))))
+              (,%packages (or ,packages
+                              (list-all-packages)))
+              (,hash (make-hash-table :test #'eq)))
+         (with-package-iterator (,next ,%packages :external :internal :inherited)
+           (loop
+             (multiple-value-bind (,morep symbol)
+                 (,next)
+               (unless ,morep
+                 (return ,return-form))
+               (unless (gethash symbol ,hash)
+                 (when (scan ,scanner (symbol-name symbol))
+                   (setf (gethash symbol ,hash) t)
+                   ,@body)))))))))
+
+;;; The following two functions were provided by Karsten Poeck
+
+#+:cormanlisp
+(defmacro do-with-all-symbols ((variable package-or-packagelist) &body body)
+  "Executes BODY with VARIABLE bound to each symbol in
+PACKAGE-OR-PACKAGELIST \(a designator for a list of packages) in
+turn."
+  (with-unique-names (pack-var)
+    `(if (listp ,package-or-packagelist)
+      (dolist (,pack-var ,package-or-packagelist)
+        (do-symbols (,variable ,pack-var)
+          ,@body))
+      (do-symbols (,variable ,package-or-packagelist)
+        ,@body))))
+
+#+:cormanlisp
+(defmacro regex-apropos-aux ((regex packages case-insensitive &optional return-form)
+                             &body body)
+  "Auxiliary macro used by REGEX-APROPOS and REGEX-APROPOS-LIST.
+Loops through PACKAGES and executes BODY with SYMBOL bound to each
+symbol which matches REGEX.  Optionally evaluates and returns
+RETURN-FORM at the end.  If CASE-INSENSITIVE is true and REGEX isn't
+already a scanner, a case-insensitive scanner is used."
+  (with-rebinding (regex)
+    (with-unique-names (scanner %packages hash)
+      `(let* ((,scanner (create-scanner ,regex
+                         :case-insensitive-mode
+                         (and ,case-insensitive
+                              (not (functionp ,regex)))))
+              (,%packages (or ,packages
+                             (list-all-packages)))
+              (,hash (make-hash-table :test #'eq)))
+        (do-with-all-symbols (symbol ,%packages)
+          (unless (gethash symbol ,hash)
+            (when (scan ,scanner (symbol-name symbol))
+              (setf (gethash symbol ,hash) t)
+              ,@body)))
+        ,return-form))))
+
+(defun regex-apropos-list (regex &optional packages &key (case-insensitive t))
+  (declare #.*standard-optimize-settings*)
+  "Similar to the standard function APROPOS-LIST but returns a list of
+all symbols which match the regular expression REGEX.  If
+CASE-INSENSITIVE is true and REGEX isn't already a scanner, a
+case-insensitive scanner is used."
+  (let ((collector '()))
+    (regex-apropos-aux (regex packages case-insensitive collector)
+      (push symbol collector))))
+
+(defun print-symbol-info (symbol)
+  "Auxiliary function used by REGEX-APROPOS. Tries to print some
+meaningful information about a symbol."
+  (declare #.*standard-optimize-settings*)
+  (handler-case
+    (let ((output-list '()))
+      (cond ((special-operator-p symbol)
+              (push "[special operator]" output-list))
+            ((macro-function symbol)
+              (push "[macro]" output-list))
+            ((fboundp symbol)
+              (let* ((function (symbol-function symbol))
+                     (compiledp (compiled-function-p function)))
+                (multiple-value-bind (lambda-expr closurep)
+                    (function-lambda-expression function)
+                  (push
+                    (format nil
+                            "[~:[~;compiled ~]~:[function~;closure~]]~:[~; ~A~]"
+                            compiledp closurep lambda-expr (cadr lambda-expr))
+                    output-list)))))
+      (let ((class (find-class symbol nil)))
+        (when class
+          (push (format nil "[class] ~S" class) output-list)))
+      (cond ((keywordp symbol)
+              (push "[keyword]" output-list))
+            ((constantp symbol)
+              (push (format nil "[constant]~:[~; value: ~S~]"
+                            (boundp symbol) (symbol-value symbol)) output-list))
+            ((boundp symbol)
+              (push #+(or :lispworks :clisp) "[variable]"
+                    #-(or :lispworks :clisp) (format nil "[variable] value: ~S"
+                                                   (symbol-value symbol))
+                    output-list)))
+      #-(or :cormanlisp :clisp)
+      (format t "~&~S ~<~;~^~A~@{~:@_~A~}~;~:>" symbol output-list)
+      #+(or :cormanlisp :clisp)
+      (loop for line in output-list
+            do (format t "~&~S ~A" symbol line)))
+    (condition ()
+      ;; this seems to be necessary due to some errors I encountered
+      ;; with LispWorks
+      (format t "~&~S [an error occurred while trying to print more info]" symbol))))
+
+(defun regex-apropos (regex &optional packages &key (case-insensitive t))
+  "Similar to the standard function APROPOS but returns a list of all
+symbols which match the regular expression REGEX.  If CASE-INSENSITIVE
+is true and REGEX isn't already a scanner, a case-insensitive scanner
+is used."
+  (declare #.*standard-optimize-settings*)
+  (regex-apropos-aux (regex packages case-insensitive)
+    (print-symbol-info symbol))
+  (values))
+
+(let* ((*use-bmh-matchers* nil)
+       (non-word-char-scanner (create-scanner "[^a-zA-Z_0-9]")))
+  (defun quote-meta-chars (string &key (start 0) (end (length string)))
+    "Quote, i.e. prefix with #\\\\, all non-word characters in STRING."
+    (regex-replace-all non-word-char-scanner string "\\\\\\&"
+                       :start start :end end)))
+
+(let* ((*use-bmh-matchers* nil)
+       (*allow-quoting* nil)
+       (quote-char-scanner (create-scanner "\\\\Q"))
+       (section-scanner (create-scanner "\\\\Q((?:[^\\\\]|\\\\(?!Q))*?)(?:\\\\E|$)")))
+  (defun quote-sections (string)
+    "Replace sections inside of STRING which are enclosed by \\Q and
+\\E with the quoted equivalent of these sections \(see
+QUOTE-META-CHARS). Repeat this as long as there are such
+sections. These sections may nest."
+    (flet ((quote-substring (target-string start end match-start
+                                           match-end reg-starts reg-ends)
+             (declare (ignore start end match-start match-end))
+             (quote-meta-chars target-string
+                               :start (svref reg-starts 0)
+                               :end (svref reg-ends 0))))
+      (loop for result = string then (regex-replace-all section-scanner
+                                                        result
+                                                        #'quote-substring)
+            while (scan quote-char-scanner result)
+            finally (return result)))))
+
+(let* ((*use-bmh-matchers* nil)
+       (comment-scanner (create-scanner "(?s)\\(\\?#.*?\\)"))
+       (extended-comment-scanner (create-scanner "(?m:#.*?$)|(?s:\\(\\?#.*?\\))"))
+       (quote-token-scanner "\\\\[QE]")
+       (quote-token-replace-scanner "\\\\([QE])"))
+  (defun clean-comments (string &optional extended-mode)
+    "Clean \(?#...) comments within STRING for quoting, i.e. convert
+\\Q to Q and \\E to E.  If EXTENDED-MODE is true, also clean
+end-of-line comments, i.e. those starting with #\\# and ending with
+#\\Newline."
+    (flet ((remove-tokens (target-string start end match-start
+                                         match-end reg-starts reg-ends)
+             (declare (ignore start end reg-starts reg-ends))
+             (loop for result = (nsubseq target-string match-start match-end)
+                   then (regex-replace-all quote-token-replace-scanner result "\\1")
+                   ;; we must probably repeat this because the comment
+                   ;; can contain substrings like \\Q
+                   while (scan quote-token-scanner result)
+                   finally (return result))))
+      (regex-replace-all (if extended-mode
+                           extended-comment-scanner
+                           comment-scanner)
+                         string
+                         #'remove-tokens))))
+
+(defun parse-tree-synonym (symbol)
+  "Returns the parse tree the SYMBOL symbol is a synonym for.  Returns
+NIL is SYMBOL wasn't yet defined to be a synonym."
+  (get symbol 'parse-tree-synonym))
+
+(defun (setf parse-tree-synonym) (new-parse-tree symbol)
+  "Defines SYMBOL to be a synonm for the parse tree NEW-PARSE-TREE."
+  (setf (get symbol 'parse-tree-synonym) new-parse-tree))
+
+(defmacro define-parse-tree-synonym (name parse-tree)
+  "Defines the symbol NAME to be a synonym for the parse tree
+PARSE-TREE.  Both arguments are quoted."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (setf (parse-tree-synonym ',name) ',parse-tree)))