Index: /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp	(revision 7844)
@@ -154,11 +154,8 @@
 ;;; Define some key event modifiers.
 
-;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use
-;;; it to map NSEvent modifier keys to key-event modifiers.
-
-(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift")
-(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control")
-(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta")
-(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock")
+(hemlock-ext:define-modifier-bit #$NSShiftKeyMask "Shift")
+(hemlock-ext:define-modifier-bit #$NSControlKeyMask "Control")
+(hemlock-ext:define-modifier-bit #$NSAlternateKeyMask "Meta")
+(hemlock-ext:define-modifier-bit #$NSAlphaShiftKeyMask "Lock")
 
 
@@ -784,5 +781,5 @@
           (when (eq buffer hi::*current-buffer*)
 	    (setf hi::*current-buffer* nil))
-	  (hi::delete-buffer buffer :force t))))))
+	  (hi::delete-buffer buffer))))))
 
 
@@ -861,4 +858,6 @@
   (with-autorelease-pool
    (call-next-method)))
+
+(defconstant +shift-event-mask+ (hemlock-ext:key-event-modifier-mask "Shift"))
 
 ;;; Translate a keyDown NSEvent to a Hemlock key-event.
@@ -887,5 +886,5 @@
             (let* ((char (code-char c)))
               (when (and char (standard-char-p char))
-                (setq bits (logandc2 bits hi::+shift-event-mask+))))
+                (setq bits (logandc2 bits +shift-event-mask+))))
 	    (hemlock-ext:make-key-event c bits)))))))
 
@@ -1516,9 +1515,10 @@
   (:metaclass ns:+ns-object))
 
-;;; Mark the pane's modeline as needing display.  This is called whenever
+;;; Mark the buffer's modeline as needing display.  This is called whenever
 ;;; "interesting" attributes of a buffer are changed.
