[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/kill-ring.lisp climacs/syntax.lisp
Dave Murray
dmurray at common-lisp.net
Fri Aug 5 12:41:00 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv32127
Modified Files:
base.lisp gui.lisp kill-ring.lisp syntax.lisp
Log Message:
Added and altered various commands.
#\Page added to whitespacep for non-sbcl
Added com-not-modified (M-~), com-set-fill-column (C-x f),
com-kill-word (M-d), com-backward-kill-word (M-Backspace),
com-backward-sentence (M-a), com-forward-sentence (M-e_,
com-forward-page (C-x ]), com-backward-page (C-x [),
com-count-lines-page (C-x l), com-beginning-of-definition (M-C-a),
com-end-of-definition (M-C-e), com-mark-definition (M-C-h).
Changed com-goto-line to be 1-based, not 0-based.
Renamed com-cut-out -> com-kill-region, com-copy-out -> com-copy-region,
com-beginning-of-paragraph -> com-backward-paragraph,
com-end-of-paragraph -> com-forward-paragraph.
Date: Fri Aug 5 14:40:57 2005
Author: dmurray
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.40 climacs/base.lisp:1.41
--- climacs/base.lisp:1.40 Fri Aug 5 00:07:44 2005
+++ climacs/base.lisp Fri Aug 5 14:40:55 2005
@@ -186,7 +186,7 @@
"A predicate to ensure that an object is a whitespace character."
(and (characterp obj)
#+sbcl (sb-impl::whitespacep obj)
- #-sbcl (member obj '(#\Space #\Tab #\Newline))))
+ #-sbcl (member obj '(#\Space #\Tab #\Newline #\Page))))
(defun forward-to-word-boundary (mark)
"Move the mark forward to the beginning of the next word."
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.169 climacs/gui.lisp:1.170
--- climacs/gui.lisp:1.169 Thu Aug 4 03:10:45 2005
+++ climacs/gui.lisp Fri Aug 5 14:40:56 2005
@@ -130,15 +130,6 @@
(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
-(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))
-
(defmethod execute-frame-command :around ((frame climacs) command)
(handler-case
(with-undo ((buffer (current-window)))
@@ -171,6 +162,14 @@
(with-slots (overwrite-mode) (current-window)
(setf overwrite-mode (not overwrite-mode))))
+(define-named-command com-not-modified ()
+ (setf (needs-saving (buffer (current-window))) nil))
+
+(define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:"))
+ (if (> column 1)
+ (setf (auto-fill-column (current-window)) column)
+ (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
+
(defun possibly-fill-line ()
(let* ((pane (current-window))
(buffer (buffer pane)))
@@ -357,6 +356,36 @@
(define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
(delete-word (point (current-window)) count))
+(define-named-command com-kill-word ((count 'integer :prompt "Number of words"))
+ (let* ((pane (current-window))
+ (point (point pane))
+ (mark (offset point)))
+ (loop repeat count
+ until (end-of-buffer-p point)
+ do (forward-word point))
+ (unless (mark= point mark)
+ (if (eq (previous-command pane) 'com-kill-word)
+ (kill-ring-concatenating-push *kill-ring*
+ (region-to-sequence mark point))
+ (kill-ring-standard-push *kill-ring*
+ (region-to-sequence mark point)))
+ (delete-region mark point))))
+
+(define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words"))
+ (let* ((pane (current-window))
+ (point (point pane))
+ (mark (offset point)))
+ (loop repeat count
+ until (end-of-buffer-p point)
+ do (backward-word point))
+ (unless (mark= point mark)
+ (if (eq (previous-command pane) 'com-backward-kill-word)
+ (kill-ring-reverse-concatenating-push *kill-ring*
+ (region-to-sequence mark point))
+ (kill-ring-standard-push *kill-ring*
+ (region-to-sequence mark point)))
+ (delete-region mark point))))
+
(define-named-command com-mark-word ((count 'integer :prompt "Number of words"))
(let* ((pane (current-window))
(point (point pane))
@@ -435,9 +464,9 @@
(begin-mark (clone-mark point))
(end-mark (clone-mark point)))
(unless (eql (object-before begin-mark) #\Newline)
- (beginning-of-paragraph begin-mark syntax))
+ (backward-paragraph begin-mark syntax))
(unless (eql (object-after end-mark) #\Newline)
- (end-of-paragraph end-mark syntax))
+ (forward-paragraph end-mark syntax))
(do-buffer-region (object offset buffer
(offset begin-mark) (offset end-mark))
(when (eql object #\Newline)
@@ -718,10 +747,10 @@
m)
do (end-of-line mark)
until (end-of-buffer-p mark)
- repeat (handler-case (accept 'integer :prompt "Goto Line")
+ repeat (1- (handler-case (accept 'integer :prompt "Goto Line")
(error () (progn (beep)
(display-message "Not a valid line number")
- (return-from com-goto-line nil))))
+ (return-from com-goto-line nil)))))
do (incf (offset mark))
(end-of-line mark)
finally (beginning-of-line mark)
@@ -882,14 +911,14 @@
(insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
;; Destructively cut a given buffer region into the kill-ring
-(define-named-command com-cut-out ()
+(define-named-command com-kill-region ()
(let ((pane (current-window)))
(kill-ring-standard-push
*kill-ring* (region-to-sequence (mark pane) (point pane)))
(delete-region (mark pane) (point pane))))
;; Non destructively copies in buffer region to the kill ring
-(define-named-command com-copy-out ()
+(define-named-command com-copy-region ()
(let ((pane (current-window)))
(kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
@@ -1168,17 +1197,17 @@
(setf (offset dabbrev-expansion-mark) offset))))
(move))))))))
-(define-named-command com-beginning-of-paragraph ()
+(define-named-command com-backward-paragraph ()
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
- (beginning-of-paragraph point syntax)))
+ (backward-paragraph point syntax)))
-(define-named-command com-end-of-paragraph ()
+(define-named-command com-forward-paragraph ()
(let* ((pane (current-window))
(point (point pane))
(syntax (syntax (buffer pane))))
- (end-of-paragraph point syntax)))
+ (forward-paragraph point syntax)))
(define-named-command com-mark-paragraph ((count 'integer :prompt "Number of paragraphs"))
(let* ((pane (current-window))
@@ -1187,8 +1216,55 @@
(syntax (syntax (buffer pane))))
(unless (eq (previous-command pane) 'com-mark-paragraph)
(setf (offset mark) (offset point))
- (beginning-of-paragraph point syntax))
- (dotimes (i count) (end-of-paragraph mark syntax))))
+ (backward-paragraph point syntax))
+ (loop repeat count do (forward-paragraph mark syntax))))
+
+(define-named-command com-backward-sentence ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (syntax (syntax (buffer pane))))
+ (backward-sentence point syntax)))
+
+(define-named-command com-forward-sentence ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (syntax (syntax (buffer pane))))
+ (forward-sentence point syntax)))
+
+(defun forward-page (mark &optional (count 1))
+ (loop repeat count
+ unless (search-forward mark (coerce (list #\Newline #\Page) 'vector))
+ do (end-of-buffer mark)
+ (loop-finish)))
+
+(define-named-command com-forward-page ((count 'integer :prompt "Number of pages"))
+ (let* ((pane (current-window))
+ (point (point pane)))
+ (forward-page point count)))
+
+(defun backward-page (mark &optional (count 1))
+ (loop repeat count
+ when (search-backward mark (coerce (list #\Newline #\Page) 'vector))
+ do (forward-object mark)
+ else do (beginning-of-buffer mark)
+ (loop-finish)))
+
+(define-named-command com-backward-page ((count 'integer :prompt "Number of pages"))
+ (let* ((pane (current-window))
+ (point (point pane)))
+ (backward-page point count)))
+
+(define-named-command com-count-lines-page ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (start (clone-mark point))
+ (end (clone-mark point)))
+ (backward-page start)
+ (forward-page end)
+ (let ((total (number-of-lines-in-region start end))
+ (before (number-of-lines-in-region start point))
+ (after (number-of-lines-in-region point end)))
+ (display-message "Page has ~A lines (~A + ~A)" total before after))))
(define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
(let* ((*package* (find-package :climacs-gui))
@@ -1262,6 +1338,28 @@
(syntax (syntax (buffer pane))))
(eval-defun point syntax)))
+(define-named-command com-beginning-of-definition ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (syntax (syntax (buffer pane))))
+ (beginning-of-definition point syntax)))
+
+(define-named-command com-end-of-definition ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (syntax (syntax (buffer pane))))
+ (end-of-definition point syntax)))
+
+(define-named-command com-mark-definition ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (mark (mark pane))
+ (syntax (syntax (buffer pane))))
+ (unless (eq (previous-command pane) 'com-mark-definition)
+ (beginning-of-definition point syntax)
+ (setf (offset mark) (offset point)))
+ (end-of-definition mark syntax)))
+
(define-named-command com-package ()
(let* ((pane (current-window))
(syntax (syntax (buffer pane)))
@@ -1331,9 +1429,9 @@
(global-set-key '(#\t :control) 'com-transpose-objects)
(global-set-key '(#\Space :control) 'com-set-mark)
(global-set-key '(#\y :control) 'com-yank)
-(global-set-key '(#\w :control) 'com-cut-out)
-(global-set-key '(#\e :meta) `(com-forward-expression ,*numeric-argument-marker*))
-(global-set-key '(#\a :meta) `(com-backward-expression ,*numeric-argument-marker*))
+(global-set-key '(#\w :control) 'com-kill-region)
+(global-set-key '(#\e :meta) 'com-forward-sentence)
+(global-set-key '(#\a :meta) 'com-backward-sentence)
(global-set-key '(#\@ :meta :control :shift) `(com-mark-expression ,*numeric-argument-marker*))
(global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))
(global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))
@@ -1343,7 +1441,7 @@
(global-set-key '(#\c :meta) 'com-capitalize-word)
(global-set-key '(#\y :meta) 'com-rotate-yank)
(global-set-key '(#\z :meta) 'com-zap-to-character)
-(global-set-key '(#\w :meta) 'com-copy-out)
+(global-set-key '(#\w :meta) 'com-copy-region)
(global-set-key '(#\v :control) 'com-page-down)
(global-set-key '(#\v :meta) 'com-page-up)
(global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
@@ -1351,12 +1449,12 @@
(global-set-key '(#\m :meta) 'com-back-to-indentation)
(global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
(global-set-key '(#\q :meta) 'com-fill-paragraph)
-(global-set-key '(#\d :meta) `(com-delete-word ,*numeric-argument-marker*))
-(global-set-key '(#\Backspace :meta) `(com-backward-delete-word ,*numeric-argument-marker*))
+(global-set-key '(#\d :meta) `(com-kill-word ,*numeric-argument-marker*))
+(global-set-key '(#\Backspace :meta) `(com-backward-kill-word ,*numeric-argument-marker*))
(global-set-key '(#\@ :meta :shift) `(com-mark-word ,*numeric-argument-marker*))
(global-set-key '(#\/ :meta) 'com-dabbrev-expand)
-(global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
-(global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
+(global-set-key '(#\{ :meta :shift) 'com-backward-paragraph)
+(global-set-key '(#\} :meta :shift) 'com-forward-paragraph)
(global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*))
(global-set-key '(#\s :control) 'com-isearch-mode-forward)
(global-set-key '(#\r :control) 'com-isearch-mode-backward)
@@ -1380,11 +1478,14 @@
(global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
(global-set-key '(:insert) 'com-toggle-overwrite-mode)
+(global-set-key '(#\~ :meta :shift) 'com-not-modified)
(global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*))
(global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*))
-(global-set-key '(#\x :control :meta) '(com-eval-defun))
-
+(global-set-key '(#\x :control :meta) 'com-eval-defun)
+(global-set-key '(#\a :control :meta) 'com-beginning-of-definition)
+(global-set-key '(#\e :control :meta) 'com-end-of-definition)
+(global-set-key '(#\h :control :meta) 'com-mark-definition)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; C-x command table
@@ -1405,13 +1506,16 @@
(c-x-set-key '(#\3) 'com-split-window-horizontally)
(c-x-set-key '(#\b) 'com-switch-to-buffer)
(c-x-set-key '(#\f :control) 'com-find-file)
+(c-x-set-key '(#\f) `(com-set-fill-column ,*numeric-argument-marker*))
(c-x-set-key '(#\h) 'com-mark-whole-buffer)
(c-x-set-key '(#\i) 'com-insert-file)
(c-x-set-key '(#\k) 'com-kill-buffer)
-(c-x-set-key '(#\l :control) 'com-load-file)
(c-x-set-key '(#\o) 'com-other-window)
(c-x-set-key '(#\r) 'com-redo)
(c-x-set-key '(#\u) 'com-undo)
+(c-x-set-key '(#\]) `(com-forward-page ,*numeric-argument-marker*))
+(c-x-set-key '(#\[) `(com-backward-page ,*numeric-argument-marker*))
+(c-x-set-key '(#\l) 'com-count-lines-page)
(c-x-set-key '(#\s :control) 'com-save-buffer)
(c-x-set-key '(#\t :control) 'com-transpose-lines)
(c-x-set-key '(#\w :control) 'com-write-buffer)
Index: climacs/kill-ring.lisp
diff -u climacs/kill-ring.lisp:1.6 climacs/kill-ring.lisp:1.7
--- climacs/kill-ring.lisp:1.6 Sun Feb 27 19:52:01 2005
+++ climacs/kill-ring.lisp Fri Aug 5 14:40:56 2005
@@ -74,6 +74,11 @@
of the current contents of the top of the kill ring.
If the kill ring is empty the a new entry is pushed."))
+(defgeneric kill-ring-reverse-concatenating-push (kr vector)
+ (:documentation "Concatenates the contents of vector onto the front
+of the current contents of the top of the kill ring. If the kill ring
+is empty a new entry is pushed."))
+
(defgeneric kill-ring-yank (kr &optional reset)
(:documentation "Returns the vector of objects currently pointed to
by the cursor. If reset is T, a call to
@@ -128,6 +133,15 @@
(pop-start chain)
vector))))
(reset-yank-position kr))
+
+(defmethod kill-ring-reverse-concatenating-push ((kr kill-ring) vector)
+ (let ((chain (kill-ring-chain kr)))
+ (if (zerop (kill-ring-length kr))
+ (push-start chain vector)
+ (push-start chain
+ (concatenate 'vector
+ vector
+ (pop-start chain))))))
(defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL))
(if reset (reset-yank-position kr))
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.54 climacs/syntax.lisp:1.55
--- climacs/syntax.lisp:1.54 Thu Aug 4 03:10:45 2005
+++ climacs/syntax.lisp Fri Aug 5 14:40:56 2005
@@ -55,6 +55,18 @@
(defgeneric eval-defun (mark syntax))
+(defgeneric beginning-of-definition (mark syntax))
+
+(defgeneric end-of-definition (mark syntax))
+
+(defgeneric backward-paragraph (mark syntax))
+
+(defgeneric forward-paragraph (mark syntax))
+
+(defgeneric backward-sentence (mark syntax))
+
+(defgeneric forward-sentence (mark syntax))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Commenting
@@ -208,6 +220,24 @@
(error 'no-such-operation))
(defmethod eval-defun (mark syntax)
+ (error 'no-such-operation))
+
+(defmethod beginning-of-defintion (mark syntax)
+ (error 'no-such-operation))
+
+(defmethod end-of-definition (mark syntax)
+ (error 'no-such-operation))
+
+(defmethod backward-paragraph (mark syntax)
+ (error 'no-such-operation))
+
+(defmethod forward-paragraph (mark syntax)
+ (error 'no-such-operation))
+
+(defmethod backward-sentence (mark syntax)
+ (error 'no-such-operation))
+
+(defmethod forward-sentence (mark syntax)
(error 'no-such-operation))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
More information about the Climacs-cvs
mailing list