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@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)