source: tags/dso-lex-0.2.1/lex.lisp

#|
Copyright (C) 2007  David Owen <dsowen@fugue88.ws>

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
|#



(defpackage #:dso-lex
    (:documentation "Allows the definition of lexers.  See DEFLEXER.")
  (:use #:cl #:cl-ppcre)
  (:export #:deflexer))

(in-package #:dso-lex)



(defun combine (regex-list)
  (let ((mapped (mapcar
                 (lambda (regex) `(:register (:regex ,regex)))
                 regex-list)))
    (when (rest mapped) (setq mapped `((:alternation ,@mapped))))
    `(:sequence (:flags :single-line-mode-p) :start-anchor ,@mapped)))

(defmacro deflexer (name &body body)
  "Defines lexers, called as a function of the given NAME.  The body
consists of token-class definitions, each being a list of a regular
expression, the name of the class, and an optional filter.

Currently, matching is done using *only* priority (first match wins),
and does not look for the longest match."
  (let ((regex (combine (mapcar #'first body)))
        (classes (map 'vector #'second body))
        (filters (map 'vector #'third body)))
    `(defun ,name (input &optional (start 0))
      (let ((parts (nth-value 3 (scan (quote ,regex) input :start start))))
        (let ((idx (position-if #'identity parts)))
          (when idx
            (let ((end (aref parts idx)))
              (let ((image (make-array (- end start)
                                       :element-type 'character
                                       :displaced-to input
                                       :displaced-index-offset start))
                    (filter (aref ,filters idx)))
                (values (aref ,classes idx)
                        (if filter (funcall filter image) image)
                        end)))))))))