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

Diff of /climacs/gui.lisp

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

revision 1.163 by rstrandh, Fri Jul 22 13:15:47 2005 UTC revision 1.164 by rstrandh, Sun Jul 24 05:10:47 2005 UTC
# Line 58  Line 58 
58                             :width 900 :height 400                             :width 900 :height 400
59                             :end-of-line-action :scroll                             :end-of-line-action :scroll
60                             :incremental-redisplay t                             :incremental-redisplay t
61                             :display-function 'display-win))                             :display-function 'display-win
62                               :command-table 'global-climacs-table))
63                 (info-pane                 (info-pane
64                  (make-pane 'climacs-info-pane                  (make-pane 'climacs-info-pane
65                             :master-pane extended-pane                             :master-pane extended-pane
# Line 91  Line 92 
92  (defun climacs (&key (width 900) (height 400))  (defun climacs (&key (width 900) (height 400))
93    "Starts up a climacs session"    "Starts up a climacs session"
94    (let ((frame (make-application-frame    (let ((frame (make-application-frame
95                  'climacs :width width :height height                  'climacs :width width :height height)))
                 :esa-command-table 'global-climacs-table)))  
96      (run-frame-top-level frame)))      (run-frame-top-level frame)))
97    
98  (defun display-info (frame pane)  (defun display-info (frame pane)
# Line 159  Line 159 
159          do (when (modified-p buffer)          do (when (modified-p buffer)
160               (setf (needs-saving buffer) t))))               (setf (needs-saving buffer) t))))
161    
162    (make-command-table 'global-climacs-table :errorp nil :inherit-from '(global-esa-table))
163    
164  (defmacro define-named-command (command-name args &body body)  (defmacro define-named-command (command-name args &body body)
165    `(define-climacs-command ,(if (listp command-name)    `(define-command ,(if (listp command-name)
166                                  `(,@command-name :name t)                          `(,@command-name :name t :command-table global-climacs-table)
167                                  `(,command-name :name t)) ,args ,@body))                          `(,command-name :name t :command-table global-climacs-table))
168           ,args ,@body))
169    
170  (define-named-command com-toggle-overwrite-mode ()  (define-named-command com-toggle-overwrite-mode ()
171    (with-slots (overwrite-mode) (current-window)    (with-slots (overwrite-mode) (current-window)
# Line 436  Line 439 
439        (possibly-fill-line)        (possibly-fill-line)
440        (setf (offset point) (offset point-backup)))))        (setf (offset point) (offset point-backup)))))
441    
 (define-command com-extended-command ()  
   (let ((item (handler-case (accept 'command :prompt "Extended Command")  
                 (error () (progn (beep)  
                                  (display-message "No such command")  
                                  (return-from com-extended-command nil))))))  
     (execute-frame-command *application-frame* item)))  
   
442  (eval-when (:compile-toplevel :load-toplevel)  (eval-when (:compile-toplevel :load-toplevel)
443    (define-presentation-type completable-pathname ()    (define-presentation-type completable-pathname ()
444    :inherit-from 'pathname))    :inherit-from 'pathname))
# Line 597  Line 593 
593          (save-buffer buffer)          (save-buffer buffer)
594          (display-message "No changes need to be saved from ~a" (name buffer)))))          (display-message "No changes need to be saved from ~a" (name buffer)))))
595    
596  (define-named-command (com-quit) ()  (defmethod frame-exit :around ((frame climacs))
597    (loop for buffer in (buffers *application-frame*)    (loop for buffer in (buffers frame)
598          when (and (needs-saving buffer)          when (and (needs-saving buffer)
599                    (filepath buffer)                    (filepath buffer)
600                    (handler-case (accept 'boolean                    (handler-case (accept 'boolean
601                                          :prompt (format nil "Save buffer: ~a ?" (name buffer)))                                          :prompt (format nil "Save buffer: ~a ?" (name buffer)))
602                      (error () (progn (beep)                      (error () (progn (beep)
603                                       (display-message "Invalid answer")                                       (display-message "Invalid answer")
604                                       (return-from com-quit nil)))))                                       (return-from frame-exit nil)))))
605            do (save-buffer buffer))            do (save-buffer buffer))
606    (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))    (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
607                      (buffers *application-frame*))                      (buffers frame))
608              (handler-case (accept 'boolean :prompt "Modified buffers exist.  Quit anyway?")              (handler-case (accept 'boolean :prompt "Modified buffers exist.  Quit anyway?")
609                (error () (progn (beep)                (error () (progn (beep)
610                                 (display-message "Invalid answer")                                 (display-message "Invalid answer")
611                                 (return-from com-quit nil)))))                                 (return-from frame-exit nil)))))
612      (frame-exit *application-frame*)))      (call-next-method)))
613    
614  (define-named-command com-write-buffer ()  (define-named-command com-write-buffer ()
615    (let ((filepath (accept 'completable-pathname    (let ((filepath (accept 'completable-pathname
# Line 803  as two values" Line 799  as two values"
799                       :name 'win                       :name 'win
800                       :end-of-line-action :scroll                       :end-of-line-action :scroll
801                       :incremental-redisplay t                       :incremental-redisplay t
802                       :display-function 'display-win))                       :display-function 'display-win
803                         :command-table 'global-climacs-table))
804           (vbox           (vbox
805            (vertically ()            (vertically ()
806              (scrolling () extended-pane)              (scrolling () extended-pane)
# Line 1254  as two values" Line 1251  as two values"
1251    
1252  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1253  ;;;  ;;;
1254  ;;; Global and dead-escape command tables  ;;; Dead-escape command tables
   
 (make-command-table 'global-climacs-table :errorp nil)  
1255    
1256  (make-command-table 'dead-escape-climacs-table :errorp nil)  (make-command-table 'dead-escape-climacs-table :errorp nil)
1257    
# Line 1306  as two values" Line 1301  as two values"
1301  (global-set-key '(#\u :meta) 'com-upcase-word)  (global-set-key '(#\u :meta) 'com-upcase-word)
1302  (global-set-key '(#\l :meta) 'com-downcase-word)  (global-set-key '(#\l :meta) 'com-downcase-word)
1303  (global-set-key '(#\c :meta) 'com-capitalize-word)  (global-set-key '(#\c :meta) 'com-capitalize-word)
 (global-set-key '(#\x :meta) 'com-extended-command)  
1304  (global-set-key '(#\y :meta) 'com-rotate-yank)  (global-set-key '(#\y :meta) 'com-rotate-yank)
1305  (global-set-key '(#\z :meta) 'com-zap-to-character)  (global-set-key '(#\z :meta) 'com-zap-to-character)
1306  (global-set-key '(#\w :meta) 'com-copy-out)  (global-set-key '(#\w :meta) 'com-copy-out)
# Line 1371  as two values" Line 1365  as two values"
1365  (c-x-set-key '(#\)) 'com-end-kbd-macro)  (c-x-set-key '(#\)) 'com-end-kbd-macro)
1366  (c-x-set-key '(#\b) 'com-switch-to-buffer)  (c-x-set-key '(#\b) 'com-switch-to-buffer)
1367  (c-x-set-key '(#\e) 'com-call-last-kbd-macro)  (c-x-set-key '(#\e) 'com-call-last-kbd-macro)
 (c-x-set-key '(#\c :control) 'com-quit)  
1368  (c-x-set-key '(#\f :control) 'com-find-file)  (c-x-set-key '(#\f :control) 'com-find-file)
1369  (c-x-set-key '(#\i) 'com-insert-file)  (c-x-set-key '(#\i) 'com-insert-file)
1370  (c-x-set-key '(#\k) 'com-kill-buffer)  (c-x-set-key '(#\k) 'com-kill-buffer)

Legend:
Removed from v.1.163  
changed lines
  Added in v.1.164

  ViewVC Help
Powered by ViewVC 1.1.5