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

Diff of /climacs/gui.lisp

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

revision 1.49 by rstrandh, Fri Jan 7 07:26:24 2005 UTC revision 1.50 by ejohnson, Fri Jan 7 13:07:45 2005 UTC
# Line 128  Line 128 
128                 (setf table (command-menu-item-value item)))                 (setf table (command-menu-item-value item)))
129          finally (return item)))          finally (return item)))
130    
131  (defvar *kill-ring* (initialize-kill-ring 7))  (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
132  (defparameter *current-gesture* nil)  (defparameter *current-gesture* nil)
133    
134  (defun meta-digit (gesture)  (defun meta-digit (gesture)
# 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    (kill-line (point (win *application-frame*))))    (let* ((payne (win *application-frame*))
351             (pnt (point payne)))
352        (if (and (beginning-of-buffer-p pnt)
353                 (end-of-line-p pnt))
354            NIL
355            (let ((mrk (offset pnt)))
356              (end-of-line pnt)
357              (if (end-of-buffer-p pnt)
358                  nil
359                 (forward-object pnt))
360              (if (eq (previous-command payne) 'com-kill-line)
361                  (kill-ring-concatenating-push *kill-ring*
362                                                (region-to-sequence mrk pnt))
363                  (kill-ring-standard-push *kill-ring*
364                                           (region-to-sequence mrk pnt)))
365              (delete-region mrk pnt)))))
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 552  Line 567 
567  ;; Kill ring commands  ;; Kill ring commands
568    
569  ;; Copies an element from a kill-ring to a buffer at the given offset  ;; Copies an element from a kill-ring to a buffer at the given offset
570  (define-named-command com-copy-in ()  (define-named-command com-yank ()
571    (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*)))    (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*)))
   
 ;; Cuts an element from a kill-ring out to a buffer at a given offset  
 (define-named-command com-cut-in ()  
   (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*)))  
572    
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       (if (< (offset point) (offset mark))       (let ((offp (offset point))
577           ((lambda (b o1 o2)             (offm (offset mark)))
578              (kr-push *kill-ring* (buffer-sequence b o1 o2))         (if (< offp offm)
579              (delete-buffer-range b o1 (- o2 o1)))             ((lambda (b o1 o2)
580            buffer (offset point) (offset mark))                (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2))
581           ((lambda (b o1 o2)                (delete-buffer-range b o1 (- o2 o1)))
582              (kr-push *kill-ring* (buffer-sequence b o2 o1))              buffer offp offm)
583              (delete-buffer-range b o1 (- o2 o1)))             ((lambda (b o1 o2)
584            buffer (offset mark) (offset point)))))                (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1))
585                  (delete-buffer-range b o1 (- o2 o1)))
586                buffer offm offp)))))
587    
588    
589  ;; Non destructively copies in buffer region to the kill ring  ;; Non destructively copies in buffer region to the kill ring
# Line 579  Line 592 
592       (let ((off1 (offset point))       (let ((off1 (offset point))
593             (off2 (offset mark)))             (off2 (offset mark)))
594         (if (< off1 off2)         (if (< off1 off2)
595             (kr-push *kill-ring* (buffer-sequence buffer off1 off2))             (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2))
596             (kr-push *kill-ring* (buffer-sequence buffer off2 off1))))))             (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1))))))
597    
598    
599  ;; Needs adjustment to be like emacs M-y  (define-named-command com-rotate-yank ()
600  (define-named-command com-kr-rotate ()    (let* ((payne (win *application-frame*))
601    (kr-rotate *kill-ring* -1))           (pnt (point payne))
602             (last-yank (kill-ring-yank *kill-ring*)))
603        (if (eq (previous-command payne)
604                'com-rotate-yank)
605            ((lambda (p ly)
606               (delete-range p (* -1 (length ly)))
607               (rotate-yank-position *kill-ring*))
608             pnt last-yank))
609        (insert-sequence pnt (kill-ring-yank *kill-ring*))))
610    
611  ;; Not bound to a key yet  (define-named-command com-resize-kill-ring ()
 (define-named-command com-kr-resize ()  
612    (let ((size (accept 'integer :prompt "New kill ring size")))    (let ((size (accept 'integer :prompt "New kill ring size")))
613      (kr-resize *kill-ring* size)))      (setf (kill-ring-max-size *kill-ring*) size)))
614    
615  (define-named-command com-search-forward ()  (define-named-command com-search-forward ()
616    (search-forward (point (win *application-frame*))    (search-forward (point (win *application-frame*))
# Line 666  Line 687 
687  (global-set-key '(#\k :control) 'com-kill-line)  (global-set-key '(#\k :control) 'com-kill-line)
688  (global-set-key '(#\t :control) 'com-transpose-objects)  (global-set-key '(#\t :control) 'com-transpose-objects)
689  (global-set-key '(#\Space :control) 'com-set-mark)  (global-set-key '(#\Space :control) 'com-set-mark)
690  (global-set-key '(#\y :control) 'com-copy-in)  (global-set-key '(#\y :control) 'com-yank)
691  (global-set-key '(#\w :control) 'com-cut-out)  (global-set-key '(#\w :control) 'com-cut-out)
692  (global-set-key '(#\f :meta) 'com-forward-word)  (global-set-key '(#\f :meta) 'com-forward-word)
693  (global-set-key '(#\b :meta) 'com-backward-word)  (global-set-key '(#\b :meta) 'com-backward-word)
694  (global-set-key '(#\t :meta) 'com-transpose-words)  (global-set-key '(#\t :meta) 'com-transpose-words)
695  (global-set-key '(#\x :meta) 'com-extended-command)  (global-set-key '(#\x :meta) 'com-extended-command)
696  (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only  (global-set-key '(#\y :meta) 'com-rotate-yank)
697  (global-set-key '(#\w :meta) 'com-copy-out)  (global-set-key '(#\w :meta) 'com-copy-out)
698  (global-set-key '(#\v :control) 'com-page-down)  (global-set-key '(#\v :control) 'com-page-down)
699  (global-set-key '(#\v :meta) 'com-page-up)  (global-set-key '(#\v :meta) 'com-page-up)

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.50

  ViewVC Help
Powered by ViewVC 1.1.5