[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp

Matthieu Villeneuve mvilleneuve at common-lisp.net
Sat Jan 15 17:39:30 UTC 2005


Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv1311

Modified Files:
	base.lisp buffer.lisp gui.lisp packages.lisp syntax.lisp 
Log Message:
Added tabify/untabify-region
Date: Sat Jan 15 18:39:24 2005
Author: mvilleneuve

Index: climacs/base.lisp
diff -u climacs/base.lisp:1.16 climacs/base.lisp:1.17
--- climacs/base.lisp:1.16	Thu Jan 13 17:52:14 2005
+++ climacs/base.lisp	Sat Jan 15 18:39:23 2005
@@ -96,6 +96,15 @@
 	count (eql (buffer-object buffer offset1) #\Newline)
 	do (incf offset1)))
 
+(defun buffer-display-column-number (buffer offset tab-width)
+  (let ((line-start-offset (- offset (buffer-column-number buffer offset))))
+    (loop with column = 0
+          for i from line-start-offset below offset
+          do (incf column (if (eql (buffer-object buffer i) #\Tab)
+                              (- tab-width (mod column tab-width))
+                              1))
+          finally (return column))))
+
 (defgeneric number-of-lines-in-region (mark1 mark2)
   (:documentation "Return the number of lines (or rather the number of
 Newline characters) in the region between MARK and MARK2.  It is
@@ -270,6 +279,72 @@
            (let ((offset (offset mark)))
              (forward-word mark)
              (capitalize-region offset mark))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; 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-number
+                             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)))
+  (tabify-buffer-region (buffer mark1) (offset mark1) (offset mark2)
+                         tab-width))
+
+(defmethod tabify-region ((offset integer) (mark mark) tab-width)
+  (tabify-buffer-region (buffer mark) offset (offset mark) tab-width))
+
+(defmethod tabify-region ((mark mark) (offset integer) tab-width)
+  (tabify-buffer-region (buffer mark) (offset mark) offset 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-number
+                           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))
+             (finish-output *error-output*)
+             (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)))
+  (untabify-buffer-region (buffer mark1) (offset mark1) (offset mark2)
+                          tab-width))
+
+(defmethod untabify-region ((offset integer) (mark mark) tab-width)
+  (untabify-buffer-region (buffer mark) offset (offset mark) tab-width))
+
+(defmethod untabify-region ((mark mark) (offset integer) tab-width)
+  (untabify-buffer-region (buffer mark) (offset mark) offset tab-width))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 


Index: climacs/buffer.lisp
diff -u climacs/buffer.lisp:1.19 climacs/buffer.lisp:1.20
--- climacs/buffer.lisp:1.19	Thu Jan 13 17:52:14 2005
+++ climacs/buffer.lisp	Sat Jan 15 18:39:24 2005
@@ -299,14 +299,30 @@
 	  do (incf offset))
     (setf (offset mark) offset)))
 
