[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Thu Jul 27 10:39:33 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv18840
Modified Files:
search-commands.lisp packages.lisp misc-commands.lisp
kill-ring.lisp climacs.asd buffer-test.lisp
Added Files:
kill-ring-test.lisp
Log Message:
Updated the kill ring protocol to signal a condition if a yank
operation is attempted on an empty kill ring, updated the kill ring
documentation, added kill ring tests to the test suite.
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/25 11:38:05 1.11
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/27 10:39:32 1.12
@@ -179,7 +179,7 @@
(let* ((pane (current-window))
(states (isearch-states pane))
(yank (handler-case (kill-ring-yank *kill-ring*)
- (flexichain:at-end-error ()
+ (empty-kill-ring ()
"")))
(string (concatenate 'string
(search-string (first states))
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/25 11:38:05 1.108
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/27 10:39:32 1.109
@@ -66,6 +66,7 @@
(defpackage :climacs-kill-ring
(:use :clim-lisp :flexichain)
(:export #:kill-ring
+ #:empty-kill-ring
#:kill-ring-length #:kill-ring-max-size
#:append-next-p
#:reset-yank-position #:rotate-yank-position #:kill-ring-yank
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/25 11:38:05 1.19
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/27 10:39:32 1.20
@@ -459,7 +459,7 @@
(define-command (com-yank :name t :command-table editing-table) ()
"Insert the objects most recently added to the kill ring at point."
(handler-case (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))
- (flexichain:at-end-error ()
+ (empty-kill-ring ()
(display-message "Kill ring is empty"))))
(set-key 'com-yank
@@ -503,7 +503,7 @@
(delete-range point (* -1 (length last-yank)))
(rotate-yank-position *kill-ring*)))
(insert-sequence point (kill-ring-yank *kill-ring*)))
- (flexichain:at-end-error ()
+ (empty-kill-ring ()
(display-message "Kill ring is empty"))))
(set-key 'com-rotate-yank
--- /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/07/24 16:33:16 1.10
+++ /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/07/27 10:39:32 1.11
@@ -36,6 +36,14 @@
:accessor append-next-p))
(:documentation "A class for all kill rings"))
+(define-condition empty-kill-ring (simple-error)
+ ()
+ (:report (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "The kill ring is empty")))
+ (:documentation "This condition is signaled whenever a yank
+ operation is performed on an empty kill ring."))
+
(defmethod initialize-instance :after((kr kill-ring) &rest args)
"Adds in the yankpoint"
(declare (ignore args))
@@ -82,10 +90,13 @@
is empty a new entry is pushed."))
(defgeneric kill-ring-yank (kr &optional reset)
- (:documentation "Returns the vector of objects currently pointed to
- by the cursor. If reset is T, a call to
- reset-yank-position is called befor the object is
- yanked. The default for reset is NIL"))
+ (:documentation "Returns the vector of objects currently
+ pointed to by the cursor. If reset is T, a
+ call to reset-yank-position is called before
+ the object is yanked. The default for reset
+ is NIL. If the kill ring is empty, a
+ condition of type `empty-kill-ring' is
+ signalled."))
(defmethod kill-ring-length ((kr kill-ring))
(nb-elements (kill-ring-chain kr)))
@@ -117,6 +128,7 @@
(setf (cursor-pos curs) pos))))
(defmethod kill-ring-standard-push ((kr kill-ring) vector)
+ (check-type vector vector)
(cond ((append-next-p kr)
(kill-ring-concatenating-push kr vector)
(setf (append-next-p kr) nil))
@@ -130,25 +142,31 @@
(reset-yank-position kr))))
(defmethod kill-ring-concatenating-push ((kr kill-ring) vector)
+ (check-type vector vector)
(let ((chain (kill-ring-chain kr)))
(if (zerop (kill-ring-length kr))
(push-start chain vector)
(push-start chain
(concatenate 'vector
(pop-start chain)
- vector))))
- (reset-yank-position kr))
+ vector)))
+ (reset-yank-position kr)))
(defmethod kill-ring-reverse-concatenating-push ((kr kill-ring) vector)
+ (check-type vector vector)
(let ((chain (kill-ring-chain kr)))
(if (zerop (kill-ring-length kr))
(push-start chain vector)
(push-start chain
(concatenate 'vector
vector
- (pop-start chain))))))
+ (pop-start chain))))
+ (reset-yank-position kr)))
(defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil))
+ (assert (plusp (kill-ring-length kr))
+ ()
+ (make-condition 'empty-kill-ring))
(if reset (reset-yank-position kr))
(element> (kill-ring-cursor kr)))
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/25 11:38:05 1.49
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/27 10:39:32 1.50
@@ -114,6 +114,7 @@
((:file "rt" :pathname #p"testing/rt.lisp")
(:file "buffer-test" :depends-on ("rt"))
(:file "base-test" :depends-on ("rt" "buffer-test"))
+ (:file "kill-ring-test" :depends-on ("buffer-test"))
(:module
"cl-automaton"
:depends-on ("rt")
--- /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/24 13:24:40 1.23
+++ /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/27 10:39:32 1.24
@@ -5,7 +5,8 @@
(cl:defpackage :climacs-tests
(:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion
- :climacs-editing :automaton :climacs-core))
+ :climacs-editing :automaton :climacs-core
+ :climacs-kill-ring))
(cl:in-package :climacs-tests)
--- /project/climacs/cvsroot/climacs/kill-ring-test.lisp 2006/07/27 10:39:33 NONE
+++ /project/climacs/cvsroot/climacs/kill-ring-test.lisp 2006/07/27 10:39:33 1.1
;;; (c) Copyright 2006 by Troels Henriksen (athas at sigkill.dk)
;;;
(in-package :climacs-tests)
(deftest kill-ring-sizing.test-1
(let* ((random-size (random 20))
(instance (make-instance 'kill-ring :max-size random-size)))
(eql (kill-ring-max-size instance)
random-size))
t)
(deftest kill-ring-sizing.test-2
(let* ((random-size (random 20))
(instance (make-instance 'kill-ring :max-size random-size)))
(setf (kill-ring-max-size instance)
(* random-size 2))
(eql (kill-ring-max-size instance)
(* random-size 2)))
t)
(deftest kill-ring-sizing.test-3
(let* ((random-size (1+ (random 20)))
(instance (make-instance 'kill-ring :max-size random-size)))
(not (eql (kill-ring-max-size instance)
(kill-ring-length instance))))
t)
(deftest kill-ring-standard-push.test-1
(let* ((random-size (min 3 (random 20)))
(instance (make-instance 'kill-ring :max-size random-size)))
(kill-ring-standard-push instance #(#\A))
(kill-ring-standard-push instance #(#\B))
(kill-ring-standard-push instance #(#\C))
(kill-ring-length instance))
3)
(deftest kill-ring-standard-push.test-2
(let* ((random-size (1+ (random 20)))
(instance (make-instance 'kill-ring :max-size random-size)))
(handler-case (kill-ring-standard-push instance nil)
(type-error ()
t)))
t)
(deftest kill-ring-standard-push.test-3
(let* ((instance (make-instance 'kill-ring :max-size 3)))
(kill-ring-standard-push instance #(#\A))
(kill-ring-standard-push instance #(#\B))
(kill-ring-standard-push instance #(#\C))
(kill-ring-standard-push instance #(#\D))
(kill-ring-standard-push instance #(#\E))
(values
(kill-ring-yank instance)
(progn
(rotate-yank-position instance)
(kill-ring-yank instance))
(progn
(rotate-yank-position instance)
(kill-ring-yank instance))))
#(#\E)
#(#\D)
#(#\C))
(deftest kill-ring-concatenating-push.test-1
(let* ((instance (make-instance 'kill-ring :max-size 3)))
(kill-ring-standard-push instance #(#\A))
(kill-ring-concatenating-push instance #(#\B))
(kill-ring-yank instance))
#(#\A #\B))
(deftest kill-ring-concatenating-push.test-2
(let* ((instance (make-instance 'kill-ring :max-size 5)))
(kill-ring-standard-push instance #(#\B))
(kill-ring-standard-push instance #(#\Space))
(kill-ring-standard-push instance #(#\A))
(rotate-yank-position instance 2)
(kill-ring-concatenating-push instance #(#\B #\C))
(kill-ring-yank instance))
#(#\A #\B #\C))
(deftest kill-ring-reverse-concatenating-push.test-1
(let* ((instance (make-instance 'kill-ring :max-size 3)))
(kill-ring-standard-push instance #(#\A))
(kill-ring-reverse-concatenating-push instance #(#\B))
(kill-ring-yank instance))
#(#\B #\A))
(deftest kill-ring-reverse-concatenating-push.test-2
(let* ((instance (make-instance 'kill-ring :max-size 5)))
(kill-ring-standard-push instance #(#\B))
(kill-ring-standard-push instance #(#\Space))
(kill-ring-standard-push instance #(#\A))
(rotate-yank-position instance 2)
(kill-ring-reverse-concatenating-push instance #(#\B #\C))
(kill-ring-yank instance))
#(#\B #\C #\A))
(deftest kill-ring-yank.test-1
(let* ((instance (make-instance 'kill-ring :max-size 5)))
(kill-ring-standard-push instance #(#\A))
(kill-ring-yank instance))
#(#\A))
(deftest kill-ring-yank.test-2
(let* ((instance (make-instance 'kill-ring :max-size 5)))
(kill-ring-standard-push instance #(#\A))
(values (kill-ring-yank instance)
(kill-ring-yank instance)))
#(#\A)
#(#\A))
(deftest kill-ring-yank.test-3
(let* ((instance (make-instance 'kill-ring :max-size 5)))
(handler-case (kill-ring-yank instance)
(empty-kill-ring ()
t)))
t)
More information about the Climacs-cvs
mailing list