[climacs-cvs] CVS climacs

[thenriksen]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv9935

Modified Files:
	packages.lisp base.lisp 
Log Message:
Added `just-n-spaces' function.


--- /project/climacs/cvsroot/climacs/packages.lisp	2006/06/12 19:10:58	1.100
+++ /project/climacs/cvsroot/climacs/packages.lisp	2006/07/03 15:46:53	1.101
@@ -75,6 +75,7 @@
            #:buffer-display-column
 	   #:number-of-lines-in-region
 	   #:constituentp
+           #:just-n-spaces
 	   #:forward-word #:backward-word
            #:buffer-region-case
 	   #:input-from-stream #:output-to-stream
--- /project/climacs/cvsroot/climacs/base.lisp	2006/06/29 14:23:26	1.52
+++ /project/climacs/cvsroot/climacs/base.lisp	2006/07/03 15:46:53	1.53
@@ -144,6 +144,29 @@
   function does not respect the current syntax."
   (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))
 
+(defun just-n-spaces (mark1 n)
+  "Remove all spaces around `mark', leaving behind `n'
+spaces. `Mark' will be moved to after any spaces inserted."
+  (let ((mark2 (clone-mark mark1)))
+    (loop
+       while (not (beginning-of-buffer-p mark2))
+       while (eql (object-before mark2) #\Space)
+       do (backward-object mark2))
+    (loop
+       while (not (end-of-buffer-p mark1))
+       while (eql (object-after mark1) #\Space)
+       do (forward-object mark1))
+    (let ((existing-spaces (- (offset mark1)
+                              (offset mark2))))
+      (cond ((= n existing-spaces))
+            ((> n existing-spaces)
+             (insert-sequence mark1 (make-array (- n existing-spaces)
+                                                :initial-element #\Space)))
+            ((< n existing-spaces)
+             (delete-region (- (offset mark1)
+                               (- existing-spaces n))
+                            mark1))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
 ;;; Character case