Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
205 lines (163 sloc) 7.92 KB
(in-package :parser-combinators)
(defparameter *tag-stack* nil)
(defclass context-front ()
((context :accessor context-of :initarg :context :initform nil)
(tags :accessor tags-of :initarg :tags :initform nil)))
(defclass context-common ()
((length :accessor length-of :initarg :length :initform 0)
(front :accessor front-of :initarg :front :initform (make-instance 'context-front))
(cache :accessor cache-of :initarg :cache :initform nil)
(seen-postions :accessor seen-postions-of :initarg :seen-position :initform (make-hash-table))))
(defclass context ()
((common :accessor common-of :initarg :common)
(position :accessor position-of :initarg :position :initform 0)))
(defmethod cache-of ((context context))
(cache-of (common-of context)))
(defmethod length-of ((context context))
(length-of (common-of context)))
(defmethod front-of ((context context))
(front-of (common-of context)))
(defmethod seen-positions-of ((context context))
(seen-postions-of (common-of context)))
(defmethod (setf front-of) (new-value (context context))
(setf (front-of (common-of context)) new-value))
(defmethod position-of ((context-front context-front))
(position-of (context-of context-front)))
(defmacro copy-context (context class &rest additional-arguments)
`(make-instance ,class
,@(iter (with default = (gensym))
(for (initarg accessor) in
'((:common common-of)
(:position position-of)))
(appending (when (eql (getf additional-arguments initarg default)
`(,initarg (,accessor ,context)))))
(defun note-position (context posn)
(declare (type (integer 0) posn))
(incf (gethash posn (seen-positions-of context) 0)))
(defgeneric context-peek (context))
(defgeneric make-context-at-position (base-context position))
(defmethod make-context-at-position :around ((context context) position)
(let ((cache (cache-of context)))
(note-position context position)
(etypecase cache
(null (call-next-method))
(vector (or (aref cache position)
(setf (aref cache position)
(hash-table (or (gethash position cache)
(setf (gethash position cache)
(defgeneric context-next (context)
(:method ((context context))
(make-context-at-position context (1+ (position-of context)))))
(defgeneric context-equal (context1 context2)
(:method ((context1 context) (context2 context))
(or (eq context1 context2)
(and (eq (common-of context1)
(common-of context2))
(eql (position-of context1)
(position-of context2))))))
(defgeneric context-greater (context1 context2)
(:method ((context1 context) (context2 context))
(and (eq (common-of context1)
(common-of context2))
(> (position-of context1)
(position-of context2)))))
(defgeneric update-front-context (context)
(:method ((context context))
(let ((front (front-of context)))
(cond ((or (null (context-of front))
(context-greater context (context-of front)))
(setf (context-of front) context
(tags-of front) (list *tag-stack*)))
((context-equal context (context-of front))
(push *tag-stack* (tags-of front)))))))
(defmethod context-peek :after ((context context))
(update-front-context context))
(defgeneric context-interval (context1 context2 &optional result-type)
(:method :before ((context1 context) (context2 context) &optional result-type)
(declare (ignore result-type))
(assert (eql (common-of context1)
(common-of context2)))
(assert (<= (position-of context1)
(position-of context2))))
(:method ((context1 context) (context2 context) &optional (result-type 'string))
(if (= (position-of context1) (position-of context2))
(coerce nil result-type)
(coerce (iter (for c initially context1 then (context-next c))
(until (eq c context2))
(collect (context-peek c)))
(defclass end-context (context)
(defgeneric end-context-p (context)
(:method ((context t))
(:method ((context end-context))
(defmethod context-next ((context end-context))
(error "Can't go past the end"))
(defmethod context-peek ((context end-context))
(warn "Trying to peek past the end.")
(defclass list-context (context)
((storage :accessor storage-of :initarg :storage)))
(defmethod make-context-at-position ((base-context list-context) position)
(assert (> position (position-of base-context)))
(assert (<= position (length-of base-context)))
(if (= position (length-of base-context))
(copy-context base-context 'end-context :position position)
(copy-context base-context 'list-context
:storage (nthcdr (- position (position-of base-context)) (storage-of base-context))
:position position)))
(defmethod context-peek ((context list-context))
(car (storage-of context)))
(defclass vector-context-common (context-common)
((storage :accessor storage-of :initarg :storage)))
(defclass vector-context (context)
(defmethod storage-of ((context vector-context))
(storage-of (common-of context)))
(defmethod make-context-at-position ((base-context vector-context) position)
(assert (<= position (length-of base-context)))
(if (= position (length-of base-context))
(copy-context base-context 'end-context :position position)
(copy-context base-context 'vector-context :position position)))
(defmethod context-peek ((context vector-context))
(aref (storage-of context) (position-of context)))
(defmethod context-interval ((context1 vector-context) (context2 vector-context) &optional (result-type 'string))
(let ((storage (storage-of context1)))
(coerce (subseq storage (position-of context1) (position-of context2)) result-type)))
(defmethod context-interval ((context1 vector-context) (context2 end-context) &optional (result-type 'string))
(let ((storage (storage-of context1)))
(coerce (subseq storage (position-of context1)) result-type)))
(defvar *default-context-cache* :vector)
(defun make-cache (cache-type length)
(ecase cache-type
((nil) nil)
(:vector (make-array (1+ length) :initial-element nil))
(:hashtable (make-hash-table))))
(defgeneric make-context (sequence &optional cache-type))
(defmethod make-context ((list list) &optional (cache-type *default-context-cache*))
(if (null list)
(make-instance 'end-context :common (make-instance 'context-common))
(make-instance 'list-context
:storage list
:common (make-instance 'context-common
:length (length list)
:cache (make-cache cache-type (length list))))))
(defmethod initialize-instance :around ((context context) &rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(let ((rest (call-next-method)))
(note-position context (slot-value rest 'position))
(defmethod make-context ((vector vector) &optional (cache-type *default-context-cache*))
(if (zerop (length vector))
(make-instance 'end-context :common (make-instance 'vector-context-common))
(make-instance 'vector-context
:common (make-instance 'vector-context-common
:storage vector
:length (length vector)
:cache (make-cache cache-type (length vector))))))