[climacs-cvs] CVS update: climacs/gui.lisp

[Alastair Bridgewater]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv23923

Modified Files:
	gui.lisp 
Log Message:
Added DEFINE-NAMED-COMMAND and converted most commands to use it.


Date: Thu Dec 30 06:37:34 2004
Author: abridgewater

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.33 climacs/gui.lisp:1.34
--- climacs/gui.lisp:1.33	Thu Dec 30 06:28:21 2004
+++ climacs/gui.lisp	Thu Dec 30 06:37:34 2004
@@ -157,7 +157,10 @@
 		 (setf (needs-saving buffer) t)))
 	     (redisplay-frame-panes frame))))
 
-(define-climacs-command (com-quit :name t) ()
+(defmacro define-named-command (command-name args &body body)
+  `(define-climacs-command ,(if (listp command-name) `(, at command-name :name t) `(,command-name :name t)) ,args , at body))
+
+(define-named-command (com-quit) ()
   (frame-exit *application-frame*))
 
 (define-command com-self-insert ()
@@ -165,49 +168,49 @@
     (possibly-expand-abbrev (point (win *application-frame*))))
   (insert-object (point (win *application-frame*)) *current-gesture*))
 
-(define-command com-backward-object ()
+(define-named-command com-backward-object ()
   (decf (offset (point (win *application-frame*)))))
 
-(define-command com-forward-object ()
+(define-named-command com-forward-object ()
   (incf (offset (point (win *application-frame*)))))
 
-(define-command com-beginning-of-line ()
+(define-named-command com-beginning-of-line ()
   (beginning-of-line (point (win *application-frame*))))
 
-(define-command com-end-of-line ()
+(define-named-command com-end-of-line ()
   (end-of-line (point (win *application-frame*))))
 
-(define-command com-delete-object ()
+(define-named-command com-delete-object ()
   (delete-range (point (win *application-frame*))))
 
-(define-command com-backward-delete-object ()
+(define-named-command com-backward-delete-object ()
   (delete-range (point (win *application-frame*)) -1))
 
-(define-command com-previous-line ()
+(define-named-command com-previous-line ()
   (previous-line (point (win *application-frame*))))
 
-(define-command com-next-line ()
+(define-named-command com-next-line ()
   (next-line (point (win *application-frame*))))
 
-(define-command com-open-line ()
+(define-named-command com-open-line ()
   (open-line (point (win *application-frame*))))
 
-(define-command com-kill-line ()
+(define-named-command com-kill-line ()
   (kill-line (point (win *application-frame*))))
 
-(define-command com-forward-word ()
+(define-named-command com-forward-word ()
   (forward-word (point (win *application-frame*))))
 
-(define-command com-backward-word ()
+(define-named-command com-backward-word ()
   (backward-word (point (win *application-frame*))))
 
-(define-command com-delete-word ()
+(define-named-command com-delete-word ()
   (delete-word (point (win *application-frame*))))
 
-(define-command com-backward-delete-word ()
+(define-named-command com-backward-delete-word ()
   (backward-delete-word (point (win *application-frame*))))
 
-(define-command com-toggle-layout ()
+(define-named-command com-toggle-layout ()
   (setf (frame-current-layout *application-frame*)
 	(if (eq (frame-current-layout *application-frame*) 'default)
 	    'with-interactor
@@ -296,7 +299,7 @@
       (concatenate 'string (pathname-name pathname)
 		   "." (pathname-type pathname))))
 
-(define-climacs-command (com-find-file :name t) ()
+(define-named-command com-find-file ()
   (let ((filename (accept 'completable-pathname
 			  :prompt "Find File")))
     (with-slots (buffer point syntax) (win *application-frame*)
@@ -313,7 +316,7 @@
        (redisplay-frame-panes *application-frame*)
        (beginning-of-buffer point))))
 
-(define-command com-save-buffer ()
+(define-named-command com-save-buffer ()
   (let* ((buffer (buffer (win *application-frame*)))
 	 (filename (or (filename buffer)
 		       (accept 'completable-pathname
@@ -328,7 +331,7 @@
 	(display-message "No changes need to be saved from ~a" (name buffer)))
     (setf (needs-saving buffer) nil)))
 
-(define-command com-write-buffer ()
+(define-named-command com-write-buffer ()
   (let ((filename (accept 'completable-pathname
 			  :prompt "Write Buffer to File"))
 	(buffer (buffer (win *application-frame*))))
@@ -339,24 +342,24 @@
 	  (needs-saving buffer) nil)
     (display-message "Wrote: ~a" (filename buffer))))
 
-(define-command com-beginning-of-buffer ()
+(define-named-command com-beginning-of-buffer ()
   (beginning-of-buffer (point (win *application-frame*))))
 
-(define-command com-end-of-buffer ()
+(define-named-command com-end-of-buffer ()
   (end-of-buffer (point (win *application-frame*))))
 
-(define-command com-back-to-indentation ()
+(define-named-command com-back-to-indentation ()
   (let ((point (point (win *application-frame*))))
     (beginning-of-line point)
     (loop until (end-of-line-p point)
 	  while (whitespacep (object-after point))
 	  do (incf (offset point)))))
 
-(define-climacs-command (com-goto-position :name t) ()
+(define-named-command com-goto-position ()
   (setf (offset (point (win *application-frame*)))
 	(accept 'integer :prompt "Goto Position")))
 
-(define-climacs-command (com-goto-line :name t) ()
+(define-named-command com-goto-line ()
   (loop with mark = (make-instance 'standard-right-sticky-mark
 		       :buffer (buffer (win *application-frame*)))
 	do (end-of-line mark)
@@ -368,10 +371,10 @@
 		(setf (offset (point (win *application-frame*)))
 		      (offset mark))))
 
-(define-climacs-command (com-browse-url :name t) ()
+(define-named-command com-browse-url ()
   (accept 'url :prompt "Browse URL"))
 
-(define-command com-set-mark ()
+(define-named-command com-set-mark ()
   (with-slots (point mark) (win *application-frame*)
 	      (setf mark (clone-mark point))))
 
@@ -379,15 +382,15 @@
 ;; Kill ring commands
 
 ;; Copies an element from a kill-ring to a buffer at the given offset
-(define-command com-copy-in ()
+(define-named-command com-copy-in ()
   (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*)))
 
 ;; Cuts an element from a kill-ring out to a buffer at a given offset
-(define-command com-cut-in ()
+(define-named-command com-cut-in ()
   (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*)))
 
 ;; Destructively cut a given buffer region into the kill-ring
-(define-command com-cut-out ()
+(define-named-command com-cut-out ()
   (with-slots (buffer point mark)(win *application-frame*)
      (if (< (offset point) (offset mark))
 	 ((lambda (b o1 o2)
@@ -401,7 +404,7 @@
 	     
 
 ;; Non destructively copies in buffer region to the kill ring
-(define-command com-copy-out ()
+(define-named-command com-copy-out ()
   (with-slots (buffer point mark)(win *application-frame*)
      (let ((off1 (offset point))
 	   (off2 (offset mark)))
@@ -410,11 +413,11 @@
 	   (kr-push *kill-ring* (buffer-sequence buffer off2 off1))))))
 
 ;; Needs adjustment to be like emacs M-y
-(define-command com-kr-rotate ()
+(define-named-command com-kr-rotate ()
   (kr-rotate *kill-ring* -1))     
 
 ;; Not bound to a key yet
-(define-command com-kr-resize ()
+(define-named-command com-kr-resize ()
   (let ((size (accept 'fixnum :prompt "New kill ring size: ")))
     (kr-resize *kill-ring* size)))