+(defgeneric buffer-line-number (buffer offset)
+  (:documentation "Return the line number of the offset.  Lines are numbered from zero."))
+
+(defmethod buffer-line-number ((buffer standard-buffer) (offset integer))
+  (loop for i from 0 below offset
+	count (eql (buffer-object buffer i) #\Newline)))
+
+(defgeneric buffer-column-number (buffer offset)
+  (:documentation "Return the column number of the offset. The column number of an offset is
+ the number of objects between it and the preceding newline, or
+ between it and the beginning of the buffer if the offset is on the
+ first line of the buffer."))
+
+(defmethod buffer-column-number ((buffer standard-buffer) (offset integer))
+  (loop for i downfrom offset
+	while (> i 0)
+	until (eql (buffer-object buffer (1- i)) #\Newline)
+	count t))
+
 (defgeneric line-number (mark)
   (:documentation "Return the line number of the mark.  Lines are numbered from zero."))
 
 (defmethod line-number ((mark mark-mixin))
-  (loop with buffer = (buffer mark)
-	with end = (offset mark)
-	for offset from 0 below end
-	count (eql (buffer-object buffer offset) #\Newline)))
+  (buffer-line-number (buffer mark) (offset mark)))
 
 (defgeneric column-number (mark)
   (:documentation "Return the column number of the mark. The column number of a mark is
@@ -315,10 +331,7 @@
  first line of the buffer."))
 
 (defmethod column-number ((mark mark-mixin))
-  (loop for offset downfrom (offset mark)
-	while (> offset 0)
-	until (eql (buffer-object (buffer mark) (1- offset)) #\Newline)
-	count t))
+  (buffer-column-number (buffer mark) (offset mark)))
 
 (defgeneric insert-buffer-object (buffer offset object)
   (:documentation "Insert the object at the offset in the buffer.  Any left-sticky marks


Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.68 climacs/gui.lisp:1.69
--- climacs/gui.lisp:1.68	Fri Jan 14 21:44:47 2005
+++ climacs/gui.lisp	Sat Jan 15 18:39:24 2005
@@ -416,6 +416,16 @@
 (define-named-command com-capitalize-word ()
   (capitalize-word (point (win *application-frame*))))
 
+(define-named-command com-tabify-region ()
+  (let ((pane (win *application-frame*)))
+    (multiple-value-bind (start end) (region-limits pane)
+      (tabify-region start end (tab-space-count (syntax pane))))))
+
+(define-named-command com-untabify-region ()
+  (let ((pane (win *application-frame*)))
+    (multiple-value-bind (start end) (region-limits pane)
+      (untabify-region start end (tab-space-count (syntax pane))))))
+
 (define-named-command com-toggle-layout ()
   (setf (frame-current-layout *application-frame*)
 	(if (eq (frame-current-layout *application-frame*) 'default)


Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.30 climacs/packages.lisp:1.31
--- climacs/packages.lisp:1.30	Fri Jan 14 14:07:39 2005
+++ climacs/packages.lisp	Sat Jan 15 18:39:24 2005
@@ -33,6 +33,7 @@
 	   #:beginning-of-buffer-p #:end-of-buffer-p
 	   #:beginning-of-line #:end-of-line
 	   #:beginning-of-line-p #:end-of-line-p
+	   #:buffer-line-number #:buffer-column-number
 	   #:line-number #:column-number
 	   #:insert-buffer-object #:insert-buffer-sequence
 	   #:insert-object #:insert-sequence
@@ -54,6 +55,7 @@
 	   #:delete-word #:backward-delete-word
            #:upcase-region #:downcase-region #:capitalize-region
            #:upcase-word #:downcase-word #:capitalize-word
+           #:tabify-region #:untabify-region
 	   #:input-from-stream #:output-to-stream
 	   #:name-mixin #:name
 	   #:buffer-lookin-at #:looking-at
@@ -69,6 +71,7 @@
 (defpackage :climacs-syntax
   (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain)
   (:export #:syntax #:define-syntax
+           #:tabify-mixin #:tab-space-count
 	   #:basic-syntax #:texinfo-syntax
 	   #:redisplay-pane #:redisplay-with-syntax #:full-redisplay
 	   #:page-down #:page-up


Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.23 climacs/syntax.lisp:1.24
--- climacs/syntax.lisp:1.23	Thu Jan 13 06:38:41 2005
+++ climacs/syntax.lisp	Sat Jan 15 18:39:24 2005
@@ -1,7 +1,9 @@
 ;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*-
 
-;;;  (c) copyright 2004 by
+;;;  (c) copyright 2004-2005 by
 ;;;           Robert Strandh (strandh at labri.fr)
+;;;  (c) copyright 2005 by
+;;;           Matthieu Villeneuve (matthieu.villeneuve at free.fr)
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Library General Public
@@ -36,6 +38,22 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
+;;; Tabify
+
+(defclass tabify-mixin ()
+  ((space-width :initarg nil :reader space-width)
+   (tab-width :initarg nil :reader tab-width)))
+
+(defgeneric tab-space-count (tabify))
+
+(defmethod tab-space-count (tabify)
+  1)
+
+(defmethod tab-space-count ((tabify tabify-mixin))
+  (round (tab-width tabify) (space-width tabify)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
 ;;; Syntax completion
 
 (defparameter *syntaxes* '())
@@ -69,14 +87,12 @@
     (insert* cache 0 nil)
     cache))
 
-(define-syntax basic-syntax ("Basic" (syntax))
+(define-syntax basic-syntax ("Basic" (syntax tabify-mixin))
   ((top :reader top)
    (bot :reader bot)
    (scan :reader scan)
    (cursor-x :initform 2)
    (cursor-y :initform 2)
-   (space-width :initform nil)
-   (tab-width :initform nil)
    (cache :initform (make-cache))))
 
 (defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane)




More information about the Climacs-cvs mailing list