Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19301
Modified Files: gui.lisp kill-ring.lisp packages.lisp Log Message: Tiding up a kill ring warning and move buffer related material to gui.lisp Date: Wed Dec 29 08:06:46 2004 Author: ejohnson
Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.28 climacs/gui.lisp:1.29 --- climacs/gui.lisp:1.28 Wed Dec 29 07:58:53 2004 +++ climacs/gui.lisp Wed Dec 29 08:06:46 2004 @@ -345,6 +345,31 @@ ;; outputs to inputs and inputs to outputs. Copying into a buffer ;; first requires coping out of the kill ring.
+(defgeneric kr-copy-in (buffer kr offset1 offset2) + (:documentation "Non destructively copies in buffer region to the kill ring")) + +(defmethod kr-copy-in ((buffer standard-buffer) (kr kill-ring) offset1 offset2) + (kr-push kr (buffer-sequence buffer offset1 offset2))) + +(defgeneric kr-cut-in (buffer kr offset1 offset2) + (:documentation "Destructively cut a given buffer region into the kill-ring")) + +(defmethod kr-cut-in ((buffer standard-buffer) (kr kill-ring) offset1 offset2) + (kr-copy-in buffer kr offset1 offset2) + (climacs-buffer::delete-buffer-range buffer offset1 (- offset2 offset1))) + +(defgeneric kr-copy-out (mark kr) + (:documentation "Copies an element from a kill-ring to a buffer at the given offset")) + +(defmethod kr-copy-out ((mark standard-right-sticky-mark)(kr kill-ring)) + (insert-sequence mark (kr-copy kr))) + +(defgeneric kr-cut-out (mark kr) + (:documentation "Cuts an element from a kill-ring out to a buffer at a given offset")) + +(defmethod kr-cut-out ((mark standard-right-sticky-mark) (kr kill-ring)) + (insert-sequence mark (kr-pop kr))) + (define-command com-copy-in () (kr-copy-out (point (win *application-frame*)) *kill-ring*))
@@ -375,7 +400,6 @@ (define-command com-kr-resize () (let ((size (accept 'fixnum :prompt "New kill ring size: "))) (kr-resize *kill-ring* size))) -
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;
Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.1 climacs/kill-ring.lisp:1.2 --- climacs/kill-ring.lisp:1.1 Wed Dec 29 06:45:37 2004 +++ climacs/kill-ring.lisp Wed Dec 29 08:06:46 2004 @@ -39,23 +39,27 @@ :max-size size :flexichain (make-instance 'standard-flexichain)))
-;; Didn't see a real reason to make gf's for these.
-(defun kr-length (kr) - "Returns the length of a kill-rings flexichain" +(defgeneric kr-length (kr) + (:documentation "Returns the length of a kill-ring's flexichain")) + +(defmethod kr-length ((kr kill-ring)) (nb-elements (kr-flexi kr)))
-(defun kr-resize (kr size) - "Resize a kill-ring to the value of size" - (kr-p kr) +(defgeneric kr-resize (kr size) + (:documentation "Resize a kill ring to the value of SIZE")) + +(defmethod kr-resize ((kr kill-ring) size) (setf (slot-value kr 'max-size) size) (let ((len (kr-length kr))) (if (> len size) (loop for n from 1 to (- len size) do (pop-end (kr-flexi kr))))))
-(defun kr-push (kr object) - "Push an object onto a kill-ring with size considerations" +(defgeneric kr-push (kr object) + (:documentation "Push an object onto a kill ring with size considerations")) + +(defmethod kr-push ((kr kill-ring) object) (let ((flexi (kr-flexi kr))) (if (>= (kr-length kr)(kr-max-size kr)) ((lambda (flex obj) @@ -64,37 +68,27 @@ flexi object) (push-start flexi object))))
-(defun kr-pop (kr) - "Pops an object off of a kill-ring" +(defgeneric kr-pop (kr) + (:documentation "Pops an object off of a kill ring")) + +(defmethod kr-pop ((kr kill-ring)) (if (> (nb-elements (kr-flexi kr)) 0) (pop-start (kr-flexi kr)) nil))
-(defun kr-rotate (kr &optional (n -1)) - "Rotates the kill-ring either once forward or an optional amount +/-" +(defgeneric kr-rotate (kr &optional n) + (:documentation "Rotates the kill ring either once forward or an optional amound +/-")) + +(defmethod kr-rotate ((kr kill-ring) &optional (n -1)) (assert (typep n 'fixnum)(n) "Can not rotate the kill ring ~S positions" n) (let ((flexi (kr-flexi kr))) (rotate flexi n)))
-(defun kr-copy (kr) - "Copies out a member of a kill-ring without deleting it" +(defgeneric kr-copy (kr) + (:documentation "Copies out a member of a kill ring without deleting it")) + +(defmethod kr-copy ((kr kill-ring)) (let ((object (kr-pop kr))) (kr-push kr object) object))
-(defun kr-copy-in (buffer kr offset1 offset2) - "Non destructively copies in buffer region to the kill-ring" - (kr-push kr (buffer-sequence buffer offset1 offset2))) - -(defun kr-cut-in (buffer kr offset1 offset2) - "Destructively cuts a given buffer region into the kill-ring" - (kr-copy-in buffer kr offset1 offset2) - (climacs-buffer::delete-buffer-range buffer offset1 (- offset2 offset1))) - -(defun kr-copy-out (mark kr) - "Copies an element from a kill-ring to a buffer at the given offset" - (insert-sequence mark (kr-copy kr))) - -(defun kr-cut-out (mark kr) - "Cuts an element from a kill-ring out to a buffer at a given offset" - (insert-sequence mark (kr-pop kr))) \ No newline at end of file
Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.13 climacs/packages.lisp:1.14 --- climacs/packages.lisp:1.13 Wed Dec 29 07:58:53 2004 +++ climacs/packages.lisp Wed Dec 29 08:06:46 2004 @@ -62,9 +62,9 @@
(defpackage :climacs-kill-ring (:use :clim-lisp :climacs-buffer :flexichain) - (:export #:initialize-kill-ring #:kr-length #:kr-resize - #:kr-rotate #:kr-copy-in #:kr-cut-in #:kr-copy-out - #:kr-cut-out)) + (:export #:initialize-kill-ring #:kr-length + #:kr-resize #:kr-rotate #:kill-ring + #:kr-copy #:kr-push #:kr-pop))
(defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-kill-ring))