Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8126 Modified Files: buffer-test.lisp buffer.lisp cl-syntax.lisp Log Message: 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. Date: Fri Feb 25 08:11:25 2005 Author: rstrandh Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.15 climacs/buffer-test.lisp:1.16 --- climacs/buffer-test.lisp:1.15 Thu Feb 10 01:27:07 2005 +++ climacs/buffer-test.lisp Fri Feb 25 08:11:24 2005 @@ -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 Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.28 climacs/buffer.lisp:1.29 --- climacs/buffer.lisp:1.28 Wed Feb 23 19:15:32 2005 +++ climacs/buffer.lisp Fri Feb 25 08:11:24 2005 @@ -179,14 +179,29 @@ (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.")) +(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 mark) &optional type) - (make-instance (or type (class-of mark)) - :buffer (buffer mark) :offset (offset mark))) +(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.")) Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.1 climacs/cl-syntax.lisp:1.2 --- climacs/cl-syntax.lisp:1.1 Mon Feb 7 16:26:41 2005 +++ climacs/cl-syntax.lisp Fri Feb 25 08:11:24 2005 @@ -171,71 +171,71 @@ (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))