Changeset 7844

Timestamp:

Dec 7, 2007, 11:04:37 AM (17 years ago)

Author:

gz

Message:

isearch, more cleanup, removing unused/supported stuff, redirect
standard output to listener during hemlock execution, start
formulating a hemlock support API in hemlock-ext package.

Location:

branches/event-ide/ccl/cocoa-ide

Files:

• cocoa-editor.lisp (modified) (24 diffs)
• cocoa-listener.lisp (modified) (3 diffs)
• cocoa-utils.lisp (modified) (2 diffs)
• compile-hemlock.lisp (modified) (1 diff)
• hemlock/src/bindings.lisp (modified) (1 diff)
• hemlock/src/buffer.lisp (modified) (5 diffs)
• hemlock/src/cocoa-hemlock.lisp (modified) (3 diffs)
• hemlock/src/command.lisp (modified) (5 diffs)
• hemlock/src/decls.lisp (modified) (1 diff)
• hemlock/src/doccoms.lisp (modified) (1 diff)
• hemlock/src/echo.lisp (modified) (5 diffs)
• hemlock/src/echocoms.lisp (modified) (1 diff)
• hemlock/src/filecoms.lisp (modified) (2 diffs)
• hemlock/src/fill.lisp (modified) (1 diff)
• hemlock/src/font.lisp (modified) (3 diffs)
• hemlock/src/hemlock-ext.lisp (modified) (3 diffs)
• hemlock/src/htext1.lisp (modified) (1 diff)
• hemlock/src/interp.lisp (modified) (1 diff)
• hemlock/src/isearchcoms.lisp (added)
• hemlock/src/key-event.lisp (modified) (5 diffs)
• hemlock/src/killcoms.lisp (modified) (1 diff)
• hemlock/src/lispdep.lisp (modified) (2 diffs)
• hemlock/src/lispmode.lisp (modified) (2 diffs)
• hemlock/src/listener.lisp (modified) (8 diffs)
• hemlock/src/macros.lisp (modified) (1 diff)
• hemlock/src/main.lisp (modified) (2 diffs)
• hemlock/src/modeline.lisp (modified) (4 diffs)
• hemlock/src/morecoms.lisp (modified) (1 diff)
• hemlock/src/package.lisp (modified) (12 diffs)
• hemlock/src/pop-up-stream.lisp (modified) (3 diffs)
• hemlock/src/ring.lisp (modified) (1 diff)
• hemlock/src/rompsite.lisp (modified) (5 diffs)
• hemlock/src/searchcoms.lisp (modified) (3 diffs)
• hemlock/src/struct.lisp (modified) (9 diffs)
• hemlock/src/symbol-completion.lisp (modified) (1 diff)
• hemlock/src/views.lisp (modified) (4 diffs)
• hemlock/unused/cursor.lisp (moved) (moved from branches/event-ide/ccl/cocoa-ide/hemlock/src/cursor.lisp )
• hemlock/unused/linimage.lisp (moved) (moved from branches/event-ide/ccl/cocoa-ide/hemlock/src/linimage.lisp )

branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

@@ -154 +154 @@
 ;;; 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 +781 @@
           (when (eq buffer hi::*current-buffer*)
             (setf hi::*current-buffer* nil))
