[climacs-cvs] CVS update: climacs/buffer-test.lisp climacs/buffer.lisp climacs/cl-syntax.lisp
Robert Strandh
rstrandh at common-lisp.net
Fri Feb 25 07:11:26 UTC 2005
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))
More information about the Climacs-cvs
mailing list