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

Diff of /climacs/gui.lisp

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

revision 1.84 by rstrandh, Wed Jan 19 05:28:38 2005 UTC revision 1.85 by rstrandh, Wed Jan 19 14:38:47 2005 UTC
# Line 50  Line 50 
50    
51  (define-application-frame climacs ()  (define-application-frame climacs ()
52    ((windows :accessor windows)    ((windows :accessor windows)
53     (buffers :initform '() :accessor buffers))     (buffers :initform '() :accessor buffers)
54       (recordingp :initform nil :accessor recordingp)
55       (executingp :initform nil :accessor executingp)
56       (recorded-keys :initform '() :accessor recorded-keys)
57       (remaining-keys :initform '() :accessor remaining-keys))
58    (:panes    (:panes
59     (win (let* ((extended-pane     (win (let* ((extended-pane
60                  (make-pane 'extended-pane                  (make-pane 'extended-pane
# Line 105  Line 109 
109    (declare (ignore frame))    (declare (ignore frame))
110    (with-slots (climacs-pane) pane    (with-slots (climacs-pane) pane
111       (let* ((buf (buffer climacs-pane))       (let* ((buf (buffer climacs-pane))
112              (name-info (format nil "   ~a   ~a   Syntax: ~a ~a"              (name-info (format nil "   ~a   ~a   Syntax: ~a ~a    ~a"
113                                 (if (needs-saving buf) "**" "--")                                 (if (needs-saving buf) "**" "--")
114                                 (name buf)                                 (name buf)
115                                 (name (syntax buf))                                 (name (syntax buf))
116                                 (if (slot-value climacs-pane 'overwrite-mode)                                 (if (slot-value climacs-pane 'overwrite-mode)
117                                     "Ovwrt"                                     "Ovwrt"
118                                       "")
119                                   (if (recordingp *application-frame*)
120                                       "Def"
121                                     ""))))                                     ""))))
122         (princ name-info pane))))         (princ name-info pane))))
123    
# Line 139  Line 146 
146              :test #'event-matches-gesture-name-p))              :test #'event-matches-gesture-name-p))
147    
148  (defun climacs-read-gesture ()  (defun climacs-read-gesture ()
149      (unless (null (remaining-keys *application-frame*))
150        (return-from climacs-read-gesture
151          (pop (remaining-keys *application-frame*))))
152    (loop for gesture = (read-gesture :stream *standard-input*)    (loop for gesture = (read-gesture :stream *standard-input*)
153          when (event-matches-gesture-name-p gesture '(#\g :control))          when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME
154            do (throw 'outer-loop nil)            do (throw 'outer-loop nil)
155          until (or (characterp gesture)          until (or (characterp gesture)
156                    (and (typep gesture 'keyboard-event)                    (and (typep gesture 'keyboard-event)
# Line 154  Line 164 
164                                            :hyper-left :hyper-right                                            :hyper-left :hyper-right
165                                            :shift-lock :caps-lock                                            :shift-lock :caps-lock
166                                            :alt-left :alt-right))))))                                            :alt-left :alt-right))))))
167          finally (return gesture)))          finally (progn (when (recordingp *application-frame*)
168                             (push gesture (recorded-keys *application-frame*)))
169                           (return gesture))))
170    
171    (defun climacs-unread-gesture (gesture stream)
172      (cond ((recordingp *application-frame*)
173             (pop (recorded-keys *application-frame*)))
174            ((executingp *application-frame*)
175             (push gesture (remaining-keys *application-frame*))))
176      (unread-gesture gesture :stream stream))
177    
178  (defun read-numeric-argument (&key (stream *standard-input*))  (defun read-numeric-argument (&key (stream *standard-input*))
179    (let ((gesture (climacs-read-gesture)))    (let ((gesture (climacs-read-gesture)))
# Line 163  Line 182 
182               (loop for gesture = (climacs-read-gesture)               (loop for gesture = (climacs-read-gesture)
183                     while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME                     while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
184                     do (setf numarg (* 4 numarg))                     do (setf numarg (* 4 numarg))
185                     finally (unread-gesture gesture :stream stream))                     finally (climacs-unread-gesture gesture stream))
186               (let ((gesture (climacs-read-gesture)))               (let ((gesture (climacs-read-gesture)))
187                 (cond ((and (characterp gesture)                 (cond ((and (characterp gesture)
188                             (digit-char-p gesture 10))                             (digit-char-p gesture 10))
# Line 173  Line 192 
192                                         (digit-char-p gesture 10))                                         (digit-char-p gesture 10))
193                              do (setf numarg (+ (* 10 numarg)                              do (setf numarg (+ (* 10 numarg)
194                                                 (- (char-code gesture) (char-code #\0))))                                                 (- (char-code gesture) (char-code #\0))))
195                              finally (unread-gesture gesture :stream stream)                              finally (climacs-unread-gesture gesture stream)
196                                      (return (values numarg t))))                                      (return (values numarg t))))
197                       (t                       (t
198                        (unread-gesture gesture :stream stream)                        (climacs-unread-gesture gesture stream)
199                        (values numarg t))))))                        (values numarg t))))))
200            ((meta-digit gesture)            ((meta-digit gesture)
201             (let ((numarg (meta-digit gesture)))             (let ((numarg (meta-digit gesture)))
202               (loop for gesture = (climacs-read-gesture)               (loop for gesture = (climacs-read-gesture)
203                     while (meta-digit gesture)                     while (meta-digit gesture)
204                     do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))                     do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
205                     finally (unread-gesture gesture :stream stream)                     finally (climacs-unread-gesture gesture stream)
206                             (return (values numarg t)))))                             (return (values numarg t)))))
207            (t (unread-gesture gesture :stream stream)            (t (climacs-unread-gesture gesture stream)
208               (values 1 nil)))))               (values 1 nil)))))
209    
210  ;;; we know the vbox pane has a scroller pane and an info  ;;; we know the vbox pane has a scroller pane and an info
# Line 237  Line 256 
256                          (let ((buffer (buffer (current-window))))                          (let ((buffer (buffer (current-window))))
257                            (when (modified-p buffer)                            (when (modified-p buffer)
258                              (setf (needs-saving buffer) t)))                              (setf (needs-saving buffer) t)))
259                          (redisplay-frame-panes frame)))                          (when (null (remaining-keys *application-frame*))
260                              (setf (executingp *application-frame*) nil)
261                              (redisplay-frame-panes frame))))
262               (beep)               (beep)
263               (let ((buffer (buffer (current-window))))               (let ((buffer (buffer (current-window))))
264                 (when (modified-p buffer)                 (when (modified-p buffer)
265                   (setf (needs-saving buffer) t)))                   (setf (needs-saving buffer) t)))
266               (redisplay-frame-panes frame)))))               (when (null (remaining-keys *application-frame*))
267                   (setf (executingp *application-frame*) nil)
268                   (redisplay-frame-panes frame))))))
269    
270  (defun region-limits (pane)  (defun region-limits (pane)
271    (if (mark< (mark pane) (point pane))    (if (mark< (mark pane) (point pane))
# Line 675  Line 698 
698    
699  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
700  ;;;  ;;;
701    ;;; Keyboard macros
702    
703    (define-named-command com-start-kbd-macro ()
704      (setf (recordingp *application-frame*) t)
705      (setf (recorded-keys *application-frame*) '()))
706    
707    (define-named-command com-end-kbd-macro ()
708      (setf (recordingp *application-frame*) nil)
709      (setf (recorded-keys *application-frame*)
710            ;; this won't work if the command was invoked in any old way
711            (reverse (cddr (recorded-keys *application-frame*)))))
712    
713    (define-named-command com-call-last-kbd-macro ()
714      (setf (remaining-keys *application-frame*)
715            (recorded-keys *application-frame*))
716      (setf (executingp *application-frame*) t))
717    
718    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
719    ;;;
720  ;;; Commands for splitting windows  ;;; Commands for splitting windows
721    
722  (defun replace-constellation (constellation additional-constellation vertical-p)  (defun replace-constellation (constellation additional-constellation vertical-p)
# Line 971  as two values" Line 1013  as two values"
1013  (c-x-set-key '(#\0) 'com-delete-window)  (c-x-set-key '(#\0) 'com-delete-window)
1014  (c-x-set-key '(#\2) 'com-split-window-vertically)  (c-x-set-key '(#\2) 'com-split-window-vertically)
1015  (c-x-set-key '(#\3) 'com-split-window-horizontally)  (c-x-set-key '(#\3) 'com-split-window-horizontally)
1016    (c-x-set-key '(#\() 'com-start-kbd-macro)
1017    (c-x-set-key '(#\)) 'com-end-kbd-macro)
1018  (c-x-set-key '(#\b) 'com-switch-to-buffer)  (c-x-set-key '(#\b) 'com-switch-to-buffer)
1019    (c-x-set-key '(#\e) 'com-call-last-kbd-macro)
1020  (c-x-set-key '(#\c :control) 'com-quit)  (c-x-set-key '(#\c :control) 'com-quit)
1021  (c-x-set-key '(#\f :control) 'com-find-file)  (c-x-set-key '(#\f :control) 'com-find-file)
1022  (c-x-set-key '(#\l :control) 'com-load-file)  (c-x-set-key '(#\l :control) 'com-load-file)

Legend:
Removed from v.1.84  
changed lines
  Added in v.1.85

  ViewVC Help
Powered by ViewVC 1.1.5