-
-(defun hi::invalidate-modeline (pane)
-  (#/setNeedsDisplay: (text-pane-mode-line pane) t))
+(defun hemlock-ext:invalidate-modeline (buffer)
+  (let* ((doc (hi::buffer-document buffer)))
+    (when doc
+      (document-invalidate-modeline doc))))
 
 (def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
@@ -1702,4 +1702,7 @@
   (declare (ignore buffer)))
 
+(defmethod document-invalidate-modeline ((self echo-area-document))
+  nil)
+
 (objc:defmethod (#/close :void) ((self echo-area-document))
   (let* ((ts (slot-value self 'textstorage)))
@@ -1708,10 +1711,6 @@
       (close-hemlock-textstorage ts))))
 
-(objc:defmethod (#/updateChangeCount: :void)
-    ((self echo-area-document)
-     (change :<NSD>ocument<C>hange<T>ype))
+(objc:defmethod (#/updateChangeCount: :void) ((self echo-area-document) (change :<NSD>ocument<C>hange<T>ype))
   (declare (ignore change)))
-
-(objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document)))
 
 (defloadvar *hemlock-frame-count* 0)
@@ -1854,9 +1853,9 @@
         (#/performSelectorOnMainThread:withObject:waitUntilDone:
          frame (@selector #/runErrorSheet:) params t)
-	(unless (eq *current-process* *initial-process*)
+	(unless (eq *current-process* ccl::*initial-process*)
 	  (wait-on-semaphore semaphore))))))
 
-(defun hi::report-hemlock-error (condition)
-  (let ((pane (hi::current-window)))
+(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition)
+  (let ((pane (hi::hemlock-view-pane view)))
     (when (and pane (not (%null-ptr-p pane)))
       (report-condition-in-hemlock-frame condition (#/window pane)))))
@@ -2017,14 +2016,4 @@
   (assume-cocoa-thread) ;; see comment in #/editingInProgress
   (slot-value (slot-value document 'textstorage) 'edit-count))
-
-#|
-(defun hi::document-set-point-position (document)
-  (declare (ignorable document))
-  #+debug
-  (#_NSLog #@"Document set point position called")
-  (let* ((textstorage (slot-value document 'textstorage)))
-    (#/performSelectorOnMainThread:withObject:waitUntilDone:
-     textstorage (@selector #/updateHemlockSelection) +null-ptr+ t)))
-|#
 
 (defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
@@ -2117,19 +2106,17 @@
 
 
-(defun hi::set-document-modified (document flag)
-  (unless flag
-    (#/performSelectorOnMainThread:withObject:waitUntilDone:
-     document
-     (@selector #/documentChangeCleared)
-     +null-ptr+
-     t)))
-
-
-(defmethod hi::document-panes ((document t))
-  )
-
-
-
-    
+(defun hemlock-ext:note-buffer-saved (buffer)
+  (assume-cocoa-thread)
+  (let* ((document (buffer-document buffer)))
+    (when document
+      ;; Hmm... I guess this is always done by the act of saving.
+      nil)))
+
+(defun hemlock-ext:note-buffer-unsaved (buffer)
+  (assume-cocoa-thread)
+  (let* ((document (buffer-document buffer)))
+    (when document
+      (#/updateChangeCount: document #$NSChangeCleared))))
+
 
 (defun size-of-char-in-font (f)
@@ -2219,9 +2206,14 @@
   (:metaclass ns:+ns-object))
 
-(objc:defmethod (#/documentChangeCleared :void) ((self hemlock-editor-document))
-  (#/updateChangeCount: self #$NSChangeCleared))
-
 (defmethod assume-not-editing ((doc hemlock-editor-document))
   (assume-not-editing (slot-value doc 'textstorage)))
+
+(defmethod document-invalidate-modeline ((self hemlock-editor-document))
+  (for-each-textview-using-storage
+   (slot-value self 'textstorage)
+   #'(lambda (tv)
+       (let* ((pane (text-view-pane tv)))
+	 (unless (%null-ptr-p pane)
+	   (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
 
 (defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
@@ -2236,9 +2228,11 @@
           (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
 
-(defun hi::document-note-selection-set-by-search (doc)
-  (with-slots (textstorage) doc
-    (when textstorage
-      (with-slots (selection-set-by-search) textstorage
-	(setq selection-set-by-search #$YES)))))
+(defun hemlock-ext:note-selection-set-by-search (buffer)
+  (let* ((doc (hi::buffer-document buffer)))
+    (when doc
+      (with-slots (textstorage) doc
+	(when textstorage
+	  (with-slots (selection-set-by-search) textstorage
+	    (setq selection-set-by-search #$YES)))))))
 
 (objc:defmethod (#/validateMenuItem: :<BOOL>)
@@ -2334,7 +2328,7 @@
     (#/updateMirror textstorage)
     (#/endEditing textstorage)
-    (hi::document-set-point-position self)
+    (#/updateHemlockSelection textstorage)
     (setf (hi::buffer-modified buffer) nil)
-    (hi::queue-buffer-change buffer)
+    (hi::note-modeline-change buffer)
     t))
 
@@ -2395,5 +2389,4 @@
                (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
 
-	  (hi::queue-buffer-change buffer)
 	  (#/beginEditing textstorage)
 
@@ -2410,4 +2403,6 @@
            0
            (hemlock-buffer-length buffer))
+
+	  (hi::note-modeline-change buffer)
 
 	  (#/endEditing textstorage))
@@ -2458,5 +2453,5 @@
 	(when cache (buffer-cache-buffer cache))))))
 
-(defmethod hi::window-buffer ((frame hemlock-frame))
+(defmethod hemlock-buffer ((frame hemlock-frame))
   (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
 	 (doc (#/documentForWindow: dc frame)))
@@ -2467,12 +2462,16 @@
       (hemlock-document-buffer doc))))
 
-(defmethod hi::window-buffer ((pane text-pane))
-  (hi::window-buffer (#/window pane)))
-
-(defun ordered-hemlock-windows ()
-  (delete-if-not #'(lambda (win)
-		     (and (typep win 'hemlock-frame)
-			  (hi::window-buffer win)))
-		   (windows)))
+(defmethod hemlock-buffer ((pane text-pane))
+  (hemlock-buffer (#/window pane)))
+
+(defmethod hemlock-buffer (whatever)
+  (let ((view (hi::hemlock-view whatever)))
+    (when view (hi::hemlock-view-buffer view))))
+
+(defun hemlock-ext:visible-buffers ()
+  "List of all buffers visible in windows, in z-order, frontmost first"
+  (loop for win in (windows)
+    as buf = (and (typep win 'hemlock-frame) (hemlock-buffer win))
+    when buf collect buf))
 
 (defmethod hi::document-panes ((document hemlock-editor-document))
@@ -2491,6 +2490,5 @@
   (with-slots (encoding) self
     (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup)))
-    ;; Force modeline update.
-    (hi::queue-buffer-change (hemlock-document-buffer self))))
+    (hi::note-modeline-change (hemlock-document-buffer self))))
 
 (objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
@@ -2630,7 +2628,8 @@
 	      (pref char-range :<NSR>ange.length)))))
     
-(defun hi::scroll-window (textpane n)
+(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) n)
   (when n
-    (let* ((sv (text-pane-scroll-view textpane))
+    (let* ((textpane (hi::hemlock-view-pane view))
+	   (sv (text-pane-scroll-view textpane))
 	   (tv (text-pane-text-view textpane))
 	   (char-height (text-view-char-height tv))
@@ -2683,8 +2682,12 @@
 		      (hi::buffer-end point))))))))))
 
-
-(defmethod hemlock::center-text-pane ((pane text-pane))
+(defmethod hemlock-ext:scroll-mark-to-top ((view hi:hemlock-view) mark)
+  "Make the position of MARK be on the first line displayed in the window"
+  (error "Not implemented yet"))
+
+
+(defmethod hemlock-ext:center-selection-in-view ((view hi:hemlock-view))
   (#/performSelectorOnMainThread:withObject:waitUntilDone:
-   (text-pane-text-view pane)
+   (text-pane-text-view (hi::hemlock-view-pane view))
    (@selector #/centerSelectionInVisibleArea:)
    +null-ptr+
@@ -2878,29 +2881,4 @@
 
 
-(defun hi::edit-definition (name)
-  (let* ((info (ccl::get-source-files-with-types&classes name)))
-    (when (null info)
-      (let* ((seen (list name))
-	     (found ())
-	     (pname (symbol-name name)))
-	(dolist (pkg (list-all-packages))
-	  (let ((sym (find-symbol pname pkg)))
-	    (when (and sym (not (member sym seen)))
-	      (let ((new (ccl::get-source-files-with-types&classes sym)))
-		(when new
-		  (setq info (append new info))
-		  (push sym found)))
-	      (push sym seen))))
-	(when found
-	  ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
-	  (hi::loud-message "No definitions for ~s, using ~s instead"
-			    name (if (cdr found) found (car found))))))
-    (if info
-      (if (cdr info)
-        (edit-definition-list name info)
-        (edit-single-definition name (car info)))
-      (hi::editor-error "No known definitions for ~s" name))))
-
-
 (defun find-definition-in-document (name indicator document)
   (let* ((buffer (hemlock-document-buffer document))
@@ -2946,5 +2924,5 @@
           (#/showWindows document))))))
 
-(defun edit-single-definition (name info)
+(defun hemlock-ext:edit-single-definition (name info)
   (let* ((request (make-instance 'cocoa-edit-definition-request
                                  :with-name (assign-id-map-id *edit-definition-id-map* name)
@@ -2956,15 +2934,12 @@
      t)))
 
-                                        
-(defun edit-definition-list (name infolist)
+
+(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
   (make-instance 'sequence-window-controller
-                 :sequence infolist
-                 :result-callback #'(lambda (info)
-                                      (edit-single-definition name info))
-                 :display #'(lambda (item stream)
-                              (prin1 (car item) stream))
-                 :title (format nil "Definitions of ~s" name)))
-
-                                       
+    :title title
+    :sequence sequence
+    :result-callback action
+    :display printer))
+
 (objc:defmethod (#/documentClassForType: :<C>lass) ((self hemlock-document-controller)
 						    type)
@@ -3042,5 +3017,5 @@
                   t)))))
           ((ccl::valid-function-name-p arg)
-           (hi::edit-definition arg))
+           (hemlock::edit-definition arg))
           (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p)))))
     t))
Index: /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp	(revision 7844)
@@ -26,4 +26,8 @@
 
 (def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output")
+
+(defun hemlock-ext:read-only-listener-p ()
+  *read-only-listener*)
+
 
 ;;; Setup the server end of a pty pair.
@@ -264,5 +268,5 @@
        (values nil t))))
   
-(defun hi::top-listener-output-stream ()
+(defun hemlock-ext:top-listener-output-stream ()
   (let* ((doc (#/topListener hemlock-listener-document)))
     (unless (%null-ptr-p doc)
@@ -290,5 +294,5 @@
 	      (hi::buffer-minor-mode buffer "Listener") t
 	      (hi::buffer-name buffer) listener-name)
-        (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
+        (hi::set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
     doc))
 
Index: /branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp	(revision 7844)
@@ -58,4 +58,5 @@
 					    notification)
   (declare (ignore notification))
+  (#/setDataSource: (slot-value self 'table-view) +null-ptr+)
   (#/autorelease self))
 
@@ -214,5 +215,5 @@
 
 (defun assume-cocoa-thread ()
-  #+debug (assert (eq *current-process* *initial-process*)))
+  #+debug (assert (eq *current-process* ccl::*initial-process*)))
 
 (defmethod assume-not-editing ((whatever t)))
Index: /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp	(revision 7844)
@@ -64,7 +64,5 @@
     "table"
     "modeline"
-    "linimage"
     "pop-up-stream"
-    "cursor"
     "font"
     "streams"
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp	(revision 7844)
@@ -129,5 +129,5 @@
 ;(bind-key "Next Window" #k"control-x o")
 ;(bind-key "Previous Window" #k"control-x p")
-(bind-key "Split Window" #k"control-x 2")
+;(bind-key "Split Window" #k"control-x 2")
 ;(bind-key "New Window" #k"control-x control-n")
 ;(bind-key "Delete Window" #k"control-x d")
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp	(revision 7844)
@@ -42,13 +42,15 @@
   "If true make the buffer modified, if NIL unmodified."
   (unless (bufferp buffer) (error "~S is not a buffer." buffer))
-  (let* ((was-modified (buffer-modified buffer)))
+  (let* ((was-modified (buffer-modified buffer))
+	 (changed (not (eq was-modified (buffer-modified buffer)))))
     (invoke-hook hemlock::buffer-modified-hook buffer sense)
     (if sense
       (setf (buffer-modified-tick buffer) (tick))
       (setf (buffer-unmodified-tick buffer) (tick)))
-    (unless (eq was-modified (buffer-modified buffer))
-      (queue-buffer-change buffer)))
-  (let* ((document (buffer-document buffer)))
-    (if document (set-document-modified document sense)))
+    (when changed
+      (if sense
+	(hemlock-ext:note-buffer-unsaved buffer)
+	(hemlock-ext:note-buffer-saved buffer))
+      (note-modeline-change buffer)))
   sense)
 
@@ -98,12 +100,5 @@
       ((null finfos) (nreverse result))))
 
-(defun %set-buffer-modeline-fields (buffer fields)
-  (check-type fields list)
-  (check-type buffer buffer "a Hemlock buffer")
-  (sub-set-buffer-modeline-fields buffer fields)
-  (dolist (w (buffer-windows buffer))
-    (update-modeline-fields buffer w)))
-
-(defun sub-set-buffer-modeline-fields (buffer modeline-fields)
+(defun set-buffer-modeline-fields (buffer modeline-fields)
   (unless (every #'modeline-field-p modeline-fields)
     (error "Fields must be a list of modeline-field objects."))
@@ -499,6 +494,5 @@
     (warn "~s already exists, trying to delete" name *buffer-names*)
     (let ((buffer (getstring name *buffer-names*)))
-      (when (buffer-windows buffer)
-	(delete-buffer buffer))))
+      (delete-buffer buffer)))
   (cond ((getstring name *buffer-names*)
 	 nil)
@@ -515,8 +509,7 @@
 			 :bindings (make-hash-table)
 			 :point (copy-mark (region-end region))
-			 :display-start (copy-mark (region-start region))
 			 :delete-hook delete-hook
 			 :variables (make-string-table))))
-	   (sub-set-buffer-modeline-fields buffer modeline-fields)
+	   (set-buffer-modeline-fields buffer modeline-fields)
 	   (setf (line-%buffer (mark-line (region-start region))) buffer)
 	   (push buffer *buffer-list*)
@@ -529,13 +522,8 @@
 	   buffer))))
 
-(defun delete-buffer (buffer &key force)
-  "Deletes a buffer.  If buffer is current, or if it is displayed in any
-   windows, an error is signaled."
+(defun delete-buffer (buffer)
+  "Deletes a buffer.  If buffer is current, an error is signaled."
   (when (eq buffer *current-buffer*)
     (error "Cannot delete current buffer ~S." buffer))
-  (unless force
-    (when (buffer-windows buffer)
-      (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
-	     buffer (length (buffer-windows buffer)))))
   (invoke-hook (buffer-delete-hook buffer) buffer)
   (invoke-hook hemlock::delete-buffer-hook buffer)
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp	(revision 7844)
@@ -6,47 +6,4 @@
 
 (in-package :hemlock-internals)
-
-(defun buffer-windows (buffer)
-  (let* ((doc (buffer-document buffer)))
-    (when doc
-      (document-panes doc))))
-
-(defvar *window-list* ())
-
-(defun current-window ()
-  "Return the current window.  The current window is specially treated by
-  redisplay in several ways, the most important of which is that is does
-  recentering, ensuring that the Buffer-Point of the current window's
-  Window-Buffer is always displayed.  This may be set with Setf."
-  (hemlock-view-pane *current-view*))
-
-(defun %set-current-window (new-window)
-  #+not-yet
-  (invoke-hook hemlock::set-window-hook new-window)
-  (activate-hemlock-view new-window)
-  (setf (hemlock-view-pane *current-view*) new-window))
-
-;;; This is a public variable.
-;;;
-
-(defun last-key-event-typed ()
-  "This function returns the last key-event typed by the user and read as input."
-  (hemlock-last-key-event-typed *current-view*))
-
-(defun %set-last-key-event-typed (key)
-  (setf (hemlock-last-key-event-typed *current-view*) key))
-
-(defun hemlock::last-char-typed ()
-  (let ((key (hemlock-last-key-event-typed *current-view*)))
-    (when key (hemlock-ext:key-event-char key))))
-
-
-(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G"))
-
-(defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift"))
-    
-(defun listen-editor-input (q)
-  (ccl::with-locked-dll-header (q)
-    (not (eq (ccl::dll-header-first q) q))))
 
 (defun add-buffer-font-region (buffer region)
@@ -118,7 +75,7 @@
       (format t "~& style ~d ~d [~s]/ ~d [~s] ~a"
               (font-mark-font start)
-              (ccl::mark-absolute-position start)
+              (gui::mark-absolute-position start)
               (mark-%kind start)
-              (ccl::mark-absolute-position end)
+              (gui::mark-absolute-position end)
               (mark-%kind end)
               (eq r (buffer-active-font-region buffer))))))
@@ -128,15 +85,2 @@
   (string-to-clipboard (region-to-string region)))
 
-;;; Meta-.
-(defun hemlock::get-def-info-and-go-to-it (string package)
-  (multiple-value-bind (fun-name error)
-      (let* ((*package* package))
-        (ignore-errors (values (read-from-string string))))
-    (if error
-      (editor-error)
-      (hi::edit-definition fun-name))))
-
-;;; Search highlighting
-(defun note-selection-set-by-search (&optional (buffer (current-buffer)))
-  (let* ((doc (buffer-document buffer)))
-    (when doc (hi::document-note-selection-set-by-search doc))))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp	(revision 7844)
@@ -263,5 +263,5 @@
                (buffer-end point)
                (when p (editor-error "No next line."))))))
-    (unless (move-to-column point target) (line-end point))
+    (unless (move-to-position point target) (line-end point))
     (setf (last-command-type) :line-motion)))
 
@@ -285,5 +285,5 @@
                (buffer-end point)
                (when p (editor-error "No next line."))))))
-    (unless (move-to-column point target) (line-end point))
+    (unless (move-to-position point target) (line-end point))
     (setf (last-command-type) :line-motion)))
 
@@ -380,5 +380,5 @@
   :value nil)
 
-(defcommand "Scroll Window Down" (p &optional (window (current-window)))
+(defcommand "Scroll Window Down" (p &optional (view (current-view)))
   "Move down one screenfull.
   With prefix argument scroll down that many lines."
@@ -386,7 +386,7 @@
   window, down one screenfull.  If P is supplied then scroll that
   many lines."
-  (scroll-window window (or p :page-down)))
-
-(defcommand "Scroll Window Up" (p &optional (window (current-window)))
+  (hemlock-ext:scroll-view view (or p :page-down)))
+
+(defcommand "Scroll Window Up" (p &optional (view (current-view)))
   "Move up one screenfull.
   With prefix argument scroll up that many lines."
@@ -394,35 +394,14 @@
   window, up one screenfull.  If P is supplied then scroll that
   many lines."
-  (scroll-window window (if p (- p) :page-up)))
-
-(defcommand "Scroll Next Window Down" (p)
-  "Do a \"Scroll Window Down\" on the next window."
-  "Do a \"Scroll Window Down\" on the next window."
-  (let ((win (next-window (current-window))))
-    (when (eq win (current-window)) (editor-error "Only one window."))
-    (scroll-window-down-command p win)))
-
-(defcommand "Scroll Next Window Up" (p)
-  "Do a \"Scroll Window Up\" on the next window."
-  "Do a \"Scroll Window Up\" on the next window."
-  (let ((win (next-window (current-window))))
-    (when (eq win (current-window)) (editor-error "Only one window."))
-    (scroll-window-up-command p win)))
-
-
-
+  (hemlock-ext:scroll-view view (if p (- p) :page-up)))
 
 ;;;; Kind of miscellaneous commands:
 
-;;; "Refresh Screen" may not be right with respect to wrapping lines in
-;;; the case where an argument is supplied due the use of
-;;; WINDOW-DISPLAY-START instead of SCROLL-WINDOW, but using the latter
-;;; messed with point and did other hard to predict stuff.
-;;; 
 (defcommand "Refresh Screen" (p)
-  "Refreshes everything in the window, centering current line."
-  "Refreshes everything in the window, centering current line."
-  (declare (ignore p))
-  (center-text-pane (current-window)))
+  "Refreshes everything in the window, centering current line.
+With prefix argument, puts moves current line to top of window"
+  (if p
+    (hemlock-ext:scroll-mark-to-top (current-view) (current-point))
+    (hemlock-ext:center-selection-in-view (current-view))))
 
 
Index: anches/event-ide/ccl/cocoa-ide/hemlock/src/cursor.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/cursor.lisp	(revision 7843)
+++ 	(revision )
@@ -1,362 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-;;; Cursor: Routines for cursor positioning and recentering
-;;;
-(in-package :hemlock-internals)
-
-
-
-;;;; Mark-To-Cursorpos
-;;;
-;;; Since performance analysis showed that HALF of the time in the editor
-;;; was being spent in this function, I threw all of the tricks in the
-;;; book at it to try and make it tenser.
-;;;
-;;; The algorithm is roughly as follows:
-;;;
-;;;    1) Eliminate the annoying boundry condition of the mark being
-;;; off the end of the window, if it is return NIL now.
-;;;    2) If the charpos is on or immediately after the last character
-;;; in the line, then find the last dis-line on which the line is
-;;; displayed.  We know that the mark is at the end of this dis-line
-;;; because it is known to be on the screen.  X position is trivially
-;;; derived from the dis-line-length.
-;;;    3) Call Real-Line-Length or Cached-Real-Line-Length to get the
-;;; X position and number of times wrapped.
-
-(declaim (special *the-sentinel*))
-
-(eval-when (:compile-toplevel :execute)
-;;; find-line
-;;;
-;;;    Find a dis-line which line is displayed on which starts before
-;;; charpos, setting ypos and dis-line to the dis-line and it's index.
-;;; Offset is expected to be the mark-charpos of the display-start for
-;;; the window initially, and is set to offset within line that
-;;; Dis-Line begins.  Charpos is the mark-charpos of the mark we want
-;;; to find.  Check if same as *redisplay-favorite-line* and then scan
-;;; if not.
-;;;
-(defmacro find-line (line offset charpos ypos dis-lines dis-line)
-  (declare (ignore charpos))
-  `(cond
-    ;; No lines at all, fail.
-    ((eq ,dis-lines *the-sentinel*) nil)
-    ;; On the first line, offset is already set, so just set dis-line and
-    ;; ypos and fall through.
-    ((eq (dis-line-line (car ,dis-lines)) ,line)
-     (setq ,dis-line ,dis-lines  ,ypos 0))
-    ;; Look farther down. 
-    ((do ((l (cdr ,dis-lines) (cdr l)))
-	 ((eq l *the-sentinel*))
-       (when (eq (dis-line-line (car l)) ,line)
-	 (setq ,dis-line l  ,ypos (dis-line-position (car l)) ,offset 0)
-	 (return t))))
-    (t
-     (error "Horrible flaming lossage, Sorry Man."))))
-
-
-;;; find-last 
-;;;
-;;;    Find the last dis-line on which line is displayed, set ypos and 
-;;; dis-line.
-;;;
-(defmacro find-last (line ypos dis-line)
-  `(do ((trail ,dis-line dl)
-	(dl (cdr ,dis-line) (cdr dl)))
-       ((not (eq (dis-line-line (car dl)) ,line))
-	(setq ,dis-line (car trail)  ,ypos (dis-line-position ,dis-line)))))
-
-;;; find-charpos
-;;;
-;;;    Special-Case mark at end of line, if not punt out to real-line-length 
-;;; function.  Return the correct values.
-;;;
-(defmacro find-charpos (line offset charpos length ypos dis-line width
-			     fun chars)
-  (declare (ignore chars))
-  `(cond
-    ((= ,charpos ,length)
-     (find-last ,line ,ypos ,dis-line)
-     (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos))
-    ((= ,charpos (1- ,length))
-     (multiple-value-bind (x dy)
-			  (,fun ,line (1- ,width) ,offset ,charpos)
-       (if (and (not (zerop dy)) (zerop x))
-	   (values (1- ,width) (1- (+ ,ypos dy)))
-	   (values x (+ ,ypos dy)))))
-    (t
-     (multiple-value-bind (x dy)
-			  (,fun ,line (1- ,width) ,offset ,charpos)
-	  (values x (+ ,ypos dy))))))
-
-); eval-when
-
-
-;;; real-line-length 
-;;;
-;;;    Return as values the X position and the number of times wrapped if
-;;; one to display the characters from Start to End of Line starting at an
-;;; X position of 0 wrapping Width wide.
-;;; %SP-Find-Character-With-Attribute is used to find charaters 
-;;; with funny representation much as in Compute-Line-Image.
-;;;
-(defun real-line-length (line width start end)
-  (declare (fixnum width start end))
-  (do ((xpos 0)
-       (ypos 0)
-       (chars (line-chars line))
-       (losing 0)
-       (dy 0))
-      ((= start end) (values xpos ypos))
-    (declare (fixnum xpos ypos dy) (simple-string chars)
-	     (type (or fixnum null) losing))
-    (setq losing (%fcwa chars start end losing-char))
-    (when (null losing)
-      (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width))
-      (return (values xpos (+ ypos dy))))
-    (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width))
-    (setq ypos (+ ypos dy)  start losing)
-    (do ((last (or (%fcwa chars start end winning-char) end)) str)
-	((= start last))
-      (declare (fixnum last))
-      (setq str (get-rep (schar chars start)))
-      (incf start)
-      (unless (simple-string-p str) (setq str (funcall str xpos)))
-      (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width))
-      (setq ypos (+ ypos dy)))))
-
-;;; cached-real-line-length
-;;;
-;;;    The same as Real-Line-Length, except does it for the cached line.
-;;; the line argument is ignored, but present to make the arglists the
-;;; same.
-;;;
-(defun cached-real-line-length (line width start end)
-  (declare (fixnum width start end) (ignore line))
-  (let ((offset (- (current-right-open-pos) (current-left-open-pos)))
-	(bound 0))
-    (declare (fixnum offset bound))
-    (cond
-     ((>= start (current-left-open-pos))
-      (setq start (+ start offset)  bound (setq end (+ end offset))))
-     ((> end (current-left-open-pos))
-      (setq bound (current-left-open-pos)  end (+ end offset)))
-     (t
-      (setq bound end)))
-    
-    (do ((xpos 0)
-	 (ypos 0)
-	 (losing 0)
-	 (dy 0))
-	(())
-      (declare (fixnum xpos ypos dy)
-	       (type (or fixnum null) losing))
-      (when (= start bound)
-	(when (= start end) (return (values xpos ypos)))
-	(setq start (current-right-open-pos)  bound end))
-      (setq losing (%fcwa (current-open-chars) start bound losing-char))
-      (cond
-       (losing
-	(multiple-value-setq (dy xpos)
-	  (truncate (+ xpos (- losing start)) width))
-	(setq ypos (+ ypos dy)  start losing)
-	(do ((last (or (%fcwa (current-open-chars) start bound winning-char) bound)) str)
-	    ((= start last))
-	  (declare (fixnum last))
-	  (setq str (get-rep (schar (current-open-chars) start)))
-	  (incf start)
-	  (unless (simple-string-p str) (setq str (funcall str xpos)))
-	  (multiple-value-setq (dy xpos)
-	    (truncate (+ xpos (strlen str)) width))
-	  (setq ypos (+ ypos dy))))
-       (t
-	(multiple-value-setq (dy xpos)
-	  (truncate (+ xpos (- bound start)) width))
-	(setq ypos (+ ypos dy)  start bound))))))
-
-
-
-;;; Dis-Line-Offset-Guess  --  Internal
-;;;
-;;;    Move Mark by Offset display lines.  The mark is assumed to be at the
-;;; beginning of a display line, and we attempt to leave it at one.  We assume
-;;; all characters print one wide.  Width is the width of the window we are
-;;; displaying in.
-;;;
-(defun dis-line-offset-guess (mark offset width)
-  (let ((w (1- width)))
-    (if (minusp offset)
-	(dotimes (i (- offset) t)
-	  (let ((pos (mark-charpos mark)))
-	    (if (>= pos w)
-		(character-offset mark (- w))
-		(let ((prev (line-previous (mark-line mark))))
-		  (unless prev (return nil))
-		  (multiple-value-bind
-		      (lines chars)
-		      (truncate (line-length prev) w)
-		    (move-to-position mark
-				      (cond ((zerop lines) 0)
-					    ((< chars 2)
-					     (* w (1- lines)))
-					    (t
-					     (* w lines)))
-				      prev))))))
-	(dotimes (i offset t)
-	  (let ((left (- (line-length (mark-line mark))
-			 (mark-charpos mark))))
-	    (if (> left width)
-		(character-offset mark w)
-		(unless (line-offset mark 1 0)
-		  (return nil))))))))
-
-;;; maybe-recenter-window  --  Internal
-;;;
-;;;     Update the dis-lines for Window and recenter if the point is off
-;;; the screen.
-;;;
-(defun maybe-recenter-window (window)
-  (unless (%displayed-p (buffer-point (window-buffer window)) window)
-    (center-window window (buffer-point (window-buffer window)))
-    t))
-
-;;; center-window  --  Public
-;;;
-;;;    Try to move the start of window so that Mark is on a line in the 
-;;; center.
-;;;
-(defun center-window (window mark)
-  "Adjust the start of Window so that Mark is displayed on the center line."
-  (let ((height (window-height window))
-	(start (window-display-start window)))
-    (move-mark start mark)
-    (unless (dis-line-offset-guess start (- (truncate height 2))
-				   (window-width window))
-      (move-mark start (buffer-start-mark (window-buffer window))))
-    (update-window-image window)
-    ;; If that doesn't work, panic and make the start the point.
-    (unless (%displayed-p mark window)
-      (move-mark start mark)
-      (update-window-image window))))
-
-
-;;; %Displayed-P  --  Internal
-;;;
-;;;    If Mark is within the displayed bounds in Window, then return true,
-;;; otherwise false.  We assume the window image is up to date.
-;;;
-(defun %displayed-p (mark window)
-  (let ((start (window-display-start window))
-	(end (window-display-end window)))
-    (not (or (mark< mark start) (mark> mark end)
-	     (if (mark= mark end)
-		 (let ((ch (next-character end)))
-		   (and ch (char/= ch #\newline)))
-		 nil)))))
-
-
-;;; Displayed-p  --  Public
-;;;
-;;;    Update the window image and then check if the mark is displayed.
-;;;
-(defun displayed-p (mark window)
-  "Return true if Mark is displayed on Window, false otherwise."
-  (maybe-update-window-image window)
-  (%displayed-p mark window))
-
-
-;;; scroll-window  --  Public
-;;;
-;;;    This is not really right, since it uses dis-line-offset-guess.
-;;; Probably if there is any screen overlap then we figure it out
-;;; exactly.
-;;;
-
-
-
-;;; Mark-Column  --  Public
-;;;
-;;;    Find the X position of a mark supposing that it were displayed
-;;; in an infinitely wide screen.
-;;;
-(defun mark-column (mark)
-  "Find the X position at which Mark would be displayed if it were on
-  an infinitely wide screen.  This takes into account tabs and control
-  characters."
-  (let ((charpos (mark-charpos mark))
-	(line (mark-line mark)))
-    (if (current-open-line-p line)
-	(values (cached-real-line-length line 10000 0 charpos))
-	(values (real-line-length line 10000 0 charpos)))))
-
-
-;;; Find-Position  --  Internal
-;;;
-;;;    Return the charpos which corresponds to the specified X position
-;;; within Line.  If there is no such position between Start and End then
-;;; rutne NIL.
-;;;
-(defun find-position (line position start end width)
-  (do* ((cached (current-open-line-p line))
-	(lo start)
-	(hi (1- end))
-	(probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2)))
-       ((> lo hi)
-	(if (= lo end) nil hi))
-    (let ((val (if cached
-		   (cached-real-line-length line width start probe)
-		   (real-line-length line width start probe))))
-      (cond ((= val position) (return probe))
-	    ((< val position) (setq lo (1+ probe)))
-	    (t (setq hi (1- probe)))))))
-
-;;; Cursorpos-To-Mark  --  Public
-;;;
-;;;    Find the right dis-line, then zero in on the correct position
-;;; using real-line-length.
-;;;
-(defun cursorpos-to-mark (x y window)
-  (check-type window window)
-  (let ((width (window-width window))
-	(first (window-first-line window)))
-    (when (>= x width)
-      (return-from cursorpos-to-mark nil))
-    (do* ((prev first dl)
-	  (dl (cdr first) (cdr dl))
-	  (ppos (mark-charpos (window-display-start window))
-		(if (eq (dis-line-line (car dl)) (dis-line-line (car prev)))
-		    (dis-line-end (car prev)) 0)))
-	((eq dl *the-sentinel*)
-	 (copy-mark (window-display-end window) :temporary))
-      (when (= (dis-line-position (car dl)) y)
-	(let* ((line (dis-line-line (car dl)))
-	       (end (dis-line-end (car dl))))
-	  (return (mark line (or (find-position line x ppos end width) end))))))))
-
-;;; Move-To-Column  --  Public
-;;;
-;;;    Just look up the charpos using find-position...
-;;;
-(defun move-to-column (mark column &optional (line (mark-line mark)))
-  "Move Mark to the specified Column on Line.  This function is analogous
-  to Move-To-Position, but it deals with the physical screen position
-  as returned by Mark-Column; the mark is moved to before the character
-  which would be displayed in Column if the line were displayed on
-  an infinitely wide screen.  If the column specified is greater than
-  the column of the last character, then Nil is returned and the mark
-  is not modified."
-  (let ((res (find-position line column 0 (line-length line) 10000)))
-    (if res
-	(move-to-position mark res line))))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp	(revision 7844)
@@ -55,5 +55,4 @@
              ,name)))
 
-(declfun window-buffer (window))
 (declfun change-to-buffer (buffer))     ;filecoms.lisp
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp	(revision 7844)
@@ -44,6 +44,6 @@
     (#\m "Describe a mode."
      (describe-mode-command nil))
-    (#\p "Describe commands with mouse/pointer bindings."
-     (describe-pointer-command nil))
+    ;(#\p "Describe commands with mouse/pointer bindings."
+    ; (describe-pointer-command nil))
     (#\w "Find out Where a command is bound."
      (where-is-command nil))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp	(revision 7844)
@@ -35,6 +35,5 @@
 ;;; Message  --  Public
 ;;;
-;;;    Display the stuff on *echo-area-stream* and then wait.  Editor-Sleep
-;;; will do a redisplay if appropriate.
+;;;    Display the stuff on *echo-area-stream* 
 ;;;
 (defun message (string &rest args)
@@ -158,5 +157,6 @@
 	   (display-prompt-nicely eps)
 	   (modifying-buffer-storage (nil)
-	     (gui::event-loop #'(lambda () (eps-parse-results eps))))
+	     (with-standard-standard-output
+	      (gui::event-loop #'(lambda () (eps-parse-results eps)))))
 	   #+gz (gui::log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
        (setf (hemlock-prompted-input-state *current-view*) old-eps)
@@ -494,28 +494,24 @@
 			       ((:help *parse-help*) "Type Y or N."))
   "Prompts for Y or N."
-  (let ((old-window (current-window)))
-    (unwind-protect
-	(progn
-	  (setf (current-window) *echo-area-window*)
-	  (display-prompt-nicely prompt (or default-string
-					    (if defaultp (if default "Y" "N"))))
-	  (loop
-	    (let ((key-event (recursive-get-key-event *editor-input*)))
-	      (cond ((or (eq key-event #k"y")
-			 (eq key-event #k"Y"))
-		     (return t))
-		    ((or (eq key-event #k"n")
-			 (eq key-event #k"N"))
-		     (return nil))
-		    ((logical-key-event-p key-event :confirm)
-		     (if defaultp
-			 (return default)
-			 (beep)))
-		    ((logical-key-event-p key-event :help)
-		     (hemlock::help-on-parse-command ()))
-		    (t
-		     (unless must-exist (return key-event))
-		     (beep))))))
-      (setf (current-window) old-window))))
+  (with-echo-area-window
+   (display-prompt-nicely prompt (or default-string
+				     (if defaultp (if default "Y" "N"))))
+   (loop
+     (let ((key-event (recursive-get-key-event *editor-input*)))
+       (cond ((or (eq key-event #k"y")
+		  (eq key-event #k"Y"))
+	      (return t))
+	     ((or (eq key-event #k"n")
+		  (eq key-event #k"N"))
+	      (return nil))
+	     ((logical-key-event-p key-event :confirm)
+	      (if defaultp
+		(return default)
+		(beep)))
+	     ((logical-key-event-p key-event :help)
+	      (hemlock::help-on-parse-command ()))
+	     (t
+	      (unless must-exist (return key-event))
+	      (beep)))))))
 
 
@@ -529,12 +525,11 @@
 
 (defun prompt-for-key-event* (prompt change-window)
-  (let ((old-window (current-window)))
-    (unwind-protect
-	(progn
-	  (when change-window
-	    (setf (current-window) *echo-area-window*))
-	  (display-prompt-nicely prompt)
-	  (recursive-get-key-event *editor-input* t))
-      (when change-window (setf (current-window) old-window)))))
+  (if change-window
+    (with-echo-area-window
+     (display-prompt-nicely prompt)
+     (recursive-get-key-event *editor-input* t))
+    (progn
+     (display-prompt-nicely prompt)
+     (recursive-get-key-event *editor-input* t))))
 
 (defun prompt-for-key (&key ((:must-exist must-exist) t)
@@ -542,68 +537,60 @@
 			    (prompt "Key: ")
 			    ((:help *parse-help*) "Type a key."))
-  (let ((old-window (current-window))
-	(string (if default
-		    (or default-string
-			(let ((l (coerce default 'list)))
-			  (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
-
-    (unwind-protect
-	(progn
-	  (setf (current-window) *echo-area-window*)
-	  (display-prompt-nicely prompt string)
-	  (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event)
-		(declare (vector key))
-		TOP
-		(setf key-event (recursive-get-key-event *editor-input*))
-		(cond ((logical-key-event-p key-event :quote)
-		       (setf key-event (recursive-get-key-event *editor-input* t)))
-		      ((logical-key-event-p key-event :confirm)
-		       (cond ((and default (zerop (length key)))
-			      (let ((res (get-command default :current)))
-				(unless (commandp res) (go FLAME))
-				(return (values default res))))
-			     ((and (not must-exist) (plusp (length key)))
-			      (return (copy-seq key)))
-			     (t 
-			      (go FLAME))))
-		      ((logical-key-event-p key-event :help)
-		       (hemlock::help-on-parse-command ())
-		       (go TOP)))
-		(vector-push-extend key-event key)	 
-		(when must-exist
-		  (let ((res (get-command key :current)))
-		    (cond ((commandp res)
-			   (hemlock-ext:print-pretty-key-event key-event
-						       *echo-area-stream*
-						       t)
-			   (write-char #\space *echo-area-stream*)
-			   (return (values (copy-seq key) res)))
-			  ((not (eq res :prefix))
-			   (vector-pop key)
-			   (go FLAME)))))
-		(hemlock-ext:print-pretty-key key-event *echo-area-stream* t)
-		(write-char #\space *echo-area-stream*)
-		(go TOP)
-		FLAME
-		(beep)
-		(go TOP)))
-      (force-output *echo-area-stream*)
-      (setf (current-window) old-window))))
+  (let ((string (if default
+		  (or default-string
+		      (let ((l (coerce default 'list)))
+			(format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
+    (with-echo-area-window
+     (display-prompt-nicely prompt string)
+     (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event)
+	   (declare (vector key))
+	   TOP
+	   (setf key-event (recursive-get-key-event *editor-input*))
+	   (cond ((logical-key-event-p key-event :quote)
+		  (setf key-event (recursive-get-key-event *editor-input* t)))
+		 ((logical-key-event-p key-event :confirm)
+		  (cond ((and default (zerop (length key)))
+			 (let ((res (get-command default :current)))
+			   (unless (commandp res) (go FLAME))
+			   (return (values default res))))
+			((and (not must-exist) (plusp (length key)))
+			 (return (copy-seq key)))
+			(t 
+			 (go FLAME))))
+		 ((logical-key-event-p key-event :help)
+		  (hemlock::help-on-parse-command ())
+		  (go TOP)))
+	   (vector-push-extend key-event key)	 
+	   (when must-exist
+	     (let ((res (get-command key :current)))
+	       (cond ((commandp res)
+		      (hemlock-ext:print-pretty-key-event key-event
+							  *echo-area-stream*
+							  t)
+		      (write-char #\space *echo-area-stream*)
+		      (return (values (copy-seq key) res)))
+		     ((not (eq res :prefix))
+		      (vector-pop key)
+		      (go FLAME)))))
+	   (hemlock-ext:print-pretty-key key-event *echo-area-stream* t)
+	   (write-char #\space *echo-area-stream*)
+	   (go TOP)
+	   FLAME
+	   (beep)
+	   (go TOP))
+     (force-output *echo-area-stream*))))
 
 (defun prompt-for-command-key ()
-  (let ((old-window (current-window)))
-    (unwind-protect
-	(let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0)))
-	  (setf (current-window) hi::*echo-area-window*)
-	  (hi::display-prompt-nicely "Describe key: " nil)
-	  (loop
-	    (let ((key-event (get-key-event hi::*editor-input*)))
-	      (vector-push-extend key-event prompt-key)
-	      (let ((res (get-command prompt-key :current)))
-		(hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
-		(write-char #\space *echo-area-stream*)
-		(unless (eq res :prefix)
-		  (return (values (copy-seq prompt-key) res)))))))
-      (setf (current-window) old-window))))
+  (with-echo-area-window
+   (let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0)))
+     (hi::display-prompt-nicely "Describe key: " nil)
+     (loop
+       (let ((key-event (get-key-event hi::*editor-input*)))
+	 (vector-push-extend key-event prompt-key)
+	 (let ((res (get-command prompt-key :current)))
+	   (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
+	   (write-char #\space *echo-area-stream*)
+	   (unless (eq res :prefix)
+	     (return (values (copy-seq prompt-key) res)))))))))
 
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp	(revision 7844)
@@ -96,5 +96,5 @@
 	  (cond (pns
 		 (write-line "Possible completions of what you have typed:" s)
-		 (let ((width (- (window-width (current-window)) 27)))
+		 (let ((width 55))
 		   (dolist (pn pns)
 		     (let* ((dir (directory-namestring pn))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp	(revision 7844)
@@ -697,28 +697,4 @@
 
 
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
 (defun universal-time-to-string (ut)
   (multiple-value-bind (sec min hour day month year)
@@ -730,28 +706,2 @@
 	    (rem year 100)
 	    hour min sec)))
-
-
-
-
-
-
-;;;; Window hacking commands:
-
-
-
-(defcommand "Split Window" (p)
-  "Make a new window by splitting the current window.
-   The new window is made the current window and displays starting at
-   the same place as the current window."
-  "Create a new window which displays starting at the same place
-   as the current window."
-  (declare (ignore p))
-  (let ((new (make-window (window-display-start (current-window)))))
-    (unless new (editor-error "Could not make a new window."))
-    (setf (current-window) new)))
-
-
-
-
-
-
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp	(revision 7844)
@@ -504,5 +504,5 @@
 					  end-mark column)
   (with-mark ((mark1 fill-mark :left-inserting))
-    (move-to-column mark1 column)
+    (move-to-position mark1 column)
     (cond ((not (whitespace-attribute-p (next-character mark1)))
 	   (if (not (find-attribute mark1 :whitespace))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/font.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/font.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/font.lisp	(revision 7844)
@@ -18,13 +18,4 @@
 
 (in-package :hemlock-internals)
-
-;;; Default-font used to be in the above list, but when I cleaned up the way
-;;; Hemlock compiles, a name conflict occurred because "Default Font" is a
-;;; Hemlock variable.  It is now exported by the export list in rompsite.lisp.
-
-(defvar *default-font-family* (make-font-family))
-
-
-
 
 ;;;; Creating, Deleting, and Moving.
@@ -64,5 +55,4 @@
     (new-font-mark new line)
     (push new (line-marks line))
-    (incf (line-font-mark-count line))
     new))
 
@@ -73,5 +63,4 @@
     (when line
       (setf (line-marks line) (delq font-mark (line-marks line)))
-      (decf (line-font-mark-count line))
       (nuke-font-mark font-mark line)
       (setf (mark-line font-mark) nil))))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp	(revision 7844)
@@ -12,15 +12,4 @@
 (defun skip-whitespace (&optional (stream *standard-input*))
   (peek-char t stream))
-
-#+clx
-(defun disable-clx-event-handling (display)
-  )
-
-(defun quit ()
-  )
-
-(defun sap-ref-8 (vec index)
-  (declare (ignore vec index))
-  (error "SAP-REF-8 called.") )
 
 (defvar hi::*command-line-switches* nil)
@@ -37,505 +26,4 @@
   with setf."
   (truename #p""))
-
-;;;;;;;;;;;;
-
-(defstruct (object-set (:constructor make-object-set (name &optional default-handler)))
-  name
-  default-handler
-  (table (make-hash-table)))
-
-(defvar *xwindow-hash* (make-hash-table :test #'eq))
-
-(defun hi::add-xwindow-object (window object object-set)
-  (setf (gethash window *xwindow-hash*) (list object object-set)))
-
-(defun hi::remove-xwindow-object (window)
-  (remhash window *xwindow-hash*))
-
-(defun lisp--map-xwindow (window)
-  ;; -> object object-set
-  (values-list (gethash window *xwindow-hash*)))
-
-
-
-;;;; Object set event handling.
-
-;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear
-;;; events on the display before signalling any errors.  This is necessary
-;;; since reading on certain CMU Common Lisp streams involves SERVER, and
-;;; getting an error while trying to handle an event causes repeated attempts
-;;; to handle the same event.
-;;;
-(defvar *process-clx-event-display* nil)
-
-(defvar *object-set-event-handler-print* nil)
-
-(declaim (declaration values))
-
-#+clx
-(defun object-set-event-handler (display &optional (timeout 0))
-  "This display event handler uses object sets to map event windows cross
-   event types to handlers.  It uses XLIB:EVENT-CASE to bind all the slots
-   of each event, calling the handlers on all these values in addition to
-   the event key and send-event-p.  Describe EXT:SERVE-MUMBLE, where mumble
-   is an event keyword name for the exact order of arguments.
-   :mapping-notify and :keymap-notify events are ignored since they do not
-   occur on any particular window.  After calling a handler, each branch
-   returns t to discard the event.  While the handler is executing, all
-   errors go through a handler that flushes all the display's events and
-   returns.  This prevents infinite errors since the debug and terminal
-   streams loop over SYSTEM:SERVE-EVENT.  This function returns t if there
-   were some event to handle, nil otherwise.  It returns immediately if
-   there is no event to handle."
-  (macrolet ((dispatch (event-key &rest args)
-               `(multiple-value-bind (object object-set)
-                 (lisp--map-xwindow event-window)
-                 (unless object
-                   (cond ((not (typep event-window 'xlib:window))
-                          ;;(xlib:discard-current-event display)
-                          (warn "Discarding ~S event on non-window ~S."
-                                ,event-key event-window)
-                          (return-from object-set-event-handler nil)
-                          )
-                         (t
-                          (flush-display-events display)
-                          (error "~S not a known X window.~%~
-			           Received event ~S."
-                                 event-window ,event-key))))
-                 (handler-bind ((error #'(lambda (condx)
-                                           (declare (ignore condx))
-                                           (flush-display-events display))))
-                   (when *object-set-event-handler-print*
-                     (print ,event-key) (force-output))
-                   (funcall (gethash ,event-key
-                                     (object-set-table object-set)
-                                     (object-set-default-handler
-                                      object-set))
-                            object ,event-key
-                            ,@args))
-                 (setf result t))))
-    (let ((*process-clx-event-display* display)
-          (result nil))
-      (xlib:event-case (display :timeout timeout)
-                       ((:key-press :key-release :button-press :button-release)
-                        (event-key event-window root child same-screen-p
-                                   x y root-x root-y state time code send-event-p)
-                        (dispatch event-key event-window root child same-screen-p
-                                  x y root-x root-y state time code send-event-p))
-                       (:motion-notify (event-window root child same-screen-p
-                                        x y root-x root-y state time hint-p send-event-p)
-                        (dispatch :motion-notify event-window root child same-screen-p
-                         x y root-x root-y state time hint-p send-event-p))
-                       (:enter-notify (event-window root child same-screen-p
-                                       x y root-x root-y state time mode kind send-event-p)
-                        (dispatch :enter-notify event-window root child same-screen-p
-                         x y root-x root-y state time mode kind send-event-p))
-                       (:leave-notify (event-window root child same-screen-p
-                                       x y root-x root-y state time mode kind send-event-p)
-                        (dispatch :leave-notify event-window root child same-screen-p
-                         x y root-x root-y state time mode kind send-event-p))
-                       (:exposure (event-window x y width height count send-event-p)
-                        (dispatch :exposure event-window x y width height count send-event-p))
-                       (:graphics-exposure (event-window x y width height count major minor
-                                            send-event-p)
-                        (dispatch :graphics-exposure event-window x y width height
-                         count major minor send-event-p))
-                       (:no-exposure (event-window major minor send-event-p)
-                        (dispatch :no-exposure event-window major minor send-event-p))
-                       (:focus-in (event-window mode kind send-event-p)
-                        (dispatch :focus-in event-window mode kind send-event-p))
-                       (:focus-out (event-window mode kind send-event-p)
-                        (dispatch :focus-out event-window mode kind send-event-p))
-                       (:keymap-notify ()
-                        (warn "Ignoring keymap notify event.")
-                        (when *object-set-event-handler-print*
-                          (print :keymap-notify) (force-output))
-                        (setf result t))
-                       (:visibility-notify (event-window state send-event-p)
-                        (dispatch :visibility-notify event-window state send-event-p))
-                       (:create-notify (event-window window x y width height border-width
-                                        override-redirect-p send-event-p)
-                        (dispatch :create-notify event-window window x y width height
-                         border-width override-redirect-p send-event-p))
-                       (:destroy-notify (event-window window send-event-p)
-                        (dispatch :destroy-notify event-window window send-event-p))
-                       (:unmap-notify (event-window window configure-p send-event-p)
-                        (dispatch :unmap-notify event-window window configure-p send-event-p))
-                       (:map-notify (event-window window override-redirect-p send-event-p)
-                        (dispatch :map-notify event-window window override-redirect-p
-                         send-event-p))
-                       (:map-request (event-window window send-event-p)
-                        (dispatch :map-request event-window window send-event-p))
-                       (:reparent-notify (event-window window parent x y override-redirect-p
-                                          send-event-p)
-                        (dispatch :reparent-notify event-window window parent x y
-                         override-redirect-p send-event-p))
-                       (:configure-notify (event-window window x y width height border-width
-                                           above-sibling override-redirect-p send-event-p)
-                        (dispatch :configure-notify event-window window x y width height
-                         border-width above-sibling override-redirect-p
-                         send-event-p))
-                       (:gravity-notify (event-window window x y send-event-p)
-                        (dispatch :gravity-notify event-window window x y send-event-p))
-                       (:resize-request (event-window width height send-event-p)
-                        (dispatch :resize-request event-window width height send-event-p))
-                       (:configure-request (event-window window x y width height border-width
-                                            stack-mode above-sibling value-mask send-event-p)
-                        (dispatch :configure-request event-window window x y width height
-                         border-width stack-mode above-sibling value-mask
-                         send-event-p))
-                       (:circulate-notify (event-window window place send-event-p)
-                        (dispatch :circulate-notify event-window window place send-event-p))
-                       (:circulate-request (event-window window place send-event-p)
-                        (dispatch :circulate-request event-window window place send-event-p))
-                       (:property-notify (event-window atom state time send-event-p)
-                        (dispatch :property-notify event-window atom state time send-event-p))
-                       (:selection-clear (event-window selection time send-event-p)
-                        (dispatch :selection-notify event-window selection time send-event-p))
-                       (:selection-request (event-window requestor selection target property
-                                            time send-event-p)
-                        (dispatch :selection-request event-window requestor selection target
-                         property time send-event-p))
-                       (:selection-notify (event-window selection target property time
-                                           send-event-p)
-                        (dispatch :selection-notify event-window selection target property time
-                         send-event-p))
-                       (:colormap-notify (event-window colormap new-p installed-p send-event-p)
-                        (dispatch :colormap-notify event-window colormap new-p installed-p
-                         send-event-p))
-                       (:mapping-notify (request)
-                        (warn "Ignoring mapping notify event -- ~S." request)
-                        (when *object-set-event-handler-print*
-                          (print :mapping-notify) (force-output))
-                        (setf result t))
-                       (:client-message (event-window format data send-event-p)
-                        (dispatch :client-message event-window format data send-event-p)))
-      result)))
-
-#+clx
-(defun default-clx-event-handler (object event-key event-window &rest ignore)
-  (declare (ignore ignore))
-  (flush-display-events *process-clx-event-display*)
-  (error "No handler for event type ~S on ~S in ~S."
-	 event-key object (lisp--map-xwindow event-window)))
-
-#+clx
-(defun flush-display-events (display)
-  "Dumps all the events in display's event queue including the current one
-   in case this is called from within XLIB:EVENT-CASE, etc."
-  (xlib:discard-current-event display)
-  (xlib:event-case (display :discard-p t :timeout 0)
-    (t () nil)))
-
-#+clx
-(defmacro with-clx-event-handling ((display handler) &rest body)
-  "Evaluates body in a context where events are handled for the display
-   by calling handler on the display.  This destroys any previously established
-   handler for display."
-  `(unwind-protect
-       (progn
-	 (enable-clx-event-handling ,display ,handler)
-	 ,@body)
-     (disable-clx-event-handling ,display) ))
-
-#+clx
-(defun enable-clx-event-handling (display handler)
-  nil)
-
-#+clx
-(defun disable-clx-event-handling (display)
-  nil)
-
-#||
-;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
-;;; *display-event-handlers*.  It also uses SYSTEM:ADD-FD-HANDLER to have
-;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows
-;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a
-;;; file descriptor, the file descriptor is also mapped to the display in
-;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
-;;;
-(defun enable-clx-event-handling (display handler)
-  "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
-   connection to the X11 server, handler is called on the display.  Handler
-   is invoked in a dynamic context with an error handler bound that will
-   flush all events from the display and return.  By returning, it declines
-   to handle the error, but it will have cleared all events; thus, entering
-   the debugger will not result in infinite errors due to streams that wait
-   via SYSTEM:SERVE-EVENT for input.  Calling this repeatedly on the same
-   display establishes handler as a new handler, replacing any previous one
-   for display."
-  (check-type display xlib:display)
-  (let ((change-handler (assoc display *display-event-handlers*)))
-    (if change-handler
-	(setf (cdr change-handler) handler)
-	(let ((fd (fd-stream-fd (xlib::display-input-stream display))))
-	  (system:add-fd-handler fd :input #'call-display-event-handler)
-	  (setf (gethash fd *clx-fds-to-displays*) display)
-	  (push (cons display handler) *display-event-handlers*)))))
-
-;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
-;;; the display to its handler.  If we can't find the display, we remove the
-;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
-;;; display from *display-event-handlers*.  This is necessary to try to keep
-;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
-;;; over.  This is possible since many CMU Common Lisp streams loop over
-;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
-;;; possible.
-;;;
-(defun call-display-event-handler (file-descriptor)
-  (let ((display (gethash file-descriptor *clx-fds-to-displays*)))
-    (unless display
-      (system:invalidate-descriptor file-descriptor)
-      (setf *display-event-handlers*
-	    (delete file-descriptor *display-event-handlers*
-		    :key #'(lambda (d/h)
-			     (fd-stream-fd
-			      (xlib::display-input-stream
-			       (car d/h))))))
-      (error "File descriptor ~S not associated with any CLX display.~%~
-                It has been removed from system:serve-event's knowledge."
-	     file-descriptor))
-    (let ((handler (cdr (assoc display *display-event-handlers*))))
-      (unless handler
-	(flush-display-events display)
-	(error "Display ~S not associated with any event handler." display))
-      (handler-bind ((error #'(lambda (condx)
-				(declare (ignore condx))
-				(flush-display-events display))))
-	(funcall handler display)))))
-
-(defun disable-clx-event-handling (display)
-  "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
-  (setf *display-event-handlers*
-	(delete display *display-event-handlers* :key #'car))
-  (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
-    (remhash fd *clx-fds-to-displays*)
-    (system:invalidate-descriptor fd)))
-||#
-
-
-
-;;;; Key and button service.
-
-(defun serve-key-press (object-set fun)
-  "Associate a method in the object-set with :key-press events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :key-press (object-set-table object-set)) fun))
-
-(defun serve-key-release (object-set fun)
-  "Associate a method in the object-set with :key-release events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :key-release (object-set-table object-set)) fun))
-
-(defun serve-button-press (object-set fun)
-  "Associate a method in the object-set with :button-press events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :button-press (object-set-table object-set)) fun))
-
-(defun serve-button-release (object-set fun)
-  "Associate a method in the object-set with :button-release events.  The
-   method is called on the object the event occurred, event key, event window,
-   root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :button-release (object-set-table object-set)) fun))
-
-
-
-
-;;;; Mouse service.
-
-(defun serve-motion-notify (object-set fun)
-  "Associate a method in the object-set with :motion-notify events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and
-   send-event-p."
-  (setf (gethash :motion-notify (object-set-table object-set)) fun))
-
-(defun serve-enter-notify (object-set fun)
-  "Associate a method in the object-set with :enter-notify events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
-   and send-event-p."
-  (setf (gethash :enter-notify (object-set-table object-set)) fun))
-
-(defun serve-leave-notify (object-set fun)
-  "Associate a method in the object-set with :leave-notify events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
-   and send-event-p."
-  (setf (gethash :leave-notify (object-set-table object-set)) fun))
-
-
-
-
-;;;; Keyboard service.
-
-(defun serve-focus-in (object-set fun)
-  "Associate a method in the object-set with :focus-in events.  The method
-   is called on the object the event occurred, event key, event window, mode,
-   kind, and send-event-p."
-  (setf (gethash :focus-in (object-set-table object-set)) fun))
-
-(defun serve-focus-out (object-set fun) 
-  "Associate a method in the object-set with :focus-out events.  The method
-   is called on the object the event occurred, event key, event window, mode,
-   kind, and send-event-p."
-  (setf (gethash :focus-out (object-set-table object-set)) fun))
-
-
-
-
-;;;; Exposure service.
-
-(defun serve-exposure (object-set fun)
-  "Associate a method in the object-set with :exposure events.  The method
-   is called on the object the event occurred, event key, event window, x, y,
-   width, height, count, and send-event-p."
-  (setf (gethash :exposure (object-set-table object-set)) fun))
-
-(defun serve-graphics-exposure (object-set fun)
-  "Associate a method in the object-set with :graphics-exposure events.  The
-   method is called on the object the event occurred, event key, event window,
-   x, y, width, height, count, major, minor, and send-event-p."
-  (setf (gethash :graphics-exposure (object-set-table object-set)) fun))
-
-(defun serve-no-exposure (object-set fun)
-  "Associate a method in the object-set with :no-exposure events.  The method
-   is called on the object the event occurred, event key, event window, major,
-   minor, and send-event-p."
-  (setf (gethash :no-exposure (object-set-table object-set)) fun))
-  
-
-
-
-;;;; Structure service.
-
-(defun serve-visibility-notify (object-set fun)
-  "Associate a method in the object-set with :visibility-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   state, and send-event-p."
-  (setf (gethash :visibility-notify (object-set-table object-set)) fun))
-
-(defun serve-create-notify (object-set fun)
-  "Associate a method in the object-set with :create-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, width, height, border-width, override-redirect-p, and
-   send-event-p."
-  (setf (gethash :create-notify (object-set-table object-set)) fun))
-
-(defun serve-destroy-notify (object-set fun)
-  "Associate a method in the object-set with :destroy-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, and send-event-p."
-  (setf (gethash :destroy-notify (object-set-table object-set)) fun))
-
-(defun serve-unmap-notify (object-set fun)
-  "Associate a method in the object-set with :unmap-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, configure-p, and send-event-p."
-  (setf (gethash :unmap-notify (object-set-table object-set)) fun))
-
-(defun serve-map-notify (object-set fun)
-  "Associate a method in the object-set with :map-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, override-redirect-p, and send-event-p."
-  (setf (gethash :map-notify (object-set-table object-set)) fun))
-
-(defun serve-map-request (object-set fun)
-  "Associate a method in the object-set with :map-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, and send-event-p."
-  (setf (gethash :map-request (object-set-table object-set)) fun))
-
-(defun serve-reparent-notify (object-set fun)
-  "Associate a method in the object-set with :reparent-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, parent, x, y, override-redirect-p, and send-event-p."
-  (setf (gethash :reparent-notify (object-set-table object-set)) fun))
-
-(defun serve-configure-notify (object-set fun)
-  "Associate a method in the object-set with :configure-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, width, height, border-width, above-sibling,
-   override-redirect-p, and send-event-p."
-  (setf (gethash :configure-notify (object-set-table object-set)) fun))
-
-(defun serve-gravity-notify (object-set fun)
-  "Associate a method in the object-set with :gravity-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, and send-event-p."
-  (setf (gethash :gravity-notify (object-set-table object-set)) fun))
-
-(defun serve-resize-request (object-set fun)
-  "Associate a method in the object-set with :resize-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   width, height, and send-event-p."
-  (setf (gethash :resize-request (object-set-table object-set)) fun))
-
-(defun serve-configure-request (object-set fun)
-  "Associate a method in the object-set with :configure-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, width, height, border-width, stack-mode, above-sibling,
-   value-mask, and send-event-p."
-  (setf (gethash :configure-request (object-set-table object-set)) fun))
-
-(defun serve-circulate-notify (object-set fun)
-  "Associate a method in the object-set with :circulate-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, place, and send-event-p."
-  (setf (gethash :circulate-notify (object-set-table object-set)) fun))
-
-(defun serve-circulate-request (object-set fun)
-  "Associate a method in the object-set with :circulate-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, place, and send-event-p."
-  (setf (gethash :circulate-request (object-set-table object-set)) fun))
-
-
-
-
-;;;; Misc. service.
-
-(defun serve-property-notify (object-set fun)
-  "Associate a method in the object-set with :property-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   atom, state, time, and send-event-p."
-  (setf (gethash :property-notify (object-set-table object-set)) fun))
-
-(defun serve-selection-clear (object-set fun)
-  "Associate a method in the object-set with :selection-clear events.  The
-   method is called on the object the event occurred, event key, event window,
-   selection, time, and send-event-p."
-  (setf (gethash :selection-clear (object-set-table object-set)) fun))
-
-(defun serve-selection-request (object-set fun)
-  "Associate a method in the object-set with :selection-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   requestor, selection, target, property, time, and send-event-p."
-  (setf (gethash :selection-request (object-set-table object-set)) fun))
-
-(defun serve-selection-notify (object-set fun)
-  "Associate a method in the object-set with :selection-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   selection, target, property, time, and send-event-p."
-  (setf (gethash :selection-notify (object-set-table object-set)) fun))
-
-(defun serve-colormap-notify (object-set fun)
-  "Associate a method in the object-set with :colormap-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   colormap, new-p, installed-p, and send-event-p."
-  (setf (gethash :colormap-notify (object-set-table object-set)) fun))
-
-(defun serve-client-message (object-set fun)
-  "Associate a method in the object-set with :client-message events.  The
-   method is called on the object the event occurred, event key, event window,
-   format, data, and send-event-p."
-  (setf (gethash :client-message (object-set-table object-set)) fun))
 
 
@@ -548,79 +36,4 @@
         do
         (setf (aref dest d) (aref src s))))
-
-#+clx
-(defun serve-event (&optional timeout)
-  (let ((dps))
-    (maphash (lambda (win value)
-               (pushnew (xlib:window-display win) dps))
-             *xwindow-hash*)
-    (when dps
-      (object-set-event-handler (car dps) timeout))))
-
-#+CLISP
-(progn
-
-  #-NIL
-  (defun serve-event (&optional timeout)
-    (hemlock.wire::serve-event timeout))
-
-;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
-;;; *display-event-handlers*.  It also uses SYSTEM:ADD-FD-HANDLER to have
-;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows
-;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a
-;;; file descriptor, the file descriptor is also mapped to the display in
-;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
-;;;
-
-  (defvar *display-event-handlers* nil)
-
-  (defun enable-clx-event-handling (display handler)
-    "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
-   connection to the X11 server, handler is called on the display.  Handler
-   is invoked in a dynamic context with an error handler bound that will
-   flush all events from the display and return.  By returning, it declines
-   to handle the error, but it will have cleared all events; thus, entering
-   the debugger will not result in infinite errors due to streams that wait
-   via SYSTEM:SERVE-EVENT for input.  Calling this repeatedly on the same
-   display establishes handler as a new handler, replacing any previous one
-   for display."
-    (check-type display xlib:display)
-    (let ((change-handler (assoc display *display-event-handlers*)))
-      (if change-handler
-          (setf (cadr change-handler) handler)
-          (let ((fd-handler
-                 (hemlock.wire::add-fd-handler display :input #'call-display-event-handler)))
-            (push (list display handler fd-handler) *display-event-handlers*)))))
-
-;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
-;;; the display to its handler.  If we can't find the display, we remove the
-;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
-;;; display from *display-event-handlers*.  This is necessary to try to keep
-;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
-;;; over.  This is possible since many CMU Common Lisp streams loop over
-;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
-;;; possible.
-;;;
-  (defun call-display-event-handler (display)
-    (let ((handler (cadr (assoc display *display-event-handlers*))))
-      (unless handler
-        (flush-display-events display)
-        (error "Display ~S not associated with any event handler." display))
-      (handler-bind ((error #'(lambda (condx)
-                                (declare (ignore condx))
-                                (flush-display-events display))))
-        (funcall handler display))))
-
-  (defun disable-clx-event-handling (display)
-    "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
-    (let ((change-handler (assoc display *display-event-handlers*)))
-      (when change-handler
-        (hemlock.wire::remove-fd-handler (third change-handler))))
-    (setf *display-event-handlers*
-          (delete display *display-event-handlers* :key #'car))
-    ) )
-
-
-;;(trace object-set-event-handler hi::invoke-scheduled-events hi::next-scheduled-event-wait serve-event)
 
 (defun hi::%sp-find-character-with-attribute (string start end table mask)
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp	(revision 7844)
@@ -434,7 +434,8 @@
   "Changes the Mark to point to the given character position on the Line,
   which defaults to the line the mark is currently on."
-  (change-line mark line)
-  (setf (mark-charpos mark) charpos)
-  mark)
+  (when (<= charpos (line-length line))
+    (change-line mark line)
+    (setf (mark-charpos mark) charpos)
+    mark))
 
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp	(revision 7844)
@@ -392,12 +392,4 @@
   *last-prefix-argument*)
 
-;;;
-(defvar *invoke-hook* #'(lambda (command p)
-			  (funcall (command-function command) p))
-  "This function is called by the command interpreter when it wants to invoke a
-  command.  The arguments are the command to invoke and the prefix argument.
-  The default value just calls the Command-Function with the prefix argument.")
-
-
 (defun get-self-insert-command ()
   ;; Get the command used to implement normal character insertion in current buffer.
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/isearchcoms.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/isearchcoms.lisp	(revision 7844)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/isearchcoms.lisp	(revision 7844)
@@ -0,0 +1,320 @@
+;;; -*- Mode: Lisp; Package: hemlock -*-
+;;;
+;;;   Copyright (C) 2007 Clozure Associates
+
+(in-package :hemlock)
+
+(defmode "I-Search" :precedence :highest
+  ;; Make anything that's not otherwise overridden exit i-search.
+  :default-command "I-Search Exit and Redo")
+
+(add-hook abort-hook 'end-isearch-mode)
+
+(defhvar "Self Insert Command Name"
+  "The name of the command to handle quoted input (i.e. after c-q) in I-Search"
+  :value "I-Search Self Insert"
+  :mode "I-Search")
+
+(defhvar "I-Search State"
+  "Internal variable containing current state of I-Search"
+  :mode "I-Search")
+
+(defun current-isearch-state ()
+  (or (value i-search-state)
+      (error "I-Search command invoked outside I-Search")))
+
+(defcommand "Incremental Search" (p)
+  "Searches for input string as characters are provided.
+
+  These are the default I-Search command characters:
+     ^Q quotes the next character typed.
+     ^W extends the search string to include the the word after the point. 
+     Delete cancels the last key typed.
+     ^G during a successful search aborts and returns point to where it started.
+       During a failing search, ^G backs up to last non-failing point.
+     ^S repeats forward, and ^R repeats backward.
+     ^R or ^S with empty string either changes the direction or yanks the previous search string.
+     Escape exits the search unless the string is empty.
+     Escape with an empty search string calls the non-incremental search command. 
+
+  Other control characters cause exit and execution of the appropriate 
+  command.
+"
+  "Set up Incremental Search mode"
+  (declare (ignore p))
+  (start-isearch-mode :forward))
+
+(defcommand "Reverse Incremental Search" (p)
+  "Searches for input string as characters are provided.
+
+  These are the default I-Search command characters:
+     ^Q quotes the next character typed.
+     ^W extends the search string to include the the word after the point. 
+     Delete cancels the last key typed.
+     ^G during a successful search aborts and returns point to where it started.
+       During a failing search, ^G backs up to last non-failing point.
+     ^S repeats forward, and ^R repeats backward.
+     ^R or ^S with empty string either changes the direction or yanks the previous search string.
+     Escape exits the search unless the string is empty.
+     Escape with an empty search string calls the non-incremental search command. 
+
+  Other control characters cause exit and execution of the appropriate 
+  command.
+"
+  "Set up Incremental Search mode"
+  (declare (ignore p))
+  (start-isearch-mode :backward))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+
+(defstruct (isearch-state (:conc-name "ISS-"))
+  string
+  direction
+  pattern
+  failure
+  wrapped-p
+  history
+  start-region)
+
+(defun current-region-info ()
+  (list (copy-mark (current-point) :temporary)
+	(copy-mark (current-mark) :temporary)
+	(region-active-p)))
+
+(defun set-current-region-info (info)
+  (destructuring-bind (point mark active-p) info
+    (move-mark (current-point) point)
+    (move-mark (current-mark) mark)
+    (if active-p
+      (progn
+	(activate-region)
+	(note-current-selection-set-by-search))
+      (deactivate-region))))
+
+(defun %i-search-save-state (iss)
+  (push (list* (iss-string iss)
+	       (iss-direction iss)
+	       (iss-failure iss)
+	       (iss-wrapped-p iss)
+	       (current-region-info))
+	(iss-history iss)))
+
+(defun %i-search-pop-state (iss)
+  (destructuring-bind (string direction failure wrapped-p . region-info)
+		      (pop (iss-history iss))
+    (setf (iss-failure iss) failure)
+    (setf (iss-wrapped-p iss) wrapped-p)
+    (%i-search-set-pattern iss :string string :direction direction)
+    (set-current-region-info region-info)))
+
+(defun %i-search-message (iss)
+  (when t ;(interactive)
+    (message "~:[~;Failing ~]~:[~;Wrapped ~]~:[Reverse I-Search~;I-Search~]: ~A"
+	     (iss-failure iss)
+	     (iss-wrapped-p iss)
+	     (eq (iss-direction iss) :forward)
+	     (or (iss-string iss) ""))))
+
+
+;; Minor errors that don't cause isearch mode to be exited, except while
+;; executing keyboard macros.
+(defun %i-search-perhaps-error (message)
+  message
+  (if t ;(interactive)
+      (beep)
+      (abort-current-command message)))
+
+;;;;
+;;
+
+(defun start-isearch-mode (direction)
+  (setf (buffer-minor-mode (current-buffer) "I-Search") t)
+  (let* ((iss (make-isearch-state :direction direction
+				  :start-region (current-region-info))))
+    (setf (value i-search-state) iss)
+    (%i-search-message iss)))
+
+(defun end-isearch-mode ()
+  (setf (buffer-minor-mode (current-buffer) "I-Search") nil))
+
+(defun i-search-backup (iss)
+  (if (iss-history iss)
+    (progn
+      (%i-search-pop-state iss)
+      (%i-search-message iss))
+    (%i-search-perhaps-error "I-Search Backup failed")))
+
+(defun i-search-revert (iss)
+  (loop while (iss-failure iss) do (%i-search-pop-state iss))
+  (%i-search-message iss))
+
+(defun i-search-repeat (iss)
+  (cond ((null (iss-string iss))
+	 ;; No search string, so "repeat" really means fetch last successful search string
+	 (if (zerop (length *last-search-string*))
+	   (%i-search-perhaps-error "No previous search string")
+	   (progn
+	     (%i-search-save-state iss)
+	     (%i-search-set-pattern iss :string *last-search-string*)
+	     (%i-search-do-search iss (current-mark)))))
+	((iss-failure iss)
+	 (%i-search-save-state iss)
+	 ;; If failed last time, "repeat" really means try again from the top.
+	 (setf (iss-wrapped-p iss) t) ;; start saying "Wrapped i-search" to remind 'em.
+	 (%i-search-do-search iss (if (eq (iss-direction iss) :forward)
+				    (buffer-start-mark (current-buffer))
+				    (buffer-end-mark (current-buffer)))))
+	(t
+	 (%i-search-save-state iss)
+	 ;; Have a non-empty string and a successful search, just find the next one!
+	 (%i-search-do-search iss (current-point))))
+  (%i-search-message iss))
+
+(defun i-search-reverse (iss)
+  (%i-search-save-state iss)
+  (%i-search-set-pattern iss :direction (ecase (iss-direction iss)
+					  (:forward :backward)
+					  (:backward :forward)))
+  (let* ((mark (current-mark))
+	 (point (current-point)))
+    (with-mark ((temp point))
+      (move-mark point mark)
+      (move-mark mark temp))
+    (when (iss-failure iss)
+      ;; if we were failing before, search immediately, otherwise wait til asked
+      (%i-search-do-search iss mark)))
+  (%i-search-message iss))
+
+(defun i-search-extend (iss extension)
+  (%i-search-save-state iss)
+  (let* ((new-string (concatenate 'simple-string (iss-string iss) extension)))
+    (%i-search-set-pattern iss :string new-string))
+  (unless (iss-failure iss)  ;; Can't succeed now if failed before, so don't try
+    (with-mark ((temp (current-mark)))
+      (when (eq (iss-direction iss) :backward)
+	(or (character-offset temp (length extension))
+	    (buffer-end temp)))
+      (%i-search-do-search iss temp)))
+  (%i-search-message iss))
+
+(defun i-search-exit (iss)
+  (let* ((string (iss-string iss)))
+    (when (and string (not (iss-failure iss)))
+      (setf *last-search-string* string)))
+  (end-isearch-mode)
+  (message ""))
+
+(defun %i-search-set-pattern (iss &key (string nil s-p) (direction nil d-p))
+  (when s-p
+    (setf (iss-string iss) (and (not (zerop (length string))) string)))
+  (when d-p
+    (setf (iss-direction iss) direction))
+  (setf (iss-pattern iss)
+	(new-search-pattern (if (value string-search-ignore-case)
+			      :string-insensitive
+			      :string-sensitive)
+			    (iss-direction iss)
+			    (or (iss-string iss) "")
+			    (iss-pattern iss))))
+
+;; Do a search for the current pattern starting at START going to
+;; end/beginning as per ISS-DIRECTION.  Sets ISS-FAILURE depending on
+;; whether found or not.  If successful, moves region to surround the
+;; found string (with point at the end for :forward search and at the
+;; beginning for :backward) and activates the region.  If failed,
+;; leaves region unchanged.  Never modifies START.
+(defun %i-search-do-search (iss start)
+  (let* ((temp (copy-mark start :temporary))
+	 (found-offset (find-pattern temp (iss-pattern iss))))
+    (setf (iss-failure iss) (not found-offset))
+    (if (iss-failure iss)
+      (%i-search-perhaps-error "I-Search failed")
+      (let* ((point (current-point))
+	     (mark (current-mark)))
+	(move-mark point temp)
+	(if (eq (iss-direction iss) :forward)
+	  (character-offset point found-offset)
+	  (character-offset temp found-offset))
+	(move-mark mark temp)
+	(activate-region)
+	(note-current-selection-set-by-search)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+
+(defcommand "I-Search Repeat Forward" (p)
+  "Repeat forward incremental search, or reverse direction if currently searching backward"
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state)))
+    (if (eq (iss-direction iss) :forward)
+      (i-search-repeat iss)
+      (i-search-reverse iss))))
+
+(defcommand "I-Search Repeat Backward" (p)
+  "Repeat backward incremental search, or reverse direction if currently searching forward"
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state)))
+    (if (eq (iss-direction iss) :backward)
+      (i-search-repeat iss)
+      (i-search-reverse iss))))
+
+(defcommand "I-Search Backup" (p)
+  "Undo last incremental search command"
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state)))
+    (i-search-backup iss)))
+
+(defcommand "I-Search Yank Word" (p)
+  "Extend the search string to include the the word after the point."
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state))
+	(point (current-point)))
+    (with-mark ((end point))
+      (if (word-offset end 1)
+	(i-search-extend iss (region-to-string (region point end)))
+	(%i-search-perhaps-error "No more words")))))
+
+(defcommand "I-Search Self Insert" (p)
+  "Add character typed to search string"
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state))
+	(char (last-char-typed)))
+    (unless char (editor-error "Can't insert that character."))
+    (i-search-extend iss (string char))))
+
+(defcommand "I-Search Abort" (p)
+  "Abort incremental search mode if search is successful.  Otherwise, revert to last
+successful search and continue searching."
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state)))
+    (if (iss-failure iss)
+      (i-search-revert iss)
+      ;; Else move back to starting point and stop searching
+      (progn
+	(set-current-region-info (iss-start-region iss))
+	(abort-current-command "Search aborted")))))
+
+;; The transparent-p flag takes care of executing the key normally when we're done,
+;; as long as we don't take a non-local exit.
+(defcommand ("I-Search Exit and Redo" :transparent-p t) (p)
+  "Exit Incremental Search and then execute the key normally"
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state)))
+    (i-search-exit iss)))
+
+(defcommand "I-Search Exit or Search" (p)
+  "Exit incremental search.  If the search string is empty, switch to non-incremental search,
+otherwise just quit"
+  (declare (ignore p))
+  (let* ((iss (current-isearch-state))
+	 (string (iss-string iss))
+	 (direction (iss-direction iss)))
+    (i-search-exit iss)
+    (when (null string)
+      (if (eq direction :forward)
+	(forward-search-command nil)
+	(reverse-search-command nil)))))
+
+
+
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp	(revision 7844)
@@ -19,5 +19,5 @@
 ;;; you would have to change if you weren't using X11):
 ;;;    *modifier-translations*
-;;;    DEFINE-CLX-MODIFIER
+;;;    DEFINE-MODIFIER-BIT
 ;;;    TRANSLATE-KEY-EVENT
 ;;;    TRANSLATE-MOUSE-KEY-EVENT
@@ -93,6 +93,6 @@
     (setf (gethash (get-name-case-right name) *names-to-keysyms*) keysym)))
 
-;;; This is an a-list mapping CLX modifier masks to defined key-event
-;;; modifier names.  DEFINE-CLX-MODIFIER fills this in, so TRANSLATE-KEY-EVENT
+;;; This is an a-list mapping native modifier bit masks to defined key-event
+;;; modifier names.  DEFINE-MODIFIER-BIT fills this in, so TRANSLATE-KEY-EVENT
 ;;; and TRANSLATE-MOUSE-KEY-EVENT can work.
 ;;;
@@ -412,8 +412,8 @@
 ;;; 
 
-;;; DEFINE-CLX-MODIFIER -- Public.
-;;;
-(defun define-clx-modifier (clx-mask modifier-name)
-  "This establishes a mapping from clx-mask to a define key-event modifier-name.
+;;; DEFINE-MODIFIER-BIT -- Public.
+;;;
+(defun define-modifier-bit (bit-mask modifier-name)
+  "This establishes a mapping from bit-mask to a define key-event modifier-name.
    TRANSLATE-KEY-EVENT and TRANSLATE-MOUSE-KEY-EVENT can only return key-events
    with bits defined by this routine."
@@ -421,9 +421,9 @@
 		    :test #'string-equal)))
     (unless map (error "~S an undefined modifier name." modifier-name))
-    (push (cons clx-mask (car map)) *modifier-translations*)))
+    (push (cons bit-mask (car map)) *modifier-translations*)))
 
 ;;;
 ;;; RE-INITIALIZE-KEY-EVENTS at the end of this file defines the system
-;;; default clx modifiers, mapping them to some system default key-event
+;;; default modifiers, mapping them to some system default key-event
 ;;; modifiers.
 ;;; 
@@ -668,5 +668,5 @@
   "This blows away all data associated with keysyms, modifiers, mouse
    translations, and key-event/characters mapping.  Then it re-establishes
-   the system defined key-event modifiers and the system defined CLX
+   the system defined key-event modifiers and the system defined
    modifier mappings to some of those key-event modifiers.
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp	(revision 7844)
@@ -155,6 +155,5 @@
   (cond ((not p)
 	 (push-buffer-mark (copy-mark (current-point)) t)
-	 (when (interactive)
-	   (message "Mark pushed.")))
+	 (message "Mark pushed."))
 	((= p (value universal-argument-default))
 	 (pop-and-goto-mark-command nil))
Index: anches/event-ide/ccl/cocoa-ide/hemlock/src/linimage.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/linimage.lisp	(revision 7843)
+++ 	(revision )
@@ -1,478 +1,0 @@
-;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-#+CMU (ext:file-comment
-  "$Header$")
-;;;
-;;; **********************************************************************
-;;;
-;;;    Written by Rob MacLachlan
-;;;
-;;; This file contains functions related to building line images.
-;;;
-(in-package :hemlock-internals)
-
-;;;    The code in here is factored out in this way because it is more
-;;; or less implementation dependant.  The reason this code is 
-;;; implementation dependant is not because it is not written in 
-;;; Common Lisp per se, but because it uses this thing called 
-;;; %SP-Find-Character-With-Attribute to find any characters that
-;;; are to be displayed on the line which do not print as themselves.
-;;; This permits us to have an arbitrary string or even string-valued
-;;; function to as the representation for such a "Funny" character
-;;; with minimal penalty for the normal case.  This function can be written 
-;;; in lisp, and is included commented-out below, but if this function
-;;; is not real fast then redisplay performance will suffer.
-;;;
-;;;    Theres also code in here that special-cases "Buffered" lines,
-;;; which is not exactly Common Lisp, but if you aren't on a perq,
-;;; you won't have to worry about it.
-;;;
-;(defun %sp-find-character-with-attribute (string start end table mask)
-;  (declare (type (simple-array (mod 256) char-code-max) table))
-;  (declare (simple-string string))
-;  (declare (fixnum start end))
-;  "%SP-Find-Character-With-Attribute  String, Start, End, Table, Mask
-;  The codes of the characters of String from Start to End are used as indices
-;  into the Table, which is a U-Vector of 8-bit bytes. When the number picked
-;  up from the table bitwise ANDed with Mask is non-zero, the current
-;  index into the String is returned. The corresponds to SCANC on the Vax."
-;  (do ((index start (1+ index)))
-;      ((= index end) nil)
-;    (declare (fixnum index))
-;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
-;	(return index))))
-;
-;(defun %sp-reverse-find-character-with-attribute (string start end table
-;							  mask)
-;  (declare (type (simple-array (mod 256) char-code-max) table))
-;  (declare (simple-string string))
-;  (declare (fixnum start end))
-;  "Like %SP-Find-Character-With-Attribute, only sdrawkcaB."
-;  (do ((index (1- end) (1- index)))
-;      ((< index start) nil)
-;    (declare (fixnum index))
-;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
-;	(return index))))
-
-
-(defconstant winning-char #b01 "Bit for a char that prints normally")
-(defconstant losing-char #b10 "Bit for char with funny representation.")
-(defvar *losing-character-mask*
-  (make-array char-code-limit :element-type '(mod 256)
-	      :initial-element winning-char)
-  "This is a character set used by redisplay to find funny chars.")
-(defvar *print-representation-vector* nil
-  "Redisplay's handle on the :print-representation attribute")
-
-;;;  Do a find-character-with-attribute on the *losing-character-mask*.
-(defmacro %fcwa (str start end mask)
-  `(%sp-find-character-with-attribute
-    ,str ,start ,end *losing-character-mask* ,mask))
-
-;;; Get the print-representation of a character.
-(defmacro get-rep (ch)
-  `(svref *print-representation-vector* (char-code ,ch)))
-
-
-
-
-(declaim (special *character-attributes*))
-
-;;; %init-line-image  --  Internal
-;;;
-;;;    Set up the print-representations for funny chars.  We make the
-;;; attribute vector by hand and do funny stuff so that chars > 127
-;;; will have a losing print-representation, so redisplay will not
-;;; die if you visit a binary file or do something stupid like that.
-;;;
-(defun %init-line-image ()
-  (defattribute "Print Representation"
-    "The value of this attribute determines how a character is displayed
-    on the screen.  If the value is a string this string is literally
-    displayed.  If it is a function, then that function is called with
-    the current X position to get the string to display.")
-  (setq *print-representation-vector*
-	(make-array char-code-limit :initial-element nil))
-  (setf (attribute-descriptor-vector
-	 (gethash :print-representation *character-attributes*))
-	*print-representation-vector*)
-  (do ((code 128 (1+ code))
-       (str (make-string 4) (make-string 4)))
-      ((= code char-code-limit))
-    (setf (aref *losing-character-mask* code) losing-char)
-    (setf (aref *print-representation-vector* code) str)
-    (setf (schar str 0) #\<)
-    (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16)))
-    (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16)))
-    (setf (schar str 3) #\>))
-
-  (add-hook hemlock::character-attribute-hook
-	    #'redis-set-char-attribute-hook-fun)
-  (do ((i (1- (char-code #\space)) (1- i)) str)
-      ((minusp i))
-    (setq str (make-string 2))
-    (setf (elt (the simple-string str) 0) #\^)
-    (setf (elt (the simple-string str) 1)
-	  (code-char (+ i (char-code #\@))))
-    (setf (character-attribute :print-representation (code-char i)) str))
-  (setf (character-attribute :print-representation (code-char #o177)) "^?")
-  (setf (character-attribute :print-representation #\tab)
-	#'redis-tab-display-fun))
-
-
-;;; redis-set-char-attribute-hook-fun
-;;;
-;;;    Keep track of which characters have funny representations.
-;;;
-(defun redis-set-char-attribute-hook-fun (attribute char new-value)
-  (when (eq attribute :print-representation)
-    (cond
-     ((simple-string-p new-value)
-      (if (and (= (length (the simple-string new-value)) 1)
-	       (char= char (elt (the simple-string new-value) 0)))
-	  (setf (aref *losing-character-mask* (char-code char)) winning-char)
-	  (setf (aref *losing-character-mask* (char-code char))
-		losing-char)))
-     ((functionp new-value)
-      (setf (aref *losing-character-mask* (char-code char)) losing-char))
-     (t (error "Bad print representation: ~S" new-value)))))
-
-;;; redis-tab-display-fun
-;;;
-;;;    This function is initially the :print-representation for tab.
-;;;
-(defun redis-tab-display-fun (xpos)
-  (svref '#("        "
-	    "       "
-	    "      "
-	    "     "
-	    "    "
-	    "   "
-	    "  "
-	    " ")
-	 (logand xpos 7)))
-
-
-
-;;;; The actual line image computing functions.
-;;;;
-
-(eval-when (:compile-toplevel :execute)
-;;; display-some-chars  --  internal
-;;;
-;;;    Put some characters into a window.  Characters from src-start 
-;;; to src-end in src are are put in the window's dis-line's.  Lines
-;;; are wrapped as necessary.  dst is the dis-line-chars of the dis-line 
-;;; currently being written.  Dis-lines is the window's vector of dis-lines.
-;;; dis-line is the dis-line currently being written.  Line is the index
-;;; into dis-lines of the current dis-line.  dst-start is the index to
-;;; start writing chars at.  Height and width are the height and width of the 
-;;; window.  src-start, dst, dst-start, line and dis-line are updated.
-;;; Done-P indicates whether there are more characters after this sequence.
-;;;
-(defmacro display-some-chars (src src-start src-end dst dst-start width done-p)
-  `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start))))
-     (declare (fixnum dst-end))
-     (cond
-      ((>= dst-end ,width)
-       (cond 
-	((and ,done-p (= dst-end ,width))
-	 (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
-	 (setq ,dst-start dst-end  ,src-start ,src-end))
-	(t
-	 (let ((1-width (1- ,width)))
-	   (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width)
-	   (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*)
-	   (setq ,src-start (+ ,src-start (- 1-width ,dst-start)))
-	   (setq ,dst-start nil)))))
-      (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
-	 (setq ,dst-start dst-end  ,src-start ,src-end)))))
-
-;;; These macros are given as args to display-losing-chars to get the
-;;; print representation of whatever is in the data vector.
-(defmacro string-get-rep (string index)
-  `(get-rep (schar ,string ,index)))
-
-(defmacro u-vec-get-rep (u-vec index)
-  `(svref *print-representation-vector*
-	  (hemlock-ext:sap-ref-8 ,u-vec ,index)))
-
-;;; display-losing-chars  --  Internal
-;;;
-;;;    This macro is called by the compute-line-image functions to
-;;; display a group of losing characters.
-;;;
-(defmacro display-losing-chars (line-chars index end dest xpos width
-					   string underhang access-fun
-					   &optional (done-p `(= ,index ,end)))
-  `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end))
-	(len 0)
-	(zero 0)
-	str)
-       (())
-     (declare (fixnum last len zero))
-     (setq str (,access-fun ,line-chars ,index))
-     (unless (simple-string-p str) (setq str (funcall str ,xpos)))
-     (setq len (strlen str)  zero 0)
-     (incf ,index)
-     (display-some-chars str zero len ,dest ,xpos ,width ,done-p)
-     (cond ((not ,xpos)
-	    ;; We wrapped in the middle of a losing char.	       
-	    (setq ,underhang zero  ,string str)
-	    (return nil))
-	   ((= ,index last)
-	    ;; No more losing chars in this bunch.
-	    (return nil)))))
-
-(defmacro update-and-punt (dis-line length string underhang end)
-  `(progn (setf (dis-line-length ,dis-line) ,length)
-	  (return (values ,string ,underhang
-			  (setf (dis-line-end ,dis-line) ,end)))))
-
-); eval-when
-
-
-;;; compute-normal-line-image  --  Internal
-;;;
-;;;    Compute the screen representation of Line starting at Start 
-;;; putting it in Dis-Line beginning at Xpos.  Width is the width of the 
-;;; window we are displaying in.  If the line will wrap then we display 
-;;; as many chars as we can then put in *line-wrap-char*.  The values 
-;;; returned are described in Compute-Line-Image, which tail-recursively 
-;;; returns them.  The length slot in Dis-Line is updated.
-;;;
-;;; We use the *losing-character-mask* to break the line to be displayed
-;;; up into chunks of characters with normal print representation and
-;;; those with funny representations.
-;;;
-(defun compute-normal-line-image (line start dis-line xpos width)
-  (declare (fixnum start width) (type (or fixnum null) xpos))
-  (do* ((index start)
-	(line-chars (line-%chars line))
-	(end (strlen line-chars))
-	(dest (dis-line-chars dis-line))
-	(losing 0)
-	underhang string)
-       (())
-    (declare (fixnum index end)
-	     (type (or fixnum null) losing)
-	     (simple-string line-chars dest))
-    (cond
-     (underhang
-      (update-and-punt dis-line width string underhang index))
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ((= index end)
-      (update-and-punt dis-line xpos nil nil index)))
-    (setq losing (%fcwa line-chars index end losing-char))
-    (when (null losing)
-      (display-some-chars line-chars index end dest xpos width t)
-      (if (or xpos (= index end))
-	  (update-and-punt dis-line xpos nil nil index)
-	  (update-and-punt dis-line width nil 0 index)))
-    (display-some-chars line-chars index losing dest xpos width nil)
-    (cond
-     ;; Did we wrap?
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ;; Are we about to cause the line to wrap? If so, wrap before
-     ;; it's too late.
-     ((= xpos width)
-      (setf (char dest (1- width)) *line-wrap-char*)
-      (update-and-punt dis-line width nil 0 index))
-     (t
-      (display-losing-chars line-chars index end dest xpos width string
-			    underhang string-get-rep)))))
-
-
-
-;;; compute-cached-line-image  --  Internal
-;;;
-;;;    Like compute-normal-line-image, only works on the cached line.
-;;;
-(defun compute-cached-line-image (index dis-line xpos width)
-  (declare (fixnum index width) (type (or fixnum null) xpos))
-  (prog ((gap (- (current-right-open-pos) (current-left-open-pos)))
-	 (dest (dis-line-chars dis-line))
-	 (done-p (= (current-right-open-pos) (current-line-cache-length)))
-	 (losing 0)
-	 string underhang)
-    (declare (fixnum gap) (simple-string dest)
-	     (type (or fixnum null) losing))
-   LEFT-LOOP
-    (cond
-     (underhang
-      (update-and-punt dis-line width string underhang index))
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 index))
-     ((>= index (current-left-open-pos))
-      (go RIGHT-START)))
-    (setq losing (%fcwa (current-open-chars) index (current-left-open-pos) losing-char))
-    (cond
-     (losing
-      (display-some-chars (current-open-chars) index losing dest xpos width nil)
-      ;; If we we didn't wrap then display some losers...
-      (if xpos
-	  (display-losing-chars (current-open-chars) index (current-left-open-pos) dest xpos
-				width string underhang string-get-rep
-				(and done-p (= index (current-left-open-pos))))
-	  (update-and-punt dis-line width nil 0 index)))
-     (t
-      (display-some-chars (current-open-chars) index (current-left-open-pos) dest xpos width done-p)))
-    (go LEFT-LOOP)
-
-   RIGHT-START
-    (setq index (+ index gap))
-   RIGHT-LOOP
-    (cond
-     (underhang
-      (update-and-punt dis-line width string underhang (- index gap)))
-     ((null xpos)
-      (update-and-punt dis-line width nil 0 (- index gap)))
-     ((= index (current-line-cache-length))
-      (update-and-punt dis-line xpos nil nil (- index gap))))
-    (setq losing (%fcwa (current-open-chars) index (current-line-cache-length) losing-char))
-    (cond
-     (losing
-      (display-some-chars (current-open-chars) index losing dest xpos width nil)
-      (cond
-       ;; Did we wrap?
-       ((null xpos)
-	(update-and-punt dis-line width nil 0 (- index gap)))
-       (t
-	(display-losing-chars (current-open-chars) index (current-line-cache-length) dest xpos
-			      width string underhang string-get-rep))))
-     (t
-      (display-some-chars (current-open-chars) index (current-line-cache-length) dest xpos width t)))
-    (go RIGHT-LOOP))) 
-
-
-(defun make-some-font-changes ()
-  (do ((res nil (make-font-change res))
-       (i 42 (1- i)))
-      ((zerop i) res)))
-
-(defvar *free-font-changes* (make-some-font-changes)
-  "Font-Change structures that nobody's using at the moment.")
-
-(defmacro alloc-font-change (x font mark)
-  `(progn
-    (unless *free-font-changes*
-      (setq *free-font-changes* (make-some-font-changes)))
-    (let ((new-fc *free-font-changes*))
-      (setq *free-font-changes* (font-change-next new-fc))
-      (setf (font-change-x new-fc) ,x
-	    (font-change-font new-fc) ,font
-	    (font-change-next new-fc) nil
-	    (font-change-mark new-fc) ,mark)
-      new-fc)))
-		     
-;;;
-;;; compute-line-image  --  Internal
-;;;
-;;;    This function builds a full line image from some characters in
-;;; a line and from some characters which may be left over from the previous
-;;; line.
-;;;
-;;; Parameters:
-;;;    String - This is the string which contains the characters left over
-;;; from the previous line.  This is NIL if there are none.
-;;;    Underhang - Characters from here to the end of String are put at the
-;;; beginning of the line image.
-;;;    Line - This is the line to display characters from.
-;;;    Offset - This is the index of the first character to display in Line.
-;;;    Dis-Line - This is the dis-line to put the line-image in.  The only
-;;; slots affected are the chars and the length.
-;;;    Width - This is the width of the field to display in.
-;;;
-;;; Three values are returned:
-;;;    1) The new overhang string, if none this is NIL.
-;;;    2) The new underhang, if this is NIL then the entire line was
-;;; displayed.  If the entire line was not displayed, but there was no
-;;; underhang, then this is 0.
-;;;    3) The index in line after the last character displayed.
-;;;
-(defun compute-line-image (string underhang line offset dis-line width)
-  ;;
-  ;; Release any old font-changes.
-  (let ((changes (dis-line-font-changes dis-line)))
-    (when changes
-      (do ((prev changes current)
-	   (current (font-change-next changes)
-		    (font-change-next current)))
-	  ((null current)
-	   (setf (dis-line-font-changes dis-line) nil)
-	   (shiftf (font-change-next prev) *free-font-changes* changes))
-	(setf (font-change-mark current) nil))))
-  ;;
-  ;; If the line has any Font-Marks, add Font-Changes for them.
-  (let ((marks (line-marks line)))
-    (when (dolist (m marks nil)
-	    (when (fast-font-mark-p m) (return t)))
-      (let ((prev nil))
-	;;
-	;; Find the last Font-Mark with charpos less than Offset.  If there is
-	;; such a Font-Mark, then there is a font-change to this font at X = 0.
-	(let ((max -1)
-	      (max-mark nil))
-	  (dolist (m marks)
-	    (when (fast-font-mark-p m)
-	      (let ((charpos (mark-charpos m)))
-		(when (and (< charpos offset) (> charpos max))
-		  (setq max charpos  max-mark m)))))
-	  (when max-mark
-	    (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
-	    (setf (dis-line-font-changes dis-line) prev)))
-	;;
-	;; Repeatedly scan through marks, adding a font-change for the
-	;; smallest Font-Mark with a charpos greater than Bound, until
-	;; we find no such mark.
-	(do ((bound (1- offset) min)
-	     (min most-positive-fixnum most-positive-fixnum)
-	     (min-mark nil nil))
-	    (())
-	  (dolist (m marks)
-	    (when (fast-font-mark-p m)
-	      (let ((charpos (mark-charpos m)))
-		(when (and (> charpos bound) (< charpos min))
-		  (setq min charpos  min-mark m)))))
-	  (unless min-mark (return nil))
-	  (let ((len (if (current-open-line-p line)
-			 (cached-real-line-length line 10000 offset min)
-			 (real-line-length line 10000 offset min))))
-	    (when (< len width)
-	      (let ((new (alloc-font-change
-			  (+ len
-			     (if string
-				 (- (length (the simple-string string)) underhang)
-				 0))
-			  (font-mark-font min-mark)
-			  min-mark)))
-		(if prev
-		    (setf (font-change-next prev) new)
-		    (setf (dis-line-font-changes dis-line) new))
-		(setq prev new))))))))
-  ;;
-  ;; Recompute the line image.
-  (cond
-   (string
-    (let ((len (strlen string))
-	  (chars (dis-line-chars dis-line))
-	  (xpos 0))
-      (declare (type (or fixnum null) xpos) (simple-string chars))
-      (display-some-chars string underhang len chars xpos width nil)
-      (cond
-       ((null xpos)
-	(values string underhang offset))	   
-       ((current-open-line-p line)
-	(compute-cached-line-image offset dis-line xpos width))
-       (t
- 	(compute-normal-line-image line offset dis-line xpos width)))))
-   ((current-open-line-p line)
-    (compute-cached-line-image offset dis-line 0 width))
-   (t
-    (compute-normal-line-image line offset dis-line 0 width))))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispdep.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispdep.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispdep.lisp	(revision 7844)
@@ -8,9 +8,4 @@
 
 (in-package :hemlock-ext)
-
-#+CLISP
-(progn
-  (setf custom:*FLOATING-POINT-CONTAGION-ANSI* t)
-  (setf custom:*WARN-ON-FLOATING-POINT-CONTAGION* nil))
 
 (defun getenv (name) 
@@ -66,6 +61,2 @@
                 (declare (ignore err))
                 nil)) )
-  
-
-(defmacro without-gcing (&body body)
-  `(progn ,@body))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp	(revision 7844)
@@ -841,5 +841,4 @@
 (defindent "with-input-from-region" 1)
 (defindent "with-output-to-mark" 1)
-(defindent "with-output-to-window" 1)
 (defindent "do-strings" 1)
 (defindent "save-for-undo" 1)
@@ -1993,10 +1992,38 @@
     (with-input-from-region (s (region mark1 mark2))
       (let* ((symbol (read s)))
-	(make-instance 'ccl::sequence-window-controller
-	  :sequence (ccl::callers symbol)
-	  :title (format nil "Callers of ~a" symbol)
-	  :result-callback #'(lambda (item)
-			       (get-def-info-and-go-to-it (symbol-name item)
-							  (symbol-package item))))))))
+	(hemlock-ext:open-sequence-dialog
+	 :title (format nil "Callers of ~a" symbol)
+	 :sequence (ccl::callers symbol)
+	 :action #'edit-definition)))))
+
+;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed. from anywhere,
+;; or it might be called from a sequence dialog, etc.
+(defun edit-definition (name)
+  (let* ((info (ccl::get-source-files-with-types&classes name)))
+    (when (null info)
+      (let* ((seen (list name))
+	     (found ())
+	     (pname (symbol-name name)))
+	(dolist (pkg (list-all-packages))
+	  (let ((sym (find-symbol pname pkg)))
+	    (when (and sym (not (member sym seen)))
+	      (let ((new (ccl::get-source-files-with-types&classes sym)))
+		(when new
+		  (setq info (append new info))
+		  (push sym found)))
+	      (push sym seen))))
+	(when found
+	  ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
+	  (loud-message "No definitions for ~s, using ~s instead"
+			name (if (cdr found) found (car found))))))
+    (if info
+      (if (cdr info)
+	(hemlock-ext:open-sequence-dialog
+	 :title (format nil "Definitions of ~s" name)
+	 :sequence info
+	 :action #'(lambda (item) (hemlock-ext:edit-single-definition name item))
+	 :printer #'(lambda (item stream) (prin1 (car item) stream)))
+        (hemlock-ext:edit-single-definition name (car info)))
+      (editor-error "No known definitions for ~s" name))))
 
 #||
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp	(revision 7844)
@@ -28,5 +28,5 @@
   (declare (ignore name new-value))
   (if (eq kind :buffer)
-    (hi::queue-buffer-change where)))
+    (hi::note-modeline-change where)))
 
 (define-file-option "Package" (buffer value)
@@ -103,5 +103,5 @@
       )
     (let* ((input-mark (variable-value 'buffer-input-mark :buffer buffer)))
-      (when gui::*read-only-listener*
+      (when (hemlock-ext:read-only-listener-p)
 	(setf (hi::buffer-protected-region buffer)
 	      (region (buffer-start-mark buffer) input-mark)))
@@ -508,18 +508,16 @@
 
 (defun macroexpand-expression (expander)
-  (let* ((out (hi::top-listener-output-stream)))
-    (when out
-      (let* ((point (buffer-point (current-buffer)))
-             (region (if (region-active-p)
-                       (current-region)
-                       (with-mark ((start point))
-                         (pre-command-parse-check start)
-                         (with-mark ((end start))
-                           (unless (form-offset end 1) (editor-error))
-                           (region start end)))))
-             (expr (with-input-from-region (s region)
-                           (read s))))
-        (let* ((*print-pretty* t))
-          (format out "~&~s~&" (funcall expander expr)))))))
+  (let* ((point (buffer-point (current-buffer)))
+	 (region (if (region-active-p)
+		   (current-region)
+		   (with-mark ((start point))
+		     (pre-command-parse-check start)
+		     (with-mark ((end start))
+		       (unless (form-offset end 1) (editor-error))
+		       (region start end)))))
+	 (expr (with-input-from-region (s region)
+		 (read s))))
+    (let* ((*print-pretty* t))
+      (format t "~&~s~&" (funcall expander expr)))))
 
 (defcommand "Editor Macroexpand-1 Expression" (p)
@@ -566,26 +564,4 @@
 
 
-;;; With-Output-To-Window  --  Internal
-;;;
-;;;
-(defmacro with-output-to-window ((stream name) &body forms)
-  "With-Output-To-Window (Stream Name) {Form}*
-  Bind Stream to a stream that writes into the buffer named Name a la
-  With-Output-To-Mark.  The buffer is created if it does not exist already
-  and a window is created to display the buffer if it is not displayed.
-  For the duration of the evaluation this window is made the current window."
-  (let ((nam (gensym)) (buffer (gensym)) (point (gensym)) 
-	(window (gensym)) (old-window (gensym)))
-    `(let* ((,nam ,name)
-	    (,buffer (or (getstring ,nam *buffer-names*) (make-buffer ,nam)))
-	    (,point (buffer-end (buffer-point ,buffer)))
-	    (,window (or (car (buffer-windows ,buffer)) (make-window ,point)))
-	    (,old-window (current-window)))
-       (unwind-protect
-	 (progn (setf (current-window) ,window)
-		(buffer-end ,point)
-		(with-output-to-mark (,stream ,point) ,@forms))
-	 (setf (current-window) ,old-window)))))
-
 (defcommand "Editor Compile File" (p)
   "Prompts for file to compile in the editor Lisp.  Does not compare source
@@ -597,6 +573,5 @@
 			     (buffer-default-pathname (current-buffer))
 			     :prompt "File to compile: ")))
-    (with-output-to-window (*error-output* "Compiler Warnings")
-      (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))
+    (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
 
 
@@ -627,6 +602,5 @@
 				    (namestring pn))))
 	     (write-buffer-file buf pn)
-	     (with-output-to-window (*error-output* "Compiler Warnings")
-	       (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))
+	     (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
 	  ((older-or-non-existent-fasl-p pn p)
 	   (when (or (not (value compile-buffer-file-confirm))
@@ -634,6 +608,5 @@
 		      :default t :default-string "Y"
 		      :prompt (list "Compile file ~A? " (namestring pn))))
-	     (with-output-to-window (*error-output* "Compiler Warnings")
-	       (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))
+	     (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))
 	  (t (when (or p
 		       (prompt-for-y-or-n
@@ -641,6 +614,5 @@
 			:prompt
 			"Fasl file up to date, compile source anyway? "))
-	       (with-output-to-window (*error-output* "Compiler Warnings")
-		 (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil))))))))
+	       (in-lisp (compile-file (namestring pn) #+cmu :error-file #+cmu nil)))))))
 
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp	(revision 7844)
@@ -493,4 +493,18 @@
 ;;;; Stuff from here on is implementation dependant.
 
+(defvar *saved-standard-output* nil)
+
+(defmacro with-output-to-listener (&body body)
+  `(let* ((*saved-standard-output* (or *saved-standard-output*
+				       (cons *standard-output* *error-output*)))
+	  (*standard-output* (hemlock-ext:top-listener-output-stream))
+	  (*error-output* *standard-output*))
+     ,@body))
+
+(defmacro with-standard-standard-output (&body body)
+  `(let* ((*standard-output* (or (car *saved-standard-output*) *standard-output*))
+	  (*error-output* (or (cdr *saved-standard-output*) *error-output*)))
+     ,@body))
+
 
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp	(revision 7844)
@@ -58,6 +58,4 @@
   (%init-syntax-table)
   ;;
-  ;; Define print representations for funny characters.
-  (%init-line-image)
   (setq *hemlock-initialized* t))
 
@@ -255,26 +253,4 @@
 	 *after-editor-initializations-funs*))
 
-(defun maybe-load-hemlock-init (init)
-  (when init
-    (let* ((switch #+NILGB (find "hinit" *command-line-switches*
-			 :test #'string-equal
-			 :key #'cmd-switch-name))
-	   (spec-name
-	    (if (not (eq init t))
-		init
-		(and switch
-		     (or (cmd-switch-value switch)
-			 (car (cmd-switch-words switch))))))
-           (home (user-homedir-pathname)))
-      (when home
-        (if spec-name
-            (load (merge-pathnames spec-name home) :if-does-not-exist nil)
-            (or (load (merge-pathnames (make-pathname :name "hemlock-init") home)
-                      :if-does-not-exist nil)
-                (load (merge-pathnames (make-pathname :name ".hemlock-init") home)
-                      :if-does-not-exist nil)))))))
-
-
-
 ;;;; SAVE-ALL-BUFFERS.
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp	(revision 7844)
@@ -42,6 +42,5 @@
 
 
-(declaim (inline modeline-field-name modeline-field-width
-		 modeline-field-function))
+(declaim (inline modeline-field-name modeline-field-width modeline-field-function))
 
 (defun modeline-field-name (ml-field)
@@ -64,30 +63,7 @@
 (declaim (special *buffer-list*))
 
-(defun %set-modeline-field-width (ml-field width)
-  (check-type ml-field modeline-field)
-  (unless (or (eq width nil) (and (integerp width) (plusp width)))
-    (error "Width must be nil or a positive integer."))
-  (unless (eql width (modeline-field-%width ml-field))
-    (setf (modeline-field-%width ml-field) width)
-    (dolist (b *buffer-list*)
-      (when (buffer-modeline-field-p b ml-field)
-	(dolist (w (buffer-windows b))
-	  (update-modeline-fields b w)))))
-  width)
-  
 (defun modeline-field-function (ml-field)
   "Returns the function of a modeline field object.  It returns a string."
   (modeline-field-%function ml-field))
-
-(defun %set-modeline-field-function (ml-field function)
-  (check-type ml-field modeline-field)
-  (check-type function (or symbol function))
-  (setf (modeline-field-%function ml-field) function)
-  (dolist (b *buffer-list*)
-    (when (buffer-modeline-field-p b ml-field)
-      (dolist (w (buffer-windows b))
-	(update-modeline-field b w ml-field))))
-  function)
-
 
 
@@ -178,9 +154,8 @@
   (declare (ignore name new-value))
   (if (eq kind :buffer)
-      (hi::queue-buffer-change where)
-      (dolist (buffer *buffer-list*)
-	(when (and (buffer-modeline-field-p buffer :buffer-pathname)
-		   (buffer-windows buffer))
-	  (hi::queue-buffer-change buffer)))))
+    (note-modeline-change where)
+    (dolist (buffer *buffer-list*)
+      (when (buffer-modeline-field-p buffer :buffer-pathname)
+	(note-modeline-change buffer)))))
 
 (defun buffer-pathname-ml-field-fun (buffer window)
@@ -244,15 +219,14 @@
 
 (defun %init-mode-redisplay ()
-  (add-hook hemlock::buffer-major-mode-hook 'queue-buffer-change)
-  (add-hook hemlock::buffer-minor-mode-hook 'queue-buffer-change)
-  (add-hook hemlock::buffer-name-hook 'queue-buffer-change)
-  (add-hook hemlock::buffer-pathname-hook 'queue-buffer-change)
+  (add-hook hemlock::buffer-major-mode-hook 'note-modeline-change)
+  (add-hook hemlock::buffer-minor-mode-hook 'note-modeline-change)
+  (add-hook hemlock::buffer-name-hook 'note-modeline-change)
+  (add-hook hemlock::buffer-pathname-hook 'note-modeline-change)
   ;; (SETF (BUFFER-MODIFIED ...)) handles updating the modeline;
   ;; it only wants to do so if the buffer's modified state changes.
-;  (add-hook hemlock::buffer-modified-hook 'queue-buffer-change)
+;  (add-hook hemlock::buffer-modified-hook 'note-modeline-change)
 )
 
-(defun queue-buffer-change (buffer &optional something-else another-else)
-  (declare (ignore something-else another-else))
-  (dolist (w (buffer-windows buffer))
-    (invalidate-modeline w)))
+(defun note-modeline-change (buffer &rest more)
+  (declare (ignore more))
+  (hemlock-ext:invalidate-modeline buffer))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp	(revision 7844)
@@ -423,5 +423,5 @@
 	     (page-offset point p))
 	    (t (goto-page point p)))
-    (line-start (move-mark (window-display-start (current-window)) point))))
+    (hemlock-ext:scroll-mark-to-top point)))
 
 (defun goto-page (mark i)
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp	(revision 7844)
@@ -85,5 +85,4 @@
    #:buffer-variables
    #:buffer-modes
-   #:buffer-windows
    #:buffer-delete-hook
    #:buffer-package
@@ -97,5 +96,4 @@
    #:buffer-modeline-fields
    #:buffer-modeline-field-p
-   #:update-modeline-fields
    #:update-modeline-field
    #:insert-character
@@ -185,22 +183,7 @@
    #:character-attribute-hooks
    #:make-window
-   #:windowp
    #:delete-window
-   #:window-display-start
-   #:window-display-end
-   #:window-display-recentering
-   #:window-point
-   #:center-window
-   #:scroll-window
-   #:displayed-p
-   #:window-height
-   #:window-width
    #:next-window
    #:previous-window
-   #:mark-to-cursorpos
-   #:cursorpos-to-mark
-   #:last-key-event-cursorpos
-   #:mark-column
-   #:move-to-column
    #:show-mark
    #:redisplay
@@ -237,6 +220,4 @@
    #:pause-hemlock
    #:clear-editor-input
-   #:listen-editor-input
-   #:editor-sleep
    #:make-hemlock-output-stream
    #:hemlock-output-stream-p
@@ -329,48 +310,55 @@
    #:file-comment
    #:without-interrupts
-   #:without-gcing
    #:define-setf-method
    #:getenv
-
    #:delq #:memq #:assq
    #:fixnump
    #:file-writable
      
-   #:define-keysym #:define-mouse-keysym #:name-keysym #:keysym-names
-   #:keysym-preferred-name #:define-key-event-modifier #:define-clx-modifier
-   #:make-key-event-bits #:key-event-modifier-mask #:key-event-bits-modifiers
-   #:*all-modifier-names* #:translate-key-event #:translate-mouse-key-event
-   #:make-key-event #:key-event #:key-event-p #:key-event-bits #:key-event-keysym
-   #:char-key-event #:key-event-char #:key-event-bit-p #:do-alpha-key-events
-   #:print-pretty-key #:print-pretty-key-event
+   ;; key-event.lisp
+   #:define-keysym
+   #:define-mouse-keysym
+   #:name-keysym
+   #:keysym-names
+   #:keysym-preferred-name
+   #:define-key-event-modifier
+   #:define-modifier-bit
+   #:make-key-event-bits
+   #:key-event-modifier-mask
+   #:key-event-bits-modifiers
+   #:*all-modifier-names*
+   #:translate-key-event
+   #:translate-mouse-key-event
+   #:make-key-event
+   #:key-event
+   #:key-event-p
+   #:key-event-bits
+   #:key-event-keysym
+   #:char-key-event
+   #:key-event-char
+   #:key-event-bit-p
+   #:do-alpha-key-events
+   #:print-pretty-key
+   #:print-pretty-key-event
 
    ;; hemlock-ext.lisp
-   #:disable-clx-event-handling
-   #:quit
-   #:serve-event
-   #:sap-ref-8
-   #:make-object-set
-   #:default-clx-event-handler
-   #:serve-exposure
-   #:serve-graphics-exposure
-   #:serve-no-exposure
-   #:serve-configure-notify
-   #:serve-destroy-notify
-   #:serve-unmap-notify
-   #:serve-map-notify
-   #:serve-reparent-notify
-   #:serve-gravity-notify
-   #:serve-circulate-notify
-   #:serve-client-message
-   #:serve-key-press
-   #:serve-button-press
-   #:serve-button-release
-   #:serve-enter-notify
-   #:serve-leave-notify
-   #:flush-display-events
-   #:object-set-event-handler
-   #:with-clx-event-handling
    #:complete-file
-   #:default-directory))
+   #:default-directory
+
+   ;; defined externally (i.e. used by but not defined in hemlock)
+   #:note-selection-set-by-search
+   #:center-selection-in-view
+   #:scroll-mark-to-top
+   #:scroll-view
+   #:report-hemlock-error
+   #:top-listener-output-stream
+   #:invalidate-modeline
+   #:note-buffer-saved
+   #:note-buffer-unsaved
+   #:read-only-listener-p
+   #:visible-buffers
+   #:open-sequence-dialog
+   #:edit-single-definition
+   ))
 
 (defpackage :hemlock-internals
@@ -412,5 +400,5 @@
    
    ;; rompsite.lisp
-   #:show-mark #:editor-sleep #:fun-defined-from-pathname
+   #:show-mark #:fun-defined-from-pathname
    #:editor-describe-function #:pause-hemlock #:store-cut-string
    #:fetch-cut-string #:schedule-event #:remove-scheduled-event
@@ -424,16 +412,14 @@
 
    ;; 
-   #:mark #:mark-line #:mark-charpos #:markp #:region #:region-start #:region-end
+   #:mark #:mark-line #:mark-charpos #:mark-column #:markp #:region #:region-start #:region-end
    #:regionp #:buffer #:bufferp #:buffer-modes #:buffer-point #:buffer-writable
-   #:buffer-delete-hook #:buffer-windows #:buffer-variables #:buffer-write-date
-   #:region #:regionp #:region-start #:region-end #:window #:windowp #:window-height
-   #:window-width #:window-display-start #:window-display-end #:window-point
-   #:window-display-recentering #:commandp #:command #:command-function
+   #:buffer-delete-hook #:buffer-variables #:buffer-write-date
+   #:region #:regionp #:region-start #:region-end
+   #:commandp #:command #:command-function
    #:command-documentation #:modeline-field #:modeline-field-p
 
    ;; from input.lisp
-   #:clear-editor-input #:listen-editor-input
-   #:last-key-event-typed #:*key-event-history*
-   #:input-waiting #:last-key-event-cursorpos
+   #:clear-editor-input
+   #:*key-event-history* #:input-waiting
 
    ;; from macros.lisp
@@ -445,5 +431,6 @@
 
    ;; from views.lisp
-   #:hemlock-view #:current-prefix-argument-state
+   #:hemlock-view #:current-view
+   #:current-prefix-argument-state #:last-key-event-typed #:last-char-typed
    #:abort-to-toplevel #:abort-current-command
 
@@ -479,8 +466,4 @@
    ;; charmacs.lisp
    #:syntax-char-code-limit #:search-char-code-limit #:do-alpha-chars
-
-   ;; cursor.lisp
-   #:mark-to-cursorpos #:center-window #:displayed-p #:scroll-window
-   #:mark-column #:cursorpos-to-mark #:move-to-column
 
    ;; display.lisp
@@ -552,5 +535,5 @@
    #:*global-variable-names* #:*mode-names* #:*buffer-names*
    #:*character-attribute-names* #:*command-names* #:*buffer-list*
-   #:*window-list* #:last-key-event-typed #:after-editor-initializations
+   #:after-editor-initializations
 
    ;; screen.lisp
@@ -582,7 +565,7 @@
    ;; window.lisp
    #:modeline-field-width
-   #:modeline-field-function #:make-modeline-field #:update-modeline-fields
+   #:modeline-field-function #:make-modeline-field
    #:update-modeline-field #:modeline-field-name #:modeline-field
-   #:editor-finish-output #:*window-list*
+   #:editor-finish-output
 
    ))
@@ -590,71 +573,7 @@
 
 (defpackage :hemlock
-  (:use :common-lisp :hemlock-interface :hi :hemlock-ext)
-;;;  (:import-from :hemlock-ext #:delq #:memq #:assq)
-;;;  (:import-from :hemlock-internals #:*fast*)
+  (:use :common-lisp :hemlock-interface :hemlock-internals :hemlock-ext)
   (:shadowing-import-from #:hemlock-ext
 			  #:char-code-limit)
-  ;;  #+cmu
-  ;; These are defined in EXTENSONS package in CMUCL
-  (:shadowing-import-from :hemlock-ext
-   #:*ALL-MODIFIER-NAMES*
-   #:ASSQ
-   #:CHAR-KEY-EVENT
-   #:DEFAULT-CLX-EVENT-HANDLER
-   #:DEFAULT-DIRECTORY
-   #:DEFINE-CLX-MODIFIER
-   #:DEFINE-KEY-EVENT-MODIFIER
-   #:DEFINE-KEYSYM
-   #:DEFINE-MOUSE-KEYSYM
-   #:DELQ
-   #:DISABLE-CLX-EVENT-HANDLING
-   #:DO-ALPHA-KEY-EVENTS
-   #:FILE-WRITABLE
-   #:FIXNUMP
-   #:FLUSH-DISPLAY-EVENTS
-   #:KEY-EVENT
-   #:KEY-EVENT-BIT-P
-   #:KEY-EVENT-BITS
-   #:KEY-EVENT-BITS-MODIFIERS
-   #:KEY-EVENT-CHAR
-   #:KEY-EVENT-KEYSYM
-   #:KEY-EVENT-MODIFIER-MASK
-   #:KEY-EVENT-P
-   #:KEYSYM-NAMES
-   #:KEYSYM-PREFERRED-NAME
-   #:MAKE-KEY-EVENT
-   #:MAKE-KEY-EVENT-BITS
-   #:MEMQ
-   #:NAME-KEYSYM
-   #:OBJECT-SET-EVENT-HANDLER
-   #:PRINT-PRETTY-KEY
-   #:PRINT-PRETTY-KEY-EVENT
-   #:QUIT
-   #:SERVE-BUTTON-PRESS
-   #:SERVE-BUTTON-RELEASE
-   #:SERVE-CIRCULATE-NOTIFY
-   #:SERVE-CLIENT-MESSAGE
-   #:SERVE-CONFIGURE-NOTIFY
-   #:SERVE-DESTROY-NOTIFY
-   #:SERVE-ENTER-NOTIFY
-   #:SERVE-EXPOSURE
-   #:SERVE-GRAPHICS-EXPOSURE
-   #:SERVE-GRAVITY-NOTIFY
-   #:SERVE-KEY-PRESS
-   #:SERVE-LEAVE-NOTIFY
-   #:SERVE-MAP-NOTIFY
-   #:SERVE-NO-EXPOSURE
-   #:SERVE-REPARENT-NOTIFY
-   #:SERVE-UNMAP-NOTIFY
-
-   ;; These four are from SYSTEM package
-   #:MAKE-OBJECT-SET
-   #:SAP-REF-8
-   #:SERVE-EVENT
-   #:WITHOUT-INTERRUPTS
-
-   #:TRANSLATE-KEY-EVENT
-   #:TRANSLATE-MOUSE-KEY-EVENT
-   #:WITH-CLX-EVENT-HANDLING)
   )
 
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/pop-up-stream.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/pop-up-stream.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/pop-up-stream.lisp	(revision 7844)
@@ -18,22 +18,6 @@
 
 
-
-
-;;;; Line-buffered Stream Methods.
-
-;; ###GB we want a more optimized interface
-
 (defmethod stream-write-char ((stream random-typeout-stream) char)
-  (with-slots (line-buffered-p) stream
-    (cond (line-buffered-p
-           (insert-character (random-typeout-stream-mark stream) char)
-           (when (and (char= char #\newline)
-                      (not (random-typeout-stream-no-prompt stream)))
-             (funcall (device-random-typeout-line-more
-                       (device-hunk-device
-                        (window-hunk (random-typeout-stream-window stream))))
-                      stream 1)))
-          (t
-           (insert-character (random-typeout-stream-mark stream) char)))))             
+  (insert-character (random-typeout-stream-mark stream) char))
 
 (defmethod stream-write-string ((stream random-typeout-stream) string &optional start end)
@@ -42,23 +26,8 @@
   (unless (and (eql start 0) (eql end (length string)))
     (setq string (subseq string start end)))
-  (with-slots (line-buffered-p) stream
-    (cond (line-buffered-p
-           (insert-string (random-typeout-stream-mark stream) string)
-           (unless (random-typeout-stream-no-prompt stream)
-             (let ((count (count #\newline string)))
-               (when count
-                 (funcall (device-random-typeout-line-more
-                           (device-hunk-device
-                            (window-hunk (random-typeout-stream-window stream))))
-                          stream count)))))
-          (t
-           (insert-string (random-typeout-stream-mark stream) string)))))
+  (insert-string (random-typeout-stream-mark stream) string))
 
 (defmethod stream-finish-output ((stream random-typeout-stream))
-  (with-slots (line-buffered-p) stream
-    (cond (line-buffered-p
-           (random-typeout-redisplay (random-typeout-stream-window stream)))
-          (t
-           nil))))
+  nil)
 
 (defmethod stream-force-output ((stream random-typeout-stream))
@@ -67,76 +36,2 @@
 (defmethod stream-line-column ((stream random-typeout-stream))
   (mark-charpos (random-typeout-stream-mark stream)))
-
-;;; Bitmap line-buffered support.
-
-;;; UPDATE-BITMAP-LINE-BUFFERED-STREAM is called when anything is written to
-;;; a line-buffered-random-typeout-stream on the bitmap.  It does a lot of
-;;; checking to make sure that strings of characters longer than the width of
-;;; the window don't screw us.  The code is a little wierd, so a brief
-;;; explanation is below.
-;;;
-;;; The more-mark is how we tell when we will next need to more.  Each time
-;;; we do a more-prompt, we point the mark at the last visible character in
-;;; the random typeout window.  That way, when the mark is no longer
-;;; DISPLAYED-P, we know it's time to do another more prompt.
-;;;
-;;; If the buffer-end-mark is DISPLAYED-P, then we return, only redisplaying
-;;; if there was at least one newline in the last batch of output.  If we
-;;; haven't done a more prompt yet (indicated by a value of T for
-;;; first-more-p), then since we know the end of the buffer isn't visible, we
-;;; need to do a more-prompt.  If neither of the first two tests returns T,
-;;; then we can only need to do a more-prompt if our more-mark has scrolled
-;;; off the top of the screen.  If it hasn't, everything is peechy-keen, so
-;;; we scroll the screen one line and redisplay.
-;;;
-(defun update-bitmap-line-buffered-stream (stream newline-count)
-  (let* ((window (random-typeout-stream-window stream))
-	 (count 0))
-    (when (plusp newline-count) (random-typeout-redisplay window))
-    (loop
-      (cond ((no-text-past-bottom-p window)
-	     (return))
-	    ((or (random-typeout-stream-first-more-p stream)
-		 (not (displayed-p (random-typeout-stream-more-mark stream)
-				   window)))
-	     (do-bitmap-more-prompt stream)
-	     (return))
-	    (t
-	     (scroll-window window 1)
-	     (random-typeout-redisplay window)))
-      (when (= (incf count) newline-count) (return)))))
-
-;;; NO-TEXT-PAST-BOTTOM-P determines whether there is text left to be displayed
-;;; in the random-typeout window.  It does this by first making sure there is a
-;;; line past the WINDOW-DISPLAY-END of the window.  If there is, this line
-;;; must be empty, and BUFFER-END-MARK must be on this line.  The final test is
-;;; that the window-end is displayed within the window.  If it is not, then the
-;;; last line wraps past the end of the window, and there is text past the
-;;; bottom.
-;;;
-;;; Win-end is bound after the call to DISPLAYED-P because it updates the
-;;; window's image moving WINDOW-DISPLAY-END.  We want this updated value for
-;;; the display end.
-;;;
-(defun no-text-past-bottom-p (window)
-  (let* ((window-end (window-display-end window))
-	 (window-end-displayed-p (displayed-p window-end window)))
-    (with-mark ((win-end window-end))
-      (let ((one-after-end (line-offset win-end 1)))
-	(if one-after-end
-	    (and (empty-line-p win-end)
-		 (same-line-p win-end (buffer-end-mark (window-buffer window)))
-		 window-end-displayed-p)
-	    window-end-displayed-p)))))
-
-(defun reset-more-mark (stream)
-  (let* ((window (random-typeout-stream-window stream))
-	 (more-mark (random-typeout-stream-more-mark stream))
-	 (end (window-display-end window)))
-    (move-mark more-mark end)
-    (unless (displayed-p end window) (character-offset more-mark -1))))
-
-
-
-
-
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp	(revision 7844)
@@ -31,7 +31,7 @@
   "Used with Ring-Push and friends to implement ring buffers."
   (first -1 :type fixnum)	   ;The index of the first position used.
-  (bound (required-argument) :type fixnum)   ;The index after the last element.
-  delete-function ;The function  to be called on deletion. 
-  (vector (required-argument) :type simple-vector) ;The vector.
+  (bound -1 :type fixnum)          ;The index after the last element.
+  delete-function                  ;The function  to be called on deletion. 
+  (vector #() :type simple-vector) ;The vector.
   (lock (ccl:make-lock)))
                          
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp	(revision 7844)
@@ -62,7 +62,5 @@
   (defhvar "Reverse Video"
     "Paints white on black in window bodies, black on white in modelines."
-    :value nil
-    #+clx
-    :hooks #+clx '(reverse-video-hook-fun))
+    :value nil)
   (defhvar "Enter Window Hook"
     "When the mouse enters an editor window, this hook is invoked.  These
@@ -140,5 +138,4 @@
 
 (declaim (declaration values))
-(declaim (special *default-font-family*))
 
 ;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would
@@ -162,11 +159,4 @@
 (defvar *line-wrap-char* #\!
   "The character to be displayed to indicate wrapped lines.")
-
-
-
-;;;; Current terminal character translation.
-
-(defvar termcap-file "/etc/termcap")
-
 
 
@@ -274,20 +264,4 @@
   "Removes function queued with SCHEDULE-EVENT."
   (setf *time-queue* (delete function *time-queue* :key #'tq-event-function)))
-
-
-
-
-;;;; Editor sleeping.
-
-(defun editor-sleep (time)
-  "Sleep for approximately Time seconds."
-  (unless (or (zerop time) (listen-editor-input *editor-input*))
-    ;(internal-redisplay)
-    (sleep-for-time time)
-    nil))
-
-(defun sleep-for-time (time)
-  (timed-wait-for-key-event *editor-input* time))
-
 
 
@@ -336,5 +310,6 @@
 
 (defvar *editor-describe-stream*
-  (#+CMU system:make-indenting-stream #-CMU progn *standard-output*))
+  #+CMU (system:make-indenting-stream *standard-output*)
+  #-CMU *standard-output*)
 
 ;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp	(revision 7844)
@@ -41,4 +41,6 @@
 
 
+(defun note-current-selection-set-by-search ()
+  (hemlock-ext:note-selection-set-by-search (current-buffer)))
 
 
@@ -62,5 +64,5 @@
 	       (character-offset point won)
                (push-buffer-mark mark t)
-	       (hi::note-selection-set-by-search))
+	       (note-current-selection-set-by-search))
 	  (t (delete-mark mark)
 	     (editor-error)))
@@ -83,5 +85,5 @@
 	       (character-offset mark won)
 	       (push-buffer-mark mark t)
-	       (hi::note-selection-set-by-search))
+	       (note-current-selection-set-by-search))
 	  (t (delete-mark mark)
 	     (editor-error)))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp	(revision 7844)
@@ -36,4 +36,8 @@
   A mark's character position is the index within the line of the character
   following the mark.")
+
+;; This used to return window position, but for now that's disabled.
+(defun mark-column (mark)
+  (mark-charpos mark))
 
 (defstruct (font-mark (:print-function
@@ -108,5 +112,4 @@
   variables		      ; string-table of local variables
   write-date		      ; File-Write-Date for pathname.
-  display-start		      ; Window display start when switching to buf.
   %modeline-fields	      ; List of modeline-field-info's.
   (delete-hook nil)	      ; List of functions to call upon deletion.
@@ -129,6 +132,4 @@
 (setf (documentation 'buffer-point 'function)
   "Return the mark that is the current focus of attention in a buffer.")
-(setf (documentation 'buffer-windows 'function)
-  "Return the list of windows that are displaying a given buffer.")
 (setf (documentation 'buffer-variables 'function)
   "Return the string-table of the variables local to the specifed buffer.")
@@ -216,99 +217,4 @@
 
 
-
-
-;#+clx
-(progn
-;;;; Windows, dis-lines, and font-changes.
-
-;;; The window object:
-;;;
-  (defstruct (window (:constructor internal-make-window)
-                     (:predicate windowp)
-                     (:copier nil)
-                     (:print-function %print-hwindow))
-    "This structure implements a Hemlock window."
-    tick				; The last time this window was updated.
-    %buffer			; buffer displayed in this window.
-    height			; Height of window in lines.
-    width				; Width of the window in characters.
-    old-start			; The charpos of the first char displayed.
-    first-line			; The head of the list of dis-lines.
-    last-line			; The last dis-line displayed.
-    first-changed			; The first changed dis-line on last update.
-    last-changed			; The last changed dis-line.
-    spare-lines			; The head of the list of unused dis-lines
-    (old-lines 0)			; Slot used by display to keep state info
-    hunk				; The device hunk that displays this window.
-    display-start			; first character position displayed
-    display-end			; last character displayed
-    point				; Where the cursor is in this window.  
-    modeline-dis-line		; Dis-line for modeline display.
-    modeline-buffer		; Complete string of all modeline data.
-    modeline-buffer-len		; Valid chars in modeline-buffer.
-    display-recentering)		; Tells whether redisplay recenters window
-                                        ;    regardless of whether it is current.
-
-  (setf (documentation 'windowp 'function)
-        "Returns true if its argument is a Hemlock window object, Nil otherwise.")
-  (setf (documentation 'window-height 'function)
-        "Return the height of a Hemlock window in character positions.")
-  (setf (documentation 'window-width 'function)
-        "Return the width of a Hemlock window in character positions.")
-  (setf (documentation 'window-display-start 'function)
-        "Return the mark which points before the first character displayed in
-   the supplied window.")
-  (setf (documentation 'window-display-end 'function)
-        "Return the mark which points after the last character displayed in
-   the supplied window.")
-  (setf (documentation 'window-point 'function)
-        "Return the mark that points to where the cursor is displayed in this
-  window.  When the window is made current, the Buffer-Point of this window's
-  buffer is moved to this position.  While the window is current, redisplay
-  makes this mark point to the same position as the Buffer-Point of its
-  buffer.")
-  (setf (documentation 'window-display-recentering 'function)
-        "This determines whether redisplay recenters window regardless of whether it
-  is current.  This is SETF'able.")
-
-  (defstruct (window-dis-line (:copier nil)
-                              (:constructor make-window-dis-line (chars))
-                              (:conc-name dis-line-))
-    chars			      ; The line-image to be displayed.
-    (length 0 :type fixnum)     ; Length of line-image.
-    font-changes                ; Font-Change structures for changes in this line.
-    old-chars		      ; Line-Chars of line displayed.
-    line			      ; Line displayed.
-    (flags 0 :type fixnum)      ; Bit flags indicate line status.
-    (delta 0 :type fixnum)      ; # lines moved from previous position.
-    (position 0 :type fixnum)   ; Line # to be displayed on.
-    (end 0 :type fixnum))	      ; Index after last logical character displayed.
-
-  (defstruct (font-change (:copier nil)
-                          (:constructor make-font-change (next)))
-    x			      ; X position that change takes effect.
-    font			      ; Index into font-map of font to use.
-    next			      ; The next Font-Change on this dis-line.
-    mark)			      ; Font-Mark responsible for this change.
-
-
-
-
-;;;; Font family.
-
-  (defstruct font-family
-    map			; Font-map for hunk.
-    height		; Height of char box includung VSP.
-    width			; Width of font.
-    baseline		; Pixels from top of char box added to Y.
-    cursor-width		; Pixel width of cursor.
-    cursor-height		; Pixel height of cursor.
-    cursor-x-offset	; Added to pos of UL corner of char box to get
-    cursor-y-offset)	; UL corner of cursor blotch.
-
-  )
-
-
-
 ;;;; Attribute descriptors.
 
@@ -361,22 +267,5 @@
                  :initform nil
                  :accessor random-typeout-stream-mark
-                 :documentation "The buffer point of the associated buffer.")
-   (window       :initarg :window
-                 :initform nil
-                 :accessor random-typeout-stream-window
-                 :documentation "The hemlock window all this shit is in.")
-   (more-mark    :initarg :more-mark
-                 :initform nil
-                 :accessor random-typeout-stream-more-mark
-                 :documentation "The mark that is not displayed when we need to more.")
-   (no-prompt    :initarg :no-prompt
-                 :initform nil
-                 :accessor random-typeout-stream-no-prompt
-                 :documentation "T when we want to exit, still collecting output.")
-   (first-more-p :initarg :first-more-p
-                 :initform t
-                 :accessor random-typeout-stream-first-more-p
-                 :documentation "T until the first time we more. Nil after.")
-   (line-buffered-p :documentation "whether line buffered") ))
+                 :documentation "The buffer point of the associated buffer.")))
 
 (defun make-random-typeout-stream (mark)
@@ -390,148 +279,4 @@
              (mark-buffer (random-typeout-stream-mark object))))))
 
-
-
-;;;; Redisplay devices.
-
-;;; Devices contain monitor specific redisplay methods referenced by
-;;; redisplay independent code.
-;;;
-(defstruct (device (:print-function print-device)
-		   (:constructor %make-device))
-  name			; simple-string such as "concept" or "lnz".
-  init			; fun to call whenever going into the editor.
-			; args: device
-  exit			; fun to call whenever leaving the editor.
-			; args: device
-  smart-redisplay	; fun to redisplay a window on this device.
-			; args: window &optional recenterp
-  dumb-redisplay	; fun to redisplay a window on this device.
-			; args: window &optional recenterp
-  after-redisplay	; args: device
-			; fun to call at the end of redisplay entry points.
-  clear			; fun to clear the entire display.
-			; args: device
-  note-read-wait	; fun to somehow note on display that input is expected.
-			; args: on-or-off
-  put-cursor		; fun to put the cursor at (x,y) or (column,line).
-			; args: hunk &optional x y
-  show-mark		; fun to display the screens cursor at a certain mark.
-			; args: window x y time
-  next-window		; funs to return the next and previous window
-  previous-window	;    of some window.
-			; args: window
-  make-window		; fun to make a window on the screen.
-			; args: device start-mark
-			;       &optional modeline-string modeline-function
-  delete-window		; fun to remove a window from the screen.
-			; args: window
-  random-typeout-setup	; fun to prepare for random typeout.
-  			; args: device n
-  random-typeout-cleanup; fun to clean up after random typeout.
-  			; args: device degree
-  random-typeout-line-more ; fun to keep line-buffered streams up to date.
-  random-typeout-full-more ; fun to do full-buffered  more-prompting.
-			   ; args: # of newlines in the object just inserted
-			   ;    in the buffer.
-  force-output		; if non-nil, fun to force any output possibly buffered.
-  finish-output		; if non-nil, fun to force output and hand until done.
-  			; args: device window
-  beep			; fun to beep or flash the screen.
-  bottom-window-base    ; bottom text line of bottom window.
-  hunks)		; list of hunks on the screen.
-
-(defun print-device (obj str n)
-  (declare (ignore n))
-  (format str "#<Hemlock Device ~S>" (device-name obj)))
-
-
-(defstruct (bitmap-device #|(:print-function print-device)|#
-			  (:include device))
-  display)		      ; CLX display object.
-
-
-(defstruct (tty-device #|(:print-function print-device)|#
-		       (:constructor %make-tty-device)
-		       (:include device))
-  dumbp			; t if it does not have line insertion and deletion.
-  lines			; number of lines on device.
-  columns		; number of columns per line.
-  display-string	; fun to display a string of characters at (x,y).
-			; args: hunk x y string &optional start end 
-  standout-init         ; fun to put terminal in standout mode.
-			; args: hunk
-  standout-end          ; fun to take terminal out of standout mode.
-			; args: hunk
-  clear-lines		; fun to clear n lines starting at (x,y).
-			; args: hunk x y n
-  clear-to-eol		; fun to clear to the end of a line from (x,y).
-			; args: hunk x y
-  clear-to-eow		; fun to clear to the end of a window from (x,y).
-			; args: hunk x y
-  open-line		; fun to open a line moving lines below it down.
-			; args: hunk x y &optional n
-  delete-line		; fun to delete a line moving lines below it up.
-			; args: hunk x y &optional n
-  insert-string		; fun to insert a string in the middle of a line.
-			; args: hunk x y string &optional start end
-  delete-char		; fun to delete a character from the middle of a line.
-			; args: hunk x y &optional n
-  (cursor-x 0)		; column the cursor is in.
-  (cursor-y 0)		; line the cursor is on.
-  standout-init-string  ; string to put terminal in standout mode.
-  standout-end-string   ; string to take terminal out of standout mode.
-  clear-to-eol-string	; string to cause device to clear to eol at (x,y).
-  clear-string		; string to cause device to clear entire screen.
-  open-line-string	; string to cause device to open a blank line.
-  delete-line-string	; string to cause device to delete a line, moving
-			; lines below it up.
-  insert-init-string	; string to put terminal in insert mode.
-  insert-char-init-string ; string to prepare terminal for insert-mode character.
-  insert-char-end-string ; string to affect terminal after insert-mode character.
-  insert-end-string	; string to take terminal out of insert mode.
-  delete-init-string	; string to put terminal in delete mode.
-  delete-char-string	; string to delete a character.
-  delete-end-string	; string to take terminal out of delete mode.
-  init-string		; device init string.
-  cm-end-string		; takes device out of cursor motion mode.
-  (cm-x-add-char nil)	; char-code to unconditionally add to x coordinate.
-  (cm-y-add-char nil)	; char-code to unconditionally add to y coordinate.
-  (cm-x-condx-char nil)	; char-code threshold for adding to x coordinate.
-  (cm-y-condx-char nil)	; char-code threshold for adding to y coordinate.
-  (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate.
-  (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate.
-  cm-string1		; initial substring of cursor motion string.
-  cm-string2		; substring of cursor motion string between coordinates.
-  cm-string3		; substring of cursor motion string after coordinates.
-  cm-one-origin		; non-nil if need to add one to coordinates.
-  cm-reversep		; non-nil if need to reverse coordinates.
-  (cm-x-pad nil)	; nil, 0, 2, or 3 for places to pad.
-			; 0 sends digit-chars.
-  (cm-y-pad nil)	; nil, 0, 2, or 3 for places to pad.
-			; 0 sends digit-chars.
-  screen-image		; vector device-lines long of strings
-			; device-columns long.
-  ;;
-  ;; This terminal's baud rate, or NIL for infinite.
-  (speed nil :type (or (unsigned-byte 24) null)))
-
-
-
-;;;; Device screen hunks and window-group.
-
-;;; Window groups are used to keep track of the old width and height of a group
-;;; so that when a configure-notify event is sent, we can determine if the size
-;;; of the window actually changed or not.
-;;;
-(defstruct (window-group (:print-function %print-window-group)
-			 (:constructor
-			  make-window-group (xparent width height)))
-  xparent
-  width
-  height)
-
-(defun %print-window-group (object stream depth)
-  (declare (ignore object depth))
-  (format stream "#<Hemlock Window Group>"))
 
 
@@ -549,7 +294,4 @@
 (defsetf getstring %set-string-table
   "Sets the value for a string-table entry, making a new one if necessary.")
-
-(defsetf window-buffer %set-window-buffer
-  "Change the buffer a window is mapped to.")
 
 (define-setf-expander value (var)
@@ -588,5 +330,4 @@
   "Set the hook list for a Hemlock character attribute.")
 (defsetf ring-ref %set-ring-ref "Set an element in a ring.")
-(defsetf current-window %set-current-window "Set the current window.")
 (defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.")
 (defsetf buffer-region %set-buffer-region "Set a buffer's region.")
@@ -606,16 +347,7 @@
   "Change the font-object associated with a font-number in new windows.")
 
-(defsetf buffer-modeline-fields %set-buffer-modeline-fields
-  "Sets the buffer's list of modeline fields causing all windows into buffer
-   to be updated for the next redisplay.")
 (defsetf modeline-field-name %set-modeline-field-name
   "Sets a modeline-field's name.  If one already exists with that name, an
    error is signaled.")
-(defsetf modeline-field-width %set-modeline-field-width
-  "Sets a modeline-field's width and updates all the fields for all windows
-   in any buffer whose fields list contains the field.")
-(defsetf modeline-field-function %set-modeline-field-function
-  "Sets a modeline-field's function and updates this field for all windows in
-   any buffer whose fields list contains the field.")
 
 ;;; Shared buffer-gap context, used to communicate between command threads
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/symbol-completion.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/symbol-completion.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/symbol-completion.lisp	(revision 7844)
@@ -103,5 +103,5 @@
 
 (defmethod dabbrev-sources-in ((state (eql :other-buffers)) context)
-  (let* ((buffers (mapcar #'window-buffer (gui::ordered-hemlock-windows))))
+  (let* ((buffers (hemlock-ext:visible-buffers)))
     ;; Remove duplicates, always keeping the first occurance (frontmost window)
     (loop for blist on buffers do (setf (cdr blist) (delete (car blist) (cdr blist))))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp	(revision 7843)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp	(revision 7844)
@@ -27,4 +27,6 @@
 (defvar *current-view* nil)
 
+(defun current-view () *current-view*)
+
 (defclass hemlock-view ()
   ((buffer :initarg :buffer :reader hemlock-view-buffer)
@@ -65,4 +67,16 @@
   (hemlock-prefix-argument-state *current-view*))
 
+(defun last-key-event-typed ()
+  "This function returns the last key-event typed by the user and read as input."
+  (hemlock-last-key-event-typed *current-view*))
+
+(defun %set-last-key-event-typed (key)
+  (setf (hemlock-last-key-event-typed *current-view*) key))
+
+(defun last-char-typed ()
+  (let ((key (hemlock-last-key-event-typed *current-view*)))
+    (when key (hemlock-ext:key-event-char key))))
+
+
 (defvar *log-event-errors* :backtrace)
 
@@ -70,23 +84,24 @@
 ;; event handling context for some view.
 (defun lisp-error-error-handler (condition)
-  (handler-case
-      (let ((emsg (ignore-errors (princ-to-string condition))))
-	(when *log-event-errors*
-	  ;; Put these in separate ignore-errors, so at least some of it can get thru
-	  (ignore-errors (clear-output *debug-io*))
-	  (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
-	  (when (eq *log-event-errors* :backtrace)
-	    (let ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
-	      (when err
-		(ignore-errors (format *debug-io* "~&Error printing call history - "))
-		(ignore-errors (print err *debug-io*))
-		(ignore-errors (princ err *debug-io*))
-		(ignore-errors (force-output *debug-io*))))))
-	(report-hemlock-error condition)
-	(abort-to-toplevel emsg))
-    (error (cc)
-      (ignore-errors (format t "~&Event error handling failed"))
-      (ignore-errors (format t ": ~a" cc))
-      (abort))))
+  (with-standard-standard-output
+    (handler-case
+	(let ((emsg (ignore-errors (princ-to-string condition))))
+	  (when *log-event-errors*
+	    ;; Put these in separate ignore-errors, so at least some of it can get thru
+	    (ignore-errors (clear-output *debug-io*))
+	    (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
+	    (when (eq *log-event-errors* :backtrace)
+	      (let ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
+		(when err
+		  (ignore-errors (format *debug-io* "~&Error printing call history - "))
+		  (ignore-errors (print err *debug-io*))
+		  (ignore-errors (princ err *debug-io*))
+		  (ignore-errors (force-output *debug-io*))))))
+	  (hemlock-ext:report-hemlock-error *current-view* condition)
+	  (abort-to-toplevel emsg))
+      (error (cc)
+	     (ignore-errors (format t "~&Event error handling failed"))
+	     (ignore-errors (format t ": ~a" cc))
+	     (abort)))))
 
 
@@ -167,17 +182,26 @@
 (defvar *last-prefix-argument*)
 
+;;;
+(defvar *invoke-hook* #'(lambda (command p)
+			  (funcall (command-function command) p))
+  "This function is called by the command interpreter when it wants to invoke a
+  command.  The arguments are the command to invoke and the prefix argument.
+  The default value just calls the Command-Function with the prefix argument.")
+
+
 (defmethod execute-hemlock-key ((view hemlock-view) key)
   (if (or (symbolp key) (functionp key))
     (funcall key)
-    (multiple-value-bind (main-binding transparent-bindings)
-			 (get-command-binding-for-key view key)
-      (when main-binding
-	(let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
-	       (*last-prefix-argument* (hemlock::prefix-argument-resetting-state))
-	       ;(*echo-area-stream* (hemlock-echo-area-stream view))
-	       )
-	  (dolist (binding transparent-bindings)
-	    (funcall *invoke-hook* binding *last-prefix-argument*))
-	  (funcall *invoke-hook* main-binding *last-prefix-argument*))))))
+    (with-output-to-listener
+      (multiple-value-bind (main-binding transparent-bindings)
+			   (get-command-binding-for-key view key)
+	(when main-binding
+	  (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil))
+		 (*last-prefix-argument* (hemlock::prefix-argument-resetting-state))
+		 ;(*echo-area-stream* (hemlock-echo-area-stream view))
+		 )
+	    (dolist (binding transparent-bindings)
+	      (funcall *invoke-hook* binding *last-prefix-argument*))
+	    (funcall *invoke-hook* main-binding *last-prefix-argument*)))))))
 
 (defmethod update-echo-area-after-command ((view hemlock-view))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/unused/cursor.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/unused/cursor.lisp	(revision 7844)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/unused/cursor.lisp	(revision 7844)
@@ -0,0 +1,362 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Written by Rob MacLachlan
+;;;
+;;; Cursor: Routines for cursor positioning and recentering
+;;;
+(in-package :hemlock-internals)
+
+
+
+;;;; Mark-To-Cursorpos
+;;;
+;;; Since performance analysis showed that HALF of the time in the editor
+;;; was being spent in this function, I threw all of the tricks in the
+;;; book at it to try and make it tenser.
+;;;
+;;; The algorithm is roughly as follows:
+;;;
+;;;    1) Eliminate the annoying boundry condition of the mark being
+;;; off the end of the window, if it is return NIL now.
+;;;    2) If the charpos is on or immediately after the last character
+;;; in the line, then find the last dis-line on which the line is
+;;; displayed.  We know that the mark is at the end of this dis-line
+;;; because it is known to be on the screen.  X position is trivially
+;;; derived from the dis-line-length.
+;;;    3) Call Real-Line-Length or Cached-Real-Line-Length to get the
+;;; X position and number of times wrapped.
+
+(declaim (special *the-sentinel*))
+
+(eval-when (:compile-toplevel :execute)
+;;; find-line
+;;;
+;;;    Find a dis-line which line is displayed on which starts before
+;;; charpos, setting ypos and dis-line to the dis-line and it's index.
+;;; Offset is expected to be the mark-charpos of the display-start for
+;;; the window initially, and is set to offset within line that
+;;; Dis-Line begins.  Charpos is the mark-charpos of the mark we want
+;;; to find.  Check if same as *redisplay-favorite-line* and then scan
+;;; if not.
+;;;
+(defmacro find-line (line offset charpos ypos dis-lines dis-line)
+  (declare (ignore charpos))
+  `(cond
+    ;; No lines at all, fail.
+    ((eq ,dis-lines *the-sentinel*) nil)
+    ;; On the first line, offset is already set, so just set dis-line and
+    ;; ypos and fall through.
+    ((eq (dis-line-line (car ,dis-lines)) ,line)
+     (setq ,dis-line ,dis-lines  ,ypos 0))
+    ;; Look farther down. 
+    ((do ((l (cdr ,dis-lines) (cdr l)))
+	 ((eq l *the-sentinel*))
+       (when (eq (dis-line-line (car l)) ,line)
+	 (setq ,dis-line l  ,ypos (dis-line-position (car l)) ,offset 0)
+	 (return t))))
+    (t
+     (error "Horrible flaming lossage, Sorry Man."))))
+
+
+;;; find-last 
+;;;
+;;;    Find the last dis-line on which line is displayed, set ypos and 
+;;; dis-line.
+;;;
+(defmacro find-last (line ypos dis-line)
+  `(do ((trail ,dis-line dl)
+	(dl (cdr ,dis-line) (cdr dl)))
+       ((not (eq (dis-line-line (car dl)) ,line))
+	(setq ,dis-line (car trail)  ,ypos (dis-line-position ,dis-line)))))
+
+;;; find-charpos
+;;;
+;;;    Special-Case mark at end of line, if not punt out to real-line-length 
+;;; function.  Return the correct values.
+;;;
+(defmacro find-charpos (line offset charpos length ypos dis-line width
+			     fun chars)
+  (declare (ignore chars))
+  `(cond
+    ((= ,charpos ,length)
+     (find-last ,line ,ypos ,dis-line)
+     (values (min (dis-line-length ,dis-line) (1- ,width)) ,ypos))
+    ((= ,charpos (1- ,length))
+     (multiple-value-bind (x dy)
+			  (,fun ,line (1- ,width) ,offset ,charpos)
+       (if (and (not (zerop dy)) (zerop x))
+	   (values (1- ,width) (1- (+ ,ypos dy)))
+	   (values x (+ ,ypos dy)))))
+    (t
+     (multiple-value-bind (x dy)
+			  (,fun ,line (1- ,width) ,offset ,charpos)
+	  (values x (+ ,ypos dy))))))
+
+); eval-when
+
+
+;;; real-line-length 
+;;;
+;;;    Return as values the X position and the number of times wrapped if
+;;; one to display the characters from Start to End of Line starting at an
+;;; X position of 0 wrapping Width wide.
+;;; %SP-Find-Character-With-Attribute is used to find charaters 
+;;; with funny representation much as in Compute-Line-Image.
+;;;
+(defun real-line-length (line width start end)
+  (declare (fixnum width start end))
+  (do ((xpos 0)
+       (ypos 0)
+       (chars (line-chars line))
+       (losing 0)
+       (dy 0))
+      ((= start end) (values xpos ypos))
+    (declare (fixnum xpos ypos dy) (simple-string chars)
+	     (type (or fixnum null) losing))
+    (setq losing (%fcwa chars start end losing-char))
+    (when (null losing)
+      (multiple-value-setq (dy xpos) (truncate (+ xpos (- end start)) width))
+      (return (values xpos (+ ypos dy))))
+    (multiple-value-setq (dy xpos) (truncate (+ xpos (- losing start)) width))
+    (setq ypos (+ ypos dy)  start losing)
+    (do ((last (or (%fcwa chars start end winning-char) end)) str)
+	((= start last))
+      (declare (fixnum last))
+      (setq str (get-rep (schar chars start)))
+      (incf start)
+      (unless (simple-string-p str) (setq str (funcall str xpos)))
+      (multiple-value-setq (dy xpos) (truncate (+ xpos (strlen str)) width))
+      (setq ypos (+ ypos dy)))))
+
+;;; cached-real-line-length
+;;;
+;;;    The same as Real-Line-Length, except does it for the cached line.
+;;; the line argument is ignored, but present to make the arglists the
+;;; same.
+;;;
+(defun cached-real-line-length (line width start end)
+  (declare (fixnum width start end) (ignore line))
+  (let ((offset (- (current-right-open-pos) (current-left-open-pos)))
+	(bound 0))
+    (declare (fixnum offset bound))
+    (cond
+     ((>= start (current-left-open-pos))
+      (setq start (+ start offset)  bound (setq end (+ end offset))))
+     ((> end (current-left-open-pos))
+      (setq bound (current-left-open-pos)  end (+ end offset)))
+     (t
+      (setq bound end)))
+    
+    (do ((xpos 0)
+	 (ypos 0)
+	 (losing 0)
+	 (dy 0))
+	(())
+      (declare (fixnum xpos ypos dy)
+	       (type (or fixnum null) losing))
+      (when (= start bound)
+	(when (= start end) (return (values xpos ypos)))
+	(setq start (current-right-open-pos)  bound end))
+      (setq losing (%fcwa (current-open-chars) start bound losing-char))
+      (cond
+       (losing
+	(multiple-value-setq (dy xpos)
+	  (truncate (+ xpos (- losing start)) width))
+	(setq ypos (+ ypos dy)  start losing)
+	(do ((last (or (%fcwa (current-open-chars) start bound winning-char) bound)) str)
+	    ((= start last))
+	  (declare (fixnum last))
+	  (setq str (get-rep (schar (current-open-chars) start)))
+	  (incf start)
+	  (unless (simple-string-p str) (setq str (funcall str xpos)))
+	  (multiple-value-setq (dy xpos)
+	    (truncate (+ xpos (strlen str)) width))
+	  (setq ypos (+ ypos dy))))
+       (t
+	(multiple-value-setq (dy xpos)
+	  (truncate (+ xpos (- bound start)) width))
+	(setq ypos (+ ypos dy)  start bound))))))
+
+
+
+;;; Dis-Line-Offset-Guess  --  Internal
+;;;
+;;;    Move Mark by Offset display lines.  The mark is assumed to be at the
+;;; beginning of a display line, and we attempt to leave it at one.  We assume
+;;; all characters print one wide.  Width is the width of the window we are
+;;; displaying in.
+;;;
+(defun dis-line-offset-guess (mark offset width)
+  (let ((w (1- width)))
+    (if (minusp offset)
+	(dotimes (i (- offset) t)
+	  (let ((pos (mark-charpos mark)))
+	    (if (>= pos w)
+		(character-offset mark (- w))
+		(let ((prev (line-previous (mark-line mark))))
+		  (unless prev (return nil))
+		  (multiple-value-bind
+		      (lines chars)
+		      (truncate (line-length prev) w)
+		    (move-to-position mark
+				      (cond ((zerop lines) 0)
+					    ((< chars 2)
+					     (* w (1- lines)))
+					    (t
+					     (* w lines)))
+				      prev))))))
+	(dotimes (i offset t)
+	  (let ((left (- (line-length (mark-line mark))
+			 (mark-charpos mark))))
+	    (if (> left width)
+		(character-offset mark w)
+		(unless (line-offset mark 1 0)
+		  (return nil))))))))
+
+;;; maybe-recenter-window  --  Internal
+;;;
+;;;     Update the dis-lines for Window and recenter if the point is off
+;;; the screen.
+;;;
+(defun maybe-recenter-window (window)
+  (unless (%displayed-p (buffer-point (window-buffer window)) window)
+    (center-window window (buffer-point (window-buffer window)))
+    t))
+
+;;; center-window  --  Public
+;;;
+;;;    Try to move the start of window so that Mark is on a line in the 
+;;; center.
+;;;
+(defun center-window (window mark)
+  "Adjust the start of Window so that Mark is displayed on the center line."
+  (let ((height (window-height window))
+	(start (window-display-start window)))
+    (move-mark start mark)
+    (unless (dis-line-offset-guess start (- (truncate height 2))
+				   (window-width window))
+      (move-mark start (buffer-start-mark (window-buffer window))))
+    (update-window-image window)
+    ;; If that doesn't work, panic and make the start the point.
+    (unless (%displayed-p mark window)
+      (move-mark start mark)
+      (update-window-image window))))
+
+
+;;; %Displayed-P  --  Internal
+;;;
+;;;    If Mark is within the displayed bounds in Window, then return true,
+;;; otherwise false.  We assume the window image is up to date.
+;;;
+(defun %displayed-p (mark window)
+  (let ((start (window-display-start window))
+	(end (window-display-end window)))
+    (not (or (mark< mark start) (mark> mark end)
+	     (if (mark= mark end)
+		 (let ((ch (next-character end)))
+		   (and ch (char/= ch #\newline)))
+		 nil)))))
+
+
+;;; Displayed-p  --  Public
+;;;
+;;;    Update the window image and then check if the mark is displayed.
+;;;
+(defun displayed-p (mark window)
+  "Return true if Mark is displayed on Window, false otherwise."
+  (maybe-update-window-image window)
+  (%displayed-p mark window))
+
+
+;;; scroll-window  --  Public
+;;;
+;;;    This is not really right, since it uses dis-line-offset-guess.
+;;; Probably if there is any screen overlap then we figure it out
+;;; exactly.
+;;;
+
+
+
+;;; Mark-Column  --  Public
+;;;
+;;;    Find the X position of a mark supposing that it were displayed
+;;; in an infinitely wide screen.
+;;;
+(defun mark-column (mark)
+  "Find the X position at which Mark would be displayed if it were on
+  an infinitely wide screen.  This takes into account tabs and control
+  characters."
+  (let ((charpos (mark-charpos mark))
+	(line (mark-line mark)))
+    (if (current-open-line-p line)
+	(values (cached-real-line-length line 10000 0 charpos))
+	(values (real-line-length line 10000 0 charpos)))))
+
+
+;;; Find-Position  --  Internal
+;;;
+;;;    Return the charpos which corresponds to the specified X position
+;;; within Line.  If there is no such position between Start and End then
+;;; rutne NIL.
+;;;
+(defun find-position (line position start end width)
+  (do* ((cached (current-open-line-p line))
+	(lo start)
+	(hi (1- end))
+	(probe (truncate (+ lo hi) 2) (truncate (+ lo hi) 2)))
+       ((> lo hi)
+	(if (= lo end) nil hi))
+    (let ((val (if cached
+		   (cached-real-line-length line width start probe)
+		   (real-line-length line width start probe))))
+      (cond ((= val position) (return probe))
+	    ((< val position) (setq lo (1+ probe)))
+	    (t (setq hi (1- probe)))))))
+
+;;; Cursorpos-To-Mark  --  Public
+;;;
+;;;    Find the right dis-line, then zero in on the correct position
+;;; using real-line-length.
+;;;
+(defun cursorpos-to-mark (x y window)
+  (check-type window window)
+  (let ((width (window-width window))
+	(first (window-first-line window)))
+    (when (>= x width)
+      (return-from cursorpos-to-mark nil))
+    (do* ((prev first dl)
+	  (dl (cdr first) (cdr dl))
+	  (ppos (mark-charpos (window-display-start window))
+		(if (eq (dis-line-line (car dl)) (dis-line-line (car prev)))
+		    (dis-line-end (car prev)) 0)))
+	((eq dl *the-sentinel*)
+	 (copy-mark (window-display-end window) :temporary))
+      (when (= (dis-line-position (car dl)) y)
+	(let* ((line (dis-line-line (car dl)))
+	       (end (dis-line-end (car dl))))
+	  (return (mark line (or (find-position line x ppos end width) end))))))))
+
+;;; Move-To-Column  --  Public
+;;;
+;;;    Just look up the charpos using find-position...
+;;;
+(defun move-to-column (mark column &optional (line (mark-line mark)))
+  "Move Mark to the specified Column on Line.  This function is analogous
+  to Move-To-Position, but it deals with the physical screen position
+  as returned by Mark-Column; the mark is moved to before the character
+  which would be displayed in Column if the line were displayed on
+  an infinitely wide screen.  If the column specified is greater than
+  the column of the last character, then Nil is returned and the mark
+  is not modified."
+  (let ((res (find-position line column 0 (line-length line) 10000)))
+    (if res
+	(move-to-position mark res line))))
Index: /branches/event-ide/ccl/cocoa-ide/hemlock/unused/linimage.lisp
===================================================================
--- /branches/event-ide/ccl/cocoa-ide/hemlock/unused/linimage.lisp	(revision 7844)
+++ /branches/event-ide/ccl/cocoa-ide/hemlock/unused/linimage.lisp	(revision 7844)
@@ -0,0 +1,478 @@
+;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+#+CMU (ext:file-comment
+  "$Header$")
+;;;
+;;; **********************************************************************
+;;;
+;;;    Written by Rob MacLachlan
+;;;
+;;; This file contains functions related to building line images.
+;;;
+(in-package :hemlock-internals)
+
+;;;    The code in here is factored out in this way because it is more
+;;; or less implementation dependant.  The reason this code is 
+;;; implementation dependant is not because it is not written in 
+;;; Common Lisp per se, but because it uses this thing called 
+;;; %SP-Find-Character-With-Attribute to find any characters that
+;;; are to be displayed on the line which do not print as themselves.
+;;; This permits us to have an arbitrary string or even string-valued
+;;; function to as the representation for such a "Funny" character
+;;; with minimal penalty for the normal case.  This function can be written 
+;;; in lisp, and is included commented-out below, but if this function
+;;; is not real fast then redisplay performance will suffer.
+;;;
+;;;    Theres also code in here that special-cases "Buffered" lines,
+;;; which is not exactly Common Lisp, but if you aren't on a perq,
+;;; you won't have to worry about it.
+;;;
+;(defun %sp-find-character-with-attribute (string start end table mask)
+;  (declare (type (simple-array (mod 256) char-code-max) table))
+;  (declare (simple-string string))
+;  (declare (fixnum start end))
+;  "%SP-Find-Character-With-Attribute  String, Start, End, Table, Mask
+;  The codes of the characters of String from Start to End are used as indices
+;  into the Table, which is a U-Vector of 8-bit bytes. When the number picked
+;  up from the table bitwise ANDed with Mask is non-zero, the current
+;  index into the String is returned. The corresponds to SCANC on the Vax."
+;  (do ((index start (1+ index)))
+;      ((= index end) nil)
+;    (declare (fixnum index))
+;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
+;	(return index))))
+;
+;(defun %sp-reverse-find-character-with-attribute (string start end table
+;							  mask)
+;  (declare (type (simple-array (mod 256) char-code-max) table))
+;  (declare (simple-string string))
+;  (declare (fixnum start end))
+;  "Like %SP-Find-Character-With-Attribute, only sdrawkcaB."
+;  (do ((index (1- end) (1- index)))
+;      ((< index start) nil)
+;    (declare (fixnum index))
+;    (if (/= (logand (aref table (char-code (elt string index))) mask) 0)
+;	(return index))))
+
+
+(defconstant winning-char #b01 "Bit for a char that prints normally")
+(defconstant losing-char #b10 "Bit for char with funny representation.")
+(defvar *losing-character-mask*
+  (make-array char-code-limit :element-type '(mod 256)
+	      :initial-element winning-char)
+  "This is a character set used by redisplay to find funny chars.")
+(defvar *print-representation-vector* nil
+  "Redisplay's handle on the :print-representation attribute")
+
+;;;  Do a find-character-with-attribute on the *losing-character-mask*.
+(defmacro %fcwa (str start end mask)
+  `(%sp-find-character-with-attribute
+    ,str ,start ,end *losing-character-mask* ,mask))
+
+;;; Get the print-representation of a character.
+(defmacro get-rep (ch)
+  `(svref *print-representation-vector* (char-code ,ch)))
+
+
+
+
+(declaim (special *character-attributes*))
+
+;;; %init-line-image  --  Internal
+;;;
+;;;    Set up the print-representations for funny chars.  We make the
+;;; attribute vector by hand and do funny stuff so that chars > 127
+;;; will have a losing print-representation, so redisplay will not
+;;; die if you visit a binary file or do something stupid like that.
+;;;
+(defun %init-line-image ()
+  (defattribute "Print Representation"
+    "The value of this attribute determines how a character is displayed
+    on the screen.  If the value is a string this string is literally
+    displayed.  If it is a function, then that function is called with
+    the current X position to get the string to display.")
+  (setq *print-representation-vector*
+	(make-array char-code-limit :initial-element nil))
+  (setf (attribute-descriptor-vector
+	 (gethash :print-representation *character-attributes*))
+	*print-representation-vector*)
+  (do ((code 128 (1+ code))
+       (str (make-string 4) (make-string 4)))
+      ((= code char-code-limit))
+    (setf (aref *losing-character-mask* code) losing-char)
+    (setf (aref *print-representation-vector* code) str)
+    (setf (schar str 0) #\<)
+    (setf (schar str 1) (char-upcase (digit-char (ash code -4) 16)))
+    (setf (schar str 2) (char-upcase (digit-char (logand code #x+F) 16)))
+    (setf (schar str 3) #\>))
+
+  (add-hook hemlock::character-attribute-hook
+	    #'redis-set-char-attribute-hook-fun)
+  (do ((i (1- (char-code #\space)) (1- i)) str)
+      ((minusp i))
+    (setq str (make-string 2))
+    (setf (elt (the simple-string str) 0) #\^)
+    (setf (elt (the simple-string str) 1)
+	  (code-char (+ i (char-code #\@))))
+    (setf (character-attribute :print-representation (code-char i)) str))
+  (setf (character-attribute :print-representation (code-char #o177)) "^?")
+  (setf (character-attribute :print-representation #\tab)
+	#'redis-tab-display-fun))
+
+
+;;; redis-set-char-attribute-hook-fun
+;;;
+;;;    Keep track of which characters have funny representations.
+;;;
+(defun redis-set-char-attribute-hook-fun (attribute char new-value)
+  (when (eq attribute :print-representation)
+    (cond
+     ((simple-string-p new-value)
+      (if (and (= (length (the simple-string new-value)) 1)
+	       (char= char (elt (the simple-string new-value) 0)))
+	  (setf (aref *losing-character-mask* (char-code char)) winning-char)
+	  (setf (aref *losing-character-mask* (char-code char))
+		losing-char)))
+     ((functionp new-value)
+      (setf (aref *losing-character-mask* (char-code char)) losing-char))
+     (t (error "Bad print representation: ~S" new-value)))))
+
+;;; redis-tab-display-fun
+;;;
+;;;    This function is initially the :print-representation for tab.
+;;;
+(defun redis-tab-display-fun (xpos)
+  (svref '#("        "
+	    "       "
+	    "      "
+	    "     "
+	    "    "
+	    "   "
+	    "  "
+	    " ")
+	 (logand xpos 7)))
+
+
+
+;;;; The actual line image computing functions.
+;;;;
+
+(eval-when (:compile-toplevel :execute)
+;;; display-some-chars  --  internal
+;;;
+;;;    Put some characters into a window.  Characters from src-start 
+;;; to src-end in src are are put in the window's dis-line's.  Lines
+;;; are wrapped as necessary.  dst is the dis-line-chars of the dis-line 
+;;; currently being written.  Dis-lines is the window's vector of dis-lines.
+;;; dis-line is the dis-line currently being written.  Line is the index
+;;; into dis-lines of the current dis-line.  dst-start is the index to
+;;; start writing chars at.  Height and width are the height and width of the 
+;;; window.  src-start, dst, dst-start, line and dis-line are updated.
+;;; Done-P indicates whether there are more characters after this sequence.
+;;;
+(defmacro display-some-chars (src src-start src-end dst dst-start width done-p)
+  `(let ((dst-end (+ ,dst-start (- ,src-end ,src-start))))
+     (declare (fixnum dst-end))
+     (cond
+      ((>= dst-end ,width)
+       (cond 
+	((and ,done-p (= dst-end ,width))
+	 (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
+	 (setq ,dst-start dst-end  ,src-start ,src-end))
+	(t
+	 (let ((1-width (1- ,width)))
+	   (%sp-byte-blt ,src ,src-start ,dst ,dst-start 1-width)
+	   (setf (elt (the simple-string ,dst) 1-width) *line-wrap-char*)
+	   (setq ,src-start (+ ,src-start (- 1-width ,dst-start)))
+	   (setq ,dst-start nil)))))
+      (t (%sp-byte-blt ,src ,src-start ,dst ,dst-start dst-end)
+	 (setq ,dst-start dst-end  ,src-start ,src-end)))))
+
+;;; These macros are given as args to display-losing-chars to get the
+;;; print representation of whatever is in the data vector.
+(defmacro string-get-rep (string index)
+  `(get-rep (schar ,string ,index)))
+
+(defmacro u-vec-get-rep (u-vec index)
+  `(svref *print-representation-vector*
+	  (hemlock-ext:sap-ref-8 ,u-vec ,index)))
+
+;;; display-losing-chars  --  Internal
+;;;
+;;;    This macro is called by the compute-line-image functions to
+;;; display a group of losing characters.
+;;;
+(defmacro display-losing-chars (line-chars index end dest xpos width
+					   string underhang access-fun
+					   &optional (done-p `(= ,index ,end)))
+  `(do ((last (or (%fcwa ,line-chars ,index ,end winning-char) ,end))
+	(len 0)
+	(zero 0)
+	str)
+       (())
+     (declare (fixnum last len zero))
+     (setq str (,access-fun ,line-chars ,index))
+     (unless (simple-string-p str) (setq str (funcall str ,xpos)))
+     (setq len (strlen str)  zero 0)
+     (incf ,index)
+     (display-some-chars str zero len ,dest ,xpos ,width ,done-p)
+     (cond ((not ,xpos)
+	    ;; We wrapped in the middle of a losing char.	       
+	    (setq ,underhang zero  ,string str)
+	    (return nil))
+	   ((= ,index last)
+	    ;; No more losing chars in this bunch.
+	    (return nil)))))
+
+(defmacro update-and-punt (dis-line length string underhang end)
+  `(progn (setf (dis-line-length ,dis-line) ,length)
+	  (return (values ,string ,underhang
+			  (setf (dis-line-end ,dis-line) ,end)))))
+
+); eval-when
+
+
+;;; compute-normal-line-image  --  Internal
+;;;
+;;;    Compute the screen representation of Line starting at Start 
+;;; putting it in Dis-Line beginning at Xpos.  Width is the width of the 
+;;; window we are displaying in.  If the line will wrap then we display 
+;;; as many chars as we can then put in *line-wrap-char*.  The values 
+;;; returned are described in Compute-Line-Image, which tail-recursively 
+;;; returns them.  The length slot in Dis-Line is updated.
+;;;
+;;; We use the *losing-character-mask* to break the line to be displayed
+;;; up into chunks of characters with normal print representation and
+;;; those with funny representations.
+;;;
+(defun compute-normal-line-image (line start dis-line xpos width)
+  (declare (fixnum start width) (type (or fixnum null) xpos))
+  (do* ((index start)
+	(line-chars (line-%chars line))
+	(end (strlen line-chars))
+	(dest (dis-line-chars dis-line))
+	(losing 0)
+	underhang string)
+       (())
+    (declare (fixnum index end)
+	     (type (or fixnum null) losing)
+	     (simple-string line-chars dest))
+    (cond
+     (underhang
+      (update-and-punt dis-line width string underhang index))
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ((= index end)
+      (update-and-punt dis-line xpos nil nil index)))
+    (setq losing (%fcwa line-chars index end losing-char))
+    (when (null losing)
+      (display-some-chars line-chars index end dest xpos width t)
+      (if (or xpos (= index end))
+	  (update-and-punt dis-line xpos nil nil index)
+	  (update-and-punt dis-line width nil 0 index)))
+    (display-some-chars line-chars index losing dest xpos width nil)
+    (cond
+     ;; Did we wrap?
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ;; Are we about to cause the line to wrap? If so, wrap before
+     ;; it's too late.
+     ((= xpos width)
+      (setf (char dest (1- width)) *line-wrap-char*)
+      (update-and-punt dis-line width nil 0 index))
+     (t
+      (display-losing-chars line-chars index end dest xpos width string
+			    underhang string-get-rep)))))
+
+
+
+;;; compute-cached-line-image  --  Internal
+;;;
+;;;    Like compute-normal-line-image, only works on the cached line.
+;;;
+(defun compute-cached-line-image (index dis-line xpos width)
+  (declare (fixnum index width) (type (or fixnum null) xpos))
+  (prog ((gap (- (current-right-open-pos) (current-left-open-pos)))
+	 (dest (dis-line-chars dis-line))
+	 (done-p (= (current-right-open-pos) (current-line-cache-length)))
+	 (losing 0)
+	 string underhang)
+    (declare (fixnum gap) (simple-string dest)
+	     (type (or fixnum null) losing))
+   LEFT-LOOP
+    (cond
+     (underhang
+      (update-and-punt dis-line width string underhang index))
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 index))
+     ((>= index (current-left-open-pos))
+      (go RIGHT-START)))
+    (setq losing (%fcwa (current-open-chars) index (current-left-open-pos) losing-char))
+    (cond
+     (losing
+      (display-some-chars (current-open-chars) index losing dest xpos width nil)
+      ;; If we we didn't wrap then display some losers...
+      (if xpos
+	  (display-losing-chars (current-open-chars) index (current-left-open-pos) dest xpos
+				width string underhang string-get-rep
+				(and done-p (= index (current-left-open-pos))))
+	  (update-and-punt dis-line width nil 0 index)))
+     (t
+      (display-some-chars (current-open-chars) index (current-left-open-pos) dest xpos width done-p)))
+    (go LEFT-LOOP)
+
+   RIGHT-START
+    (setq index (+ index gap))
+   RIGHT-LOOP
+    (cond
+     (underhang
+      (update-and-punt dis-line width string underhang (- index gap)))
+     ((null xpos)
+      (update-and-punt dis-line width nil 0 (- index gap)))
+     ((= index (current-line-cache-length))
+      (update-and-punt dis-line xpos nil nil (- index gap))))
+    (setq losing (%fcwa (current-open-chars) index (current-line-cache-length) losing-char))
+    (cond
+     (losing
+      (display-some-chars (current-open-chars) index losing dest xpos width nil)
+      (cond
+       ;; Did we wrap?
+       ((null xpos)
+	(update-and-punt dis-line width nil 0 (- index gap)))
+       (t
+	(display-losing-chars (current-open-chars) index (current-line-cache-length) dest xpos
+			      width string underhang string-get-rep))))
+     (t
+      (display-some-chars (current-open-chars) index (current-line-cache-length) dest xpos width t)))
+    (go RIGHT-LOOP))) 
+
+
+(defun make-some-font-changes ()
+  (do ((res nil (make-font-change res))
+       (i 42 (1- i)))
+      ((zerop i) res)))
+
+(defvar *free-font-changes* (make-some-font-changes)
+  "Font-Change structures that nobody's using at the moment.")
+
+(defmacro alloc-font-change (x font mark)
+  `(progn
+    (unless *free-font-changes*
+      (setq *free-font-changes* (make-some-font-changes)))
+    (let ((new-fc *free-font-changes*))
+      (setq *free-font-changes* (font-change-next new-fc))
+      (setf (font-change-x new-fc) ,x
+	    (font-change-font new-fc) ,font
+	    (font-change-next new-fc) nil
+	    (font-change-mark new-fc) ,mark)
+      new-fc)))
+		     
+;;;
+;;; compute-line-image  --  Internal
+;;;
+;;;    This function builds a full line image from some characters in
+;;; a line and from some characters which may be left over from the previous
+;;; line.
+;;;
+;;; Parameters:
+;;;    String - This is the string which contains the characters left over
+;;; from the previous line.  This is NIL if there are none.
+;;;    Underhang - Characters from here to the end of String are put at the
+;;; beginning of the line image.
+;;;    Line - This is the line to display characters from.
+;;;    Offset - This is the index of the first character to display in Line.
+;;;    Dis-Line - This is the dis-line to put the line-image in.  The only
+;;; slots affected are the chars and the length.
+;;;    Width - This is the width of the field to display in.
+;;;
+;;; Three values are returned:
+;;;    1) The new overhang string, if none this is NIL.
+;;;    2) The new underhang, if this is NIL then the entire line was
+;;; displayed.  If the entire line was not displayed, but there was no
+;;; underhang, then this is 0.
+;;;    3) The index in line after the last character displayed.
+;;;
+(defun compute-line-image (string underhang line offset dis-line width)
+  ;;
+  ;; Release any old font-changes.
+  (let ((changes (dis-line-font-changes dis-line)))
+    (when changes
+      (do ((prev changes current)
+	   (current (font-change-next changes)
+		    (font-change-next current)))
+	  ((null current)
+	   (setf (dis-line-font-changes dis-line) nil)
+	   (shiftf (font-change-next prev) *free-font-changes* changes))
+	(setf (font-change-mark current) nil))))
+  ;;
+  ;; If the line has any Font-Marks, add Font-Changes for them.
+  (let ((marks (line-marks line)))
+    (when (dolist (m marks nil)
+	    (when (fast-font-mark-p m) (return t)))
+      (let ((prev nil))
+	;;
+	;; Find the last Font-Mark with charpos less than Offset.  If there is
+	;; such a Font-Mark, then there is a font-change to this font at X = 0.
+	(let ((max -1)
+	      (max-mark nil))
+	  (dolist (m marks)
+	    (when (fast-font-mark-p m)
+	      (let ((charpos (mark-charpos m)))
+		(when (and (< charpos offset) (> charpos max))
+		  (setq max charpos  max-mark m)))))
+	  (when max-mark
+	    (setq prev (alloc-font-change 0 (font-mark-font max-mark) max-mark))
+	    (setf (dis-line-font-changes dis-line) prev)))
+	;;
+	;; Repeatedly scan through marks, adding a font-change for the
+	;; smallest Font-Mark with a charpos greater than Bound, until
+	;; we find no such mark.
+	(do ((bound (1- offset) min)
+	     (min most-positive-fixnum most-positive-fixnum)
+	     (min-mark nil nil))
+	    (())
+	  (dolist (m marks)
+	    (when (fast-font-mark-p m)
+	      (let ((charpos (mark-charpos m)))
+		(when (and (> charpos bound) (< charpos min))
+		  (setq min charpos  min-mark m)))))
+	  (unless min-mark (return nil))
+	  (let ((len (if (current-open-line-p line)
+			 (cached-real-line-length line 10000 offset min)
+			 (real-line-length line 10000 offset min))))
+	    (when (< len width)
+	      (let ((new (alloc-font-change
+			  (+ len
+			     (if string
+				 (- (length (the simple-string string)) underhang)
+				 0))
+			  (font-mark-font min-mark)
+			  min-mark)))
+		(if prev
+		    (setf (font-change-next prev) new)
+		    (setf (dis-line-font-changes dis-line) new))
+		(setq prev new))))))))
+  ;;
+  ;; Recompute the line image.
+  (cond
+   (string
+    (let ((len (strlen string))
+	  (chars (dis-line-chars dis-line))
+	  (xpos 0))
+      (declare (type (or fixnum null) xpos) (simple-string chars))
+      (display-some-chars string underhang len chars xpos width nil)
+      (cond
+       ((null xpos)
+	(values string underhang offset))	   
+       ((current-open-line-p line)
+	(compute-cached-line-image offset dis-line xpos width))
+       (t
+ 	(compute-normal-line-image line offset dis-line xpos width)))))
+   ((current-open-line-p line)
+    (compute-cached-line-image offset dis-line 0 width))
+   (t
+    (compute-normal-line-image line offset dis-line 0 width))))