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

[Robert Strandh]

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

Modified Files:
	gui.lisp 
Log Message:
Implemented keyboard macros, except that there is a bug that
do not have time to track down right now, leaving an extra 'e' 
in the buffer.

Date: Wed Jan 19 06:38:48 2005
Author: rstrandh

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.84 climacs/gui.lisp:1.85
--- climacs/gui.lisp:1.84	Tue Jan 18 21:28:38 2005
+++ climacs/gui.lisp	Wed Jan 19 06:38:47 2005
@@ -50,7 +50,11 @@
 
 (define-application-frame climacs ()
   ((windows :accessor windows)
-   (buffers :initform '() :accessor buffers))
+   (buffers :initform '() :accessor buffers)
+   (recordingp :initform nil :accessor recordingp)
+   (executingp :initform nil :accessor executingp)
+   (recorded-keys :initform '() :accessor recorded-keys)
+   (remaining-keys :initform '() :accessor remaining-keys))
   (:panes
    (win (let* ((extended-pane 
 		(make-pane 'extended-pane
@@ -105,12 +109,15 @@
   (declare (ignore frame))
   (with-slots (climacs-pane) pane
      (let* ((buf (buffer climacs-pane))
-	    (name-info (format nil "   ~a   ~a   Syntax: ~a ~a"
+	    (name-info (format nil "   ~a   ~a   Syntax: ~a ~a    ~a"
 			       (if (needs-saving buf) "**" "--")
 			       (name buf)
 			       (name (syntax buf))
 			       (if (slot-value climacs-pane 'overwrite-mode)
 				   "Ovwrt"
+				   "")
+			       (if (recordingp *application-frame*)
+				   "Def"
 				   ""))))
        (princ name-info pane))))
 
@@ -139,8 +146,11 @@
 	    :test #'event-matches-gesture-name-p))
 
 (defun climacs-read-gesture ()
+  (unless (null (remaining-keys *application-frame*))
+    (return-from climacs-read-gesture
+      (pop (remaining-keys *application-frame*))))
   (loop for gesture = (read-gesture :stream *standard-input*)
-	when (event-matches-gesture-name-p gesture '(#\g :control))
+	when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME
 	  do (throw 'outer-loop nil)
 	until (or (characterp gesture)
 		  (and (typep gesture 'keyboard-event)
@@ -154,7 +164,16 @@
 					  :hyper-left :hyper-right
 					  :shift-lock :caps-lock
 					  :alt-left :alt-right))))))
-	finally (return gesture)))	  
+	finally (progn (when (recordingp *application-frame*)
+			 (push gesture (recorded-keys *application-frame*)))
+		       (return gesture))))
+
+(defun climacs-unread-gesture (gesture stream)
+  (cond ((recordingp *application-frame*)
+	 (pop (recorded-keys *application-frame*)))
+	((executingp *application-frame*)
+	 (push gesture (remaining-keys *application-frame*))))
+  (unread-gesture gesture :stream stream))
 
 (defun read-numeric-argument (&key (stream *standard-input*))
   (let ((gesture (climacs-read-gesture)))
@@ -163,7 +182,7 @@
 	     (loop for gesture = (climacs-read-gesture)
 		   while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
 		   do (setf numarg (* 4 numarg))
-		   finally (unread-gesture gesture :stream stream))
+		   finally (climacs-unread-gesture gesture stream))
 	     (let ((gesture (climacs-read-gesture)))
 	       (cond ((and (characterp gesture)
 			   (digit-char-p gesture 10))
@@ -173,19 +192,19 @@
 				       (digit-char-p gesture 10))
 			    do (setf numarg (+ (* 10 numarg)
 					       (- (char-code gesture) (char-code #\0))))
-			    finally (unread-gesture gesture :stream stream)
+			    finally (climacs-unread-gesture gesture stream)
 				    (return (values numarg t))))
 		     (t
-		      (unread-gesture gesture :stream stream)
+		      (climacs-unread-gesture gesture stream)
 		      (values numarg t))))))
 	  ((meta-digit gesture)
 	   (let ((numarg (meta-digit gesture)))
 	     (loop for gesture = (climacs-read-gesture)
 		   while (meta-digit gesture)
 		   do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
-		   finally (unread-gesture gesture :stream stream)
+		   finally (climacs-unread-gesture gesture stream)
 			   (return (values numarg t)))))
-	  (t (unread-gesture gesture :stream stream)
+	  (t (climacs-unread-gesture gesture stream)
 	     (values 1 nil)))))
 
 ;;; we know the vbox pane has a scroller pane and an info
@@ -237,12 +256,16 @@
 			(let ((buffer (buffer (current-window))))
 			  (when (modified-p buffer)
 			    (setf (needs-saving buffer) t)))
-			(redisplay-frame-panes frame)))
+			(when (null (remaining-keys *application-frame*))
+			  (setf (executingp *application-frame*) nil)
+			  (redisplay-frame-panes frame))))
 	     (beep)
 	     (let ((buffer (buffer (current-window))))
 	       (when (modified-p buffer)
 		 (setf (needs-saving buffer) t)))
-	     (redisplay-frame-panes frame)))))
+	     (when (null (remaining-keys *application-frame*))
+	       (setf (executingp *application-frame*) nil)
+	       (redisplay-frame-panes frame))))))
 
 (defun region-limits (pane)
   (if (mark< (mark pane) (point pane))
@@ -675,6 +698,25 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
+;;; Keyboard macros
+
+(define-named-command com-start-kbd-macro ()
+  (setf (recordingp *application-frame*) t)
+  (setf (recorded-keys *application-frame*) '()))
+
+(define-named-command com-end-kbd-macro ()
+  (setf (recordingp *application-frame*) nil)
+  (setf (recorded-keys *application-frame*)
+	;; this won't work if the command was invoked in any old way
+	(reverse (cddr (recorded-keys *application-frame*)))))
+
+(define-named-command com-call-last-kbd-macro ()
+  (setf (remaining-keys *application-frame*)
+	(recorded-keys *application-frame*))
+  (setf (executingp *application-frame*) t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
 ;;; Commands for splitting windows
 
 (defun replace-constellation (constellation additional-constellation vertical-p)
@@ -971,7 +1013,10 @@
 (c-x-set-key '(#\0) 'com-delete-window)
 (c-x-set-key '(#\2) 'com-split-window-vertically)
 (c-x-set-key '(#\3) 'com-split-window-horizontally)
+(c-x-set-key '(#\() 'com-start-kbd-macro)
+(c-x-set-key '(#\)) 'com-end-kbd-macro)
 (c-x-set-key '(#\b) 'com-switch-to-buffer)
+(c-x-set-key '(#\e) 'com-call-last-kbd-macro)
 (c-x-set-key '(#\c :control) 'com-quit)
 (c-x-set-key '(#\f :control) 'com-find-file)
 (c-x-set-key '(#\l :control) 'com-load-file)