Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1713
Modified Files: gui.lisp kill-ring.lisp Log Message: Kill Ring clean up. Fixed com-cut-out bug and substituted my habitual use of lambdas for progn's Date: Fri Jan 7 19:58:08 2005 Author: ejohnson
Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.53 climacs/gui.lisp:1.54 --- climacs/gui.lisp:1.53 Fri Jan 7 16:01:20 2005 +++ climacs/gui.lisp Fri Jan 7 19:58:08 2005 @@ -347,22 +347,22 @@ (open-line (point (win *application-frame*))))
(define-named-command com-kill-line () - (let* ((payne (win *application-frame*)) - (pnt (point payne)) - (mrk (offset pnt))) - (if (end-of-line-p pnt) - (forward-object pnt) + (let* ((pane (win *application-frame*)) + (point (point pane)) + (mark (offset point))) + (if (end-of-line-p point) + (forward-object point) (progn - (end-of-line pnt) - (cond ((or (beginning-of-buffer-p pnt) - (end-of-buffer-p pnt)) nil) - ((beginning-of-line-p pnt)(forward-object pnt))))) - (if (eq (previous-command payne) 'com-kill-line) + (end-of-line point) + (cond ((or (beginning-of-buffer-p point) + (end-of-buffer-p point)) nil) + ((beginning-of-line-p point)(forward-object point))))) + (if (eq (previous-command pane) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mrk pnt)) + (region-to-sequence mark point)) (kill-ring-standard-push *kill-ring* - (region-to-sequence mrk pnt))) - (delete-region mrk pnt))) + (region-to-sequence mark point))) + (delete-region mark point)))
(define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) @@ -573,40 +573,35 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) - (let ((offp (offset point)) - (offm (offset mark))) - (if (< offp offm) - ((lambda (b o1 o2) - (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2)) - (delete-buffer-range b o1 (- o2 o1))) - buffer offp offm) - ((lambda (b o1 o2) - (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1)) - (delete-buffer-range b o1 (- o2 o1))) - buffer offm offp))))) + (let ((offset-point (offset point)) + (offset-mark (offset mark))) + (if (< offset-point offset-mark) + (progn + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-buffer-range buffer offset-point (- offset-mark offset-point ))) + (progn + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-buffer-range buffer offset-mark (- offset-point offset-mark)))))))
;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () - (with-slots (buffer point mark)(win *application-frame*) - (let ((off1 (offset point)) - (off2 (offset mark))) - (if (< off1 off2) - (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2)) - (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + (with-slots (point mark)(win *application-frame*) + (if (< (offset point) (offset mark)) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)))))
(define-named-command com-rotate-yank () - (let* ((payne (win *application-frame*)) - (pnt (point payne)) + (let* ((pane (win *application-frame*)) + (point (point pane)) (last-yank (kill-ring-yank *kill-ring*))) - (if (eq (previous-command payne) + (if (eq (previous-command pane) 'com-rotate-yank) - ((lambda (p ly) - (delete-range p (* -1 (length ly))) - (rotate-yank-position *kill-ring*)) - pnt last-yank)) - (insert-sequence pnt (kill-ring-yank *kill-ring*)))) + (progn + (delete-range point (* -1 (length last-yank))) + (rotate-yank-position *kill-ring*))) + (insert-sequence point (kill-ring-yank *kill-ring*))))
(define-named-command com-resize-kill-ring () (let ((size (accept 'integer :prompt "New kill ring size")))
Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.4 climacs/kill-ring.lisp:1.5 --- climacs/kill-ring.lisp:1.4 Fri Jan 7 14:07:45 2005 +++ climacs/kill-ring.lisp Fri Jan 7 19:58:08 2005 @@ -113,10 +113,9 @@ (let ((chain (kill-ring-chain kr))) (if (>= (kill-ring-length kr) (kill-ring-max-size kr)) - ((lambda (flex obj) - (pop-end flex) - (push-start flex obj)) - chain vector) + (progn + (pop-end chain) + (push-start chain vector)) (push-start chain vector))) (reset-yank-position kr))
@@ -132,5 +131,4 @@
(defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL)) (if reset (reset-yank-position kr)) - (element> (kill-ring-cursor kr))) - + (element> (kill-ring-cursor kr))) \ No newline at end of file