;;;; A reader extension for precompiled regular expression literals.
;;
;; Copyright (c) 2006-2007 Arto Bendiken <http://bendiken.net/>
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to
;; deal in the Software without restriction, including without limitation the
;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
;; sell copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;; IN THE SOFTWARE.

(require-extension regex)

(eval-when (compile)
  (declare
    (export read-regex-literal) ) )

;;;; Exported procedures

(define (read-regex-literal #!optional (port (current-output-port)))
  (define (read-option)
    (let ((char (peek-char port)))
      (cond ((eq? char #\i) (read-char port) 'caseless)
            ((eq? char #\x) (read-char port) 'extended)
            ((eq? char #\u) (read-char port) 'utf8)
            (else #f) ) ) )
  (let loop ((buffer '()))
    (let ((char (read-char port)))
      (cond ((char=? char #\/)
             (let ((options (list (read-option) (read-option) (read-option))))
               `(regexp ,(list->string (reverse buffer))
                        ,(not (not (memq 'caseless options)))
                        ,(not (not (memq 'extended options)))
                        ,(not (not (memq 'utf8 options))) ) ) )
            ((char=? char #\\) ; escaped character
             (loop (cons (read-char port) (cons char buffer))) )
            (else
             (loop (cons char buffer)) ) ) ) ) )

;;;; Initialization

(define-inline (init-regex-literals!)
  (set-sharp-read-syntax! #\/ read-regex-literal) )

(init-regex-literals!)