Mercurial > core / lisp/lib/parse/lex.lisp

 ;;; lib/parse/lex.lisp --- Lexer Tools
 
 ;; https://github.com/Shinmera/plump/blob/master/lexer.lisp
 
 ;;; Commentary:
 
 ;; TODO: make less dynamic, compile lexer functions for compatibility
 ;; with PARSE/YACC.
 
 ;;; Code:
 (in-package :parse/lex)
 (declaim (optimize (speed 3) (safety 1)))
 (defvar *string*)
 (defvar *length*)
 (defvar *index*)
 (defvar *matchers* (make-hash-table))
 (declaim (fixnum *length* *index*)
          (simple-string *string*)
          (hash-table *matchers*))
 
 (defmacro with-lexer-environment ((string) &body body)
   `(let* ((*string* ,string)
           (*string* (etypecase *string*
                       (simple-string *string*)
                       (string (copy-seq *string*))))
           (*length* (length *string*))
           (*index* 0))
      (handler-bind ((error #'(lambda (err)
                                (declare (ignore err))
                                (format T "Error during lexing at index ~a~%" *index*))))
        ,@body)))
 
 (declaim (ftype (function () (or character null)) consume)
          (inline consume))
 (defun consume ()
   (declare (optimize (speed 3) (safety 0)))
   (when (< *index* *length*)
     (prog1 (aref *string* *index*)
       #+debug (format T "~a +~%" *index*)
       (incf *index*))))
 
 (declaim (ftype (function () (or fixnum null)) advance)
          (inline advance))
 (defun advance ()
   (declare (optimize (speed 3) (safety 0)))
   (when (< *index* *length*)
     #+debug (format T "~a +~%" *index*)
     (incf *index*)))
 
 (declaim (ftype (function () fixnum) unread)
          (inline unread))
 (defun unread ()
   (declare (optimize (speed 3) (safety 0)))
   (when (< 0 *index*)
     #+debug (format T "~a -~%" *index*)
     (decf *index*))
   *index*)
 
 (declaim (ftype (function () (or character null)) peek)
          (inline peek))
 (defun peek ()
   (declare (optimize (speed 3) (safety 0)))
   (when (< *index* *length*)
     #+debug (format T "~a ?~%" *index*)
     (aref *string* *index*)))
 
 (declaim (ftype (function (fixnum) fixnum) advance-n)
          (inline advance-n))
 (defun advance-n (n)
   (declare (optimize (speed 3) (safety 0)))
   (declare (fixnum n))
   #+debug (format T "~a +~d~%" *index* n)
   (incf *index* n)
   (when (<= *length* *index*)
     (setf *index* *length*))
   *index*)
 
 (declaim (ftype (function (fixnum) fixnum) unread-n)
          (inline unread-n))
 (defun unread-n (n)
   (declare (optimize (speed 3) (safety 0)))
   (declare (fixnum n))
   #+debug (format T "~a -~d~%" *index* n)
   (decf *index* n)
   (when (< *index* 0)
     (setf *index* 0))
   *index*)
 
 (declaim (ftype (function (function) string) consume-until))
 (defun consume-until (matcher)
   (declare (function matcher))
   (loop with start = *index*
         until (funcall matcher)
         while (advance)
         finally (return (subseq *string* start *index*))))
 
 (declaim (ftype (function (character) function) matcher-character))
 (defun matcher-character (character)
   #'(lambda ()
       (let ((char (peek)))
         (when char
           (char= char character)))))
 
 (declaim (ftype (function (simple-string) function) matcher-string))
 (defun matcher-string (string)
   (declare (simple-string string))
   (let ((len (length string)))
     #'(lambda ()
         (let ((len (+ *index* len)))
           (and (<= len *length*)
                (string= string *string* :start2 *index* :end2 len))))))
 
 (declaim (ftype (function ((or fixnum character string) (or fixnum character string)) function) matcher-range))
 (defun matcher-range (from to)
   (flet ((normalize (in) (etypecase in
                            (fixnum in)
                            (character (char-code in))
                            (simple-string (char-code (char in 0))))))
     (let ((from (normalize from))
           (to (normalize to)))
       #'(lambda ()
           (let ((char (peek)))
             (when char
               (<= from (char-code char) to)))))))
 
 (declaim (ftype (function (list) function) matcher-find))
 (defun matcher-find (list)
   #'(lambda ()
       (let ((char (peek)))
         (and char (member char list :test #'char=)))))
 
 (declaim (ftype (function (&rest function) function) matcher-or))
 (defun matcher-or (&rest matchers)
   #'(lambda ()
       (loop for matcher of-type function in matchers
             thereis (funcall matcher))))
 
 (declaim (ftype (function (&rest function) function) matcher-and))
 (defun matcher-and (&rest matchers)
   #'(lambda ()
       (loop for matcher of-type function in matchers
             always (funcall matcher))))
 
 (declaim (ftype (function (function) function) matcher-not))
 (defun matcher-not (matcher)
   (declare (function matcher))
   #'(lambda ()
       (not (funcall matcher))))
 
 (declaim (ftype (function (function) function) matcher-next))
 (defun matcher-next (matcher)
   #'(lambda ()
       (let ((*index* (1+ *index*)))
         (when (< *index* *length*)
           (funcall matcher)))))
 
 (declaim (ftype (function (function) function) matcher-prev))
 (defun matcher-prev (matcher)
   #'(lambda ()
       (let ((*index* (1- *index*)))
         (when (<= 0 *index*)
           (funcall matcher)))))
 
 (defmacro matcher-any (&rest is)
   `(matcher-or ,@(loop for i in is
                        collect `(,(typecase i
                                     (string 'matcher-string)
                                     (character 'matcher-character)
                                     (T 'matcher-string)) ,i))))
 
 (defmacro make-matcher (form)
   (labels ((transform (form)
              (etypecase form
                (keyword
                 `(gethash ',form *matchers*))
                (atom form)
                (T
                 (cons
                  (case (find-symbol (string (car form)) "PARSE/LEX")
                    (not 'matcher-not)
                    (and 'matcher-and)
                    (or 'matcher-or)
                    (is (typecase (second form)
                          (string 'matcher-string)
                          (character 'matcher-character)
                          (T 'matcher-string)))
                    (in 'matcher-range)
                    (next 'matcher-next)
                    (prev 'matcher-prev)
                    (any 'matcher-any)
                    (find 'matcher-find)
                    (T (car form)))
                  (mapcar #'transform (cdr form)))))))
     (transform form)))
 
 (defmacro define-matcher (name form)
   `(setf (gethash ,(intern (string name) "KEYWORD") *matchers*) (make-matcher ,form)))