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

[Christophe Rhodes]

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

Modified Files:
	gui.lisp 
Log Message:
Implement, basically from Tim Moore, a command input context for the climacs
top level.  (This allows presentation-to-command translators to be clickable)

Date: Tue Feb 22 12:01:42 2005
Author: crhodes

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.120 climacs/gui.lisp:1.121
--- climacs/gui.lisp:1.120	Tue Feb 22 09:29:03 2005
+++ climacs/gui.lisp	Tue Feb 22 12:01:38 2005
@@ -249,57 +249,65 @@
   (substitute numargp *numeric-argument-p* command :test #'eq))
 
 (defun climacs-top-level (frame &key
-			  command-parser command-unparser 
-			  partial-command-parser prompt)
+                          command-parser command-unparser
+                          partial-command-parser prompt)
   (declare (ignore command-parser command-unparser partial-command-parser prompt))
   (with-slots (windows) frame
-     (setf windows (list (find-climacs-pane (find-pane-named frame 'win))))
-     (push (buffer (car windows)) (buffers frame))
-     (let ((*standard-output* (car windows))
-	   (*standard-input* (find-pane-named frame 'int))
-	   (*print-pretty* nil)
-	   (*abort-gestures* '((:keyboard #\g 512))))
-       (redisplay-frame-panes frame :force-p t)
-       (loop (handler-case 
-		 (loop for gestures = '()
-		       do (multiple-value-bind (numarg numargp)
-			      (read-numeric-argument :stream *standard-input*)
-			    (loop (setf *current-gesture* (climacs-read-gesture))
-				  (setf gestures (nconc gestures (list *current-gesture*)))
-				  (let ((item (find-gestures gestures 'global-climacs-table)))
-				    (cond ((not item)
-					   (beep) (return))
-					  ((eq (command-menu-item-type item) :command)
-					   (let ((command (command-menu-item-value item)))
-					     (unless (consp command)
-					       (setf command (list command)))
-					     (setf command (substitute-numeric-argument-marker command numarg))
-					     (setf command (substitute-numeric-argument-p command numargp))
-					     (handler-case 
-						 (execute-frame-command frame command)
-					       (error (condition)
-						 (beep)
-						 (format *error-output* "~a~%" condition)))
-					     (setf (previous-command *standard-output*)
-						   (if (consp command)
-						       (car command)
-						       command))
-					     (return)))
-					  (t nil))))
-			    (let ((buffer (buffer (current-window))))
-			      (when (modified-p buffer)
-				(setf (needs-saving buffer) t)))
-			    (when (null (remaining-keys *application-frame*))
-			      (setf (executingp *application-frame*) nil)
-			      (redisplay-frame-panes frame))))
-	       (abort-gesture () (display-message "Quit")))
-	     (beep)
-	     (let ((buffer (buffer (current-window))))
-	       (when (modified-p buffer)
-		 (setf (needs-saving buffer) t)))
-	     (when (null (remaining-keys *application-frame*))
-	       (setf (executingp *application-frame*) nil)
-	       (redisplay-frame-panes frame))))))
+    (setf windows (list (find-climacs-pane (find-pane-named frame 'win))))
+    (push (buffer (car windows)) (buffers frame))
+    (let ((*standard-output* (car windows))
+	  (*standard-input* (find-pane-named frame 'int))
+	  (*print-pretty* nil)
+	  (*abort-gestures* '((:keyboard #\g 512))))
+      (redisplay-frame-panes frame :force-p t)
+      (flet ((do-command (command)
+	       (handler-case
+		   (execute-frame-command frame command)
+		 (error (condition)
+		   (beep)
+		   (format *error-output* "~a~%" condition)))
+	       (setf (previous-command *standard-output*)
+		     (if (consp command)
+			 (car command)
+			 command)))
+	     (update-climacs ()
+	       (let ((buffer (buffer (current-window))))
+		 (when (modified-p buffer)
+		   (setf (needs-saving buffer) t)))
+	       (when (null (remaining-keys *application-frame*))
+		 (setf (executingp *application-frame*) nil)
+		 (redisplay-frame-panes frame))))
+	(loop
+	   for maybe-error = t
+	   do (handler-case
+		  (with-input-context ('(command
+					 :command-table 'global-climacs-table))
+		    (object)
+		    (loop
+		       for gestures = '()
+		       for numarg = (read-numeric-argument :stream *standard-input*)
+		       do (loop (setf *current-gesture* (climacs-read-gesture))
+			     (setf gestures (nconc gestures (list *current-gesture*)))
+			     (let ((item (find-gestures gestures 'global-climacs-table)))
+			       (cond ((not item)
+				      (beep) (return))
+				     ((eq (command-menu-item-type item) :command)
+				      (let ((command (command-menu-item-value item)))
+					(unless (consp command)
+					  (setf command (list command)))
+					(setf command (substitute-numeric-argument-marker command numarg))
+					(do-command command)
+					(return)))
+				     (t nil))))
+			 (update-climacs))
+		    (t
+		     (do-command object)
+		     (setq maybe-error nil)))
+		(abort-gesture ()
+		  (display-message "Quit")))
+	     (when maybe-error
+	       (beep))
+	     (update-climacs))))))
 
 (defmacro simple-command-loop (command-table loop-condition end-clauses)
   (let ((gesture (gensym))