[climacs-cvs] CVS climacs

[thenriksen]

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

Modified Files:
	packages.lisp lisp-syntax-commands.lisp base.lisp 
Log Message:
Added `fill-region' function and used it to implement filling of
strings in the Lisp syntax. I have not implemented a Fill Region
command because it seemed to fit poorly within the way filling works
in Climacs.


--- /project/climacs/cvsroot/climacs/packages.lisp	2006/05/28 15:58:24	1.97
+++ /project/climacs/cvsroot/climacs/packages.lisp	2006/06/05 21:01:51	1.98
@@ -77,7 +77,7 @@
            #:indent-line
            #:indent-region
            #:delete-indentation
-           #:fill-line
+           #:fill-line #:fill-region
 	   #:input-from-stream #:output-to-stream
 	   #:name-mixin #:name
 	   #:buffer-looking-at #:looking-at
--- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp	2006/03/26 14:14:48	1.4
+++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp	2006/06/05 21:01:51	1.5
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
+;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX; -*-
 
 ;;;  (c) copyright 2004-2005 by
 ;;;           Robert Strandh (strandh at labri.fr)
@@ -43,13 +43,36 @@
 (define-command (com-package :name t :command-table lisp-table) ()
   (let* ((pane (current-window))
          (syntax (syntax (buffer pane)))
-         (package (climacs-lisp-syntax::package-of syntax)))
+         (package (package-at-mark syntax (point pane))))
     (esa:display-message (format nil "~A" (if (packagep package)
                                               (package-name package)
                                               package)))))
 
-(define-command (com-fill-paragraph :name t :command-table lisp-table) ()
-  )
+(define-command (com-fill-paragraph :name t :command-table lisp-table) 
+    ()
+  "Fill paragraph at point. Will have no effect unless there is a
+string at point."
+  (let* ((pane (current-window))
+         (buffer (buffer pane))
+         (implementation (implementation buffer))
+         (syntax (syntax buffer))
+         (token (form-around syntax (offset (point pane))))
+         (fill-column (auto-fill-column pane))
+         (tab-width (tab-space-count (stream-default-view pane))))
+    (when (typep token 'string-form)
+      (with-accessors ((offset1 start-offset) 
+                       (offset2 end-offset)) token
+        (fill-region (make-instance 'standard-right-sticky-mark
+                                    :buffer implementation
+                                    :offset offset1)
+                     (make-instance 'standard-right-sticky-mark
+                                    :buffer implementation
+                                    :offset offset2)
+                     #'(lambda (mark)
+                         (syntax-line-indentation mark tab-width syntax))
+                     fill-column
+                     tab-width
+                     t)))))
 
 (esa:set-key 'com-fill-paragraph
              'lisp-table
--- /project/climacs/cvsroot/climacs/base.lisp	2006/05/14 20:35:44	1.49
+++ /project/climacs/cvsroot/climacs/base.lisp	2006/06/05 21:01:51	1.50
@@ -587,6 +587,23 @@
                (setf column 0))
              (incf (offset walking-mark)))))
 
+(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width
+                    &optional (compress-whitespaces t))
+  "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be
+mark<= `mark2.'"
+  (let* ((buffer (buffer mark1)))
+    (do-buffer-region (object offset buffer
+                              (offset mark1) (offset mark2))
+      (when (eql object #\Newline)
+        (setf object #\Space)))
+    (when (>= (buffer-display-column buffer (offset mark2) tab-width)
+              (1- fill-column))
+      (fill-line mark2
+                 syntax-line-indentation-function
+                 fill-column
+                 tab-width
+                 compress-whitespaces))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
 ;;; Named objects