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

Diff of /climacs/gui.lisp

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

revision 1.169 by rstrandh, Thu Aug 4 01:10:45 2005 UTC revision 1.170 by dmurray, Fri Aug 5 12:40:56 2005 UTC
# Line 130  Line 130 
130    
131  (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))  (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
132    
 (defun meta-digit (gesture)  
   (position gesture  
             '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)  
               (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))  
             :test #'event-matches-gesture-name-p))  
   
 (defun substitute-numeric-argument-p (command numargp)  
   (substitute numargp *numeric-argument-p* command :test #'eq))  
   
133  (defmethod execute-frame-command :around ((frame climacs) command)  (defmethod execute-frame-command :around ((frame climacs) command)
134    (handler-case    (handler-case
135        (with-undo ((buffer (current-window)))        (with-undo ((buffer (current-window)))
# Line 171  Line 162 
162    (with-slots (overwrite-mode) (current-window)    (with-slots (overwrite-mode) (current-window)
163      (setf overwrite-mode (not overwrite-mode))))      (setf overwrite-mode (not overwrite-mode))))
164    
165    (define-named-command com-not-modified ()
166      (setf (needs-saving (buffer (current-window))) nil))
167    
168    (define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:"))
169      (if (> column 1)
170          (setf (auto-fill-column (current-window)) column)
171          (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
172    
173  (defun possibly-fill-line ()  (defun possibly-fill-line ()
174    (let* ((pane (current-window))    (let* ((pane (current-window))
175           (buffer (buffer pane)))           (buffer (buffer pane)))
# Line 357  Line 356 
356  (define-named-command com-delete-word ((count 'integer :prompt "Number of words"))  (define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
357    (delete-word (point (current-window)) count))    (delete-word (point (current-window)) count))
358    
359    (define-named-command com-kill-word ((count 'integer :prompt "Number of words"))
360      (let* ((pane (current-window))
361             (point (point pane))
362             (mark (offset point)))
363        (loop repeat count
364              until (end-of-buffer-p point)
365              do (forward-word point))
366        (unless (mark= point mark)
367          (if (eq (previous-command pane) 'com-kill-word)
368              (kill-ring-concatenating-push *kill-ring*
369                                            (region-to-sequence mark point))
370              (kill-ring-standard-push *kill-ring*
371                                       (region-to-sequence mark point)))
372          (delete-region mark point))))
373    
374    (define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words"))
375      (let* ((pane (current-window))
376             (point (point pane))
377             (mark (offset point)))
378        (loop repeat count
379              until (end-of-buffer-p point)
380              do (backward-word point))
381        (unless (mark= point mark)
382          (if (eq (previous-command pane) 'com-backward-kill-word)
383              (kill-ring-reverse-concatenating-push *kill-ring*
384                                            (region-to-sequence mark point))
385              (kill-ring-standard-push *kill-ring*
386                                       (region-to-sequence mark point)))
387          (delete-region mark point))))
388    
389  (define-named-command com-mark-word ((count 'integer :prompt "Number of words"))  (define-named-command com-mark-word ((count 'integer :prompt "Number of words"))
390    (let* ((pane (current-window))    (let* ((pane (current-window))
391           (point (point pane))           (point (point pane))
# Line 435  Line 464 
464           (begin-mark (clone-mark point))           (begin-mark (clone-mark point))
465           (end-mark (clone-mark point)))           (end-mark (clone-mark point)))
466      (unless (eql (object-before begin-mark) #\Newline)      (unless (eql (object-before begin-mark) #\Newline)
467        (beginning-of-paragraph begin-mark syntax))        (backward-paragraph begin-mark syntax))
468      (unless (eql (object-after end-mark) #\Newline)      (unless (eql (object-after end-mark) #\Newline)
469        (end-of-paragraph end-mark syntax))        (forward-paragraph end-mark syntax))
470      (do-buffer-region (object offset buffer      (do-buffer-region (object offset buffer
471                         (offset begin-mark) (offset end-mark))                         (offset begin-mark) (offset end-mark))
472        (when (eql object #\Newline)        (when (eql object #\Newline)
# Line 718  Line 747 
747                        m)                        m)
748          do (end-of-line mark)          do (end-of-line mark)
749          until (end-of-buffer-p mark)          until (end-of-buffer-p mark)
750          repeat (handler-case (accept 'integer :prompt "Goto Line")          repeat (1- (handler-case (accept 'integer :prompt "Goto Line")
751                   (error () (progn (beep)                   (error () (progn (beep)
752                                    (display-message "Not a valid line number")                                    (display-message "Not a valid line number")
753                                    (return-from com-goto-line nil))))                                    (return-from com-goto-line nil)))))
754          do (incf (offset mark))          do (incf (offset mark))
755             (end-of-line mark)             (end-of-line mark)
756          finally (beginning-of-line mark)          finally (beginning-of-line mark)
# Line 882  as two values" Line 911  as two values"
911    (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))    (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
912    
913  ;; Destructively cut a given buffer region into the kill-ring  ;; Destructively cut a given buffer region into the kill-ring
914  (define-named-command com-cut-out ()  (define-named-command com-kill-region ()
915    (let ((pane (current-window)))    (let ((pane (current-window)))
916      (kill-ring-standard-push      (kill-ring-standard-push
917       *kill-ring* (region-to-sequence (mark pane) (point pane)))       *kill-ring* (region-to-sequence (mark pane) (point pane)))
918      (delete-region (mark pane) (point pane))))      (delete-region (mark pane) (point pane))))
919    
920  ;; Non destructively copies in buffer region to the kill ring  ;; Non destructively copies in buffer region to the kill ring
921  (define-named-command com-copy-out ()  (define-named-command com-copy-region ()
922    (let ((pane (current-window)))    (let ((pane (current-window)))
923      (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))      (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
924    
# Line 1168  as two values" Line 1197  as two values"
1197                                                  (setf (offset dabbrev-expansion-mark) offset))))                                                  (setf (offset dabbrev-expansion-mark) offset))))
1198                        (move))))))))                        (move))))))))
1199    
1200  (define-named-command com-beginning-of-paragraph ()  (define-named-command com-backward-paragraph ()
1201    (let* ((pane (current-window))    (let* ((pane (current-window))
1202           (point (point pane))           (point (point pane))
1203           (syntax (syntax (buffer pane))))           (syntax (syntax (buffer pane))))
1204      (beginning-of-paragraph point syntax)))      (backward-paragraph point syntax)))
1205    
1206  (define-named-command com-end-of-paragraph ()  (define-named-command com-forward-paragraph ()
1207    (let* ((pane (current-window))    (let* ((pane (current-window))
1208           (point (point pane))           (point (point pane))
1209           (syntax (syntax (buffer pane))))           (syntax (syntax (buffer pane))))
1210      (end-of-paragraph point syntax)))      (forward-paragraph point syntax)))
1211    
1212  (define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs"))  (define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs"))
1213    (let* ((pane (current-window))    (let* ((pane (current-window))
# Line 1187  as two values" Line 1216  as two values"
1216           (syntax (syntax (buffer pane))))           (syntax (syntax (buffer pane))))
1217      (unless (eq (previous-command pane) 'com-mark-paragraph)      (unless (eq (previous-command pane) 'com-mark-paragraph)
1218        (setf (offset mark) (offset point))        (setf (offset mark) (offset point))
1219        (beginning-of-paragraph point syntax))        (backward-paragraph point syntax))
1220      (dotimes (i count) (end-of-paragraph mark syntax))))      (loop repeat count do (forward-paragraph mark syntax))))
1221    
1222    (define-named-command com-backward-sentence ()
1223      (let* ((pane (current-window))
1224             (point (point pane))
1225             (syntax (syntax (buffer pane))))
1226        (backward-sentence point syntax)))
1227    
1228    (define-named-command com-forward-sentence ()
1229      (let* ((pane (current-window))
1230             (point (point pane))
1231             (syntax (syntax (buffer pane))))
1232        (forward-sentence point syntax)))
1233    
1234    (defun forward-page (mark &optional (count 1))
1235      (loop repeat count
1236            unless (search-forward mark (coerce (list #\Newline #\Page) 'vector))
1237              do (end-of-buffer mark)
1238                 (loop-finish)))
1239    
1240    (define-named-command com-forward-page ((count 'integer :prompt "Number of pages"))
1241      (let* ((pane (current-window))
1242             (point (point pane)))
1243        (forward-page point count)))
1244    
1245    (defun backward-page (mark &optional (count 1))
1246      (loop repeat count
1247              when (search-backward mark (coerce (list #\Newline #\Page) 'vector))
1248                do (forward-object mark)
1249              else do (beginning-of-buffer mark)
1250                      (loop-finish)))
1251    
1252    (define-named-command com-backward-page ((count 'integer :prompt "Number of pages"))
1253      (let* ((pane (current-window))
1254             (point (point pane)))
1255        (backward-page point count)))
1256    
1257    (define-named-command com-count-lines-page ()
1258      (let* ((pane (current-window))
1259             (point (point pane))
1260             (start (clone-mark point))
1261             (end (clone-mark point)))
1262        (backward-page start)
1263        (forward-page end)
1264        (let ((total (number-of-lines-in-region start end))
1265              (before (number-of-lines-in-region start point))
1266              (after (number-of-lines-in-region point end)))
1267          (display-message "Page has ~A lines (~A + ~A)" total before after))))
1268    
1269  (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))  (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
1270    (let* ((*package* (find-package :climacs-gui))    (let* ((*package* (find-package :climacs-gui))
# Line 1262  as two values" Line 1338  as two values"
1338           (syntax (syntax (buffer pane))))           (syntax (syntax (buffer pane))))
1339      (eval-defun point syntax)))      (eval-defun point syntax)))
1340    
1341    (define-named-command com-beginning-of-definition ()
1342      (let* ((pane (current-window))
1343             (point (point pane))
1344             (syntax (syntax (buffer pane))))
1345        (beginning-of-definition point syntax)))
1346    
1347    (define-named-command com-end-of-definition ()
1348      (let* ((pane (current-window))
1349             (point (point pane))
1350             (syntax (syntax (buffer pane))))
1351        (end-of-definition point syntax)))
1352    
1353    (define-named-command com-mark-definition ()
1354      (let* ((pane (current-window))
1355             (point (point pane))
1356             (mark (mark pane))
1357             (syntax (syntax (buffer pane))))
1358        (unless (eq (previous-command pane) 'com-mark-definition)
1359          (beginning-of-definition point syntax)
1360          (setf (offset mark) (offset point)))
1361        (end-of-definition mark syntax)))
1362    
1363  (define-named-command com-package ()  (define-named-command com-package ()
1364    (let* ((pane (current-window))    (let* ((pane (current-window))
1365           (syntax (syntax (buffer pane)))           (syntax (syntax (buffer pane)))
# Line 1331  as two values" Line 1429  as two values"
1429  (global-set-key '(#\t :control) 'com-transpose-objects)  (global-set-key '(#\t :control) 'com-transpose-objects)
1430  (global-set-key '(#\Space :control) 'com-set-mark)  (global-set-key '(#\Space :control) 'com-set-mark)
1431  (global-set-key '(#\y :control) 'com-yank)  (global-set-key '(#\y :control) 'com-yank)
1432  (global-set-key '(#\w :control) 'com-cut-out)  (global-set-key '(#\w :control) 'com-kill-region)
1433  (global-set-key '(#\e :meta) `(com-forward-expression ,*numeric-argument-marker*))  (global-set-key '(#\e :meta) 'com-forward-sentence)
1434  (global-set-key '(#\a :meta) `(com-backward-expression ,*numeric-argument-marker*))  (global-set-key '(#\a :meta) 'com-backward-sentence)
1435  (global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*))  (global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*))
1436  (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))  (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))
1437  (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))  (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))
# Line 1343  as two values" Line 1441  as two values"
1441  (global-set-key '(#\c :meta) 'com-capitalize-word)  (global-set-key '(#\c :meta) 'com-capitalize-word)
1442  (global-set-key '(#\y :meta) 'com-rotate-yank)  (global-set-key '(#\y :meta) 'com-rotate-yank)
1443  (global-set-key '(#\z :meta) 'com-zap-to-character)  (global-set-key '(#\z :meta) 'com-zap-to-character)
1444  (global-set-key '(#\w :meta) 'com-copy-out)  (global-set-key '(#\w :meta) 'com-copy-region)
1445  (global-set-key '(#\v :control) 'com-page-down)  (global-set-key '(#\v :control) 'com-page-down)
1446  (global-set-key '(#\v :meta) 'com-page-up)  (global-set-key '(#\v :meta) 'com-page-up)
1447  (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)  (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
# Line 1351  as two values" Line 1449  as two values"
1449  (global-set-key '(#\m :meta) 'com-back-to-indentation)  (global-set-key '(#\m :meta) 'com-back-to-indentation)
1450  (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)  (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
1451  (global-set-key '(#\q :meta) 'com-fill-paragraph)  (global-set-key '(#\q :meta) 'com-fill-paragraph)
1452  (global-set-key '(#\d :meta) `(com-delete-word ,*numeric-argument-marker*))  (global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*))
1453  (global-set-key '(#\Backspace :meta) `(com-backward-delete-word ,*numeric-argument-marker*))  (global-set-key '(#\Backspace :meta) `(com-backward-kill-word ,*numeric-argument-marker*))
1454  (global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*))  (global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*))
1455  (global-set-key '(#\/ :meta) 'com-dabbrev-expand)  (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
1456  (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)  (global-set-key '(#\{ :meta :shift) 'com-backward-paragraph)
1457  (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)  (global-set-key '(#\} :meta :shift) 'com-forward-paragraph)
1458  (global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*))  (global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*))
1459  (global-set-key '(#\s :control) 'com-isearch-mode-forward)  (global-set-key '(#\s :control) 'com-isearch-mode-forward)
1460  (global-set-key '(#\r :control) 'com-isearch-mode-backward)  (global-set-key '(#\r :control) 'com-isearch-mode-backward)
# Line 1380  as two values" Line 1478  as two values"
1478  (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))  (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
1479    
1480  (global-set-key '(:insert) 'com-toggle-overwrite-mode)  (global-set-key '(:insert) 'com-toggle-overwrite-mode)
1481    (global-set-key '(#\~ :meta :shift) 'com-not-modified)
1482    
1483  (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*))  (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*))
1484  (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*))  (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*))
1485  (global-set-key '(#\x :control :meta) '(com-eval-defun))  (global-set-key '(#\x :control :meta) 'com-eval-defun)
1486    (global-set-key '(#\a :control :meta) 'com-beginning-of-definition)
1487    (global-set-key '(#\e :control :meta) 'com-end-of-definition)
1488    (global-set-key '(#\h :control :meta) 'com-mark-definition)
1489  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1490  ;;;  ;;;
1491  ;;; C-x command table  ;;; C-x command table
# Line 1405  as two values" Line 1506  as two values"
1506  (c-x-set-key '(#\3) 'com-split-window-horizontally)  (c-x-set-key '(#\3) 'com-split-window-horizontally)
1507  (c-x-set-key '(#\b) 'com-switch-to-buffer)  (c-x-set-key '(#\b) 'com-switch-to-buffer)
1508  (c-x-set-key '(#\f :control) 'com-find-file)  (c-x-set-key '(#\f :control) 'com-find-file)
1509    (c-x-set-key '(#\f) `(com-set-fill-column ,*numeric-argument-marker*))
1510  (c-x-set-key '(#\h) 'com-mark-whole-buffer)  (c-x-set-key '(#\h) 'com-mark-whole-buffer)
1511  (c-x-set-key '(#\i) 'com-insert-file)  (c-x-set-key '(#\i) 'com-insert-file)
1512  (c-x-set-key '(#\k) 'com-kill-buffer)  (c-x-set-key '(#\k) 'com-kill-buffer)
 (c-x-set-key '(#\l :control) 'com-load-file)  
1513  (c-x-set-key '(#\o) 'com-other-window)  (c-x-set-key '(#\o) 'com-other-window)
1514  (c-x-set-key '(#\r) 'com-redo)  (c-x-set-key '(#\r) 'com-redo)
1515  (c-x-set-key '(#\u) 'com-undo)  (c-x-set-key '(#\u) 'com-undo)
1516    (c-x-set-key '(#\]) `(com-forward-page ,*numeric-argument-marker*))
1517    (c-x-set-key '(#\[) `(com-backward-page ,*numeric-argument-marker*))
1518    (c-x-set-key '(#\l) 'com-count-lines-page)
1519  (c-x-set-key '(#\s :control) 'com-save-buffer)  (c-x-set-key '(#\s :control) 'com-save-buffer)
1520  (c-x-set-key '(#\t :control) 'com-transpose-lines)  (c-x-set-key '(#\t :control) 'com-transpose-lines)
1521  (c-x-set-key '(#\w :control) 'com-write-buffer)  (c-x-set-key '(#\w :control) 'com-write-buffer)

Legend:
Removed from v.1.169  
changed lines
  Added in v.1.170

  ViewVC Help
Powered by ViewVC 1.1.5