[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Fri Jul 7 23:59:38 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv10216
Modified Files:
packages.lisp editing.lisp base.lisp
Log Message:
A number of major changes, involving moving a bit of stuff back from
editing.lisp (and CLIMACS EDITING) to base.lisp (and CLIMACS-BASE).
* Reintroduced primitive, non-syntax-aware `previous-line' and
`next-line' generic functions.
* Moved `open-line' back to base.lisp and added a primitive
`delete-line' function for deleting lines at a given mark.
* Moved most of the character casing, tabyfying and indentation code
back from editing.lisp to base.lisp. I'm still not sure it belongs
there, but it will have to do for now.
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/03 15:46:53 1.101
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/07 23:59:38 1.102
@@ -70,12 +70,15 @@
(:export #:do-buffer-region
#:do-buffer-region-lines
#:previous-line #:next-line
+ #:open-line
+ #:delete-line
#:empty-line-p
#:line-indentation
#:buffer-display-column
#:number-of-lines-in-region
#:constituentp
#:just-n-spaces
+ #:buffer-whitespacep
#:forward-word #:backward-word
#:buffer-region-case
#:input-from-stream #:output-to-stream
@@ -85,6 +88,11 @@
#:buffer-re-search-forward #:buffer-re-search-backward
#:search-forward #:search-backward
#:re-search-forward #:re-search-backward
+ #:downcase-buffer-region #:downcase-region
+ #:upcase-buffer-region #:upcase-region
+ #:capitalize-buffer-region #:capitalize-region
+ #:tabify-region #:untabify-region
+ #:indent-line #:delete-indentation
#:*kill-ring*))
(defpackage :climacs-abbrev
@@ -231,7 +239,6 @@
(:use :clim-lisp :clim :climacs-base :climacs-buffer
:climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring)
(:export #:transpose-objects
- #:open-line
;; Lines
#:forward-delete-line #:backward-delete-line
@@ -271,15 +278,10 @@
#:forward-kill-sentence #:backward-kill-sentence
#:transpose-sentences
- #:downcase-buffer-region #:downcase-region
- #:upcase-buffer-region #:upcase-region
- #:downcase-word #:upcase-word
- #:capitalize-buffer-region #:capitalize-region
- #:capitalize-word
- #:tabify-region #:untabify-region
- #:indent-line
+
+ #:downcase-word #:upcase-word #:capitalize-word
+
#:indent-region
- #:delete-indentation
#:fill-line
#:fill-region))
--- /project/climacs/cvsroot/climacs/editing.lisp 2006/06/12 19:10:58 1.1
+++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/07 23:59:38 1.2
@@ -211,17 +211,6 @@
;;;
;;; Line editing
-(defmethod open-line ((mark left-sticky-mark) &optional (count 1))
- "Create a new line in a buffer after the mark."
- (loop repeat count
- do (insert-object mark #\Newline)))
-
-(defmethod open-line ((mark right-sticky-mark) &optional (count 1))
- "Create a new line in a buffer after the mark."
- (loop repeat count
- do (insert-object mark #\Newline)
- (decf (offset mark))))
-
(define-edit-fns line)
(define-edit-fns line-start)
@@ -280,38 +269,6 @@
;;;
;;; Character case
-;;; I'd rather have update-buffer-range methods spec. on buffer for this,
-;;; for performance and history-size reasons --amb
-(defun downcase-buffer-region (buffer offset1 offset2)
- (do-buffer-region (object offset buffer offset1 offset2)
- (when (and (constituentp object) (upper-case-p object))
- (setf object (char-downcase object)))))
-
-(defgeneric downcase-region (mark1 mark2)
- (:documentation "Convert all characters after mark1 and before mark2 to
-lowercase. An error is signaled if the two marks are positioned in different
-buffers. It is acceptable to pass an offset in place of one of the marks."))
-
-(defmethod downcase-region ((mark1 mark) (mark2 mark))
- (assert (eq (buffer mark1) (buffer mark2)))
- (let ((offset1 (offset mark1))
- (offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (downcase-buffer-region (buffer mark1) offset1 offset2)))
-
-(defmethod downcase-region ((offset1 integer) (mark2 mark))
- (let ((offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (downcase-buffer-region (buffer mark2) offset1 offset2)))
-
-(defmethod downcase-region ((mark1 mark) (offset2 integer))
- (let ((offset1 (offset mark1)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (downcase-buffer-region (buffer mark1) offset1 offset2)))
-
(defun downcase-word (mark &optional (n 1))
"Convert the next N words to lowercase, leaving mark after the last word."
(let ((syntax (syntax (buffer mark))))
@@ -321,36 +278,6 @@
(forward-word mark syntax 1 nil)
(downcase-region offset mark)))))
-(defun upcase-buffer-region (buffer offset1 offset2)
- (do-buffer-region (object offset buffer offset1 offset2)
- (when (and (constituentp object) (lower-case-p object))
- (setf object (char-upcase object)))))
-
-(defgeneric upcase-region (mark1 mark2)
- (:documentation "Convert all characters after mark1 and before mark2 to
-uppercase. An error is signaled if the two marks are positioned in different
-buffers. It is acceptable to pass an offset in place of one of the marks."))
-
-(defmethod upcase-region ((mark1 mark) (mark2 mark))
- (assert (eq (buffer mark1) (buffer mark2)))
- (let ((offset1 (offset mark1))
- (offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (upcase-buffer-region (buffer mark1) offset1 offset2)))
-
-(defmethod upcase-region ((offset1 integer) (mark2 mark))
- (let ((offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (upcase-buffer-region (buffer mark2) offset1 offset2)))
-
-(defmethod upcase-region ((mark1 mark) (offset2 integer))
- (let ((offset1 (offset mark1)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (upcase-buffer-region (buffer mark1) offset1 offset2)))
-
(defun upcase-word (mark syntax &optional (n 1))
"Convert the next N words to uppercase, leaving mark after the last word."
(loop repeat n
@@ -359,42 +286,6 @@
(forward-word mark syntax 1 nil)
(upcase-region offset mark))))
-(defun capitalize-buffer-region (buffer offset1 offset2)
- (let ((previous-char-constituent-p nil))
- (do-buffer-region (object offset buffer offset1 offset2)
- (when (constituentp object)
- (if previous-char-constituent-p
- (when (upper-case-p object)
- (setf object (char-downcase object)))
- (when (lower-case-p object)
- (setf object (char-upcase object)))))
- (setf previous-char-constituent-p (constituentp object)))))
-
-(defgeneric capitalize-region (mark1 mark2)
- (:documentation "Capitalize all words after mark1 and before mark2.
-An error is signaled if the two marks are positioned in different buffers.
-It is acceptable to pass an offset in place of one of the marks."))
-
-(defmethod capitalize-region ((mark1 mark) (mark2 mark))
- (assert (eq (buffer mark1) (buffer mark2)))
- (let ((offset1 (offset mark1))
- (offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (capitalize-buffer-region (buffer mark1) offset1 offset2)))
-
-(defmethod capitalize-region ((offset1 integer) (mark2 mark))
- (let ((offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (capitalize-buffer-region (buffer mark2) offset1 offset2)))
-
-(defmethod capitalize-region ((mark1 mark) (offset2 integer))
- (let ((offset1 (offset mark1)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (capitalize-buffer-region (buffer mark1) offset1 offset2)))
-
(defun capitalize-word (mark &optional (n 1))
"Capitalize the next N words, leaving mark after the last word."
(let ((syntax (syntax (buffer mark))))
@@ -406,134 +297,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; Tabify
-
-(defun tabify-buffer-region (buffer offset1 offset2 tab-width)
- (flet ((looking-at-spaces (buffer offset count)
- (loop for i from offset
- repeat count
- unless (char= (buffer-object buffer i) #\Space)
- return nil
- finally (return t))))
- (loop for offset = offset1 then (1+ offset)
- until (>= offset offset2)
- do (let* ((column (buffer-display-column
- buffer offset tab-width))
- (count (- tab-width (mod column tab-width))))
- (when (looking-at-spaces buffer offset count)
- (finish-output)
- (delete-buffer-range buffer offset count)
- (insert-buffer-object buffer offset #\Tab)
- (decf offset2 (1- count)))))))
-
-(defgeneric tabify-region (mark1 mark2 tab-width)
- (:documentation "Replace sequences of tab-width spaces with tabs
-in the region delimited by mark1 and mark2."))
-
-(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width)
- (assert (eq (buffer mark1) (buffer mark2)))
- (let ((offset1 (offset mark1))
- (offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
-
-(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width)
- (let ((offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))
-
-(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width)
- (let ((offset1 (offset mark1)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
-
-(defun untabify-buffer-region (buffer offset1 offset2 tab-width)
- (loop for offset = offset1 then (1+ offset)
- until (>= offset offset2)
- when (char= (buffer-object buffer offset) #\Tab)
- do (let* ((column (buffer-display-column buffer
- offset
- tab-width))
- (count (- tab-width (mod column tab-width))))
- (delete-buffer-range buffer offset 1)
- (loop repeat count
- do (insert-buffer-object buffer offset #\Space))
- (incf offset (1- count))
- (incf offset2 (1- count)))))
-
-(defgeneric untabify-region (mark1 mark2 tab-width)
- (:documentation "Replace tabs with tab-width spaces in the region
-delimited by mark1 and mark2."))
-
-(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width)
- (assert (eq (buffer mark1) (buffer mark2)))
- (let ((offset1 (offset mark1))
- (offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
-
-(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width)
- (let ((offset2 (offset mark2)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))
-
-(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width)
- (let ((offset1 (offset mark1)))
- (when (> offset1 offset2)
- (rotatef offset1 offset2))
- (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
;;; Indentation
-(defgeneric indent-line (mark indentation tab-width)
- (:documentation "Indent the line containing mark with indentation
-spaces. Use tabs and spaces if tab-width is not nil, otherwise use
-spaces only."))
-
-(defun indent-line* (mark indentation tab-width left)
- (let ((mark2 (clone-mark mark)))
- (beginning-of-line mark2)
- (loop until (end-of-buffer-p mark2)
- as object = (object-after mark2)
- while (or (eql object #\Space) (eql object #\Tab))
- do (delete-range mark2 1))
- (loop until (zerop indentation)
- do (cond ((and tab-width (>= indentation tab-width))
- (insert-object mark2 #\Tab)
- (when left ; spaces must follow tabs
- (forward-object mark2))
- (decf indentation tab-width))
- (t
- (insert-object mark2 #\Space)
- (decf indentation))))))
-
-(defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
- (indent-line* mark indentation tab-width t))
-
-(defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
- (indent-line* mark indentation tab-width nil))
-
-(defun delete-indentation (mark syntax)
- (beginning-of-line mark)
- (unless (beginning-of-buffer-p mark)
- (delete-range mark -1)
- (loop until (end-of-buffer-p mark)
- while (whitespacep syntax (object-after mark))
- do (delete-range mark 1))
- (loop until (beginning-of-buffer-p mark)
- while (whitespacep syntax (object-before mark))
- do (delete-range mark -1))
- (when (and (not (beginning-of-buffer-p mark))
- (constituentp (object-before mark)))
- (insert-object mark #\Space))))
-
(defun indent-region (pane mark1 mark2)
"Indent all lines in the region delimited by `mark1' and `mark2'
according to the rules of the active syntax in `pane'."
--- /project/climacs/cvsroot/climacs/base.lisp 2006/07/03 15:46:53 1.53
+++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/07 23:59:38 1.54
@@ -63,6 +63,81 @@
(unless (end-of-buffer-p ,mark-sym)
(forward-object ,mark-sym)))))))
+(defgeneric previous-line (mark &optional column count)
+ (:documentation "Move a mark up `count' lines conserving
+ horizontal position. This is a relatively low-level function,
+ you should probably use `climacs-motion:backward-line'
+ instead."))
+
+(defmethod previous-line (mark &optional column (count 1))
+ (unless column
+ (setf column (column-number mark)))
+ (loop repeat count
+ do (beginning-of-line mark)
+ until (beginning-of-buffer-p mark)
+ do (backward-object mark))
+ (end-of-line mark)
+ (when (> (column-number mark) column)
+ (beginning-of-line mark)
+ (incf (offset mark) column)))
+
+(defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1))
+ (unless column
+ (setf column (column-number mark)))
+ (let* ((line (line-number mark))
+ (goto-line (max 0 (- line count))))
+ (setf (offset mark)
+ (+ column (buffer-line-offset (buffer mark) goto-line)))))
+
+(defgeneric next-line (mark &optional column count)
+ (:documentation "Move a mark down `count' lines conserving
+ horizontal position. This is a relatively low-level function,
+ you should probably use `climacs-motion:forward-line'
+ instead."))
+
+(defmethod next-line (mark &optional column (count 1))
+ (unless column
+ (setf column (column-number mark)))
+ (loop repeat count
+ do (end-of-line mark)
+ until (end-of-buffer-p mark)
+ do (forward-object mark))
+ (end-of-line mark)
+ (when (> (column-number mark) column)
+ (beginning-of-line mark)
+ (incf (offset mark) column)))
+
+(defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1))
+ (unless column
+ (setf column (column-number mark)))
+ (let* ((line (line-number mark))
+ (goto-line (min (number-of-lines (buffer mark))
+ (+ line count))))
+ (setf (offset mark)
+ (+ column (buffer-line-offset (buffer mark) goto-line)))))
+
+(defgeneric open-line (mark &optional count)
+ (:documentation "Create a new line in a buffer after the mark."))
+
+(defmethod open-line ((mark left-sticky-mark) &optional (count 1))
+ (loop repeat count
+ do (insert-object mark #\Newline)))
+
+(defmethod open-line ((mark right-sticky-mark) &optional (count 1))
+ (loop repeat count
+ do (insert-object mark #\Newline)
+ (decf (offset mark))))
+
+(defun delete-line (mark &optional (count 1))
+ "Delete `count' lines at `mark' from the buffer."
+ (dotimes (i count)
+ (if (end-of-line-p mark)
+ (unless (end-of-buffer-p mark)
+ (delete-range mark))
+ (let ((offset (offset mark)))
+ (end-of-line mark)
+ (delete-region offset mark)))))
+
(defun empty-line-p (mark)
"Check whether the mark is in an empty line."
(and (beginning-of-line-p mark) (end-of-line-p mark)))
@@ -381,6 +456,238 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
+;;; Character case
+
+;;; I'd rather have update-buffer-range methods spec. on buffer for this,
+;;; for performance and history-size reasons --amb
+(defun downcase-buffer-region (buffer offset1 offset2)
+ (do-buffer-region (object offset buffer offset1 offset2)
+ (when (and (constituentp object) (upper-case-p object))
+ (setf object (char-downcase object)))))
+
+(defgeneric downcase-region (mark1 mark2)
+ (:documentation "Convert all characters after mark1 and before mark2 to
+lowercase. An error is signaled if the two marks are positioned in different
+buffers. It is acceptable to pass an offset in place of one of the marks."))
+
+(defmethod downcase-region ((mark1 mark) (mark2 mark))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (downcase-buffer-region (buffer mark1) offset1 offset2)))
+
+(defmethod downcase-region ((offset1 integer) (mark2 mark))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (downcase-buffer-region (buffer mark2) offset1 offset2)))
+
+(defmethod downcase-region ((mark1 mark) (offset2 integer))
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (downcase-buffer-region (buffer mark1) offset1 offset2)))
+
+(defun upcase-buffer-region (buffer offset1 offset2)
+ (do-buffer-region (object offset buffer offset1 offset2)
+ (when (and (constituentp object) (lower-case-p object))
+ (setf object (char-upcase object)))))
+
+(defgeneric upcase-region (mark1 mark2)
+ (:documentation "Convert all characters after mark1 and before mark2 to
+uppercase. An error is signaled if the two marks are positioned in different
+buffers. It is acceptable to pass an offset in place of one of the marks."))
+
+(defmethod upcase-region ((mark1 mark) (mark2 mark))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (upcase-buffer-region (buffer mark1) offset1 offset2)))
+
+(defmethod upcase-region ((offset1 integer) (mark2 mark))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (upcase-buffer-region (buffer mark2) offset1 offset2)))
+
+(defmethod upcase-region ((mark1 mark) (offset2 integer))
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (upcase-buffer-region (buffer mark1) offset1 offset2)))
+
+(defun capitalize-buffer-region (buffer offset1 offset2)
+ (let ((previous-char-constituent-p nil))
+ (do-buffer-region (object offset buffer offset1 offset2)
+ (when (constituentp object)
+ (if previous-char-constituent-p
+ (when (upper-case-p object)
+ (setf object (char-downcase object)))
+ (when (lower-case-p object)
+ (setf object (char-upcase object)))))
+ (setf previous-char-constituent-p (constituentp object)))))
+
+(defgeneric capitalize-region (mark1 mark2)
+ (:documentation "Capitalize all words after mark1 and before mark2.
+An error is signaled if the two marks are positioned in different buffers.
+It is acceptable to pass an offset in place of one of the marks."))
+
+(defmethod capitalize-region ((mark1 mark) (mark2 mark))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (capitalize-buffer-region (buffer mark1) offset1 offset2)))
+
+(defmethod capitalize-region ((offset1 integer) (mark2 mark))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (capitalize-buffer-region (buffer mark2) offset1 offset2)))
+
+(defmethod capitalize-region ((mark1 mark) (offset2 integer))
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (capitalize-buffer-region (buffer mark1) offset1 offset2)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Tabify
+
+(defun tabify-buffer-region (buffer offset1 offset2 tab-width)
+ (flet ((looking-at-spaces (buffer offset count)
+ (loop for i from offset
+ repeat count
+ unless (char= (buffer-object buffer i) #\Space)
+ return nil
+ finally (return t))))
+ (loop for offset = offset1 then (1+ offset)
+ until (>= offset offset2)
+ do (let* ((column (buffer-display-column
+ buffer offset tab-width))
+ (count (- tab-width (mod column tab-width))))
+ (when (looking-at-spaces buffer offset count)
+ (finish-output)
+ (delete-buffer-range buffer offset count)
+ (insert-buffer-object buffer offset #\Tab)
+ (decf offset2 (1- count)))))))
+
+(defgeneric tabify-region (mark1 mark2 tab-width)
+ (:documentation "Replace sequences of tab-width spaces with tabs
+in the region delimited by mark1 and mark2."))
+
+(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width)
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
+
+(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width)
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))
+
+(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width)
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
+
+(defun untabify-buffer-region (buffer offset1 offset2 tab-width)
+ (loop for offset = offset1 then (1+ offset)
+ until (>= offset offset2)
+ when (char= (buffer-object buffer offset) #\Tab)
+ do (let* ((column (buffer-display-column buffer
+ offset
+ tab-width))
+ (count (- tab-width (mod column tab-width))))
+ (delete-buffer-range buffer offset 1)
+ (loop repeat count
+ do (insert-buffer-object buffer offset #\Space))
+ (incf offset (1- count))
+ (incf offset2 (1- count)))))
+
+(defgeneric untabify-region (mark1 mark2 tab-width)
+ (:documentation "Replace tabs with tab-width spaces in the region
+delimited by mark1 and mark2."))
+
+(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width)
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
+
+(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width)
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))
+
+(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width)
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Indentation
+
+(defgeneric indent-line (mark indentation tab-width)
+ (:documentation "Indent the line containing mark with indentation
+spaces. Use tabs and spaces if tab-width is not nil, otherwise use
+spaces only."))
+
+(defun indent-line* (mark indentation tab-width left)
+ (let ((mark2 (clone-mark mark)))
+ (beginning-of-line mark2)
+ (loop until (end-of-buffer-p mark2)
+ as object = (object-after mark2)
+ while (or (eql object #\Space) (eql object #\Tab))
+ do (delete-range mark2 1))
+ (loop until (zerop indentation)
+ do (cond ((and tab-width (>= indentation tab-width))
+ (insert-object mark2 #\Tab)
+ (when left ; spaces must follow tabs
+ (forward-object mark2))
+ (decf indentation tab-width))
+ (t
+ (insert-object mark2 #\Space)
+ (decf indentation))))))
+
+(defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
+ (indent-line* mark indentation tab-width t))
+
+(defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
+ (indent-line* mark indentation tab-width nil))
+
+(defun delete-indentation (mark)
+ (beginning-of-line mark)
+ (unless (beginning-of-buffer-p mark)
+ (delete-range mark -1)
+ (loop until (end-of-buffer-p mark)
+ while (buffer-whitespacep (object-after mark))
+ do (delete-range mark 1))
+ (loop until (beginning-of-buffer-p mark)
+ while (buffer-whitespacep (object-before mark))
+ do (delete-range mark -1))
+ (when (and (not (beginning-of-buffer-p mark))
+ (constituentp (object-before mark)))
+ (insert-object mark #\Space))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
;;; Kill ring
-(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
\ No newline at end of file
+(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
More information about the Climacs-cvs
mailing list