[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