cl-stream/parser-stream/parser.lisp

Branch - branch -master

• Show log

  Commit

• Hash : 6349554f
  Author : Thomas de Grivel
  Date : 2018-06-29T12:05:03
  

  Type declarations.

Download

• parser.lisp

• 
  (in-package :parser-stream)
  
  (defvar *buffer-size* 64)
  
  (deftype token-vector (&optional (size '*))
    `(array token (,size)))
  
  (defclass item ()
    ((tokens :initform #()
             :accessor item-tokens
             :type (simple-array token (*)))))
  
  (defgeneric item-character (item))
  (defgeneric item-line (item))
  (defgeneric item-token (item n))
  
  (defmethod item-token ((item item) (n integer))
    (declare (type fixnum n))
    (svref (item-tokens item) n))
  
  (defmethod item-line ((item item))
    (token-stream:token-line (item-token item 0)))
  
  (defmethod item-character ((item item))
    (token-stream:token-character (item-token item 0)))
  
  (defun make-buffer ()
    (make-array `(,*buffer-size*)
  	      :adjustable t
                :element-type '(or null item)
  	      :fill-pointer 0
                :initial-element nil))
  
  (defclass parser (super-stream input-stream)
    ((buffer :initform (make-buffer)
             :accessor parser-buffer
             :type token-vector)
     (eof-p :initform nil
            :accessor parser-eof-p
            :type boolean)
     (input-ended :initform nil
                  :accessor parser-input-ended
                  :type boolean)
     (match-start :initform 0
                  :accessor parser-match-start
                  :type fixnum)
     (stack :initform ()
            :accessor parser-stack
            :type list)))
  
  (defgeneric parser-parse (parser))
  
  (declaim (ftype (function (parser) token-vector) parser-buffer))
  (declaim (ftype (function (parser) fixnum) parser-match-start))
  
  (defmethod stream-element-type ((stream parser))
    'item)
  
  ;;  Input
  
  (defmethod parser-push-extend ((pr parser) item)
    (vector-push-extend item (parser-buffer pr) 64))
  
  (defmethod parser-token ((pr parser) (index integer))
    (declare (type fixnum index))
    (let ((buf (parser-buffer pr)))
      (when (< index (fill-pointer buf))
        (aref buf index))))
  
  (defmethod parser-input ((pr parser))
    (let ((in (stream-underlying-stream pr)))
      (multiple-value-bind (token state) (stream-read in)
        (ecase state
          ((nil) (parser-push-extend pr token)
           (values token nil))
          ((:eof) (setf (parser-input-ended pr) t)
           (values nil :eof))
          ((:non-blocking)
           (signal (make-condition 'non-blocking :stream pr)))))))
  
  (defmethod parser-input-n ((pr parser) (n integer))
    (declare (type fixnum n))
    (loop
       (let ((length (- (the fixnum (fill-pointer (parser-buffer pr)))
                        (parser-match-start pr))))
         (declare (type fixnum length))
         (unless (< length n)
           (return t))
         (when (parser-input-ended pr)
           (return))
         (parser-input pr))))
  
  (defmethod parser-match-token ((pr parser) (index integer))
    (declare (type fixnum index))
    (when (parser-input-n pr (the fixnum (1+ index)))
      (let ((buf (parser-buffer pr))
            (match-index (+ (parser-match-start pr)
                            index)))
        (declare (type fixnum match-index))
        (aref buf match-index))))
  
  ;;  Matcher
  
  (defmethod match ((pr parser) (type symbol))
    (let ((item (parser-match-token pr 0)))
      (when (and item (subtypep (type-of item) (find-class type)))
        (incf (parser-match-start pr))
        item)))
  
  (defmethod match-or ((pr parser) (types cons))
    (loop
       (when (endp types)
         (return))
       (let* ((type (pop types))
              (token (match pr type)))
         (when token
           (return token)))))
  
  (defmethod match-option ((pr parser) (f function))
    (or (funcall f pr)
        (parser-match-start pr)))
  
  (defmethod match-not ((pr parser) (f function))
    (let ((match-start (parser-match-start pr)))
      (cond ((or (funcall f pr)
                 (parser-input-ended pr))
             (setf (parser-match-start pr) match-start)
             nil)
            (t
             (let ((token (parser-match-token pr 0)))
               (when token
                 (incf (the fixnum (parser-match-start pr)))
                 token))))))
  
  (defmacro match-sequence (parser &body body)
    (let ((pr (gensym "PR-"))
  	(match-start (gensym "MATCH-START-"))
  	(result (gensym "RESULT-")))
      `(let* ((,pr ,parser)
  	    (,match-start (parser-match-start ,pr))
  	    (,result (progn ,@body)))
         (cond (,result
  	      ,result)
  	     (t
  	      (setf (parser-match-start ,pr) ,match-start)
  	      nil)))))
  
  (defmethod match-times ((pr parser) (f function) (min integer) (max integer))
    (declare (type fixnum min max))
    (match-sequence pr
      (let ((n 0))
        (loop
           (unless (< n max)
             (return (parser-match-start pr)))
           (unless (funcall f pr)
             (if (< n min)
                 (return nil)
                 (return (parser-match-start pr))))
           (incf n)))))
  
  (defmethod match-times ((pr parser) (f function) (min integer) (max null))
    (declare (type fixnum min))
    (match-sequence pr
      (let ((n 0))
        (declare (type fixnum n))
        (loop
           (unless (funcall f pr)
             (if (< n min)
                 (return nil)
                 (return (parser-match-start pr))))
           (incf n)))))
  
  (defmethod stream-read ((pr parser))
    (if (parser-eof-p pr)
        (values nil :eof)
        (handler-case (values (parser-parse pr) nil)
          (end-of-file () (values nil :eof))
          (non-blocking () (values nil :non-blocking)))))
  
  ;;  Item stack
  
  (defmethod parser-push ((pr parser))
    (push (parser-match-start pr) (parser-stack pr)))
  
  (defmethod parser-pop ((pr parser))
    (assert (parser-stack pr))
    (let* ((buffer (parser-buffer pr))
  	 (fp (fill-pointer buffer))
  	 (start (pop (parser-stack pr)))
  	 (match-start (parser-match-start pr))
           (tokens (subseq buffer start match-start))
           (item (make-instance 'item :tokens tokens)))
      (when (endp (parser-stack pr))
        (replace buffer buffer :start2 match-start :end2 fp)
        (setf (parser-match-start pr) 0
  	    (fill-pointer (parser-buffer pr)) (- fp match-start)))
      item))
  
  (defmethod parser-discard ((pr parser))
    (assert (parser-stack pr))
    (let* ((buffer (parser-buffer pr))
  	 (fp (fill-pointer buffer))
  	 (match-start (parser-match-start pr)))
      (pop (parser-stack pr))
      (when (endp (parser-stack pr))
        (replace buffer buffer :start2 match-start :end2 fp)
        (setf (parser-match-start pr) 0
  	    (fill-pointer buffer) (- fp match-start)))
      nil))
  

Download