-          (hi::delete-buffer buffer :force t))))))
+          (hi::delete-buffer buffer))))))
 
 
@@ -861 +858 @@
   (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 +886 @@
             (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 +1515 @@
   (: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 +1702 @@
   (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 +1711 @@
       (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 +1853 @@
         (#/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 +2016 @@
   (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 +2106 @@
 
 
-(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 +2206 @@
   (: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 +2228 @@
           (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 +2328 @@
     (#/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 +2389 @@
                (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
 
-          (hi::queue-buffer-change buffer)
           (#/beginEditing textstorage)
 
@@ -2410 +2403 @@
            0
            (hemlock-buffer-length buffer))
+
+          (hi::note-modeline-change buffer)
 
           (#/endEditing textstorage))
@@ -2458 +2453 @@
         (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 +2462 @@
       (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 +2490 @@
   (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 +2628 @@
               (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 +2682 @@
                       (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 +2881 @@
 
 
-(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 +2924 @@
           (#/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 +2934 @@
      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 +3017 @@
                   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))

branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp

@@ -26 +26 @@
 
 (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 +268 @@
        (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 +294 @@
               (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))
 

branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp

@@ -58 +58 @@
                                             notification)
   (declare (ignore notification))
+  (#/setDataSource: (slot-value self 'table-view) +null-ptr+)
   (#/autorelease self))
 
@@ -214 +215 @@
 
 (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)))

branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp

@@ -64 +64 @@
     "table"
     "modeline"
-    "linimage"
     "pop-up-stream"
-    "cursor"
     "font"
     "streams"

branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

@@ -129 +129 @@
 ;(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")

branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp

@@ -42 +42 @@
   "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 +100 @@
       ((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 +494 @@
     (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 +509 @@
                          :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 +522 @@
            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)

branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp

@@ -6 +6 @@
 
 (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 +75 @@
       (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 +85 @@
   (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))))

branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

@@ -263 +263 @@
                (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 +285 @@
                (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 +380 @@
   :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 +386 @@
   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 +394 @@
   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))))
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp

@@ -55 +55 @@
              ,name)))
 
-(declfun window-buffer (window))
 (declfun change-to-buffer (buffer))     ;filecoms.lisp
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp

@@ -44 +44 @@
     (#\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))

branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

@@ -35 +35 @@
 ;;; 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 +157 @@
            (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 +494 @@
                                ((: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 +525 @@
 
 (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 +537 @@
                             (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)))))))))
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp

@@ -96 +96 @@
           (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))

branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp

@@ -697 +697 @@
 
 
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
 (defun universal-time-to-string (ut)
   (multiple-value-bind (sec min hour day month year)
@@ -730 +706 @@
             (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)))
-
-
-
-
-
-

branches/event-ide/ccl/cocoa-ide/hemlock/src/fill.lisp

@@ -504 +504 @@
                                           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))

branches/event-ide/ccl/cocoa-ide/hemlock/src/font.lisp

@@ -18 +18 @@
 
 (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 +55 @@
     (new-font-mark new line)
     (push new (line-marks line))
-    (incf (line-font-mark-count line))
     new))
 
@@ -73 +63 @@
     (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))))

branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp

@@ -12 +12 @@
 (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 +26 @@
   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 +36 @@
         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)

branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp

@@ -434 +434 @@
   "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))
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp

@@ -392 +392 @@
   *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.

branches/event-ide/ccl/cocoa-ide/hemlock/src/key-event.lisp

@@ -19 +19 @@
 ;;; 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 +93 @@
     (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 +412 @@
 ;;; 
 
-;;; 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 +421 @@
                     :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 +668 @@
   "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.
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp

@@ -155 +155 @@
   (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))

branches/event-ide/ccl/cocoa-ide/hemlock/src/lispdep.lisp

@@ -8 +8 @@
 
 (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 +61 @@
                 (declare (ignore err))
                 nil)) )
-  
-
-(defmacro without-gcing (&body body)
-  `(progn ,@body))

branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp

@@ -841 +841 @@
 (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 +1992 @@
     (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))))
 
 #||

branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp

@@ -28 +28 @@
   (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 +103 @@
       )
     (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 +508 @@
 
 (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 +564 @@
 
 
-;;; 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 +573 @@
                              (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 +602 @@
                                     (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 +608 @@
                       :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 +614 @@
                         :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)))))))
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

@@ -493 +493 @@
 ;;;; 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))
+
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp

@@ -58 +58 @@
   (%init-syntax-table)
   ;;
-  ;; Define print representations for funny characters.
-  (%init-line-image)
   (setq *hemlock-initialized* t))
 
@@ -255 +253 @@
          *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.
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp

@@ -42 +42 @@
 
 
-(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 +63 @@
 (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 +154 @@
   (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 +219 @@
 
 (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))

branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp

@@ -423 +423 @@
              (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)

branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

@@ -85 +85 @@
    #:buffer-variables
    #:buffer-modes
-   #:buffer-windows
    #:buffer-delete-hook
    #:buffer-package
@@ -97 +96 @@
    #:buffer-modeline-fields
    #:buffer-modeline-field-p
-   #:update-modeline-fields
    #:update-modeline-field
    #:insert-character
@@ -185 +183 @@
    #: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 +220 @@
    #:pause-hemlock
    #:clear-editor-input
-   #:listen-editor-input
-   #:editor-sleep
    #:make-hemlock-output-stream
    #:hemlock-output-stream-p
@@ -329 +310 @@
    #: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 +400 @@
    
    ;; 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 +412 @@
 
    ;; 
-   #: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 +431 @@
 
    ;; 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 +466 @@
    ;; 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 +535 @@
    #:*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 +565 @@
    ;; 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 +573 @@
 
 (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)
   )
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/pop-up-stream.lisp

@@ -18 +18 @@
 
 
-
-
-;;;; 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 +26 @@
   (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 +36 @@
 (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))))
-
-
-
-
-

branches/event-ide/ccl/cocoa-ide/hemlock/src/ring.lisp

@@ -31 +31 @@
   "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)))
                          

branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp

@@ -62 +62 @@
   (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 +138 @@
 
 (declaim (declaration values))
-(declaim (special *default-font-family*))
 
 ;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would
@@ -162 +159 @@
 (defvar *line-wrap-char* #\!
   "The character to be displayed to indicate wrapped lines.")
-
-
-
-;;;; Current terminal character translation.
-
-(defvar termcap-file "/etc/termcap")
-
 
 
@@ -274 +264 @@
   "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 +310 @@
 
 (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

branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

@@ -41 +41 @@
 
 
+(defun note-current-selection-set-by-search ()
+  (hemlock-ext:note-selection-set-by-search (current-buffer)))
 
 
@@ -62 +64 @@
                (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 +85 @@
                (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)))

branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp

@@ -36 +36 @@
   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 +112 @@
   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 +132 @@
 (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 +217 @@
 
 
-
-
-;#+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 +267 @@
                  :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 +279 @@
              (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 +294 @@
 (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 +330 @@
   "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 +347 @@
   "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

branches/event-ide/ccl/cocoa-ide/hemlock/src/symbol-completion.lisp

@@ -103 +103 @@
 
 (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))))

branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

@@ -27 +27 @@
 (defvar *current-view* nil)
 
+(defun current-view () *current-view*)
+
 (defclass hemlock-view ()
   ((buffer :initarg :buffer :reader hemlock-view-buffer)
@@ -65 +67 @@
   (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 +84 @@
 ;; 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 +182 @@
 (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))