[mcclim-cvs] CVS mcclim/Drei

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv26101

Modified Files:
	packages.lisp core.lisp 
Log Message:
Fixed `delete-indentation', added `join-line' and exported some more
symbols from DREI-LISP-SYNTAX.


--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2007/01/15 11:35:54	1.12
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2007/02/13 12:14:12	1.13
@@ -410,6 +410,7 @@
            #:indent-region
            #:fill-line #:fill-region
            #:indent-line #:delete-indentation
+           #:join-line
            #:set-syntax
 
            #:*killed-rectangle*
@@ -445,7 +446,8 @@
            #:edit-definition
            #:form
            #:form-to-object
-           #:form-conversion-error)
+           #:form-conversion-error
+           #:forward-one-list #:backward-one-list #:forward-list #:backward-list)
   (:shadow clim:form)
   (:documentation "Implementation of the syntax module used for
 editing Common Lisp code."))
--- /project/mcclim/cvsroot/mcclim/Drei/core.lisp	2007/02/12 19:32:58	1.4
+++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp	2007/02/13 12:14:12	1.5
@@ -294,11 +294,33 @@
   (let ((working-mark (clone-mark mark)))
     (beginning-of-line working-mark)
     (let ((end-offset (loop for offset from (offset working-mark) below (size *current-buffer*)
-                         unless (whitespacep syntax (buffer-object *current-buffer* offset))
+                         for buffer-object = (buffer-object *current-buffer* offset)
+                         until (char= buffer-object #\Newline)
+                         unless (whitespacep syntax buffer-object)
                          return offset)))
       (when end-offset
         (delete-region working-mark end-offset)))))
 
+(defgeneric join-line (syntax mark)
+  (:documentation "Join the line that `mark' is in to the
+previous line, and remove whitespace objects at the join
+point. `Syntax' is used for judging what a whitespace character
+is."))
+
+(defmethod join-line ((syntax syntax) (mark mark))
+  (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))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
 ;;; Syntax handling