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))