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

Robert Strandh rstrandh at common-lisp.net
Wed Jan 12 16:41:19 UTC 2005


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

Modified Files:
	gui.lisp syntax.lisp 
Log Message:
  * added numeric arguments.  This feature requires a CVS version of McCLIM as
    of 2005-01-11.  Only a few commands take numeric arguments at the moment
    such as forward-object, backward-object, delete-object, and 
    backward-delete-object.  There are more to come.

  * the cursor display problem has been "fixed" by drawing a rectangle rather than
    a line.  This makes obsolete the hacky code for explicit rounding of cursor
    coordinates. 


Date: Wed Jan 12 17:41:17 2005
Author: rstrandh

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.61 climacs/gui.lisp:1.62
--- climacs/gui.lisp:1.61	Mon Jan 10 06:31:16 2005
+++ climacs/gui.lisp	Wed Jan 12 17:41:16 2005
@@ -71,15 +71,17 @@
 		   :name 'win
 		   :incremental-redisplay t
 		   :display-function 'display-win))
-    (info :application
-	  :width 900 :height 20 :max-height 20
-	  :name 'info :background +light-gray+
-	  :scroll-bars nil
-	  :incremental-redisplay t
-	  :display-function 'display-info)
-    (int (make-pane 'minibuffer-pane
-		    :width 900 :height 20 :max-height 20 :min-height 20
-		    :scroll-bars nil)))
+   
+   (info :application
+	 :width 900 :height 20 :max-height 20
+	 :name 'info :background +light-gray+
+	 :scroll-bars nil
+	 :borders nil
+	 :incremental-redisplay t
+	 :display-function 'display-info)
+   (int (make-pane 'minibuffer-pane
+		   :width 900 :height 20 :max-height 20 :min-height 20
+		   :scroll-bars nil)))
   (:layouts
    (default
        (vertically (:scroll-bars nil)
@@ -162,10 +164,10 @@
 
 (defun read-numeric-argument (&key (stream *standard-input*))
   (let ((gesture (climacs-read-gesture)))
-    (cond ((event-matches-gesture-name-p gesture '(#\u :control))
+    (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
 	   (let ((numarg 4))
 	     (loop for gesture = (climacs-read-gesture)
-		   while (event-matches-gesture-name-p gesture '(#\u :control))
+		   while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
 		   do (setf numarg (* 4 numarg))
 		   finally (unread-gesture gesture :stream stream))
 	     (let ((gesture (climacs-read-gesture)))
@@ -175,11 +177,12 @@
 		      (loop for gesture = (climacs-read-gesture)
 			    while (and (characterp gesture)
 				       (digit-char-p gesture 10))
-			    do (setf gesture (+ (* 10 numarg)
-						(- (char-code gesture) (char-code #\0))))
+			    do (setf numarg (+ (* 10 numarg)
+					       (- (char-code gesture) (char-code #\0))))
 			    finally (unread-gesture gesture :stream stream)
 				    (return (values numarg t))))
 		     (t
+		      (unread-gesture gesture :stream stream)
 		      (values numarg t))))))
 	  ((meta-digit gesture)
 	   (let ((numarg (meta-digit gesture)))
@@ -202,29 +205,29 @@
 	(*abort-gestures* nil))
     (redisplay-frame-panes frame :force-p t)
     (loop (catch 'outer-loop
-	    (loop with gestures = '()
-		  with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*)
-		  do (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) (setf gestures '()))
-			     ((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))
-				(handler-case 
-				    (execute-frame-command frame command)
-				  (error (condition)
-				    (beep)
-				    (format *error-output* "~a~%" condition)))
-				(setf gestures '())
-				(setf (previous-command *standard-output*)
-				      (if (consp command)
-					  (car command)
-					  command))))
-			     (t nil)))
+	    (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))
+				      (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 (win frame))))
 		       (when (modified-p buffer)
 			 (setf (needs-saving buffer) t)))
@@ -236,7 +239,9 @@
 	  (redisplay-frame-panes frame))))
 
 (defmacro define-named-command (command-name args &body body)
-  `(define-climacs-command ,(if (listp command-name) `(, at command-name :name t) `(,command-name :name t)) ,args , at body))
+  `(define-climacs-command ,(if (listp command-name)
+				`(, at command-name :name t)
+				`(,command-name :name t)) ,args , at body))
 
 (define-named-command (com-quit) ()
   (frame-exit *application-frame*))
@@ -260,11 +265,11 @@
 (define-named-command com-end-of-line ()
   (end-of-line (point (win *application-frame*))))
 
-(define-named-command com-delete-object ()
-  (delete-range (point (win *application-frame*))))
+(define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
+  (delete-range (point (win *application-frame*)) count))
 
-(define-named-command com-backward-delete-object ()
-  (delete-range (point (win *application-frame*)) -1))
+(define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
+  (delete-range (point (win *application-frame*)) (- count)))
 
 (define-named-command com-transpose-objects ()
   (let* ((point (point (win *application-frame*))))
@@ -277,11 +282,11 @@
        (insert-object point object)
        (forward-object point)))))
 
-(define-named-command com-backward-object ()
-  (backward-object (point (win *application-frame*))))
+(define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
+  (backward-object (point (win *application-frame*)) count))
 
-(define-named-command com-forward-object ()
-  (forward-object (point (win *application-frame*))))
+(define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
+  (forward-object (point (win *application-frame*)) count))
 
 (define-named-command com-transpose-words ()
   (let* ((point (point (win *application-frame*))))
@@ -676,11 +681,11 @@
 
 (global-set-key #\newline 'com-self-insert)
 (global-set-key #\tab 'com-self-insert)
-(global-set-key '(#\f :control) 'com-forward-object)
-(global-set-key '(#\b :control) 'com-backward-object)
+(global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
+(global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
 (global-set-key '(#\a :control) 'com-beginning-of-line)
 (global-set-key '(#\e :control) 'com-end-of-line)
-(global-set-key '(#\d :control) 'com-delete-object)
+(global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
 (global-set-key '(#\p :control) 'com-previous-line)
 (global-set-key '(#\n :control) 'com-next-line)
 (global-set-key '(#\o :control) 'com-open-line)
@@ -709,8 +714,8 @@
 
 (global-set-key '(:up) 'com-previous-line)
 (global-set-key '(:down) 'com-next-line)
-(global-set-key '(:left) 'com-backward-object)
-(global-set-key '(:right) 'com-forward-object)
+(global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
+(global-set-key '(:right) `(com-forward-object *numeric-argument-marker*))
 (global-set-key '(:left :control) 'com-backward-word)
 (global-set-key '(:right :control) 'com-forward-word)
 (global-set-key '(:home) 'com-beginning-of-line)
@@ -719,8 +724,8 @@
 (global-set-key '(:next) 'com-page-down)
 (global-set-key '(:home :control) 'com-beginning-of-buffer)
 (global-set-key '(:end :control) 'com-end-of-buffer)
-(global-set-key #\Rubout 'com-delete-object)
-(global-set-key #\Backspace 'com-backward-delete-object)
+(global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
+(global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
 
 (global-set-key '(:insert) 'com-toggle-overwrite-mode)
 


Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.21 climacs/syntax.lisp:1.22
--- climacs/syntax.lisp:1.21	Mon Jan 10 06:31:17 2005
+++ climacs/syntax.lisp	Wed Jan 12 17:41:17 2005
@@ -279,12 +279,6 @@
 	 (beginning-of-line (point pane))
 	 (empty-cache cache)))))
 
-;;; this one should not be necessary. 
-(defun round-up (x)
-  (cond ((zerop x) 2)
-	((evenp x) x)
-	(t (1+ x))))
-
 (defmethod redisplay-with-syntax (pane (syntax basic-syntax))
   (let* ((medium (sheet-medium pane))
 	 (style (medium-text-style medium))
@@ -310,13 +304,10 @@
 	   (setf cursor-x x
 		 cursor-y y)))
        (updating-output (pane :unique-id -1)
-	 (draw-line* pane
-		     ;; cursors with odd or zero x-positions were invisible
-		     ;; so we round them up to even. 
-		     ;; We don't know why, though.
-		     (round-up cursor-x) (- cursor-y (* 0.2 height))
-		     (round-up cursor-x) (+ cursor-y (* 0.8 height))
-		     :ink +red+)))))
+	 (draw-rectangle* pane
+			  cursor-x (- cursor-y (* 0.2 height))
+			  (1+ cursor-x) (+ cursor-y (* 0.8 height))
+			  :ink +red+)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;




More information about the Climacs-cvs mailing list