[climacs-cvs] CVS climacs - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

12 Nov 2006

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv16484
Modified Files:
    cl-syntax.lisp climacs.asd climacs.lisp core.lisp 
    developer-commands.lisp file-commands.lisp groups.lisp 
    gui.lisp html-syntax.lisp misc-commands.lisp packages.lisp 
    prolog-syntax.lisp prolog2paiprolog.lisp search-commands.lisp 
    slidemacs-gui.lisp slidemacs.lisp text-syntax.lisp 
    ttcn3-syntax.lisp window-commands.lisp 
Added Files:
    climacs-lisp-syntax-commands.lisp climacs-lisp-syntax.lisp 
Log Message:
Make Climacs use Drei. There are known problems (apart from the docs
now being outdated):
* Some syntaxes have not been updated.
* Group functionality has been disabled.
* It's a large change and Climacs has no test suite. Bugs probably
  still remain.
But it should work nicely most of the time. Otherwise, you'll get a
full refund.

--- /project/climacs/cvsroot/climacs/cl-syntax.lisp	2006/09/02 21:43:56	1.20
+++ /project/climacs/cvsroot/climacs/cl-syntax.lisp	2006/11/12 16:06:06	1.21
@@ -1106,7 +1106,7 @@
    (display-parse-tree (target-parse-tree state) syntax pane))))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax cl-syntax) current-p)
