/[climacs]/climacs/gui.lisp
ViewVC logotype

Diff of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.61 by rstrandh, Mon Jan 10 05:31:16 2005 UTC revision 1.62 by rstrandh, Wed Jan 12 16:41:16 2005 UTC
# Line 71  Line 71 
71                     :name 'win                     :name 'win
72                     :incremental-redisplay t                     :incremental-redisplay t
73                     :display-function 'display-win))                     :display-function 'display-win))
74      (info :application  
75            :width 900 :height 20 :max-height 20     (info :application
76            :name 'info :background +light-gray+           :width 900 :height 20 :max-height 20
77            :scroll-bars nil           :name 'info :background +light-gray+
78            :incremental-redisplay t           :scroll-bars nil
79            :display-function 'display-info)           :borders nil
80      (int (make-pane 'minibuffer-pane           :incremental-redisplay t
81                      :width 900 :height 20 :max-height 20 :min-height 20           :display-function 'display-info)
82                      :scroll-bars nil)))     (int (make-pane 'minibuffer-pane
83                       :width 900 :height 20 :max-height 20 :min-height 20
84                       :scroll-bars nil)))
85    (:layouts    (:layouts
86     (default     (default
87         (vertically (:scroll-bars nil)         (vertically (:scroll-bars nil)
# Line 162  Line 164 
164    
165  (defun read-numeric-argument (&key (stream *standard-input*))  (defun read-numeric-argument (&key (stream *standard-input*))
166    (let ((gesture (climacs-read-gesture)))    (let ((gesture (climacs-read-gesture)))
167      (cond ((event-matches-gesture-name-p gesture '(#\u :control))      (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
168             (let ((numarg 4))             (let ((numarg 4))
169               (loop for gesture = (climacs-read-gesture)               (loop for gesture = (climacs-read-gesture)
170                     while (event-matches-gesture-name-p gesture '(#\u :control))                     while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
171                     do (setf numarg (* 4 numarg))                     do (setf numarg (* 4 numarg))
172                     finally (unread-gesture gesture :stream stream))                     finally (unread-gesture gesture :stream stream))
173               (let ((gesture (climacs-read-gesture)))               (let ((gesture (climacs-read-gesture)))
# Line 175  Line 177 
177                        (loop for gesture = (climacs-read-gesture)                        (loop for gesture = (climacs-read-gesture)
178                              while (and (characterp gesture)                              while (and (characterp gesture)
179                                         (digit-char-p gesture 10))                                         (digit-char-p gesture 10))
180                              do (setf gesture (+ (* 10 numarg)                              do (setf numarg (+ (* 10 numarg)
181                                                  (- (char-code gesture) (char-code #\0))))                                                 (- (char-code gesture) (char-code #\0))))
182                              finally (unread-gesture gesture :stream stream)                              finally (unread-gesture gesture :stream stream)
183                                      (return (values numarg t))))                                      (return (values numarg t))))
184                       (t                       (t
185                          (unread-gesture gesture :stream stream)
186                        (values numarg t))))))                        (values numarg t))))))
187            ((meta-digit gesture)            ((meta-digit gesture)
188             (let ((numarg (meta-digit gesture)))             (let ((numarg (meta-digit gesture)))
# Line 202  Line 205 
205          (*abort-gestures* nil))          (*abort-gestures* nil))
206      (redisplay-frame-panes frame :force-p t)      (redisplay-frame-panes frame :force-p t)
207      (loop (catch 'outer-loop      (loop (catch 'outer-loop
208              (loop with gestures = '()              (loop for gestures = '()
209                    with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*)                    for numarg = (read-numeric-argument :stream *standard-input*)
210                    do (setf *current-gesture* (climacs-read-gesture))                    do (loop (setf *current-gesture* (climacs-read-gesture))
211                       (setf gestures (nconc gestures (list *current-gesture*)))                             (setf gestures (nconc gestures (list *current-gesture*)))
212                       (let ((item (find-gestures gestures 'global-climacs-table)))                             (let ((item (find-gestures gestures 'global-climacs-table)))
213                         (cond ((not item)                               (cond ((not item)
214                                (beep) (setf gestures '()))                                      (beep) (return))
215                               ((eq (command-menu-item-type item) :command)                                     ((eq (command-menu-item-type item) :command)
216                                (let ((command (command-menu-item-value item)))                                      (let ((command (command-menu-item-value item)))
217                                  (unless (consp command)                                        (unless (consp command)
218                                    (setf command (list command)))                                          (setf command (list command)))
219                                  (setf command (substitute-numeric-argument-marker command numarg))                                        (setf command (substitute-numeric-argument-marker command numarg))
220                                  (handler-case                                        (handler-case
221                                      (execute-frame-command frame command)                                            (execute-frame-command frame command)
222                                    (error (condition)                                          (error (condition)
223                                      (beep)                                            (beep)
224                                      (format *error-output* "~a~%" condition)))                                            (format *error-output* "~a~%" condition)))
225                                  (setf gestures '())                                        (setf (previous-command *standard-output*)
226                                  (setf (previous-command *standard-output*)                                              (if (consp command)
227                                        (if (consp command)                                                  (car command)
228                                            (car command)                                                  command))
229                                            command))))                                        (return)))
230                               (t nil)))                                     (t nil))))
231                       (let ((buffer (buffer (win frame))))                       (let ((buffer (buffer (win frame))))
232                         (when (modified-p buffer)                         (when (modified-p buffer)
233                           (setf (needs-saving buffer) t)))                           (setf (needs-saving buffer) t)))
# Line 236  Line 239 
239            (redisplay-frame-panes frame))))            (redisplay-frame-panes frame))))
240    
241  (defmacro define-named-command (command-name args &body body)  (defmacro define-named-command (command-name args &body body)
242    `(define-climacs-command ,(if (listp command-name) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body))    `(define-climacs-command ,(if (listp command-name)
243                                    `(,@command-name :name t)
244                                    `(,command-name :name t)) ,args ,@body))
245    
246  (define-named-command (com-quit) ()  (define-named-command (com-quit) ()
247    (frame-exit *application-frame*))    (frame-exit *application-frame*))
# Line 260  Line 265 
265  (define-named-command com-end-of-line ()  (define-named-command com-end-of-line ()
266    (end-of-line (point (win *application-frame*))))    (end-of-line (point (win *application-frame*))))
267    
268  (define-named-command com-delete-object ()  (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
269    (delete-range (point (win *application-frame*))))    (delete-range (point (win *application-frame*)) count))
270    
271  (define-named-command com-backward-delete-object ()  (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
272    (delete-range (point (win *application-frame*)) -1))    (delete-range (point (win *application-frame*)) (- count)))
273    
274  (define-named-command com-transpose-objects ()  (define-named-command com-transpose-objects ()
275    (let* ((point (point (win *application-frame*))))    (let* ((point (point (win *application-frame*))))
# Line 277  Line 282 
282         (insert-object point object)         (insert-object point object)
283         (forward-object point)))))         (forward-object point)))))
284    
285  (define-named-command com-backward-object ()  (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
286    (backward-object (point (win *application-frame*))))    (backward-object (point (win *application-frame*)) count))
287    
288  (define-named-command com-forward-object ()  (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
289    (forward-object (point (win *application-frame*))))    (forward-object (point (win *application-frame*)) count))
290    
291  (define-named-command com-transpose-words ()  (define-named-command com-transpose-words ()
292    (let* ((point (point (win *application-frame*))))    (let* ((point (point (win *application-frame*))))
# Line 676  Line 681 
681    
682  (global-set-key #\newline 'com-self-insert)  (global-set-key #\newline 'com-self-insert)
683  (global-set-key #\tab 'com-self-insert)  (global-set-key #\tab 'com-self-insert)
684  (global-set-key '(#\f :control) 'com-forward-object)  (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
685  (global-set-key '(#\b :control) 'com-backward-object)  (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
686  (global-set-key '(#\a :control) 'com-beginning-of-line)  (global-set-key '(#\a :control) 'com-beginning-of-line)
687  (global-set-key '(#\e :control) 'com-end-of-line)  (global-set-key '(#\e :control) 'com-end-of-line)
688  (global-set-key '(#\d :control) 'com-delete-object)  (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
689  (global-set-key '(#\p :control) 'com-previous-line)  (global-set-key '(#\p :control) 'com-previous-line)
690  (global-set-key '(#\n :control) 'com-next-line)  (global-set-key '(#\n :control) 'com-next-line)
691  (global-set-key '(#\o :control) 'com-open-line)  (global-set-key '(#\o :control) 'com-open-line)
# Line 709  Line 714 
714    
715  (global-set-key '(:up) 'com-previous-line)  (global-set-key '(:up) 'com-previous-line)
716  (global-set-key '(:down) 'com-next-line)  (global-set-key '(:down) 'com-next-line)
717  (global-set-key '(:left) 'com-backward-object)  (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
718  (global-set-key '(:right) 'com-forward-object)  (global-set-key '(:right) `(com-forward-object *numeric-argument-marker*))
719  (global-set-key '(:left :control) 'com-backward-word)  (global-set-key '(:left :control) 'com-backward-word)
720  (global-set-key '(:right :control) 'com-forward-word)  (global-set-key '(:right :control) 'com-forward-word)
721  (global-set-key '(:home) 'com-beginning-of-line)  (global-set-key '(:home) 'com-beginning-of-line)
# Line 719  Line 724 
724  (global-set-key '(:next) 'com-page-down)  (global-set-key '(:next) 'com-page-down)
725  (global-set-key '(:home :control) 'com-beginning-of-buffer)  (global-set-key '(:home :control) 'com-beginning-of-buffer)
726  (global-set-key '(:end :control) 'com-end-of-buffer)  (global-set-key '(:end :control) 'com-end-of-buffer)
727  (global-set-key #\Rubout 'com-delete-object)  (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
728  (global-set-key #\Backspace 'com-backward-delete-object)  (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
729    
730  (global-set-key '(:insert) 'com-toggle-overwrite-mode)  (global-set-key '(:insert) 'com-toggle-overwrite-mode)
731    

Legend:
Removed from v.1.61  
changed lines
  Added in v.1.62

  ViewVC Help
Powered by ViewVC 1.1.5