/[climacs]/climacs/gui.lisp
ViewVC logotype

Diff of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.53 by ejohnson, Fri Jan 7 15:01:20 2005 UTC revision 1.54 by ejohnson, Fri Jan 7 18:58:08 2005 UTC
# Line 347  Line 347 
347    (open-line (point (win *application-frame*))))    (open-line (point (win *application-frame*))))
348    
349  (define-named-command com-kill-line ()  (define-named-command com-kill-line ()
350    (let* ((payne (win *application-frame*))    (let* ((pane (win *application-frame*))
351           (pnt (point payne))           (point (point pane))
352           (mrk (offset pnt)))           (mark (offset point)))
353      (if (end-of-line-p pnt)      (if (end-of-line-p point)
354          (forward-object pnt)          (forward-object point)
355          (progn          (progn
356            (end-of-line pnt)            (end-of-line point)
357            (cond ((or (beginning-of-buffer-p pnt)            (cond ((or (beginning-of-buffer-p point)
358                       (end-of-buffer-p pnt)) nil)                       (end-of-buffer-p point)) nil)
359                  ((beginning-of-line-p pnt)(forward-object pnt)))))                  ((beginning-of-line-p point)(forward-object point)))))
360      (if (eq (previous-command payne) 'com-kill-line)      (if (eq (previous-command pane) 'com-kill-line)
361          (kill-ring-concatenating-push *kill-ring*          (kill-ring-concatenating-push *kill-ring*
362                                        (region-to-sequence mrk pnt))                                        (region-to-sequence mark point))
363          (kill-ring-standard-push *kill-ring*          (kill-ring-standard-push *kill-ring*
364                                 (region-to-sequence mrk pnt)))                                 (region-to-sequence mark point)))
365      (delete-region mrk pnt)))      (delete-region mark point)))
366    
367  (define-named-command com-forward-word ()  (define-named-command com-forward-word ()
368    (forward-word (point (win *application-frame*))))    (forward-word (point (win *application-frame*))))
# Line 573  Line 573 
573  ;; Destructively cut a given buffer region into the kill-ring  ;; Destructively cut a given buffer region into the kill-ring
574  (define-named-command com-cut-out ()  (define-named-command com-cut-out ()
575    (with-slots (buffer point mark)(win *application-frame*)    (with-slots (buffer point mark)(win *application-frame*)
576       (let ((offp (offset point))       (let ((offset-point (offset point))
577             (offm (offset mark)))             (offset-mark (offset mark)))
578         (if (< offp offm)         (if (< offset-point offset-mark)
579             ((lambda (b o1 o2)             (progn
580                (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2))               (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
581                (delete-buffer-range b o1 (- o2 o1)))               (delete-buffer-range buffer offset-point (- offset-mark offset-point )))
582              buffer offp offm)             (progn
583             ((lambda (b o1 o2)               (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))
584                (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1))               (delete-buffer-range buffer offset-mark (- offset-point offset-mark)))))))
               (delete-buffer-range b o1 (- o2 o1)))  
             buffer offm offp)))))  
585    
586    
587  ;; Non destructively copies in buffer region to the kill ring  ;; Non destructively copies in buffer region to the kill ring
588  (define-named-command com-copy-out ()  (define-named-command com-copy-out ()
589    (with-slots (buffer point mark)(win *application-frame*)    (with-slots (point mark)(win *application-frame*)
590       (let ((off1 (offset point))       (if (< (offset point) (offset mark))
591             (off2 (offset mark)))           (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
592         (if (< off1 off2)           (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)))))
            (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2))  
            (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1))))))  
593    
594    
595  (define-named-command com-rotate-yank ()  (define-named-command com-rotate-yank ()
596    (let* ((payne (win *application-frame*))    (let* ((pane (win *application-frame*))
597           (pnt (point payne))           (point (point pane))
598           (last-yank (kill-ring-yank *kill-ring*)))           (last-yank (kill-ring-yank *kill-ring*)))
599      (if (eq (previous-command payne)      (if (eq (previous-command pane)
600              'com-rotate-yank)              'com-rotate-yank)
601          ((lambda (p ly)          (progn
602             (delete-range p (* -1 (length ly)))            (delete-range point (* -1 (length last-yank)))
603             (rotate-yank-position *kill-ring*))            (rotate-yank-position *kill-ring*)))
604           pnt last-yank))      (insert-sequence point (kill-ring-yank *kill-ring*))))
     (insert-sequence pnt (kill-ring-yank *kill-ring*))))  
605    
606  (define-named-command com-resize-kill-ring ()  (define-named-command com-resize-kill-ring ()
607    (let ((size (accept 'integer :prompt "New kill ring size")))    (let ((size (accept 'integer :prompt "New kill ring size")))

Legend:
Removed from v.1.53  
changed lines
  Added in v.1.54

  ViewVC Help
Powered by ViewVC 1.1.5