+(defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax cl-syntax) current-p)
   (with-slots (top bot) pane
     (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
      *current-line* 0
--- /project/climacs/cvsroot/climacs/climacs.asd	2006/09/12 17:24:56	1.56
+++ /project/climacs/cvsroot/climacs/climacs.asd	2006/11/12 16:06:06	1.57
@@ -29,105 +29,31 @@
(defparameter *climacs-directory* (directory-namestring *load-truename*))
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun find-swank-package ()
-    (find-package :swank))
-  (defun find-swank-system ()
-    (handler-case (asdf:find-system :swank)
-      (asdf:missing-component ())))
-  (defun find-swank ()
-    (or (find-swank-package)
-        (find-swank-system))))
-
 (defsystem :climacs
-  :depends-on (:mcclim :flexichain :esa #.(if (find-swank-system) :swank (values)))
+  :depends-on (:mcclim :flexichain)
   :components
-  ((:module "cl-automaton"
-	    :components ((:file "automaton-package")
-			 (:file "eqv-hash" :depends-on ("automaton-package"))
-			 (:file "state-and-transition" :depends-on ("eqv-hash"))
-			 (:file "automaton" :depends-on ("state-and-transition" "eqv-hash"))
-			 (:file "regexp" :depends-on ("automaton"))))
-   (:module "Persistent"
-            :components ((:file "binseq-package")
-                         (:file "binseq" :depends-on ("binseq-package"))
-                         (:file "obinseq" :depends-on ("binseq-package" "binseq"))
-                         (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq"))))
-
-   (:file "packages" :depends-on ("cl-automaton" "Persistent"))
-   (:file "utils" :depends-on ("packages"))
-   (:file "buffer" :depends-on ("packages"))
-   (:file "motion" :depends-on ("packages" "buffer" "syntax"))
-   (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring"))
-   (:file "persistent-buffer"
-          :pathname #p"Persistent/persistent-buffer.lisp"
-          :depends-on ("packages" "buffer" "Persistent"))
-
-   (:file "base" :depends-on ("packages" "utils" "buffer" "persistent-buffer" "kill-ring"))
-   (:file "abbrev" :depends-on ("packages" "buffer" "base"))
-   (:file "syntax" :depends-on ("packages" "utils" "buffer" "base"))
-   (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion"))
-   (:file "delegating-buffer" :depends-on ("packages" "buffer"))
-   (:file "kill-ring" :depends-on ("packages"))
-   (:file "undo" :depends-on ("packages"))
-   (:file "persistent-undo"
-          :pathname #p"Persistent/persistent-undo.lisp"
-          :depends-on ("packages" "buffer" "persistent-buffer" "undo"))
-   (:file "pane" :depends-on ("packages" "utils" "syntax" "buffer" "base"
-                                         "persistent-undo" "persistent-buffer" "abbrev"
-                                         "delegating-buffer" "undo"))
-   (:file "fundamental-syntax" :depends-on ("packages" "syntax" "buffer" "pane"
-                                                       "base"))
-   (:file "cl-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
-   (:file "html-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
-   (:file "prolog-syntax" :depends-on ("packages" "base" "syntax" "pane" "buffer"))
+  ((:file "packages")
+   (:file "text-syntax" :depends-on ("packages"))
+   (:file "cl-syntax" :depends-on ("packages"))
+   (:file "html-syntax" :depends-on ("packages"))
+   (:file "prolog-syntax" :depends-on ("packages"))
    (:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
-   (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base"
-						 "pane"))
-   (:file "lisp-syntax" :depends-on ("packages" "utils" "syntax" "buffer" "base" "pane"
-						"window-commands" "gui" "groups"))
-   (:file "lisp-syntax-swine" :depends-on ("lisp-syntax"))
-   (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands"
-                                                                  "editing-commands" "misc-commands"))
-   #.(if (find-swank)
-         '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax"))
-         (values))
-   (:file "gui" :depends-on ("packages" "utils" "syntax" "base" "buffer" "undo" "pane"
-                                        "kill-ring" "text-syntax"
-					"abbrev" "editing" "motion"))
-   (:file "io" :depends-on ("packages" "gui"))
+   (:file "ttcn3-syntax" :depends-on ("packages"))
+   (:file "climacs-lisp-syntax" :depends-on ("core" #+nil groups))
+   (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands"))
+   (:file "gui" :depends-on ("packages" "text-syntax"))
    (:file "core" :depends-on ("gui"))
-   (:file "rectangle" :depends-on ("core"))
-   (:file "groups" :depends-on ("core"))
+   (:file "io" :depends-on ("packages" "gui"))
+   #+nil (:file "groups" :depends-on ("core"))
    (:file "climacs" :depends-on ("gui" "core"))
-;;    (:file "buffer-commands" :depends-on ("gui"))
-   (:file "developer-commands" :depends-on ("gui" "lisp-syntax" "core"))
-   (:file "motion-commands" :depends-on ("gui" "core"))
-   (:file "editing-commands" :depends-on ("gui" "core"))
+   (:file "developer-commands" :depends-on ("core"))
+  
    (:file "file-commands" :depends-on ("gui" "core"))
-   (:file "misc-commands" :depends-on ("gui" "core" "rectangle" "groups"))
-   (:file "search-commands" :depends-on ("gui" "core"))
+   (:file "misc-commands" :depends-on ("gui" "core" #+nil "groups"))
+   (:file "search-commands" :depends-on ("gui" "core" #+nil "groups"))
    (:file "window-commands" :depends-on ("gui" "core"))
-   (:file "unicode-commands" :depends-on ("gui" "core"))
-   (:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane" ))
-   (:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax" "gui"))))
-
-(defsystem :climacs.tests
-  :depends-on (:climacs)
-  :components
-  ((:file "rt" :pathname #p"testing/rt.lisp")
-   (:file "buffer-test" :depends-on ("rt"))
-   (:file "base-test" :depends-on ("rt" "buffer-test"))
-   (:file "kill-ring-test" :depends-on ("buffer-test"))
-   (:module
-    "cl-automaton"
-    :depends-on ("rt")
-    :components
-    ((:file "automaton-test-package")
-     (:file "eqv-hash-test" :depends-on ("automaton-test-package"))
-     (:file "state-and-transition-test" :depends-on ("automaton-test-package"))
-     (:file "automaton-test" :depends-on ("automaton-test-package"))
-     (:file "regexp-test" :depends-on ("automaton-test-package"))))))
+   (:file "slidemacs" :depends-on ("packages" ))
+   (:file "slidemacs-gui" :depends-on ("packages" "gui" "slidemacs"))))
#+asdf
 (defmethod asdf:perform :around ((o asdf:compile-op)
--- /project/climacs/cvsroot/climacs/climacs.lisp	2006/07/11 14:20:20	1.3
+++ /project/climacs/cvsroot/climacs/climacs.lisp	2006/11/12 16:06:06	1.4
@@ -46,8 +46,8 @@
   ;; SBCL doesn't inherit dynamic bindings when starting new
   ;; processes, so start a new processes and THEN setup the colors.
   (flet ((run ()
-           (let ((*bg-color* +black+)
-                 (*fg-color* +gray+)
+           (let ((*background-color* +black+)
+                 (*foreground-color* +gray+)
                  (*info-bg-color* +darkslategray+)
                  (*info-fg-color* +gray+)
                  (*mini-bg-color* +black+)
--- /project/climacs/cvsroot/climacs/core.lisp	2006/09/12 19:49:18	1.10
+++ /project/climacs/cvsroot/climacs/core.lisp	2006/11/12 16:06:06	1.11
@@ -15,323 +15,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
-;;; Misc stuff
-
-(defun display-string (string)
-  (with-output-to-string (result)
-    (loop for char across string
-	  do (cond ((graphic-char-p char) (princ char result))
-		((char= char #\Space) (princ char result))
-		(t (prin1 char result))))))
-
-(defun object-equal (x y)
-  "Case insensitive equality that doesn't require characters"
-  (if (characterp x)
-      (and (characterp y) (char-equal x y))
-      (eql x y)))
-
-(defun object= (x y)
-  "Case sensitive equality that doesn't require characters"
-  (if (characterp x)
-      (and (characterp y) (char= x y))
-      (eql x y)))
-
-(defun no-upper-p (string)
-  "Does STRING contain no uppercase characters"
-  (notany #'upper-case-p string))
-
-(defun case-relevant-test (string)
-  "Returns a test function based on the search-string STRING.
-If STRING contains no uppercase characters the test is case-insensitive,
-otherwise it is case-sensitive."
-  (if (no-upper-p string)
-      #'object-equal
-      #'object=))
-
-(defun possibly-fill-line ()
-  (let* ((pane (current-window))
-         (buffer (buffer pane)))
-    (when (auto-fill-mode pane)
-      (let* ((fill-column (auto-fill-column pane))
-             (point (point pane))
-             (offset (offset point))
-             (tab-width (tab-space-count (stream-default-view pane)))
-             (syntax (syntax buffer)))
-        (when (>= (buffer-display-column buffer offset tab-width)
-                  (1- fill-column))
-          (fill-line point
-                     (lambda (mark)
-                       (syntax-line-indentation mark tab-width syntax))
-                     fill-column
-                     tab-width
-                     (syntax buffer)))))))
-
-(defun insert-character (char)
-  (let* ((window (current-window))
-	 (point (point window)))
-    (unless (constituentp char)
-      (possibly-expand-abbrev point))
-    (when (whitespacep (syntax (buffer window)) char)
-      (possibly-fill-line))
-    (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
-	(progn
-	  (delete-range point)
-	  (insert-object point char))
-	(insert-object point char))))
-
-(defun back-to-indentation (mark syntax)
-  (beginning-of-line mark)
-  (loop until (end-of-line-p mark)
-     while (whitespacep syntax (object-after mark))
-     do (forward-object mark)))
-
-(defun delete-horizontal-space (mark syntax &optional (backward-only-p nil))
-  (let ((mark2 (clone-mark mark)))
-    (loop until (beginning-of-line-p mark)
-	  while (whitespacep syntax (object-before mark))
-	  do (backward-object mark))
-    (unless backward-only-p
-      (loop until (end-of-line-p mark2)
-	    while (whitespacep syntax (object-after mark2))
-	    do (forward-object mark2)))
-    (delete-region mark mark2)))
-
-(defun goto-position (mark pos)
-  (setf (offset mark) pos))
-
-(defun goto-line (mark line-number)
-  (loop with m = (clone-mark (low-mark (buffer mark))
-		       :right)
-	initially (beginning-of-buffer m)
-	do (end-of-line m)
-	until (end-of-buffer-p m)
-	repeat (1- line-number)
-	do (incf (offset m))
-	   (end-of-line m)
-	finally (beginning-of-line m)
-		(setf (offset mark) (offset m))))
-
-(defun indent-current-line (pane point)
-  (let* ((buffer (buffer pane))
-         (view (stream-default-view pane))
-         (tab-space-count (tab-space-count view))
-         (indentation (syntax-line-indentation point
-                                               tab-space-count
-                                               (syntax buffer))))
-    (indent-line point indentation (and (indent-tabs-mode buffer)
-                                        tab-space-count))))
-
-(defun insert-pair (mark syntax &optional (count 0) (open #() (close #)))
-  (cond ((> count 0)
-	 (loop while (and (not (end-of-buffer-p mark))
-			  (whitespacep syntax (object-after mark)))
-	       do (forward-object mark)))
-	((< count 0)
-	 (setf count (- count))
-	 (loop repeat count do (backward-expression mark syntax))))
-  (unless (or (beginning-of-buffer-p mark)
-	      (whitespacep syntax (object-before mark)))
-    (insert-object mark #\Space))
-  (insert-object mark open)
-  (let ((here (clone-mark mark)))
-    (loop repeat count
-	  do (forward-expression here syntax))
-    (insert-object here close)
-    (unless (or (end-of-buffer-p here)
-		(whitespacep syntax (object-after here)))
-      (insert-object here #\Space))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Character case
-
-(defun downcase-word (mark syntax &optional (n 1))
-  "Convert the next N words to lowercase, leaving mark after the last word."
-  (loop repeat n
-     do (forward-to-word-boundary mark syntax)
-     (let ((offset (offset mark)))
-       (forward-word mark syntax 1 nil)
-       (downcase-region offset mark))))
-
-(defun upcase-word (mark syntax &optional (n 1))
-  "Convert the next N words to uppercase, leaving mark after the last word."
-  (loop repeat n
-     do (forward-to-word-boundary mark syntax)
-     (let ((offset (offset mark)))
-       (forward-word mark syntax 1 nil)
-       (upcase-region offset mark))))
-
-(defun capitalize-word (mark syntax &optional (n 1))
-  "Capitalize the next N words, leaving mark after the last word."
-  (loop repeat n
-     do (forward-to-word-boundary mark syntax)
-     (let ((offset (offset mark)))
-       (forward-word mark syntax 1 nil)
-       (capitalize-region offset mark))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Indentation
-
-(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'."
-  (let* ((buffer (buffer pane))
-         (view (clim:stream-default-view pane))
-         (tab-space-count (tab-space-count view))
-         (tab-width (and (indent-tabs-mode buffer)
-                         tab-space-count))
-         (syntax (syntax buffer)))
-    (do-buffer-region-lines (line mark1 mark2)
-      (let ((indentation (syntax-line-indentation
-                          line
-                          tab-space-count
-                          syntax)))
-        (indent-line line indentation tab-width))
-      ;; We need to update the syntax every time we perform an
-      ;; indentation, so that subsequent indentations will be
-      ;; correctly indented (this matters in list forms). FIXME: This
-      ;; should probably happen automatically.
-      (update-syntax buffer syntax))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Auto fill
-
-(defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax
-		  &optional (compress-whitespaces t))
-  "Breaks the contents of line pointed to by MARK up to MARK into
-multiple lines such that none of them is longer than FILL-COLUMN. If
-COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the
-decision is made to break the line at a point. For now, the
-compression means just the deletion of trailing whitespaces."
-  (let ((begin-mark (clone-mark mark)))
-    (beginning-of-line begin-mark)
-    (loop with column = 0
-          with line-beginning-offset = (offset begin-mark)
-          with walking-mark = (clone-mark begin-mark)
-          while (mark< walking-mark mark)
-          as object = (object-after walking-mark)
-          do (case object
-               (#\Space
-                (setf (offset begin-mark) (offset walking-mark))
-                (incf column))
-               (#\Tab
-                (setf (offset begin-mark) (offset walking-mark))
-                (incf column (- tab-width (mod column tab-width))))
-               (t
-                (incf column)))
-             (when (and (>= column fill-column)
-			(/= (offset begin-mark) line-beginning-offset))
-	       (when compress-whitespaces
-		 (let ((offset (buffer-search-backward
-				(buffer begin-mark)
-				(offset begin-mark)
-				#(nil)
-				:test #'(lambda (o1 o2)
-					  (declare (ignore o2))
-					  (not (whitespacep syntax o1))))))
-		   (when offset
-		     (delete-region begin-mark (1+ offset)))))
-               (insert-object begin-mark #\Newline)
-               (incf (offset begin-mark))
-               (let ((indentation
-                      (funcall syntax-line-indentation-function begin-mark)))
-                 (indent-line begin-mark indentation tab-width))
-               (beginning-of-line begin-mark)
-               (setf line-beginning-offset (offset begin-mark))
-               (setf (offset walking-mark) (offset begin-mark))
-               (setf column 0))
-             (incf (offset walking-mark)))))
-
-(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax
-                    &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
-                 syntax))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; 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))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Syntax handling
-
-(defgeneric set-syntax (buffer syntax))
-
-(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax))
-  (setf (syntax buffer) syntax))
-
-;;FIXME - what should this specialise on?
-(defmethod set-syntax ((buffer climacs-buffer) syntax)
-  (set-syntax buffer (make-instance syntax :buffer buffer)))
-
-(defmethod set-syntax ((buffer climacs-buffer) (syntax string))
-  (let ((syntax-class (syntax-from-name syntax)))
-    (cond (syntax-class
-	   (set-syntax buffer (make-instance syntax-class
-				 :buffer buffer)))
-	  (t
-	   (beep)
-	   (display-message "No such syntax: ~A." syntax)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
 ;;; Buffer handling
(defmethod frame-make-new-buffer ((application-frame climacs)
@@ -347,7 +30,7 @@
    	 :key #'name :test #'string=)))
     (when b (erase-buffer b))))
-(defmethod erase-buffer ((buffer climacs-buffer))
+(defmethod erase-buffer ((buffer drei-buffer))
   (let* ((point (point buffer))
     (mark (clone-mark point)))
     (beginning-of-buffer mark)
@@ -384,7 +67,7 @@
(defgeneric switch-to-buffer (pane buffer))
-(defmethod switch-to-buffer ((pane extended-pane) (buffer climacs-buffer))
+(defmethod switch-to-buffer ((pane drei) (buffer drei-buffer))
   (with-accessors ((buffers buffers)) *application-frame*
    (let* ((position (position buffer buffers))
           (pane (current-window)))
@@ -396,9 +79,9 @@
      (full-redisplay pane)
      buffer)))
-(defmethod switch-to-buffer ((pane typeout-pane) (buffer climacs-buffer))
+(defmethod switch-to-buffer ((pane typeout-pane) (buffer drei-buffer))
   (let ((usable-pane (or (find-if #'(lambda (pane)
-                                      (typep pane 'extended-pane))
+                                      (typep pane 'drei))
                                   (windows *application-frame*))
                          (split-window t))))
     (switch-to-buffer usable-pane buffer)))
@@ -412,14 +95,14 @@
;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND.  -- CSR,
 ;; ;;; 2005-10-31.
-;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
+;; (defmethod (setf buffer) :around (buffer (pane drei))
 ;;   (call-next-method)
 ;;   (note-pane-syntax-changed pane (syntax buffer)))
(defgeneric kill-buffer (buffer))
-(defmethod kill-buffer ((buffer climacs-buffer))
-  (with-slots (buffers) *application-frame*
+(defmethod kill-buffer ((buffer drei-buffer))
+  (with-accessors ((buffers buffers)) *application-frame*
      (when (and (needs-saving buffer)
    	(handler-case (accept 'boolean :prompt "Save buffer first?")
    	  (error () (progn (beep)
@@ -453,13 +136,13 @@
    	   "." (pathname-type pathname))))
(defun syntax-class-name-for-filepath (filepath)
-  (or (climacs-syntax::syntax-description-class-name
+  (or (drei-syntax::syntax-description-class-name
        (find (or (pathname-type filepath)
    	 (pathname-name filepath))
-	     climacs-syntax::*syntaxes*
+	     drei-syntax::*syntaxes*
         :test (lambda (x y)
    	     (member x y :test #'string-equal))
-	     :key #'climacs-syntax::syntax-description-pathname-types))
+	     :key #'drei-syntax::syntax-description-pathname-types))
       *default-syntax*))
(defun evaluate-attributes (buffer options)
@@ -634,7 +317,7 @@
         (t
          (let ((existing-buffer (find-buffer-with-pathname filepath)))
            (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
-               (switch-to-buffer existing-buffer)
+               (switch-to-buffer *current-window* existing-buffer)
                (progn
                  (when readonlyp
                    (unless (probe-file filepath)
--- /project/climacs/cvsroot/climacs/developer-commands.lisp	2006/07/24 13:24:40	1.3
+++ /project/climacs/cvsroot/climacs/developer-commands.lisp	2006/11/12 16:06:06	1.4
@@ -43,7 +43,7 @@
 (define-gesture-name :select-other #+mcclim :pointer-button-press #-mcclim :pointer-button (:left :meta) :unique nil)
(define-presentation-translator lisp-string-to-string
-    (climacs-lisp-syntax::lisp-string string development-table
+    (drei-lisp-syntax::lisp-string string development-table
                   :gesture :select-other
                   :tester-definitive t
                   :menu nil
--- /project/climacs/cvsroot/climacs/file-commands.lisp	2006/09/12 19:49:18	1.25
+++ /project/climacs/cvsroot/climacs/file-commands.lisp	2006/11/12 16:06:06	1.26
@@ -99,10 +99,10 @@
    			     name))))))))
(define-presentation-method present (object (type pathname)
-                                            stream (view climacs-textual-view) &key)
+                                            stream (view drei-textual-view) &key)
   (princ (namestring object) stream))
-(define-presentation-method accept ((type pathname) stream (view climacs-textual-view)
+(define-presentation-method accept ((type pathname) stream (view drei-textual-view)
                                     &key (default nil defaultp) (default-type type))
   (multiple-value-bind (pathname success string)
       (complete-input stream
--- /project/climacs/cvsroot/climacs/groups.lisp	2006/09/11 20:13:32	1.3
+++ /project/climacs/cvsroot/climacs/groups.lisp	2006/11/12 16:06:06	1.4
@@ -113,7 +113,7 @@
 NIL. If a pathname is returned, it is assumed to be safe to find
 the file with that name."
   (typecase element
-    (climacs-buffer
+    (drei-buffer
      (find element (buffers *application-frame*)))
     ((or pathname string)
      (or (find-buffer-with-pathname (pathname element))
@@ -125,7 +125,7 @@
 (defun display-group-element (element stream)
   (let ((norm-element (normalise-group-element element)))
    (typecase norm-element
-     (climacs-buffer
+     (drei-buffer
       (present norm-element 'buffer stream))
      ((or pathname string)
       (present norm-element 'pathname stream)))))
@@ -133,7 +133,7 @@
 ;; Singular group elements.
 (defmethod group-buffers ((group group-element))
   (let ((element (element group)))
-    (cond ((and (typep element 'climacs-buffer)
+    (cond ((and (typep element 'drei-buffer)
                 (find element (buffers *application-frame*)))
            (list element))
           ((or (pathnamep element)
@@ -144,7 +144,7 @@
(defmethod ensure-group-buffers ((group group-element))
   (typecase (element group)
-    (climacs-buffer
+    (drei-buffer
      (unless (find (element group) (buffers *application-frame*))
        (ensure-open-file (pathname (filepath (element group))))))
     (pathname
--- /project/climacs/cvsroot/climacs/gui.lisp	2006/09/12 19:49:18	1.231
+++ /project/climacs/cvsroot/climacs/gui.lisp	2006/11/12 16:06:06	1.232
@@ -28,17 +28,52 @@
(in-package :climacs-gui)
-(defclass extended-pane (climacs-pane esa-pane-mixin)
-  (;; for next-line and previous-line commands
-   (goal-column :initform nil :accessor goal-column)
-   ;; for dynamic abbrev expansion
-   (original-prefix :initform nil :accessor original-prefix)
-   (prefix-start-offset :initform nil :accessor prefix-start-offset)
-   (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark)
-   (overwrite-mode :initform nil :accessor overwrite-mode)))
+(defvar *default-external-format* :utf-8
+  "The encoding to use by default when reading and saving
+files.")
+
+(defvar *with-scrollbars* t
+  "If T, classic look and feel. If NIL, stripped-down look (:")
+
+(defvar *show-info-pane-mark-position* nil
+  "If T, show the line number and column number in the info pane
+  of all panes. If NIL, don't. This is off by default, as finding
+  the line and column numbers is potentially expensive.")
+
+(defclass climacs-buffer (drei-buffer)
+  ((%external-format :initform *default-external-format*
+                     :accessor external-format
+                     :documentation "The external format that was
+used when reading the source destination of the buffer
+contents.")))
+
+(defclass climacs-pane (drei-pane esa-pane-mixin)
+  ()
+  (:default-initargs
+   :buffer (make-instance 'climacs-buffer)
+    :command-table 'global-climacs-table
+    :width 900 :height 400))
+
+;; Ensure that only one pane can be active.
+(defmethod (setf active) :after ((new-val (eql t)) (climacs-pane climacs-pane))
+  (mapcar #'(lambda (pane)
+              (unless (eq climacs-pane pane)
+                (setf (active pane) nil)))
+          (windows (pane-frame climacs-pane))))
+
+(defmethod command-table ((drei climacs-pane))
+  (command-table (pane-frame drei)))
(defclass typeout-pane (application-pane esa-pane-mixin)
-  ())
+  ((%active :accessor active
+            :initform nil
+            :initarg :active)))
+
+(defmethod buffer ((pane typeout-pane)))
+
+(defmethod point ((pane typeout-pane)))
+
+(defmethod mark ((pane typeout-pane)))
(defmethod full-redisplay ((pane typeout-pane)))
@@ -49,29 +84,35 @@
   (declare (ignore pane))
   nil)
-(defmethod buffer-pane-p ((pane extended-pane))
+(defmethod buffer-pane-p ((pane climacs-pane))
   t)
+(defmethod in-focus-p ((pane climacs-pane))
+  (eq pane (first (windows *application-frame*))))
+
+(defvar *info-bg-color* +gray85+)
+(defvar *info-fg-color* +black+)
+(defvar *mini-bg-color* +white+)
+(defvar *mini-fg-color* +black+)
+
 (defclass climacs-info-pane (info-pane)
   ()
   (:default-initargs
       :height 20 :max-height 20 :min-height 20
       :display-function 'display-info
-      :incremental-redisplay t))
+      :incremental-redisplay t
+      :background *info-bg-color*
+      :foreground *info-fg-color*
+      :width 900))
(defclass climacs-minibuffer-pane (minibuffer-pane)
   ()
   (:default-initargs
-      :height 20 :max-height 20 :min-height 20
-      :default-view +climacs-textual-view+))
-
-(defparameter *with-scrollbars* t
-  "If T, classic look and feel. If NIL, stripped-down look (:")
-
-(defparameter *show-info-pane-mark-position* nil
-  "If T, show the line number and column number in the info pane
-  of all panes. If NIL, don't. This is off by default, as finding
-  the line and column numbers is potentially expensive.")
+   :height 20 :max-height 20 :min-height 20
+   :default-view +drei-textual-view+
+   :background *mini-bg-color*
+   :foreground *mini-fg-color*
+   :width 900))
;;; Basic command tables follow. The global command table,
 ;;; `global-climacs-table', inherits from these, so they should not
@@ -83,35 +124,13 @@
;;; Basic functionality
 (make-command-table 'base-table :errorp nil)
-;;; buffers
+;;; Buffers
 (make-command-table 'buffer-table :errorp nil)
-;;; case
-(make-command-table 'case-table :errorp nil)
-;;; comments
-(make-command-table 'comment-table :errorp nil)
-;;; deleting
-(make-command-table 'deletion-table :errorp nil)
-;;; commands used for climacs development
+;;; Commands used for climacs development
 (make-command-table 'development-table :errorp nil)
-;;; editing - making changes to a buffer
-(make-command-table 'editing-table :errorp nil)
-;;; filling
-(make-command-table 'fill-table :errorp nil)
-;;; indentation
-(make-command-table 'indent-table :errorp nil)
-;;; information about the buffer
-(make-command-table 'info-table :errorp nil)
-;;; marking things
-(make-command-table 'marking-table :errorp nil)
-;;; moving around
-(make-command-table 'movement-table :errorp nil)
-;;; panes
+;;; Panes
 (make-command-table 'pane-table :errorp nil)
-;;; searching
-(make-command-table 'search-table :errorp nil)
-;;; self-insertion
-(make-command-table 'self-insert-table :errorp nil)
-;;; windows
+;;; Windows
 (make-command-table 'window-table :errorp nil)
;;; customization of help.  FIXME: this might be better done by having
@@ -121,9 +140,9 @@
 (make-command-table 'climacs-help-table :inherit-from '(help-table)
                     :errorp nil)
-;; We have a special command table for typeout panes because we want
-;; to keep being able to do window, buffer, etc, management, but we do
-;; not want any actual editing commands.
+;;; We have a special command table for typeout panes because we want
+;;; to keep being able to do window, buffer, etc, management, but we do
+;;; not want any actual editing commands.
 (make-command-table 'typeout-pane-table
                     :errorp nil
                     :inherit-from '(global-esa-table
@@ -133,71 +152,52 @@
                                     development-table
                                     climacs-help-table))
-(defvar *bg-color* +white+)
-(defvar *fg-color* +black+)
-(defvar *info-bg-color* +gray85+)
-(defvar *info-fg-color* +black+)
-(defvar *mini-bg-color* +white+)
-(defvar *mini-fg-color* +black+)
+(defclass climacs-command-table (standard-command-table)
+  ())
-(define-application-frame climacs (standard-application-frame
-				   esa-frame-mixin)
-  ((buffers :initform '() :accessor buffers)
-   (groups :initform (make-hash-table :test #'equal) :accessor groups)
-   (active-group :initform nil :accessor active-group)
-   (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring))
+(defmethod command-table-inherit-from ((table climacs-command-table))
+  (append (when *current-syntax* (list (command-table *current-syntax*)))
+          '(global-climacs-table)
+          (call-next-method)))
+
+(define-application-frame climacs (esa-frame-mixin
+				   standard-application-frame)
+  ((%buffers :initform '() :accessor buffers)
+   (%groups :initform (make-hash-table :test #'equal) :accessor groups)
+   (%active-group :initform nil :accessor active-group)
+   (%kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring)
+   (%command-table :initform (make-instance 'climacs-command-table
+                                            :name 'climacs-dispatching-table)
+                   :accessor find-applicable-command-table))
   (:command-table (global-climacs-table
-		   :inherit-from (global-esa-table
-                                  esa-io-table
-				  keyboard-macro-table
-				  climacs-help-table
-				  base-table
-				  buffer-table
-				  case-table
-				  comment-table
-				  deletion-table
-				  development-table
-				  editing-table
-				  fill-table
-				  indent-table
-				  info-table
-				  marking-table
-				  movement-table
-				  pane-table
-				  search-table
-				  self-insert-table
-				  window-table)))
+                   :inherit-from (esa-io-table
+                                  keyboard-macro-table
+                                  climacs-help-table
+                                  base-table
+                                  buffer-table
+                                  case-table
+                                  development-table
+                                  info-table
+                                  pane-table
+                                  window-table
+                                  editor-table
+                                  global-esa-table)))
   (:menu-bar nil)
   (:panes
    (climacs-window
-    (let* ((extended-pane 
-	    (make-pane 'extended-pane
-		       :width 900 :height 400
-		       :end-of-line-action :scroll
-		       :incremental-redisplay t
-		       :background *bg-color*
-		       :foreground *fg-color*
-		       :display-function 'display-window
-		       :command-table 'global-climacs-table))
-	   (info-pane
-	    (make-pane 'climacs-info-pane
-		       :master-pane extended-pane
-		       :background *info-bg-color*
-		       :foreground *info-fg-color*
-		       :width 900)))
-      (setf (windows *application-frame*) (list extended-pane)
-	    (buffers *application-frame*) (list (buffer extended-pane)))
-	  
+    (let* ((climacs-pane (make-pane 'climacs-pane
+                                    :active t))
+	   (info-pane (make-pane 'climacs-info-pane
+                                 :master-pane climacs-pane)))
+      (setf (windows *application-frame*) (list climacs-pane)
+	    (buffers *application-frame*) (list (buffer climacs-pane)))
       (vertically ()
    (if *with-scrollbars*
        (scrolling ()
-	      extended-pane)
-	    extended-pane)
+	      climacs-pane)
+	    climacs-pane)
    info-pane)))
-   (minibuffer (make-pane 'climacs-minibuffer-pane
-			  :background *mini-bg-color*
-			  :foreground *mini-fg-color*
-			  :width 900)))
+   (minibuffer (make-pane 'climacs-minibuffer-pane)))
   (:layouts
    (default
        (vertically (:scroll-bars nil)
@@ -207,23 +207,22 @@
                  (let ((*kill-ring* (kill-ring frame)))
                    (esa-top-level frame :prompt "M-x "))))))
+(define-esa-top-level ((frame climacs) command-parser
+                       command-unparser
+                       partial-command-parser
+                       prompt)
+    :bindings ((*current-point* (current-point))
+               (*current-mark* (current-mark))
+               (*previous-command* (previous-command *current-window*))
+               (*current-syntax* (and *current-buffer*
+                                      (syntax *current-buffer*)))))
+
 (defmethod frame-standard-input ((frame climacs))
   (get-frame-pane frame 'minibuffer))
-(defun current-window ()
-  (car (windows *application-frame*)))
-
-(defun current-point ()
-  "Return the current panes point."
-  (point (current-window)))
-
-(defun current-mark ()
-  "Return the current panes mark."
-  (mark (current-window)))
-
 (defmethod frame-current-buffer ((application-frame climacs))
   "Return the current buffer."
-  (buffer (car (windows application-frame))))
+  (buffer (frame-current-window application-frame)))
(defun any-buffer ()
   "Return some buffer, any buffer, as long as it is a buffer!"
@@ -296,59 +295,24 @@
    	 "")
         pane))))
-(defun display-window (frame pane)
-  "The display function used by the climacs application frame."
-  (redisplay-pane pane (eq pane (car (windows frame)))))
-
-(defmethod handle-repaint :before ((pane extended-pane) region)
-  (declare (ignore region))
-  (redisplay-frame-pane *application-frame* pane))
+(defmethod execute-drei-command ((drei-instance climacs-pane) command)
+  (execute-frame-command (pane-frame drei-instance) command))
(defmethod execute-frame-command :around ((frame climacs) command)
-  (let ((current-window (car (windows frame))))
-    (handler-case
-        (progn
-          (if (buffer-pane-p current-window)
-              (with-undo ((buffers frame))
-                (call-next-method))
-              (call-next-method))
-          (loop for buffer in (buffers frame)
-                do (when (modified-p buffer)
-                     (clear-modify buffer))))
-      (offset-before-beginning ()
-        (beep) (display-message "Beginning of buffer"))
-      (offset-after-end ()
-        (beep) (display-message "End of buffer"))
-      (motion-before-beginning ()
-        (beep) (display-message "Beginning of buffer"))
-      (motion-after-end ()
-        (beep) (display-message "End of buffer"))
-      (no-expression ()
-        (beep) (display-message "No expression around point"))
-      (no-such-operation ()
-        (beep) (display-message "Operation unavailable for syntax"))
-      (buffer-read-only ()
-        (beep) (display-message "Buffer is read only")))))
+  (handling-drei-conditions
+    (with-undo ((buffers frame))
+      (call-next-method))
+    (loop for buffer in (buffers frame)
+       do (when (modified-p buffer)
+            (clear-modify buffer)))))
(defmethod execute-frame-command :after ((frame climacs) command)
   (when (eq frame *application-frame*)
     (loop for buffer in (buffers frame)
-          do (when (syntax buffer)
-               (update-syntax buffer (syntax buffer)))
-          do (when (modified-p buffer)
-               (setf (needs-saving buffer) t)))))
-
-(defmethod find-applicable-command-table ((frame climacs))
-  (cond ((typep (current-window) 'typeout-pane)
-         (find-command-table 'typeout-pane-table))
-        ((buffer-pane-p (current-window))
-         (or (let ((syntax (syntax (buffer (current-window)))))
-               ;; Why all this absurd checking? Smells fishy.
-               (and (slot-exists-p syntax 'command-table)
-                    (slot-boundp syntax 'command-table)
-                    (slot-value syntax 'command-table)
-                    (find-command-table (slot-value syntax 'command-table))))
-             (find-command-table 'global-climacs-table)))))
+       do (when (syntax buffer)
+            (update-syntax buffer (syntax buffer)))
+       do (when (modified-p buffer)
+            (setf (needs-saving buffer) t)))))
(define-command (com-full-redisplay :name t :command-table base-table) ()
   "Redisplay the contents of the current window.
@@ -359,18 +323,6 @@
     'base-table
     '((#\l :control)))
-(define-command com-self-insert ((count 'integer))
-  (loop repeat count do (insert-character *current-gesture*)))
-
-(loop for code from (char-code #\Space) to (char-code #~)
-      do (set-key `(com-self-insert ,*numeric-argument-marker*)
-	     'self-insert-table
-	     (list (list (code-char code)))))
-
-(set-key `(com-self-insert ,*numeric-argument-marker*)
-	 'self-insert-table
-	 '((#\Newline)))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Pane functions
[86 lines skipped]
--- /project/climacs/cvsroot/climacs/html-syntax.lisp	2006/09/02 21:43:56	1.35
+++ /project/climacs/cvsroot/climacs/html-syntax.lisp	2006/11/12 16:06:06	1.36
@@ -697,20 +697,21 @@
(defun handle-whitespace (pane buffer start end)
   (let ((space-width (space-width pane))
-	(tab-width (tab-width pane)))
-    (loop while (< start end)
-	  do (ecase (buffer-object buffer start)
-	       (#\Newline (terpri pane)
-			  (setf (aref *cursor-positions* (incf *current-line*))
-				(multiple-value-bind (x y) (stream-cursor-position pane)
-				  (declare (ignore x))
-				  y)))
-	       (#\Space (stream-increment-cursor-position
-			 pane space-width 0))
-	       (#\Tab (let ((x (stream-cursor-position pane)))
-			(stream-increment-cursor-position
-			 pane (- tab-width (mod x tab-width)) 0))))
-	     (incf start))))		    
+        (tab-width (tab-width pane)))
+    (with-sheet-medium (medium pane)
+      (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
+        (loop while (< start end)
+           do (case (buffer-object buffer start)
+                (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
+                           (terpri pane)
+                           (stream-increment-cursor-position
+                            pane (first (aref cursor-positions 0)) 0))
+                ((#\Page #\Return #\Space) (stream-increment-cursor-position
+                                            pane space-width 0))
+                (#\Tab (let ((x (stream-cursor-position pane)))
+                         (stream-increment-cursor-position
+                          pane (- tab-width (mod x tab-width)) 0))))
+           (incf start))))))
(defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
   (with-slots (top bot) pane
@@ -762,42 +763,42 @@
    (display-parse-stack (parse-stack-symbol top) top syntax pane)
    (display-parse-tree (target-parse-tree state) syntax pane))))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
+(defmethod display-drei-contents ((pane clim-stream-pane) (drei drei) (syntax html-syntax))
   (with-slots (top bot) pane
-     (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
-	   *current-line* 0
-	   (aref *cursor-positions* 0) (stream-cursor-position pane))
-     (with-slots (lexer) syntax
-	(let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
-				       1.0)))
-	  ;; find the last token before bot
-	  (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
-	    ;; go back to a token before bot
-	    (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
-		  do (decf end-token-index))
-	    ;; go forward to the last token before bot
-	    (loop until (or (= end-token-index (nb-lexemes lexer))
-			    (mark> (start-offset (lexeme lexer end-token-index)) bot))
-		  do (incf end-token-index))
-	    (let ((start-token-index end-token-index))
-	      ;; go back to the first token after top, or until the previous token
-	      ;; contains a valid parser state
-	      (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
-			      (not (parse-state-empty-p 
-				    (slot-value (lexeme lexer (1- start-token-index)) 'state))))
-		    do (decf start-token-index))
-	      (let ((*white-space-start* (offset top)))
-		;; display the parse tree if any
-		(unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
-		  (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
-				       syntax
-				       pane))
-		;; display the lexemes
-		(with-drawing-options (pane :ink +red+)
-		  (loop while (< start-token-index end-token-index)
-			do (let ((token (lexeme lexer start-token-index)))
-			     (display-parse-tree token syntax pane))
-			   (incf start-token-index))))))))
-     (when (region-visible-p pane) (display-region pane syntax))
-     (display-cursor pane syntax current-p)))
-	    
+    (with-accessors ((cursor-positions cursor-positions)) syntax
+      (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
+                                         :initial-element nil)
+            *current-line* 0
+            (aref cursor-positions 0) (multiple-value-list
+                                       (stream-cursor-position pane))))
+    (setf *white-space-start* (offset top))
+    (with-slots (lexer) syntax
+      (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
+                                     1.0)))
+        ;; find the last token before bot
+        (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
+          ;; go back to a token before bot
+          (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
+             do (decf end-token-index))
+          ;; go forward to the last token before bot
+          (loop until (or (= end-token-index (nb-lexemes lexer))
+                          (mark> (start-offset (lexeme lexer end-token-index)) bot))
+             do (incf end-token-index))
+          (let ((start-token-index end-token-index))
+            ;; go back to the first token after top, or until the previous token
+            ;; contains a valid parser state
+            (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
+                            (not (parse-state-empty-p 
+                                  (slot-value (lexeme lexer (1- start-token-index)) 'state))))
+               do (decf start-token-index))
+            ;; display the parse tree if any
+            (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
+              (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
+                                   syntax
+                                   pane))
+            ;; display the lexemes
+            (with-drawing-options (pane :ink +red+)
+              (loop while (< start-token-index end-token-index)
+                 do (let ((token (lexeme lexer start-token-index)))
+                      (display-parse-tree token syntax pane))
+                 (incf start-token-index)))))))))
--- /project/climacs/cvsroot/climacs/misc-commands.lisp	2006/09/06 20:07:21	1.25
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp	2006/11/12 16:06:06	1.26
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
+;;; -*- Mode: Lisp; Package: CLIMACS-COMMANDS -*-
;;;  (c) copyright 2004-2005 by
 ;;;           Robert Strandh (strandh@labri.fr)
@@ -28,19 +28,6 @@
(in-package :climacs-commands)
-(define-command (com-overwrite-mode :name t :command-table editing-table) ()
-  "Toggle overwrite mode for the current mode.
-When overwrite is on, an object entered on the keyboard 
-will replace the object after the point. 
-When overwrite is off (the default), objects are inserted at point. 
-In both cases point is positioned after the new object."
-  (with-slots (overwrite-mode) (current-window)
-    (setf overwrite-mode (not overwrite-mode))))
-
-(set-key 'com-overwrite-mode
-	 'editing-table
-	 '((:insert)))
-
 (define-command (com-not-modified :name t :command-table buffer-table) ()
   "Clear the modified flag for the current buffer.
 The modified flag is automatically set when the contents 
@@ -52,624 +39,6 @@
     'buffer-table
     '((#~ :meta :shift)))
-(defun set-fill-column (column)
-  (if (> column 1)
-      (setf (auto-fill-column (current-window)) column)
-      (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
-
-(define-command (com-set-fill-column :name t :command-table fill-table)
-    ((column 'integer :prompt "Column Number:"))
-  "Set the fill column to the specified value.
-You must supply a numeric argument. The fill column is 
-the column beyond which automatic line-wrapping will occur. 
-
-The default fill column is 70."
-  (set-fill-column column))
-
-(set-key `(com-set-fill-column ,*numeric-argument-marker*)
-	 'fill-table
-	 '((#\x :control) (#\f)))
-
-(define-command (com-zap-to-object :name t :command-table deletion-table) ()
-  "Prompt for an object and kill to the next occurence of that object after point.
-Characters can be entered in #\ format."
-  (let* ((item (handler-case (accept 't :prompt "Zap to Object")
-		(error () (progn (beep)
-				 (display-message "Not a valid object")
-				 (return-from com-zap-to-object nil)))))
-	 (current-point (point (current-window)))
-	 (item-mark (clone-mark current-point))
-	 (current-offset (offset current-point)))
-    (search-forward item-mark (vector item))
-    (delete-range current-point (- (offset item-mark) current-offset))))
-
-(define-command (com-zap-to-character :name t :command-table deletion-table) ()
-  "Prompt for a character and kill to the next occurence of that character after point.
-FIXME: Accepts a string (that is, zero or more characters) 
-terminated by a #\NEWLINE. If a zero length string signals an error. 
-If a string of length >1, uses the first character of the string."
-  (let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d.  (or 'string 'character)?
-		(error () (progn (beep)
-				 (display-message "Not a valid string. ")
-				 (return-from com-zap-to-character nil)))))
-       (item (subseq item-string 0 1))
-       (current-point (point (current-window)))
-       (item-mark (clone-mark current-point))
-
-       (current-offset (offset current-point)))
-  (if (> (length item-string) 1)
-      (display-message "Using just the first character"))
-  (search-forward item-mark item)
-  (delete-range current-point (- (offset item-mark) current-offset))))
-
-(set-key 'com-zap-to-character
-	 'deletion-table
-	 '((#\z :meta)))
-
-(define-command (com-open-line :name t :command-table editing-table)
-    ((numarg 'integer :prompt "How many lines?"))
-  "Insert a #\Newline and leave point before it.
-With a numeric argument greater than 1, insert that many #\Newlines."
-  (open-line (point (current-window)) numarg))
-
-(set-key `(com-open-line ,*numeric-argument-marker*)
-	 'editing-table
-	 '((#\o :control)))
-
-(defmacro define-mark-unit-command (unit command-table &key
-                                    move-point
-                                    noun
-                                    plural)
-  "Define a COM-MARK-<UNIT> for `unit' command and put it in
-  `command-table'."
-  (labels ((symbol (&rest strings)
-             (intern (apply #'concat strings)))
-           (concat (&rest strings)
-             (apply #'concatenate 'STRING (mapcar #'string strings))))
-    (let ((forward (symbol "FORWARD-" unit))
-          (backward (symbol "BACKWARD-" unit))
-          (noun (or noun (string-downcase unit)))
-          (plural (or plural (concat (string-downcase unit) "s"))))
-      `(define-command (,(symbol "COM-MARK-" unit)
-                         :name t
-                         :command-table ,command-table)
-           ((count 'integer :prompt ,(concat "Number of " plural)))
-           ,(if (not (null move-point))
-                (concat "Place point and mark around the current " noun ".
-Put point at the beginning of the current " noun ", and mark at the end. 
-With a positive numeric argument, put mark that many " plural " forward. 
-With a negative numeric argument, put point at the end of the current 
-" noun " and mark that many " plural " backward. 
-Successive invocations extend the selection.")
-                (concat "Place mark at the next " noun " end.
-With a positive numeric argument, place mark at the end of 
-that many " plural " forward. With a negative numeric argument, 
-place mark at the beginning of that many " plural " backward. 
-
-Successive invocations extend the selection."))
-         (let* ((pane (current-window))
-                (point (point pane))
-                (mark (mark pane)))
-           (unless (eq (previous-command pane) 'com-mark-word)
-             (setf (offset mark) (offset point))
-             ,(when (not (null move-point))
-                    `(if (plusp count)
-                         (,backward point (syntax (buffer pane)))
-                         (,forward point (syntax (buffer pane))))))
-           (,forward mark (syntax (buffer pane)) count))))))
-
-(define-mark-unit-command word marking-table)
-(define-mark-unit-command expression marking-table)
-(define-mark-unit-command paragraph marking-table :move-point t)
-(define-mark-unit-command definition marking-table :move-point t)
-
-(set-key `(com-mark-word ,*numeric-argument-marker*)
-	 'marking-table
-	 '((#@ :meta :shift)))
-
-(set-key `(com-mark-paragraph ,*numeric-argument-marker*)
-	 'marking-table
-	 '((#\h :meta)))
-
-(set-key 'com-mark-definition
-	 'marking-table
-	 '((#\h :control :meta)))
-
-(define-command (com-upcase-region :name t :command-table case-table) ()
-  "Convert the region to upper case."
-  (let ((cw (current-window)))
-    (upcase-region (mark cw) (point cw))))
-
-(define-command (com-downcase-region :name t :command-table case-table) ()
-  "Convert the region to lower case."
-  (let ((cw (current-window)))
-    (downcase-region (mark cw) (point cw))))
-
-(define-command (com-capitalize-region :name t :command-table case-table) ()
-  "Capitalize each word in the region."
-  (let ((cw (current-window)))
-    (capitalize-region (mark cw) (point cw))))
-
-(define-command (com-upcase-word :name t :command-table case-table) ()
-  "Convert the characters from point until the next word end to upper case.
-Leave point at the word end."
-  (upcase-word (point (current-window))
-               (syntax (buffer (current-window)))))
-
-(set-key 'com-upcase-word
-	 'case-table
-	 '((#\u :meta)))
-
-(define-command (com-downcase-word :name t :command-table case-table) ()
-  "Convert the characters from point until the next word end to lower case.
-Leave point at the word end."
-  (downcase-word (point (current-window))
-                 (syntax (buffer (current-window)))))
-
-(set-key 'com-downcase-word
-	 'case-table
-	 '((#\l :meta)))
-
-(define-command (com-capitalize-word :name t :command-table case-table) ()
-  "Capitalize the next word.
-If point is in a word, convert the next character to 
-upper case and the remaining letters in the word to lower case. 
-If point is before the start of a word, convert the first character 
-of that word to upper case and the rest of the letters to lower case. 
-
-Leave point at the word end."
-  (capitalize-word (point (current-window))
-                   (syntax (buffer (current-window)))))
-
-(set-key 'com-capitalize-word
-	 'case-table
-	 '((#\c :meta)))
-
-(define-command (com-tabify-region :name t :command-table editing-table) ()
-  "Replace runs of spaces with tabs in region where possible.
-Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane."
-  (let ((pane (current-window)))
-    (tabify-region
-     (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-
-(define-command (com-untabify-region :name t :command-table editing-table) ()
-  "Replace tabs with equivalent runs of spaces in the region.
-Uses TAB-SPACE-COUNT of the STREAM-DEFAULT-VIEW of the pane."
-  (let ((pane (current-window)))
-    (untabify-region
-     (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-
-(define-command (com-indent-line :name t :command-table indent-table) ()
-  (let* ((pane (current-window))
-         (point (point pane)))
-    (indent-current-line pane point)))
-
-(set-key 'com-indent-line
-	 'indent-table
-	 '((#\Tab)))
-
-(set-key 'com-indent-line
-	 'indent-table
-	 '((#\i :control)))
-
-(define-command (com-newline-and-indent :name t :command-table indent-table) ()
-  "Inserts a newline and indents the new line."
-  (let* ((pane (current-window))
-	 (point (point pane)))
-    (insert-object point #\Newline)
-    (update-syntax (current-buffer *application-frame*)
-                   (syntax (current-buffer *application-frame*)))
-    (indent-current-line pane point)))
-
-(set-key 'com-newline-and-indent
-	 'indent-table
-	 '((#\j :control)))
-
-(define-command (com-indent-region :name t :command-table indent-table) ()
-  "Indent every line of the current region as specified by the
-syntax for the buffer."
-  (let* ((pane (current-window))
-         (point (point pane))
-         (mark (mark pane)))
-    (indent-region pane point mark)))
-
-(define-command (com-delete-indentation :name t :command-table indent-table) ()
-  "Join current line to previous non-blank line.
-Leaves a single space between the last non-whitespace object 
-of the previous line and the first non-whitespace object of 
-the current line, and point after that space. If there is no 
-previous non-blank line, deletes all whitespace at the 
-beginning of the buffer at leaves point there."
-  (delete-indentation (point (current-window))))
-
-(set-key 'com-delete-indentation
-	 'indent-table
-	 '((#^ :shift :meta)))
-
-(define-command (com-auto-fill-mode :name t :command-table fill-table) ()
-  (let ((pane (current-window)))
-    (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
-
-(define-command (com-fill-paragraph :name t :command-table fill-table) ()
-  (let* ((pane (current-window))
-         (buffer (buffer pane))
-         (syntax (syntax buffer))
-	 (point (point pane))
-         (begin-mark (clone-mark point))
-         (end-mark (clone-mark point)))
-    (unless (eql (object-before begin-mark) #\Newline)
-      (backward-paragraph begin-mark syntax))
-    (unless (eql (object-after end-mark) #\Newline)
-      (forward-paragraph end-mark syntax))
-    (do-buffer-region (object offset buffer
-                       (offset begin-mark) (offset end-mark))
-      (when (eql object #\Newline)
-        (setf object #\Space)))
-    (let ((point-backup (clone-mark point)))
-      (setf (offset point) (offset end-mark))
-      (possibly-fill-line)
-      (setf (offset point) (offset point-backup)))))
-
-(set-key 'com-fill-paragraph
-	 'fill-table
-	 '((#\q :meta)))
-
-(define-command (com-beginning-of-buffer :name t :command-table movement-table) ()
-  "Move point to the beginning of the buffer."
-  (beginning-of-buffer (point (current-window))))
-
-(set-key 'com-beginning-of-buffer
-	 'movement-table
-	 '((#< :shift :meta)))
-
-(set-key 'com-beginning-of-buffer
-	 'movement-table
-	 '((:home :control)))
-
-(define-command (com-page-down :name t :command-table movement-table) ()
-  (let ((pane (current-window)))
-    (page-down pane)))
-
-(set-key 'com-page-down
-	 'movement-table
-	 '((#\v :control)))
-
-(set-key 'com-page-down
-	 'movement-table
-	 '((:next)))
-
-(define-command (com-page-up :name t :command-table movement-table) ()
-  (let ((pane (current-window)))
-    (page-up pane)))
-
-(set-key 'com-page-up
-	 'movement-table
-	 '((#\v :meta)))
-
-(set-key 'com-page-up
-	 'movement-table
-	 '((:prior)))
-
-(define-command (com-end-of-buffer :name t :command-table movement-table) ()
-  "Move point to the end of the buffer."
-  (end-of-buffer (point (current-window))))
-
-(set-key 'com-end-of-buffer
-	 'movement-table
-	 '((#> :shift :meta)))
-
-(set-key 'com-end-of-buffer
-	 'movement-table
-	 '((:end :control)))
-
-(define-command (com-mark-whole-buffer :name t :command-table marking-table) ()
-  "Place point at the beginning and mark at the end of the buffer."
-  (beginning-of-buffer (point (current-window)))
-  (end-of-buffer (mark (current-window))))
-
-(set-key 'com-mark-whole-buffer
-	 'marking-table
-	 '((#\x :control) (#\h)))
-
-(define-command (com-back-to-indentation :name t :command-table movement-table) ()
-  "Move point to the first non-whitespace object on the current line.
-If there is no non-whitespace object, leaves point at the end of the line."
-  (back-to-indentation (point (current-window))
-                       (syntax (buffer (current-window)))))
-
-(set-key 'com-back-to-indentation
-	 'movement-table
-	 '((#\m :meta)))
-
-(define-command (com-delete-horizontal-space :name t :command-table deletion-table)
-    ((backward-only-p
-      'boolean :prompt "Delete backwards only?"))
-  "Delete whitespace around point.
-With a numeric argument, only delete whitespace before point."
-  (delete-horizontal-space (point (current-window))
-                           (syntax (buffer (current-window)))
-                           backward-only-p))
-
-(set-key `(com-delete-horizontal-space ,*numeric-argument-p*)
-	 'deletion-table
-	 '((#\ :meta)))
-
-(define-command (com-just-one-space :name t :command-table deletion-table)
-    ((count 'integer :prompt "Number of spaces"))
-  "Delete whitespace around point, leaving a single space.
-With a positive numeric argument, leave that many spaces.
-
-FIXME: should distinguish between types of whitespace."
-  (just-n-spaces (point (current-window))
-                 count))
-
-(set-key `(com-just-one-space ,*numeric-argument-marker*)
-	 'deletion-table
-	 '((#\Space :meta)))
-
-(define-command (com-goto-position :name t :command-table movement-table) 
-    ((position 'integer :prompt "Goto Position"))
-  "Prompts for an integer, and sets the offset of point to that integer."
-  (goto-position
-   (point (current-window))
-   position))  
-
-(define-command (com-goto-line :name t :command-table movement-table) 
-    ((line-number 'integer :prompt "Goto Line"))
-  "Prompts for a line number, and sets point to the beginning of that line.
-The first line of the buffer is 1. Giving a number <1 leaves 
-point at the beginning of the buffer. Giving a line number 
-larger than the number of the last line in the buffer leaves
[461 lines skipped]
--- /project/climacs/cvsroot/climacs/packages.lisp	2006/09/15 22:34:24	1.120
+++ /project/climacs/cvsroot/climacs/packages.lisp	2006/11/12 16:06:06	1.121
@@ -26,325 +26,22 @@
(in-package :cl-user)
-(defpackage :climacs-utils
-  (:use :clim-lisp)
-  (:export #:with-gensyms
-           #:once-only
-           #:unlisted
-           #:fully-unlisted
-           #:listed
-           #:list-aref))
-
-(defpackage :climacs-buffer
-  (:use :clim-lisp :flexichain :binseq)
-  (:export #:buffer #:standard-buffer
-	   #:mark #:left-sticky-mark #:right-sticky-mark
-	   #:standard-left-sticky-mark #:standard-right-sticky-mark
-	   #:clone-mark
-	   #:no-such-offset #:offset-before-beginning #:offset-after-end
-	   #:invalid-motion #:motion-before-beginning #:motion-after-end
-	   #:size #:number-of-lines
-	   #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>=
-           #:forward-object
-           #:backward-object
-           #:forward-line-start #:backward-line-start
-           #:forward-line-end #:backward-line-end
-	   #:beginning-of-buffer #:end-of-buffer
-	   #: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
-           #:buffer-substring
-	   #:insert-object #:insert-sequence
-	   #:delete-buffer-range #:delete-range
-	   #:delete-region
-	   #:buffer-object #:buffer-sequence
-	   #:object-before #:object-after #:region-to-sequence
-	   #:low-mark #:high-mark #:modified-p #:clear-modify
-	   #:binseq-buffer #:obinseq-buffer #:binseq2-buffer
-	   #:persistent-left-sticky-mark #:persistent-right-sticky-mark
-	   #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark
-	   #:p-line-mark-mixin #:buffer-line-offset
-	   #:delegating-buffer #:implementation)
-  (:documentation "An implementation of the Climacs buffer
-  protocol. This package is quite low-level, not syntax-aware,
-  not CLIM-aware and not user-oriented at all."))
-
-(defpackage :climacs-kill-ring
-  (:use :clim-lisp :flexichain)
-  (:export #:kill-ring
-           #:empty-kill-ring
-           #:kill-ring-length #:kill-ring-max-size
-	   #:append-next-p
-	   #:reset-yank-position #:rotate-yank-position #:kill-ring-yank
-	   #:kill-ring-standard-push #:kill-ring-concatenating-push
-	   #:kill-ring-reverse-concatenating-push
-           #:*kill-ring*)
-  (:documentation "An implementation of a kill ring."))
-
-(defpackage :climacs-base
-  (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer :climacs-utils)
-  (:export #:as-offsets
-           #: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
-           #:move-to-column
-           #:buffer-whitespacep
-           #:buffer-region-case
-	   #:name-mixin #:name
-	   #:buffer-looking-at #:looking-at
-	   #:buffer-search-forward #:buffer-search-backward
-	   #: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)
-  (:documentation "Basic functionality built on top of the buffer
- protocol. Here is where we define slightly higher level
- functions, that can be directly implemented in terms of the
- buffer protocol, but that are not, strictly speaking, part of
- that protocol. The functions in this package are not
- syntax-aware, and are thus limited in what they can do. They
- percieve the buffer as little more than a sequence of
- characters."))
-
-(defpackage :climacs-abbrev
-  (:use :clim-lisp :clim :climacs-buffer :climacs-base)
-  (:export #:abbrev-expander #:dictionary-abbrev-expander #:dictionary
-	   #:expand-abbrev #:abbrev-mixin #:possibly-expand-abbrev
-	   #:add-abbrev))
-
-(defpackage :climacs-syntax
-  (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-utils)
-  (:export #:syntax #:define-syntax #:*default-syntax*
-           #:eval-option
-           #:define-option-for-syntax
-           #:current-attributes-for-syntax
-           #:make-attribute-line
-	   #:syntax-from-name
-	   #:update-syntax #:update-syntax-for-display
-	   #:grammar #:grammar-rule #:add-rule
-	   #:parser #:initial-state
-	   #:advance-parse
-	   #:parse-tree #:start-offset #:end-offset
-	   #:lexer #:nb-lexemes #:lexeme #:insert-lexeme
-	   #:incremental-lexer #:next-lexeme
-	   #:delete-invalid-lexemes #:inter-lexeme-object-p
-	   #:skip-inter-lexeme-objects #:update-lex
-	   #:parse-stack-top #:target-parse-tree #:parse-state-empty-p
-	   #:parse-stack-next #:parse-stack-symbol
-	   #:parse-stack-parse-trees #:map-over-parse-trees
-	   #:no-such-operation #:no-expression
-	   #:name-for-info-pane
-           #:display-syntax-name
-           #:syntax-line-indentation
-	   #:forward-expression #:backward-expression
-	   #:eval-defun
-	   #:beginning-of-definition #:end-of-definition
-	   #:redisplay-pane-with-syntax
-	   #:backward-paragraph #:forward-paragraph
-	   #:backward-sentence #:forward-sentence
-	   #:forward-list #:backward-list
-	   #:down-list #:up-list
-	   #:backward-down-list #:backward-up-list
-	   #:syntax-line-comment-string
-	   #:line-comment-region #:comment-region
-	   #:line-uncomment-region #:uncomment-region
-           #:word-constituentp
-           #:whitespacep
-           #:page-delimiter
-           #:paragraph-delimiter)
-  (:documentation "The Climacs syntax protocol. Contains
-  functions that can be used to implement higher-level operations
-  on buffer contents."))
-
-(defpackage :undo
-  (:use :clim-lisp)
-  (:export #:no-more-undo
-	   #:undo-tree #:standard-undo-tree
-	   #:undo-record #:standard-undo-record
-	   #:add-undo #:flip-undo-record #:undo #:redo))
-
-(defpackage :climacs-pane
-  (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev
-	:climacs-syntax :flexichain :undo :esa-buffer :esa-io :climacs-utils)
-  (:export #:climacs-buffer #:needs-saving
-	   #:filepath #:file-saved-p #:file-write-time
-	   #:read-only-p #:buffer-read-only
-	   #:climacs-pane #:point #:mark
-           #:clear-cache
-	   #:redisplay-pane #:full-redisplay
-	   #:display-cursor
-	   #:display-region
-           #:offset-to-screen-position
-	   #:page-down #:page-up
-	   #:top #:bot
-           #:tab-space-count #:space-width #:tab-width
-           #:indent-tabs-mode
-           #:auto-fill-mode #:auto-fill-column
-           #:isearch-state #:search-string #:search-mark
-           #:search-forward-p #:search-success-p
-           #:isearch-mode #:isearch-states #:isearch-previous-string
-           #:query-replace-state #:string1 #:string2 #:buffers #:mark
-           #:query-replace-mode
-	   #:region-visible-p
-	   #:with-undo
-	   #:url
-	   #:climacs-textual-view #:+climacs-textual-view+))
-
-(defpackage :climacs-motion
-  (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax)
-  (:export #:forward-to-word-boundary #:backward-to-word-boundary
-           #:define-motion-fns
-           #:beep-limit-action #:revert-limit-action #:error-limit-action
-           #:motion-limit-error
-           #:make-diligent-motor
-
-           ;; Lines
-           #:forward-one-line
-           #:backward-one-line
-           #:forward-line
-           #:backward-line
-
-           ;; Words
-           #:forward-one-word
-           #:backward-one-word
-           #:forward-word
-           #:backward-word
-
-           ;; Pages
-           #:forward-one-page
-           #:backward-one-page
-           #:forward-page
-           #:backward-page
-
-           ;; Expressions
-           #:forward-one-expression
-           #:backward-one-expression
-           #:forward-expression
-           #:backward-expression
-
-           ;; Definitions
-           #:forward-one-definition
-           #:backward-one-definition
-           #:forward-definition
-           #:backward-definition
-
-           ;; Up
-           #:forward-one-up
-           #:backward-one-up
-           #:forward-up
-           #:backward-up
-
-           ;; Down
-           #:forward-one-down
-           #:backward-one-down
-           #:forward-down
-           #:backward-down
-
-           ;; Paragraphs
-           #:forward-one-paragraph
-           #:backward-one-paragraph
-           #:forward-paragraph
-           #:backward-paragraph
-
-           ;; Sentences
-           #:forward-one-sentence
-           #:backward-one-sentence
-           #:forward-sentence
-           #:backward-sentence)
-  (:documentation "Functions and facilities for moving a mark
-  around by syntactical elements. The functions in this package
-  are syntax-aware, and their behavior is based on the semantics
-  defined by the syntax of the buffer, that the mark they are
-  manipulating belong to. These functions are also directly used
-  to implement the motion commands."))
-
-(defpackage :climacs-editing
-  (:use :clim-lisp :climacs-base :climacs-buffer
-        :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring)
-  (:export #:transpose-objects
-           
-           ;; Lines
-           #:forward-delete-line #:backward-delete-line
-           #:forward-kill-line #:backward-kill-line
-           #:transpose-lines
-           #:forward-delete-line-start #:backward-delete-line-start
-           #:forward-kill-line-start #:backward-kill-line-start
-           #:transpose-line-starts
-           
-           ;; Words
-           #:forward-delete-word #:backward-delete-word
-           #:forward-kill-word #:backward-kill-word
-           #:transpose-words
-
-           ;; Pages
-           #:forward-delete-page #:backward-delete-page
-           #:forward-kill-page #:backward-kill-page
-           #:transpose-page
-           
-           ;; Expressions
-           #:forward-delete-expression #:backward-delete-expression
-           #:forward-kill-expression #:backward-kill-expression
-           #:transpose-expressions
-
-           ;; Definitions
-           #:forward-delete-definition #:backward-delete-definition
-           #:forward-kill-definition #:backward-kill-definition
-           #:transpose-definitions
-
-           ;; Paragraphs
-           #:forward-delete-paragraph #:backward-delete-paragraph
-           #:forward-kill-paragraph #:backward-kill-paragraph
-           #:transpose-paragraphs
-
-           ;; Sentences
-           #:forward-delete-sentence #:backward-delete-sentence
-           #:forward-kill-sentence #:backward-kill-sentence
-           #:transpose-sentences)
-  (:documentation "Functions and facilities for changing the
-  buffer contents by syntactical elements. The functions in this package
-  are syntax-aware, and their behavior is based on the semantics
-  defined by the syntax of the buffer, that the mark they are
-  manipulating belong to. These functions are also directly used
-  to implement the editing commands."))
-
-(defpackage :climacs-fundamental-syntax
-  (:use :clim-lisp :clim :climacs-buffer :climacs-base 
-	:climacs-syntax :flexichain :climacs-pane)
-  (:export #:fundamental-syntax))
-
 (defpackage :climacs-gui
-    (:use :clim-lisp :clim :climacs-buffer :climacs-base
-          :climacs-abbrev :climacs-syntax :climacs-motion
-          :climacs-kill-ring :climacs-pane :clim-extensions
-          :undo :esa :climacs-editing :climacs-motion :esa-buffer :esa-io)
+    (:use :clim-lisp :clim :drei-buffer :drei-base
+          :drei-abbrev :drei-syntax :drei-motion
+          :drei-kill-ring :drei :clim-extensions
+          :drei-undo :esa :drei-editing :drei-motion
+          :esa-buffer :esa-io :esa-utils)
     ;;(:import-from :lisp-string)
     (:export #:climacs                  ; Frame.
-             #:extended-pane
+             #:climacs-buffer #:external-format
+             #:climacs-pane
              #:climacs-info-pane
              #:typeout-pane
              #:kill-ring
;; GUI functions follow.
-             #:current-window
-             #:current-point
-             #:current-buffer
-             #:current-point
-             #:current-mark
              #:any-buffer
              #:point
              #:syntax
@@ -352,7 +49,6 @@
              #:buffers
              #:active-group
              #:groups
-             #:insert-character
              #:display-window
              #:split-window
              #:typeout-window
@@ -368,53 +64,26 @@
              #:*mini-bg-color*
              #:*mini-fg-color*
              #:*with-scrollbars*
+             #:*default-external-format*
;; The command tables
              #:global-climacs-table #:keyboard-macro-table #:climacs-help-table
-             #:base-table #:buffer-table #:case-table #:comment-table
-             #:deletion-table #:development-table #:editing-table
-             #:fill-table #:indent-table #:info-table #:marking-table
-             #:movement-table #:pane-table #:search-table #:self-insert-table
-             #:window-table
-
-             ;; Other stuff
-             #:dabbrev-expansion-mark
-             #:original-prefix
-             #:prefix-start-offset
-             #:overwrite-mode
-             #:goal-column
-             ))
+             #:base-table #:buffer-table #:case-table 
+              #:development-table
+              #:info-table #:pane-table
+             #:window-table))
(defpackage :climacs-core
-  (:use :clim-lisp :climacs-base :climacs-buffer :climacs-fundamental-syntax
-        :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring
-        :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io
-        :climacs-utils)
+  (:use :clim-lisp :drei-base :drei-buffer :drei-fundamental-syntax
+        :drei-syntax :drei-motion :drei :drei-kill-ring
+        :drei-editing :climacs-gui :clim :drei-abbrev :esa :esa-buffer :esa-io
+        :esa-utils :drei-core :flexi-streams)
   (:export #:display-string
            #:object-equal
            #:object=
            #:no-upper-p
            #:case-relevant-test
-           #:goto-position
-           #:goto-line
-
-           #:possibly-fill-line
-           #:insert-character
-           #:back-to-indentation
-           #:delete-horizontal-space
-           #:indent-current-line
-           #:insert-pair
-
-           #:downcase-word #:upcase-word #:capitalize-word
- 
-           #:indent-region
-           #:fill-line #:fill-region
-
-           #:indent-line #:delete-indentation
[76 lines skipped]
--- /project/climacs/cvsroot/climacs/prolog-syntax.lisp	2006/09/02 21:43:56	1.29
+++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp	2006/11/12 16:06:06	1.30
@@ -77,18 +77,18 @@
(defclass start-lexeme (prolog-lexeme) ())
-(defgeneric display-parse-tree (entity syntax pane))
+(defgeneric display-parse-tree (entity syntax stream drei))
(defclass layout-text (prolog-nonterminal)
   ((comment :initarg :comment :accessor comment :initform nil)
    (cont :initarg :cont :accessor cont)))
 (defmethod display-parse-tree
-    ((entity layout-text) (syntax prolog-syntax) pane)
+    ((entity layout-text) (syntax prolog-syntax) (stream extended-output-stream) (drei drei))
   (when (cont entity)
-    (display-parse-tree (cont entity) syntax pane))
+    (display-parse-tree (cont entity) syntax stream drei))
   (when (comment entity)
-    (with-drawing-options (pane :ink (make-rgb-color 0.7 0.0 0.0))
-      (display-parse-tree (comment entity) syntax pane))))
+    (with-drawing-options (stream :ink (make-rgb-color 0.7 0.0 0.0))
+      (display-parse-tree (comment entity) syntax stream drei))))
(defgeneric syntactic-lexeme (thing))
 (defmethod syntactic-lexeme ((lexeme prolog-lexeme))
@@ -103,12 +103,12 @@
                           ((layout-text :initarg :layout-text :accessor layout-text :initform nil)
                            (syntactic-lexeme :initarg :syntactic-lexeme :accessor syntactic-lexeme)))
                         (defmethod display-parse-tree
-                            ((entity ,name) (syntax prolog-syntax) pane)
+                            ((entity ,name) (syntax prolog-syntax) (stream extended-output-stream) (drei drei))
                           (when (layout-text entity)
                             (display-parse-tree
-                             (layout-text entity) syntax pane))
+                             (layout-text entity) syntax stream drei))
                           (display-parse-tree
-                           (syntactic-lexeme entity) syntax pane))
+                           (syntactic-lexeme entity) syntax stream drei))
                         (define-prolog-rule (,name -> (,(f name)))
                           (make-instance ',name :syntactic-lexeme ,(f name)))
                         (define-prolog-rule (,name -> (layout-text ,(f name)))
@@ -143,8 +143,9 @@
 ;;; expression here.
 (defclass open-ct (prolog-nonterminal)
   ((syntactic-lexeme :initarg :syntactic-lexeme :accessor syntactic-lexeme)))
-(defmethod display-parse-tree ((entity open-ct) (syntax prolog-syntax) pane)
-  (display-parse-tree (syntactic-lexeme entity) syntax pane))
+(defmethod display-parse-tree ((entity open-ct) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (syntactic-lexeme entity) syntax stream drei))
 (define-prolog-rule (open-ct -> (open-ct-lexeme))
   (make-instance 'open-ct :syntactic-lexeme open-ct-lexeme))
@@ -409,18 +410,21 @@
    (text-rest :initarg :text-rest :accessor text-rest)))
(defmethod display-parse-tree
-    ((entity empty-prolog-text) (syntax prolog-syntax) pane)
-  (declare (ignore pane))
+    ((entity empty-prolog-text) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (declare (ignore stream drei))
   nil)
 (defmethod display-parse-tree
-    ((entity clause-prolog-text) (syntax prolog-syntax) pane)
-  (display-parse-tree (text-rest entity) syntax pane)
-  (display-parse-tree (clause entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity directive-prolog-text) (syntax prolog-syntax) pane)
-  (display-parse-tree (text-rest entity) syntax pane)
-  (with-text-face (pane :italic)
-    (display-parse-tree (directive entity) syntax pane)))
+    ((entity clause-prolog-text) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (text-rest entity) syntax stream drei)
+  (display-parse-tree (clause entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity directive-prolog-text) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (text-rest entity) syntax stream drei)
+  (with-text-face (stream :italic)
+    (display-parse-tree (directive entity) syntax stream drei)))
(defclass directive (prolog-nonterminal)
   ((directive-term :initarg :directive-term :accessor directive-term)
@@ -433,19 +437,23 @@
 (defclass clause-term (prolog-nonterminal)
   ((term :initarg :term :accessor term)))
-(defmethod display-parse-tree ((entity directive) (syntax prolog-syntax) pane)
-  (with-text-face (pane :italic)
-    (display-parse-tree (directive-term entity) syntax pane))
-  (display-parse-tree (end entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity directive-term) (syntax prolog-syntax) pane)
-  (display-parse-tree (term entity) syntax pane))
-(defmethod display-parse-tree ((entity clause) (syntax prolog-syntax) pane)
-  (display-parse-tree (clause-term entity) syntax pane)
-  (display-parse-tree (end entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity clause-term) (syntax prolog-syntax) pane)
-  (display-parse-tree (term entity) syntax pane))
+(defmethod display-parse-tree ((entity directive) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (with-text-face (stream :italic)
+    (display-parse-tree (directive-term entity) syntax stream drei))
+  (display-parse-tree (end entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity directive-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (term entity) syntax stream drei))
+(defmethod display-parse-tree ((entity clause) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (clause-term entity) syntax stream drei)
+  (display-parse-tree (end entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity clause-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (term entity) syntax stream drei))
(defgeneric functor (term))
 (defgeneric arity (term))
@@ -514,57 +522,67 @@
   2)
(defmethod display-parse-tree
-    ((entity constant-term) (syntax prolog-syntax) pane)
+    ((entity constant-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
   ;; FIXME: this is so not the right thing.
   (cond
     ((consp (value entity))
-     (display-parse-tree (first (value entity)) syntax pane)
-     (display-parse-tree (second (value entity)) syntax pane))
-    (t (display-parse-tree (value entity) syntax pane))))
+     (display-parse-tree (first (value entity)) syntax stream drei)
+     (display-parse-tree (second (value entity)) syntax stream drei))
+    (t (display-parse-tree (value entity) syntax stream drei))))
 (defmethod display-parse-tree 
-    ((entity variable-term) (syntax prolog-syntax) pane)
-  (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.0))
-    (display-parse-tree (name entity) syntax pane)))
+    ((entity variable-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (with-drawing-options (stream :ink (make-rgb-color 0.7 0.7 0.0))
+    (display-parse-tree (name entity) syntax stream drei)))
 (defmethod display-parse-tree 
-    ((entity functional-compound-term) (syntax prolog-syntax) pane)
-  (with-drawing-options (pane :ink (make-rgb-color 0.9 0 0.9))
-    (display-parse-tree (functor entity) syntax pane))
-  (display-parse-tree (open-ct entity) syntax pane)
-  (display-parse-tree (arg-list entity) syntax pane)
-  (display-parse-tree (close entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity bracketed-term) (syntax prolog-syntax) pane)
-  (display-parse-tree (open entity) syntax pane)
-  (display-parse-tree (term entity) syntax pane)
-  (display-parse-tree (close entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity binary-operator-compound-term) (syntax prolog-syntax) pane)
-  (display-parse-tree (left entity) syntax pane)
-  (display-parse-tree (operator entity) syntax pane)
-  (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity prefix-operator-compound-term) (syntax prolog-syntax) pane)
-  (display-parse-tree (operator entity) syntax pane)
-  (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity postfix-operator-compound-term) (syntax prolog-syntax) pane)
-  (display-parse-tree (left entity) syntax pane)
-  (display-parse-tree (operator entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity list-compound-term) (syntax prolog-syntax) pane)
-  (with-drawing-options (pane :ink (make-rgb-color 0.0 0.0 0.8))
-    (display-parse-tree ([ entity) syntax pane)
-    (display-parse-tree (items entity) syntax pane)
-    (display-parse-tree (] entity) syntax pane)))
-(defmethod display-parse-tree
-    ((entity curly-compound-term) (syntax prolog-syntax) pane)
-  (display-parse-tree ({ entity) syntax pane)
-  (display-parse-tree (term entity) syntax pane)
-  (display-parse-tree (} entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity char-code-list-compound-term) (syntax prolog-syntax) pane)
-  (with-drawing-options (pane :ink (make-rgb-color 0.0 0.6 0.0))
-    (display-parse-tree (ccl entity) syntax pane)))
+    ((entity functional-compound-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (with-drawing-options (stream :ink (make-rgb-color 0.9 0 0.9))
+    (display-parse-tree (functor entity) syntax stream drei))
+  (display-parse-tree (open-ct entity) syntax stream drei)
+  (display-parse-tree (arg-list entity) syntax stream drei)
+  (display-parse-tree (close entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity bracketed-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (open entity) syntax stream drei)
+  (display-parse-tree (term entity) syntax stream drei)
+  (display-parse-tree (close entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity binary-operator-compound-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (left entity) syntax stream drei)
+  (display-parse-tree (operator entity) syntax stream drei)
+  (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity prefix-operator-compound-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (operator entity) syntax stream drei)
+  (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity postfix-operator-compound-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (left entity) syntax stream drei)
+  (display-parse-tree (operator entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity list-compound-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (with-drawing-options (stream :ink (make-rgb-color 0.0 0.0 0.8))
+    (display-parse-tree ([ entity) syntax stream drei)
+    (display-parse-tree (items entity) syntax stream drei)
+    (display-parse-tree (] entity) syntax stream drei)))
+(defmethod display-parse-tree
+    ((entity curly-compound-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree ({ entity) syntax stream drei)
+  (display-parse-tree (term entity) syntax stream drei)
+  (display-parse-tree (} entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity char-code-list-compound-term) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (with-drawing-options (stream :ink (make-rgb-color 0.0 0.6 0.0))
+    (display-parse-tree (ccl entity) syntax stream drei)))
(defclass atom (prolog-nonterminal)
   ((value :initarg :value :accessor value)))
@@ -591,15 +609,18 @@
 (defmethod canonical-name ((thing curly-brackets))
   ;; FIXME: see comment in CANONICAL-NAME (EMPTY-LIST)
   "{}")
-(defmethod display-parse-tree ((entity atom) (syntax prolog-syntax) pane)
-  (display-parse-tree (value entity) syntax pane))
-(defmethod display-parse-tree ((entity empty-list) (syntax prolog-syntax) pane)
-  (display-parse-tree ([ entity) syntax pane)
-  (display-parse-tree (] entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity curly-brackets) (syntax prolog-syntax) pane)
-  (display-parse-tree ({ entity) syntax pane)
-  (display-parse-tree (} entity) syntax pane))
+(defmethod display-parse-tree ((entity atom) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (value entity) syntax stream drei))
+(defmethod display-parse-tree ((entity empty-list) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree ([ entity) syntax stream drei)
+  (display-parse-tree (] entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity curly-brackets) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree ({ entity) syntax stream drei)
+  (display-parse-tree (} entity) syntax stream drei))
(defclass arg-list (prolog-nonterminal)
   ((exp :initarg :exp :accessor exp)))
@@ -617,13 +638,15 @@
       (exp a)
       (arg-list-nth (1- n) (arg-list a))))
-(defmethod display-parse-tree ((entity arg-list) (syntax prolog-syntax) pane)
-  (display-parse-tree (exp entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity arg-list-pair) (syntax prolog-syntax) pane)
-  (display-parse-tree (exp entity) syntax pane)
-  (display-parse-tree (comma entity) syntax pane)
-  (display-parse-tree (arg-list entity) syntax pane))
+(defmethod display-parse-tree ((entity arg-list) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (exp entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity arg-list-pair) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (exp entity) syntax stream drei)
+  (display-parse-tree (comma entity) syntax stream drei)
+  (display-parse-tree (arg-list entity) syntax stream drei))
(defclass exp (prolog-nonterminal) ())
 (defclass exp-atom (exp)
@@ -631,10 +654,12 @@
 (defclass exp-term (exp)
   ((term :initarg :term :accessor term)))
-(defmethod display-parse-tree ((entity exp-atom) (syntax prolog-syntax) pane)
-  (display-parse-tree (atom entity) syntax pane))
-(defmethod display-parse-tree ((entity exp-term) (syntax prolog-syntax) pane)
-  (display-parse-tree (term entity) syntax pane))
+(defmethod display-parse-tree ((entity exp-atom) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (atom entity) syntax stream drei))
+(defmethod display-parse-tree ((entity exp-term) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (term entity) syntax stream drei))
(defclass lterm (term)
   ((term :initarg :term :accessor term)))
@@ -645,8 +670,9 @@
 (defmethod arity ((l lterm))
   (arity (term l)))
-(defmethod display-parse-tree ((entity lterm) (syntax prolog-syntax) pane)
-  (display-parse-tree (term entity) syntax pane))
+(defmethod display-parse-tree ((entity lterm) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (term entity) syntax stream drei))
;;; FIXME: the need for these is because it is a protocol violation to
 ;;; create nested nonterminals from one rule.
@@ -671,18 +697,21 @@
   1)
(defmethod display-parse-tree
-    ((entity binary-operator-compound-lterm) (syntax prolog-syntax) pane)
-  (display-parse-tree (left entity) syntax pane)
-  (display-parse-tree (operator entity) syntax pane)
-  (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity prefix-operator-compound-lterm) (syntax prolog-syntax) pane)
-  (display-parse-tree (operator entity) syntax pane)
-  (display-parse-tree (right entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity postfix-operator-compound-lterm) (syntax prolog-syntax) pane)
-  (display-parse-tree (left entity) syntax pane)
-  (display-parse-tree (operator entity) syntax pane))
+    ((entity binary-operator-compound-lterm) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (left entity) syntax stream drei)
+  (display-parse-tree (operator entity) syntax stream drei)
+  (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity prefix-operator-compound-lterm) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (operator entity) syntax stream drei)
+  (display-parse-tree (right entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity postfix-operator-compound-lterm) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (left entity) syntax stream drei)
+  (display-parse-tree (operator entity) syntax stream drei))
(defclass op (prolog-nonterminal)
   ((name :initarg :name :accessor name)
@@ -694,8 +723,9 @@
 (defclass binary-op (op) ())
 (defclass postfix-op (op) ())
-(defmethod display-parse-tree ((entity op) (syntax prolog-syntax) pane)
-  (display-parse-tree (name entity) syntax pane))
+(defmethod display-parse-tree ((entity op) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (name entity) syntax stream drei))
(defclass items (prolog-nonterminal)
   ((exp :initarg :exp :accessor exp)))
@@ -706,18 +736,21 @@
   ((comma :initarg :comma :accessor comma)
    (tlist :initarg :tlist :accessor tlist)))
-(defmethod display-parse-tree ((entity items) (syntax prolog-syntax) pane)
-  (display-parse-tree (exp entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity items-pair) (syntax prolog-syntax) pane)
-  (display-parse-tree (exp entity) syntax pane)
-  (display-parse-tree (htsep entity) syntax pane)
-  (display-parse-tree (texp entity) syntax pane))
-(defmethod display-parse-tree
-    ((entity items-list) (syntax prolog-syntax) pane)
-  (display-parse-tree (exp entity) syntax pane)
-  (display-parse-tree (comma entity) syntax pane)
-  (display-parse-tree (tlist entity) syntax pane))
+(defmethod display-parse-tree ((entity items) (syntax prolog-syntax)
+                               (stream extended-output-stream) (drei drei))
+  (display-parse-tree (exp entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity items-pair) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (exp entity) syntax stream drei)
+  (display-parse-tree (htsep entity) syntax stream drei)
+  (display-parse-tree (texp entity) syntax stream drei))
+(defmethod display-parse-tree
+    ((entity items-list) (syntax prolog-syntax)
+     (stream extended-output-stream) (drei drei))
+  (display-parse-tree (exp entity) syntax stream drei)
+  (display-parse-tree (comma entity) syntax stream drei)
+  (display-parse-tree (tlist entity) syntax stream drei))
;;; FIXME FIXME FIXME!!!
 ;;;
@@ -1093,7 +1126,7 @@
(defmethod update-syntax-for-display (buffer (syntax prolog-syntax) top bot)
[261 lines skipped]
--- /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp	2006/08/20 13:06:38	1.2
+++ /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp	2006/11/12 16:06:06	1.3
@@ -53,13 +53,13 @@
     buffer))
(defun buffer->paiprolog (buffer) 
-  (let ((lexemes (climacs-syntax::lexemes (lexer (syntax buffer))))
+  (let ((lexemes (drei-syntax::lexemes (lexer (syntax buffer))))
         (expressions '()))
     (dotimes (i (flexichain:nb-elements lexemes) (nreverse expressions))
       (let ((lexeme (flexichain:element* lexemes i)))
         (when (typep lexeme 'end-lexeme)
           (with-hash-table-iterator 
-              (next-entry (climacs-syntax::parse-trees (slot-value lexeme 'state)))
+              (next-entry (drei-syntax::parse-trees (slot-value lexeme 'state)))
             (loop
              (multiple-value-bind (more from-state items) 
                  (next-entry)
--- /project/climacs/cvsroot/climacs/search-commands.lisp	2006/09/12 19:49:18	1.15
+++ /project/climacs/cvsroot/climacs/search-commands.lisp	2006/11/12 16:06:06	1.16
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
+;;; -*- Mode: Lisp; Package: CLIMACS-COMMANDS -*-
;;;  (c) copyright 2004-2005 by
 ;;;           Robert Strandh (strandh@labri.fr)
@@ -24,483 +24,15 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
-;;; Search commands for the Climacs editor. 
+;;; Search commands for Climacs.
(in-package :climacs-commands)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
-;;; String search
-
-(define-command (com-string-search :name t :command-table search-table)
-    ((string 'string :prompt "String Search"))
-  "Prompt for a string and search forward for it.
-If found, leaves point after string. If not, leaves point where it is."
-  (let* ((pane (current-window))
-	 (point (point pane)))
-    (search-forward point string :test (case-relevant-test string))))
-
-(define-command (com-reverse-string-search :name t :command-table search-table)
-    ((string 'string :prompt "Reverse String Search"))
-  "Prompt for a string and search backward for it.
-If found, leaves point before string. If not, leaves point where it is."
-  (let* ((pane (current-window))
-	 (point (point pane)))
-    (search-backward point string :test (case-relevant-test string))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Word search
-
-(define-command (com-word-search :name t :command-table search-table)
-    ((word 'string :prompt "Search word"))
-  "Prompt for a whitespace delimited word and search forward for it.
-If found, leaves point after the word. If not, leaves point where it is."
-  (let* ((pane (current-window))
-	 (point (point pane)))
-    (climacs-base::search-word-forward point word)))
-
-(define-command (com-reverse-word-search :name t :command-table search-table)
-    ((word 'string :prompt "Search word"))
-  "Prompt for a whitespace delimited word and search backward for it.
-If found, leaves point before the word. If not, leaves point where it is."
-  (let* ((pane (current-window))
-	 (point (point pane)))
-    (climacs-base::search-word-backward point word)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Incremental search
-
-(make-command-table 'isearch-climacs-table :errorp nil)
-
-(defun isearch-command-loop (pane forwardp)
-  (let ((point (point pane)))
-    (unless (endp (isearch-states pane))
-      (setf (isearch-previous-string pane)
-            (search-string (first (isearch-states pane)))))
-    (setf (isearch-mode pane) t)
-    (setf (isearch-states pane)
-          (list (make-instance 'isearch-state
-                               :search-string ""
-                               :search-mark (clone-mark point)
-                               :search-forward-p forwardp
-                               :search-success-p t)))
-    (simple-command-loop 'isearch-climacs-table
-                         (isearch-mode pane)
-                         ((setf (isearch-mode pane) nil)))))
-
-(defun isearch-from-mark (pane mark string forwardp)
-  (let* ((point (point pane))
-	 (mark2 (clone-mark mark))
-	 (success (funcall (if forwardp #'search-forward #'search-backward)
-			   mark2
-			   string
-			   :test (case-relevant-test string))))
-    (when success
-      (setf (offset point) (offset mark2)
-	    (offset mark) (if forwardp
-			      (- (offset mark2) (length string))
-			      (+ (offset mark2) (length string)))))
-    (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A"
-		     success forwardp (display-string string))
-    (push (make-instance 'isearch-state
-	     :search-string string
-	     :search-mark mark
-	     :search-forward-p forwardp
-	     :search-success-p success)
-	  (isearch-states pane))
-    (unless success
-      (beep))))
-
-(define-command (com-isearch-forward :name t :command-table search-table) ()
-  (display-message "Isearch: ")
-  (isearch-command-loop (current-window) t))
-
-(set-key 'com-isearch-forward
-	 'search-table
-	 '((#\s :control)))
-
-(define-command (com-isearch-backward :name t :command-table search-table) ()
-  (display-message "Isearch backward: ")
-  (isearch-command-loop (current-window) nil))
-
-(set-key 'com-isearch-backward
-	 'search-table
-	 '((#\r :control)))
-
-(defun isearch-append-char (char)
-  (let* ((pane (current-window))
-         (states (isearch-states pane))
-         (string (concatenate 'string
-                              (search-string (first states))
-                              (string char)))
-         (mark (clone-mark (search-mark (first states))))
-         (forwardp (search-forward-p (first states))))
-    (unless (or forwardp (end-of-buffer-p mark))
-      (incf (offset mark)))
-    (isearch-from-mark pane mark string forwardp)))
-
-(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) ()
-  (isearch-append-char *current-gesture*))
-
-(define-command (com-isearch-append-newline :name t :command-table isearch-climacs-table) ()
-  (isearch-append-char #\Newline))
-
-(defun isearch-append-text (movement-function)
-  (let* ((pane (current-window))
-	 (states (isearch-states pane))
-	 (buffer (buffer pane))
-	 (point (point pane))
-	 (start (clone-mark point))
-	 (mark (clone-mark (search-mark (first states))))
-	 (forwardp (search-forward-p (first states))))
-    (funcall movement-function point)
-    (let* ((start-offset (offset start))
-	   (point-offset (offset point))
-	   (string (concatenate 'string
-				(search-string (first states))
-				(buffer-substring buffer
-						  start-offset
-						  point-offset))))
-      (unless (or forwardp (end-of-buffer-p mark))
-	(incf (offset mark) (- point-offset start-offset)))
-      (isearch-from-mark pane mark string forwardp))))
-
-(define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) ()
-  (let ((syntax (syntax (current-buffer *application-frame*))))
-   (isearch-append-text #'(lambda (mark)
-                            (forward-word mark syntax)))))
-
-(define-command (com-isearch-append-line :name t :command-table isearch-climacs-table) ()
-  (isearch-append-text #'end-of-line))
-
-(define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) ()
-  (let* ((pane (current-window))
-	 (states (isearch-states pane))
-	 (yank (handler-case (kill-ring-yank *kill-ring*)
-                 (empty-kill-ring ()
-                   "")))
-	 (string (concatenate 'string
-			      (search-string (first states))
-			      yank))
-	 (mark (clone-mark (search-mark (first states))))
-	 (forwardp (search-forward-p (first states))))
-    (unless (or forwardp (end-of-buffer-p mark))
-      (incf (offset mark) (length yank)))
-    (isearch-from-mark pane mark string forwardp)))
-
-(define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) ()
-  (let* ((pane (current-window)))
-    (cond ((null (second (isearch-states pane)))
-	   (display-message "Isearch: ")
-           (beep))
-          (t
-           (pop (isearch-states pane))
-           (loop until (endp (rest (isearch-states pane)))
-                 until (search-success-p (first (isearch-states pane)))
-                 do (pop (isearch-states pane)))
-           (let ((state (first (isearch-states pane))))
-             (setf (offset (point pane))
-                   (if (search-forward-p state)
-                       (+ (offset (search-mark state))
-                          (length (search-string state)))
-                       (- (offset (search-mark state))
-                          (length (search-string state)))))
-	     (display-message "Isearch~:[ backward~;~]: ~A"
-			      (search-forward-p state)
-			      (display-string (search-string state))))))))
-
-(define-command (com-isearch-search-forward :name t :command-table isearch-climacs-table) ()
-  (let* ((pane (current-window))
-         (point (point pane))
-         (states (isearch-states pane))
-         (string (if (null (second states))
-                     (isearch-previous-string pane)
-                     (search-string (first states))))
-         (mark (clone-mark point)))
-    (isearch-from-mark pane mark string t)))
-
-(define-command (com-isearch-search-backward :name t :command-table isearch-climacs-table) ()
-  (let* ((pane (current-window))
-         (point (point pane))
-         (states (isearch-states pane))
-         (string (if (null (second states))
-                     (isearch-previous-string pane)
-                     (search-string (first states))))
-         (mark (clone-mark point)))
-    (isearch-from-mark pane mark string nil)))
-
-(define-command (com-isearch-exit :name t :command-table isearch-climacs-table) ()
-  (let* ((pane (current-window))
-	 (states (isearch-states pane))
-	 (string (search-string (first states)))
-	 (search-forward-p (search-forward-p (first states))))
-    (setf (isearch-mode pane) nil)
-    (when (string= string "")
-      (execute-frame-command *application-frame*
-			     (funcall
-			      *partial-command-parser*
-			      (frame-command-table *application-frame*)
-			      (frame-standard-input *application-frame*)
-			      (if search-forward-p
-				  `(com-string-search ,*unsupplied-argument-marker*)
-				  `(com-reverse-string-search ,*unsupplied-argument-marker*))
-			      0)))))
-
-(defun isearch-set-key (gesture command)
-  (add-command-to-command-table command 'isearch-climacs-table
-                                :keystroke gesture :errorp nil))
-
-(loop for code from (char-code #\Space) to (char-code #~)
-      do (isearch-set-key (code-char code) 'com-isearch-append-char))
-
-(isearch-set-key '(#\Newline) 'com-isearch-exit)
-(isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
-(isearch-set-key '(#\s :control) 'com-isearch-search-forward)
-(isearch-set-key '(#\r :control) 'com-isearch-search-backward)
-(isearch-set-key '(#\j :control) 'com-isearch-append-newline)
-(isearch-set-key '(#\w :control) 'com-isearch-append-word)
-(isearch-set-key '(#\y :control) 'com-isearch-append-line)
-(isearch-set-key '(#\y :meta) 'com-isearch-append-kill)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Unconditional replace
-
-(defun replace-one-string (mark length newstring &optional (use-region-case t))
-  "Replace LENGTH objects at MARK with NEWSTRING,
-using the case of those objects if USE-REGION-CASE is true."
-  (let* ((start (offset mark))
-	 (end (+ start length))
-	 (region-case (and use-region-case
-			   (buffer-region-case (buffer mark)
-					       start
-					       end)))) 
-    (delete-range mark length)
-    (insert-sequence mark newstring)
-    (when (and use-region-case region-case)
-      (let ((buffer (buffer mark))
-	    (end2 (+ start (length newstring))))
-	(funcall (case region-case
-		   (:upper-case #'upcase-buffer-region)
-		   (:lower-case #'downcase-buffer-region)
-		   (:capitalized #'capitalize-buffer-region))
-		 buffer
-		 start
-		 end2)))))
-
-(define-command (com-replace-string :name t :command-table search-table)
-    ()
-  "Replace all occurrences of `string' with `newstring'."
-  ;; We have to do it this way if we want to refer to STRING in NEWSTRING
-  (let* ((string (accept 'string :prompt "Replace String"))
-	 (newstring (accept'string :prompt (format nil "Replace ~A with" string))))
-    (loop with point = (point (current-window))
-	  with length = (length string)
-	  with use-region-case = (no-upper-p string)
-	  for occurrences from 0
-	  while (let ((offset-before (offset point)))
-                  (search-forward point string :test (case-relevant-test string))
-                  (/= (offset point) offset-before))
-	  do (backward-object point length)
-	     (replace-one-string point length newstring use-region-case)
-	  finally (display-message "Replaced ~A occurrence~:P" occurrences))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 
-;;; Query replace
-
-(make-command-table 'query-replace-climacs-table :errorp nil)
-
-(defun query-replace-find-next-match (state)
-  (with-accessors ((string string1)
-                   (buffers buffers)
-                   (mark mark)) state
-    (flet ((head-to-buffer (buffer)
-             (switch-to-buffer (current-window) buffer)
-             (setf mark (point (current-window)))
-             (beginning-of-buffer mark)))
-      (unless (eq (current-buffer) (first buffers))
-        (when t buffers
-          (head-to-buffer (first buffers))))
-      (let ((offset-before (offset mark)))
-        (search-forward mark string :test (case-relevant-test string))
-        (or (/= (offset mark) offset-before)
-            (unless (null (rest buffers))
-              (pop buffers)
-              (query-replace-find-next-match state)))))))
-
-(define-command (com-query-replace :name t :command-table search-table) ()
-  (let* ((pane (current-window))
-	 (old-state (query-replace-state pane))
-	 (old-string1 (when old-state (string1 old-state)))
-	 (old-string2 (when old-state (string2 old-state)))
-	 (string1 (handler-case 
-		      (if old-string1
-			  (accept 'string 
-				  :prompt "Query Replace"
-				  :default old-string1
-				  :default-type 'string)
-			  (accept 'string :prompt "Query Replace"))
-		    (error () (progn (beep)
-				     (display-message "Empty string")
-				     (return-from com-query-replace nil)))))
-         (string2 (handler-case 
-		      (if old-string2
-			  (accept 'string
-				  :prompt (format nil "Replace ~A with"
-						  string1)
-				  :default old-string2
-				  :default-type 'string)
-			  (accept 'string
-				  :prompt (format nil "Replace ~A with" string1)))
-		    (error () (progn (beep)
-				     (display-message "Empty string")
-				     (return-from com-query-replace nil)))))
-         (point (point pane))
-	 (occurrences 0))
-    (declare (special string1 string2 occurrences))
-    (with-group-buffers (buffers (get-active-group))
-      (setf (query-replace-state pane) (make-instance 'query-replace-state
-                                                      :string1 string1
-                                                      :string2 string2
-                                                      :mark point
-                                                      :buffers buffers))
-      (when (query-replace-find-next-match (query-replace-state pane))
-        (setf (query-replace-mode pane) t)
-        (display-message "Replace ~A with ~A:"
-                         string1 string2)
-        (simple-command-loop 'query-replace-climacs-table
-                             (query-replace-mode pane)
-                             ((setf (query-replace-mode pane) nil))))
-      (display-message "Replaced ~A occurrence~:P" occurrences))))
-
-(set-key 'com-query-replace
-	 'search-table
-	 '((#% :shift :meta)))
-
-(define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) ()
-  (declare (special string1 string2 occurrences))
-  (let* ((pane (current-window))
-         (string1-length (length string1))
-         (state (query-replace-state pane)))
-    (backward-object (mark state) string1-length)
-    (replace-one-string (mark state)
-                        string1-length
-                        string2
-                        (no-upper-p string1))
-    (incf occurrences)
-    (if (query-replace-find-next-match (query-replace-state pane))
-	(display-message "Replace ~A with ~A:"
-		       string1 string2)
-	(setf (query-replace-mode pane) nil))))
-
-(define-command (com-query-replace-replace-and-quit
-		 :name t
-		 :command-table query-replace-climacs-table)
-    ()
-  (declare (special string1 string2 occurrences))
-  (let* ((pane (current-window))
-	 (string1-length (length string1))
-         (state (query-replace-state pane)))
-    (backward-object (mark state) string1-length)
-    (replace-one-string (mark state)
-                        string1-length
-                        string2
-                        (no-upper-p string1))
-    (incf occurrences)
-    (setf (query-replace-mode pane) nil)))
[147 lines skipped]
--- /project/climacs/cvsroot/climacs/slidemacs-gui.lisp	2006/07/25 11:38:05	1.23
+++ /project/climacs/cvsroot/climacs/slidemacs-gui.lisp	2006/11/12 16:06:06	1.24
@@ -240,7 +240,7 @@
                  (pushnew (cons from to)
                           edges :test #'equal))))))
         (possibly-capturing-and-flipping-output-twice
-            pane (typep pane 'climacs-pane)
+            pane (typep pane 'drei-pane)
           (format-graph-from-roots
            roots
            (lambda (node stream)
@@ -437,7 +437,7 @@
(defparameter *slidemacs-gui-ink* +black+)
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-gui-syntax) current-p)
+(defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax slidemacs-gui-syntax) current-p)
   (with-drawing-options (pane :ink *slidemacs-gui-ink*)
     (with-slots (top bot point) pane
       (with-slots (lexer) syntax
@@ -530,11 +530,11 @@
   (full-redisplay (climacs-gui::current-window)))
(define-command (com-first-talking-point :name t :command-table slidemacs-table) ()
-  (climacs-commands::com-beginning-of-buffer)
+  (drei-commands::com-beginning-of-buffer)
   (com-next-talking-point))
(define-command (com-last-talking-point :name t :command-table slidemacs-table) ()
-  (climacs-commands::com-end-of-buffer)
+  (drei-commands::com-end-of-buffer)
   (com-previous-talking-point))
(define-command (com-flip-slidemacs-syntax :name t :command-table slidemacs-table) ()
@@ -572,7 +572,7 @@
(define-command (com-postscript-print-presentation :name t :command-table slidemacs-table) ()
   (let ((pane (climacs-gui::current-window)))
-    (if (not (and (typep pane 'climacs-pane)
+    (if (not (and (typep pane 'drei-pane)
                   (typep (syntax (buffer pane)) 'slidemacs-gui-syntax)))
         (beep)
         (let ((file (accept 'pathname :prompt "Output to")))
--- /project/climacs/cvsroot/climacs/slidemacs.lisp	2006/09/02 21:43:56	1.11
+++ /project/climacs/cvsroot/climacs/slidemacs.lisp	2006/11/12 16:06:06	1.12
@@ -21,8 +21,8 @@
 ;;; Boston, MA  02111-1307  USA.
(defpackage :climacs-slidemacs-editor
-  (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base 
-	:climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)
+  (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base 
+	:drei-syntax :flexichain :drei :drei-fundamental-syntax)
   (:export))
(in-package :climacs-slidemacs-editor)
@@ -387,23 +387,21 @@
(defun handle-whitespace (pane buffer start end)
   (let ((space-width (space-width pane))
-	(tab-width (tab-width pane)))
-    (loop while (and (< start end)
-                     (whitespacep (syntax buffer)
-                                  (buffer-object buffer start)))
-          do (ecase (buffer-object buffer start)
-               (#\Newline (terpri pane)
-                          (setf (aref *cursor-positions* (incf *current-line*))
-                                (multiple-value-bind (x y) (stream-cursor-position pane)
-                                  (declare (ignore x))
-                                  y)))
-               (#\Space (stream-increment-cursor-position
-                         pane space-width 0))
-               (#\Tab (let ((x (stream-cursor-position pane)))
-                        (stream-increment-cursor-position
-                         pane (- tab-width (mod x tab-width)) 0)))
-               (#\Page nil))
-	 (incf start))))
+        (tab-width (tab-width pane)))
+    (with-sheet-medium (medium pane)
+      (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
+        (loop while (< start end)
+           do (case (buffer-object buffer start)
+                (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
+                           (terpri pane)
+                           (stream-increment-cursor-position
+                            pane (first (aref cursor-positions 0)) 0))
+                ((#\Page #\Return #\Space) (stream-increment-cursor-position
+                                            pane space-width 0))
+                (#\Tab (let ((x (stream-cursor-position pane)))
+                         (stream-increment-cursor-position
+                          pane (- tab-width (mod x tab-width)) 0))))
+           (incf start))))))
(defvar *handle-whitespace* t)
@@ -419,11 +417,13 @@
           (call-next-method)))
       (call-next-method)))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax slidemacs-editor-syntax) current-p)
+(defmethod display-drei-contents ((pane drei-pane) (drei drei) (syntax slidemacs-editor-syntax))
   (with-slots (top bot) pane
-    (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
-	  *current-line* 0
-	  (aref *cursor-positions* 0) (stream-cursor-position pane))
+    (with-accessors ((cursor-positions cursor-positions)) syntax
+      (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
+                                         :initial-element nil)
+            *current-line* 0
+            (aref cursor-positions 0) (multiple-value-list (stream-cursor-position pane))))
     (with-slots (lexer) syntax
       (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
    			     1.0)))
@@ -442,7 +442,7 @@
        (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
    		    (not (parse-state-empty-p 
    			  (slot-value (lexeme lexer (1- start-token-index)) 'state))))
-		 do (decf start-token-index))
+               do (decf start-token-index))
        (let ((*white-space-start* (offset top)))
          ;; display the parse tree if any
          (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
@@ -454,6 +454,4 @@
    	(loop while (< start-token-index end-token-index)
    	   do (let ((token (lexeme lexer start-token-index)))
    		(display-parse-tree token syntax pane))
-		     (incf start-token-index))))))))
-    (when (region-visible-p pane) (display-region pane syntax))
-    (display-cursor pane syntax current-p)))
+                   (incf start-token-index))))))))))
--- /project/climacs/cvsroot/climacs/text-syntax.lisp	2006/09/02 21:43:56	1.11
+++ /project/climacs/cvsroot/climacs/text-syntax.lisp	2006/11/12 16:06:06	1.12
@@ -52,7 +52,7 @@
 ;;;       Right stickies at non whitespace characters preceeded by space and punctuation.
 ;;;
-(in-package :climacs-syntax) ;;; Put this in a separate package once it works
+(in-package :drei-syntax) ;;; Put this in a separate package once it works
(defun index-of-mark-after-offset (flexichain offset)
   "Searches for the mark after `offset' in the marks stored in `flexichain'."
@@ -65,7 +65,7 @@
             (setf low-position (floor (+ low-position 1 high-position) 2)))
      finally (return low-position)))
-(define-syntax text-syntax (climacs-fundamental-syntax:fundamental-syntax)
+(define-syntax text-syntax (drei-fundamental-syntax:fundamental-syntax)
   ((paragraphs :initform (make-instance 'standard-flexichain))
    (sentence-beginnings :initform (make-instance 'standard-flexichain))
    (sentence-endings :initform (make-instance 'standard-flexichain)))
@@ -197,7 +197,7 @@
   (loop with indentation = 0
         with mark2 = (clone-mark mark)
         until (beginning-of-buffer-p mark2)
-        do (climacs-motion:backward-line mark2 syntax)
+        do (drei-motion:backward-line mark2 syntax)
            (setf indentation (line-indentation mark2 tab-width))
         while (empty-line-p mark2)
         finally (return indentation)))
--- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp	2006/09/02 21:43:56	1.7
+++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp	2006/11/12 16:06:06	1.8
@@ -21,8 +21,8 @@
 ;;; Boston, MA  02111-1307  USA.
(defpackage :climacs-ttcn3-syntax
-  (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base 
-	:climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)
+  (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base 
+	:drei-syntax :flexichain :drei :drei-fundamental-syntax)
   (:export))
 (in-package :climacs-ttcn3-syntax)
@@ -417,7 +417,7 @@
     (when (and (end-offset entity) (mark> (end-offset entity) top))
       (call-next-method))))
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax ttcn3-syntax) current-p)
+(defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax ttcn3-syntax) current-p)
   (with-slots (top bot) pane
     (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
      *current-line* 0
--- /project/climacs/cvsroot/climacs/window-commands.lisp	2006/07/24 16:33:16	1.10
+++ /project/climacs/cvsroot/climacs/window-commands.lisp	2006/11/12 16:06:06	1.11
@@ -96,8 +96,8 @@
         (eq window (current-window)))
     (setf (offset (mark window))
      (click-to-offset window x y))
-    (com-exchange-point-and-mark)
-    (com-copy-region)))
+    (drei-commands::com-exchange-point-and-mark)
+    (drei-commands::com-copy-region)))
(define-presentation-to-command-translator blank-area-to-mouse-save
     (blank-area com-mouse-save window-table :echo nil :gesture :select-other)
@@ -112,7 +112,7 @@
     (other-window window)
     (setf (offset (point window))
      (click-to-offset window x y))
-    (com-yank)))
+    (drei-commands::com-yank)))
(define-presentation-to-command-translator blank-area-to-yank-here
     (blank-area com-yank-here window-table :echo nil :gesture :middle-button)
--- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp	2006/11/12 16:06:07	NONE
+++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp	2006/11/12 16:06:07	1.1
;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX; -*-
;;;  (c) copyright 2004-2005 by
;;;           Robert Strandh (strandh@labri.fr)
;;;  (c) copyright 2004-2005 by
;;;           Elliott Johnson (ejohnson@fasl.info)
;;;  (c) copyright 2005 by
;;;           Matthieu Villeneuve (matthieu.villeneuve@free.fr)
;;;  (c) copyright 2005 by
;;;           Aleksandar Bakic (a_bakic@yahoo.com)
;;;  (c) copyright 2006 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.
;;; Commands specific to the Lisp syntax for Climacs.
(in-package :drei-lisp-syntax)
(make-command-table 'climacs-lisp-table
                    :errorp nil)
(defmethod additional-command-tables append ((frame climacs-gui:climacs) (command-table lisp-table))
  '(climacs-lisp-table))
(define-command (com-package :name t :command-table climacs-lisp-table) ()
  (let ((package (package-at-mark *current-syntax* *current-point*)))
    (esa:display-message (format nil "~A" (if (packagep package)
                                              (package-name package)
                                              package)))))
(define-command (com-set-base :name t :command-table climacs-lisp-table)
    ((base '(integer 2 36)))
  "Set the base for the current buffer."
  (setf (base *current-syntax*) base))
(define-command (com-set-package :name t :command-table climacs-lisp-table)
    ((package 'package))
  "Set the package for the current buffer."
  (setf (option-specified-package *current-syntax*) package))
(define-command (com-macroexpand-1 :name t :command-table climacs-lisp-table)
    ()
  "Macroexpand-1 the expression at point.
The expanded expression will be displayed in a
"*Macroexpansion*"-buffer."
  (let*((token (expression-at-mark *current-point* *current-syntax*)))
    (if token
        (macroexpand-token *current-syntax* token)
        (esa:display-message "Nothing to expand at point."))))
(define-command (com-macroexpand-all :name t :command-table climacs-lisp-table)
    ()
  "Completely macroexpand the expression at point.
The expanded expression will be displayed in a
"*Macroexpansion*"-buffer."
  (let ((token (expression-at-mark *current-point* *current-syntax*)))
    (if token
        (macroexpand-token *current-syntax* token t)
        (esa:display-message "Nothing to expand at point."))))
(define-command (com-compile-and-load-file :name t :command-table climacs-lisp-table)
    ()
  "Compile and load the current file.
Compiler notes will be displayed in a seperate buffer."
  (compile-file-interactively *current-buffer* t))
(define-command (com-compile-file :name t :command-table climacs-lisp-table)
    ()
  "Compile the file open in the current buffer.
This command does not load the file after it has been compiled."
  (compile-file-interactively *current-buffer* nil))
(define-command (com-goto-location :name t :command-table climacs-lisp-table)
    ((note 'compiler-note))
  "Move point to the part of a given file that caused the
compiler note.
If the file is not already open, a new buffer will be opened with
that file."
  (goto-location (location note)))
(define-presentation-to-command-translator compiler-note-to-goto-location-translator
    (compiler-note com-goto-location climacs-lisp-table)
    (presentation)
  (list (presentation-object presentation)))
(define-command (com-goto-xref :name t :command-table climacs-lisp-table)
    ((xref 'xref))
  "Go to the referenced location of a code cross-reference."
  (goto-location xref))
(define-presentation-to-command-translator xref-to-goto-location-translator
    (xref com-goto-xref climacs-lisp-table)
    (presentation)
    (list (presentation-object presentation)))
(define-command (com-edit-this-definition :command-table climacs-lisp-table)
    ()
  "Edit definition of the symbol at point.
If there is no symbol at point, this is a no-op."
  (let* ((token (this-form *current-point* *current-syntax*))
         (this-symbol (token-to-object *current-syntax* token)))
    (when (and this-symbol (symbolp this-symbol))
      (edit-definition this-symbol))))
(define-command (com-return-from-definition :name t :command-table climacs-lisp-table)
    ()
  "Return point to where it was before the previous Edit
Definition command was issued."
  (pop-find-definition-stack))
(esa:set-key 'com-eval-defun
             'climacs-lisp-table
             '((#\x :control :meta)))
(esa:set-key 'com-macroexpand-1
             'climacs-lisp-table
             '((#\c :control) (#\Newline)))
(esa:set-key 'com-macroexpand-all
             'climacs-lisp-table
             '((#\c :control) (#\m :control)))
(esa:set-key 'com-compile-and-load-file
         'climacs-lisp-table
         '((#\c :control) (#\k :control)))
(esa:set-key 'com-compile-file
             'climacs-lisp-table
             '((#\c :control) (#\k :meta)))
(esa:set-key 'com-edit-this-definition
             'climacs-lisp-table
             '((#. :meta)))
(esa:set-key  'com-return-from-definition
          'climacs-lisp-table
          '((#, :meta)))
--- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp	2006/11/12 16:06:07	NONE
+++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp	2006/11/12 16:06:07	1.1
;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX -*-
;;;  (c) copyright 2005 by
;;;           Robert Strandh (strandh@labri.fr)
;;;  (c) copyright 2006 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.
;;; Add Climacs-dependent functionality to the stock Lisp syntax.
(in-package :drei-lisp-syntax)
(defmethod frame-clear-completions ((frame climacs-gui:climacs))
  (let ((completions-pane
         (when (typep *application-frame* 'esa-frame-mixin)
           (find "Completions" (windows *application-frame*)
                 :key #'pane-name
                 :test #'string=))))
    (unless (null completions-pane)
      (climacs-gui:delete-window completions-pane)
      (setf completions-pane nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Compiler note hyperlinking
(defclass location ()()
  (:documentation "The base for all locations."))
(defclass error-location (location)
  ((error-message :initarg :error-message :accessor error-message)))
(defclass actual-location (location)
  ((source-position :initarg :position :accessor source-position)
   (snippet :initarg :snippet :accessor snippet :initform nil))
  (:documentation "The base for all non-error locations."))
(defclass buffer-location (actual-location)
  ((buffer-name :initarg :buffer :accessor buffer-name)))
(defclass file-location (actual-location)
  ((file-name :initarg :file :accessor file-name)))
(defclass source-location (actual-location)
  ((source-form :initarg :source-form :accessor source-form)))
(defclass basic-position () ()
  (:documentation "The base for all positions."))
(defclass char-position (basic-position)
  ((char-position :initarg :position :accessor char-position)
   (align-p :initarg :align-p :initform nil :accessor align-p)))
(defun make-char-position (position-list)
  (make-instance 'char-position :position (second position-list)
                 :align-p (third position-list)))
(defclass line-position (basic-position)
  ((start-line :initarg :line :accessor start-line)
   (end-line :initarg :end-line :initform nil :accessor end-line)))
(defun make-line-position (position-list)
  (make-instance 'line-position :line (second position-list)
                 :end-line (third position-list)))
(defclass function-name-position (basic-position)
  ((function-name :initarg :function-name)))
(defun make-function-name-position (position-list)
  (make-instance 'function-name-position :function-name (second position-list)))
(defclass source-path-position (basic-position)
  ((path :initarg :source-path :accessor path)
   (start-position :initarg :start-position :accessor start-position)))
(defun make-source-path-position (position-list)
  (make-instance 'source-path-position :source-path (second position-list)
                 :start-position (third position-list)))
(defclass text-anchored-position (basic-position)
  ((start :initarg :text-anchored :accessor start)
   (text :initarg :text :accessor text)
   (delta :initarg :delta :accessor delta)))
(defun make-text-anchored-position (position-list)
  (make-instance 'text-anchored-position :text-anchored (second position-list)
                 :text (third position-list)
                 :delta (fourth position-list)))
(defclass method-position (basic-position)
  ((name :initarg :method :accessor name)
   (specializers :initarg :specializers :accessor specializers)
   (qualifiers :initarg :qualifiers :accessor qualifiers)))
(defun make-method-position (position-list)
  (make-instance 'method-position :method (second position-list)
                 :specializers (third position-list)
                 :qualifiers (last position-list)))
(defun make-location (location-list)
  (ecase (first location-list)
    (:error (make-instance 'error-location :error-message (second location-list)))
    (:location
     (destructuring-bind (l buf pos hints) location-list
       (declare (ignore l))
       (let ((location
              (apply #'make-instance
                     (ecase (first buf)
                       (:file 'file-location)
                       (:buffer 'buffer-location)
                       (:source-form 'source-location))
                     buf))
             (position
              (funcall
               (ecase (first pos)
                 (:position #'make-char-position)
                 (:line #'make-line-position)
                 (:function-name #'make-function-name-position)
                 (:source-path #'make-source-path-position)
                 (:text-anchored #'make-text-anchored-position)
                 (:method #'make-method-position))
               pos)))
         (setf (source-position location) position)
         (when hints
           (setf (snippet location) (rest hints)))
         location)))))
(defmethod initialize-instance :after ((note compiler-note) &rest args)
  (declare (ignore args))
  (setf (location note) (make-location (location note))))
(defun show-note-counts (notes &optional seconds)
  (loop with nerrors = 0
     with nwarnings = 0
     with nstyle-warnings = 0
     with nnotes = 0
     for note in notes
     do (etypecase note
          (error-compiler-note (incf nerrors))
          (read-error-compiler-note (incf nerrors))
          (warning-compiler-note (incf nwarnings))
          (style-warning-compiler-note (incf nstyle-warnings))
          (note-compiler-note (incf nnotes)))
     finally
     (esa:display-message "Compilation finished: ~D error~:P ~
                            ~D warning~:P ~D style-warning~:P ~D note~:P ~
                            ~@[[~D secs]~]"
                          nerrors nwarnings nstyle-warnings nnotes seconds)))
(defun one-line-ify (string)
  "Return a single-line version of STRING.
Each newline and following whitespace is replaced by a single space."
  (loop with count = 0
     while (< count (length string))
     with new-string = (make-array 0 :element-type 'character :adjustable t
                                   :fill-pointer 0)
     when (char= (char string count) #\Newline)
     do (loop while (and (< count (length string))
                         (whitespacep *current-syntax* (char string count)))
           do (incf count)
           ;; Just ignore whitespace if it is last in the
           ;; string.
           finally (when (< count (length string))
                     (vector-push-extend #\Space new-string)))
     else
     do (vector-push-extend (char string count) new-string)
     (incf count)
     finally (return new-string)))
(defgeneric print-for-menu (object stream))
(defun print-note-for-menu (note stream severity ink)
  (with-accessors ((message message) (short-message short-message)) note
    (with-drawing-options (stream :ink ink
                                  :text-style (make-text-style :sans-serif :italic nil))
      (princ severity stream)
      (princ " " stream))
    (princ (if short-message
               (one-line-ify short-message)
               (one-line-ify message))
           stream)))
(defmacro def-print-for-menu (class name colour)
  `(defmethod print-for-menu ((object ,class) stream)
     (print-note-for-menu object stream ,name ,colour)))
(def-print-for-menu error-compiler-note "Error" +red+)
(def-print-for-menu read-error-compiler-note "Read Error" +red+)
(def-print-for-menu warning-compiler-note "Warning" +dark-red+)
(def-print-for-menu style-warning-compiler-note "Style Warning" +brown+)
(def-print-for-menu note-compiler-note "Note" +brown+)
(defun show-notes (notes buffer-name definition)
  (let ((stream (climacs-gui:typeout-window
                 (format nil "~10TCompiler Notes: ~A  ~A" buffer-name definition))))
    (loop for note in notes
       do (with-output-as-presentation (stream note 'compiler-note)
            (print-for-menu note stream))
       (terpri stream)
       count note into length
       finally (change-space-requirements stream
                                          :height (* length (stream-line-height stream)))
       (scroll-extent stream 0 0))))
(defgeneric goto-location (location))
(defmethod goto-location ((location error-location))
  (esa:display-message (error-message location)))
[180 lines skipped]

    