Commit 7bbc5c01 authored by Troels Henriksen's avatar Troels Henriksen

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.
parent bd87934a
......@@ -1999,9 +1999,12 @@ contents with a sequence constructed of new and pre-existing SORP objects. This
latter method is refered to as a ``concatenating push''.
For data retrievial the kill ring class provides a ``yank point'' which
allows focus to be shifted from the SORP to other positions within the kill ring.
The yank point is limited to two types of motition, one being a rotation away from the SORP
and the other being an immediate return or ``reset'' to the start position.
allows focus to be shifted from the SORP to other positions within the
kill ring. The yank point is limited to two types of motition, one
being a rotation away from the SORP and the other being an immediate
return or ``reset'' to the start position. When the kill ring is
modified, for example by a push, the yank point will be reset to the
start position.
@section General
......@@ -2038,7 +2041,13 @@ will be removed from the ring until the maximum size is reached.
@deffn {generic function} kill-ring-concatenating-push kill-ring vector
Concatenates the contents of vector onto the end of the contents of
the current top of the kill-ring. If the kill-ring is empty, a new
entry is pushed..
entry is pushed.
@end deffn
@deffn {generic function} kill-ring-reverse-concatenating-push kill-ring vector
Concatenates the contents of vector onto the front of the current
contents of the top of the kill ring. If the kill ring is empty a new
entry is pushed.
@end deffn
@deffn {generic function} rotate-yank-position kill-ring &optional times
......@@ -2053,9 +2062,10 @@ the start of ring position.
@end deffn
@deffn {generic function} kill-ring-yank kill-ring &optional reset
Returns the vector of objects currently pointed to by the cursor. If reset is T, then a
call to reset-yank-position is called before the object is yanked. The default for reset
is NIL.
Returns the vector of objects currently pointed to by the cursor. If
reset is T, then 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.
@end deffn
@section Implementation
......
......@@ -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)
......
......@@ -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")
......
;;; (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)
\ No newline at end of file
......@@ -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 @@ of the current contents of the top of the kill ring. If the kill ring
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 @@ is empty a new entry is pushed."))
(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 @@ is empty a new entry is pushed."))
(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)))
......
......@@ -459,7 +459,7 @@ point at the beginning of the last line of the buffer."
(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 @@ objects in the kill ring."
(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
......
......@@ -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
......
......@@ -179,7 +179,7 @@ If found, leaves point before the word. If not, leaves point where it is."
(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))
......
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