Commit 49323b25 authored by Robert Strandh's avatar Robert Strandh

Changed the contract of clone mark so that the optional argument is

either :left or :right forcing the return value to be a
left-sticky-mark and a right-sticky-mark respectively.

Altered the two calls (in test code) that actually used the optional
argument to pass the right thing.

Modified the implementation of clone-mark to use constant symbols for
the class to instantiate, and made two methods so that the type of the
argument will be known statically.  Still needed an explicit test for
the optional argument, but that is still much faster than using a
variable class to make-instance.
parent cf174036
......@@ -77,8 +77,8 @@
(high (slot-value buffer 'high-mark))
(low2 (clone-mark low))
(high2 (clone-mark high))
(low3 (clone-mark high %%left-sticky-mark))
(high3 (clone-mark low %%right-sticky-mark)))
(low3 (clone-mark high :left))
(high3 (clone-mark low :right)))
(and (reduce #'%all-eq
(list (class-of low) (class-of low2) (class-of low3)))
(reduce #'%all-eq
......
......@@ -179,14 +179,29 @@ made to move a mark after the end of the buffer."))
(setf low-mark (make-instance 'standard-left-sticky-mark :buffer buffer))
(setf high-mark (make-instance 'standard-right-sticky-mark :buffer buffer))))
(defgeneric clone-mark (mark &optional type)
(:documentation "Clone a mark. By default (when type is NIL) the same type of mark is
returned. Otherwise type is the name of a class (subclass of the mark
class) to be used as a class of the clone."))
(defmethod clone-mark ((mark mark) &optional type)
(make-instance (or type (class-of mark))
:buffer (buffer mark) :offset (offset mark)))
(defgeneric clone-mark (mark &optional stick-to)
(:documentation "Clone a mark. By default (when stick-to is NIL)
the same type of mark is returned. Otherwise stick-to is either :left
or :right indicating whether a left-sticky or a right-sticky mark
should be created."))
(defmethod clone-mark ((mark standard-left-sticky-mark) &optional stick-to)
(cond ((or (null stick-to) (eq stick-to :left))
(make-instance 'standard-left-sticky-mark
:buffer (buffer mark) :offset (offset mark)))
((eq stick-to :right)
(make-instance 'standard-right-sticky-mark
:buffer (buffer mark) :offset (offset mark)))
(t (error "invalid value for stick-to"))))
(defmethod clone-mark ((mark standard-right-sticky-mark) &optional stick-to)
(cond ((or (null stick-to) (eq stick-to :right))
(make-instance 'standard-right-sticky-mark
:buffer (buffer mark) :offset (offset mark)))
((eq stick-to :left)
(make-instance 'standard-left-sticky-mark
:buffer (buffer mark) :offset (offset mark)))
(t (error "invalid value for stick-to"))))
(defgeneric size (buffer)
(:documentation "Return the number of objects in the buffer."))
......
......@@ -171,71 +171,71 @@ macro characters that start more complex expressions."))
(defun next-entry (scan)
(let ((start-mark (clone-mark scan)))
(flet ((make-entry (type)
(return-from next-entry
(make-instance type :start-mark start-mark :end-mark (clone-mark scan))))
(fo () (forward-object scan)))
(loop with object = (object-after scan)
until (end-of-buffer-p scan)
do (case object
(#\( (fo) (make-entry 'list-start-entry))
(#\) (fo) (make-entry 'list-end-entry))
(#\; (fo) (make-entry 'comment-entry))
(#\" (fo) (make-entry 'double-quote-entry))
(#\' (fo) (make-entry 'quote-entry))
(#\` (fo) (make-entry 'backquote-entry))
(#\, (fo) (make-entry 'unquote-entry))
(#\# (fo)
(loop until (end-of-buffer-p scan)
while (member (object-after scan)
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
do (fo))
(if (end-of-buffer-p scan)
(make-entry 'error-entry)
(case (object-after scan)
(#\# (fo) (make-entry 'label-ref-entry))
(#\= (fo) (make-entry 'label-entry))
(#\' (fo) (make-entry 'function-entry))
(#\| (fo) (make-entry 'balanced-comment-entry))
(#\+ (fo) (make-entry 'read-time-conditional-plus-entry))
(#\- (fo) (make-entry 'read-time-conditional-minus-entry))
(#\( (fo) (make-entry 'vector-entry))
(#\* (fo) (make-entry 'bitvector-entry))
(#\: (fo) (make-entry 'uninterned-symbol-entry))
(#\. (fo) (make-entry 'read-time-evaluation-entry))
((#\A #\a) (fo) (make-entry 'array-entry))
((#\B #\b) (fo) (make-entry 'binary-entry))
((#\C #\c) (fo) (make-entry 'complex-entry))
((#\O #\o) (fo) (make-entry 'octal-entry))
((#\P #\p) (fo) (make-entry 'pathname-entry))
((#\R #\r) (fo) (make-entry 'radix-n-entry))
((#\S #\s) (fo) (make-entry 'structure-entry))
((#\X #\x) (fo) (make-entry 'hex-entry))
(#\\ (fo)
(cond ((end-of-buffer-p scan)
(make-entry 'error-entry))
((not (constituentp (object-after scan)))
(fo)
(make-entry 'character-entry))
(t
(fo)
(loop until (end-of-buffer-p scan)
while (constituentp (object-after scan))
do (fo))
(make-entry 'character-entry))))
(t (make-entry 'error-entry)))))
(t (cond ((whitespacep object)
(loop until (end-of-buffer-p scan)
while (whitespacep (object-after scan))
do (fo))
(make-entry 'whitespace-entry))
((constituentp object)
(loop until (end-of-buffer-p scan)
while (constituentp (object-after scan))
do (fo))
(make-entry 'token-entry))
(t
(fo) (make-entry 'error-entry)))))))))
(flet ((fo () (forward-object scan)))
(macrolet ((make-entry (type)
`(return-from next-entry
(make-instance ,type :start-mark start-mark :end-mark (clone-mark scan)))))
(loop with object = (object-after scan)
until (end-of-buffer-p scan)
do (case object
(#\( (fo) (make-entry 'list-start-entry))
(#\) (fo) (make-entry 'list-end-entry))
(#\; (fo) (make-entry 'comment-entry))
(#\" (fo) (make-entry 'double-quote-entry))
(#\' (fo) (make-entry 'quote-entry))
(#\` (fo) (make-entry 'backquote-entry))
(#\, (fo) (make-entry 'unquote-entry))
(#\# (fo)
(loop until (end-of-buffer-p scan)
while (member (object-after scan)
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
do (fo))
(if (end-of-buffer-p scan)
(make-entry 'error-entry)
(case (object-after scan)
(#\# (fo) (make-entry 'label-ref-entry))
(#\= (fo) (make-entry 'label-entry))
(#\' (fo) (make-entry 'function-entry))
(#\| (fo) (make-entry 'balanced-comment-entry))
(#\+ (fo) (make-entry 'read-time-conditional-plus-entry))
(#\- (fo) (make-entry 'read-time-conditional-minus-entry))
(#\( (fo) (make-entry 'vector-entry))
(#\* (fo) (make-entry 'bitvector-entry))
(#\: (fo) (make-entry 'uninterned-symbol-entry))
(#\. (fo) (make-entry 'read-time-evaluation-entry))
((#\A #\a) (fo) (make-entry 'array-entry))
((#\B #\b) (fo) (make-entry 'binary-entry))
((#\C #\c) (fo) (make-entry 'complex-entry))
((#\O #\o) (fo) (make-entry 'octal-entry))
((#\P #\p) (fo) (make-entry 'pathname-entry))
((#\R #\r) (fo) (make-entry 'radix-n-entry))
((#\S #\s) (fo) (make-entry 'structure-entry))
((#\X #\x) (fo) (make-entry 'hex-entry))
(#\\ (fo)
(cond ((end-of-buffer-p scan)
(make-entry 'error-entry))
((not (constituentp (object-after scan)))
(fo)
(make-entry 'character-entry))
(t
(fo)
(loop until (end-of-buffer-p scan)
while (constituentp (object-after scan))
do (fo))
(make-entry 'character-entry))))
(t (make-entry 'error-entry)))))
(t (cond ((whitespacep object)
(loop until (end-of-buffer-p scan)
while (whitespacep (object-after scan))
do (fo))
(make-entry 'whitespace-entry))
((constituentp object)
(loop until (end-of-buffer-p scan)
while (constituentp (object-after scan))
do (fo))
(make-entry 'token-entry))
(t
(fo) (make-entry 'error-entry))))))))))
(defmethod update-syntax (buffer (syntax cl-syntax))
(let ((low-mark (low-mark buffer))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment