Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2151
Modified Files: abbrev.lisp gui.lisp Log Message: Prelimary code for reading numeric argument. However, I suspect a bug in McCLIM with respect to unread-gesture, so waiting for a fix for that before actually using the code.
Date: Fri Dec 31 07:39:22 2004 Author: rstrandh
Index: climacs/abbrev.lisp diff -u climacs/abbrev.lisp:1.4 climacs/abbrev.lisp:1.5 --- climacs/abbrev.lisp:1.4 Thu Dec 23 09:00:33 2004 +++ climacs/abbrev.lisp Fri Dec 31 07:39:21 2004 @@ -52,10 +52,7 @@
(defun string-upper-case-p (string) "A predicate testing if each character of a string is uppercase." - (loop for c across string - unless (upper-case-p c) - do (return nil) - finally (return t))) + (every #'upper-case-p string))
(defmethod expand-abbrev (word (expander dictionary-abbrev-expander)) "Expands an abbrevated word by attempting to assocate it with a member of
Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.35 climacs/gui.lisp:1.36 --- climacs/gui.lisp:1.35 Thu Dec 30 11:42:45 2004 +++ climacs/gui.lisp Fri Dec 31 07:39:21 2004 @@ -117,6 +117,43 @@ (defvar *kill-ring* (initialize-kill-ring 7)) (defparameter *current-gesture* nil)
+(defun meta-digit (gesture) + (position gesture + '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta) + (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) + :test #'event-matches-gesture-name-p)) + +(defun read-numeric-argument (&key (stream *standard-input*)) + (let ((gesture (read-gesture :stream stream))) + (cond ((event-matches-gesture-name-p gesture '(#\u :control)) + (let ((numarg 4)) + (loop for gesture = (read-gesture :stream stream) + while (event-matches-gesture-name-p gesture '(#\u :control)) + do (setf numarg (* 4 numarg)) + finally (unread-gesture gesture :stream stream)) + (let ((gesture (read-gesture :stream stream))) + (cond ((and (characterp gesture) + (digit-char-p gesture 10)) + (setf numarg (- (char-code gesture) (char-code #\0))) + (loop for gesture = (read-gesture :stream stream) + while (and (characterp gesture) + (digit-char-p gesture 10)) + do (setf gesture (+ (* 10 numarg) + (- (char-code gesture) (char-code #\0)))) + finally (unread-gesture gesture :stream stream) + (return (values numarg t)))) + (t + (values numarg t)))))) + ((meta-digit gesture) + (let ((numarg (meta-digit gesture))) + (loop for gesture = (read-gesture :stream stream) + while (meta-digit gesture) + do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) + finally (unread-gesture gesture :stream stream) + (return (values numarg t))))) + (t (unread-gesture gesture :stream stream) + (values 1 nil))))) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -128,6 +165,7 @@ (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) (loop with gestures = '() + with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) do (setf *current-gesture* (read-gesture :stream *standard-input*)) (when (or (characterp *current-gesture*) (and (typep *current-gesture* 'keyboard-event) @@ -145,12 +183,16 @@ (cond ((not item) (beep) (setf gestures '())) ((eq (command-menu-item-type item) :command) - (handler-case - (funcall (command-menu-item-value item)) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf gestures '())) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf gestures '()))) (t nil)))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer)