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

[Robert Strandh]

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)