[climacs-cvs] CVS update: climacs/gui.lisp climacs/kill-ring.lisp
Elliott Johnson
ejohnson at common-lisp.net
Fri Jan 7 18:58:10 UTC 2005
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
More information about the Climacs-cvs
mailing list