Changeset 7833

Timestamp:

Dec 6, 2007, 11:31:36 AM (17 years ago)

Author:

gz

Message:

checkpoint work in progress

Location:

branches/event-ide/ccl/cocoa-ide

Files:

• cocoa-editor.lisp (modified) (30 diffs)
• cocoa-listener.lisp (modified) (5 diffs)
• cocoa-utils.lisp (modified) (1 diff)
• cocoa-window.lisp (modified) (5 diffs)
• cocoa.lisp (modified) (1 diff)
• compile-hemlock.lisp (modified) (3 diffs)
• hemlock/src/bindings.lisp (modified) (13 diffs)
• hemlock/src/buffer.lisp (modified) (18 diffs)
• hemlock/src/cocoa-hemlock.lisp (modified) (5 diffs)
• hemlock/src/command.lisp (modified) (6 diffs)
• hemlock/src/completion.lisp (modified) (1 diff)
• hemlock/src/decls.lisp (modified) (1 diff)
• hemlock/src/doccoms.lisp (modified) (6 diffs)
• hemlock/src/echo.lisp (modified) (20 diffs)
• hemlock/src/echocoms.lisp (modified) (16 diffs)
• hemlock/src/edit-defs.lisp (modified) (1 diff)
• hemlock/src/filecoms.lisp (modified) (4 diffs)
• hemlock/src/files.lisp (modified) (1 diff)
• hemlock/src/hemlock-ext.lisp (modified) (1 diff)
• hemlock/src/htext1.lisp (modified) (5 diffs)
• hemlock/src/htext2.lisp (modified) (7 diffs)
• hemlock/src/htext3.lisp (modified) (1 diff)
• hemlock/src/htext4.lisp (modified) (4 diffs)
• hemlock/src/interp.lisp (modified) (12 diffs)
• hemlock/src/kbdmac.lisp (deleted)
• hemlock/src/killcoms.lisp (modified) (1 diff)
• hemlock/src/listener.lisp (modified) (1 diff)
• hemlock/src/macros.lisp (modified) (7 diffs)
• hemlock/src/main.lisp (modified) (3 diffs)
• hemlock/src/modeline.lisp (modified) (2 diffs)
• hemlock/src/morecoms.lisp (modified) (8 diffs)
• hemlock/src/package.lisp (modified) (14 diffs)
• hemlock/src/register.lisp (modified) (3 diffs)
• hemlock/src/searchcoms.lisp (modified) (2 diffs)
• hemlock/src/streams.lisp (modified) (2 diffs)
• hemlock/src/struct.lisp (modified) (10 diffs)
• hemlock/src/syntax.lisp (modified) (20 diffs)
• hemlock/src/undo.lisp (modified) (1 diff)
• hemlock/src/vars.lisp (modified) (6 diffs)
• hemlock/src/views.lisp (added)
• hemlock/unused/kbdmac.lisp (copied) (copied from trunk/ccl/cocoa-ide/hemlock/src/kbdmac.lisp )

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

@@ -26 +26 @@
 
 (def-cocoa-default *use-screen-fonts* :bool t "Use bitmap screen fonts when available")
+
+
+(defgeneric hi:hemlock-view (ns-object))
+
+(defmethod hi:hemlock-view ((unknown t)) nil)
+
+
 
 (defmacro nsstring-encoding-to-nsinteger (n)
@@ -656 +663 @@
   (with-slots (mirror styles) self
     (when (>= index (#/length mirror))
-      (#_NSLog #@"Attributes at index: %lu  edit-count: %d mirror: %@ layout: %@" :<NSUI>nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0))
-      (for-each-textview-using-storage self
-                                       (lambda (tv)
-                                         (let* ((w (#/window tv))
-                                                (proc (slot-value w 'command-thread)))
-                                           (process-interrupt proc #'ccl::dbg))))
+      (#_NSLog #@"Bounds error - Attributes at index: %lu  edit-count: %d mirror: %@ layout: %@" :<NSUI>nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0))
       (ccl::dbg))
     (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr)))
@@ -713 +715 @@
       (when textstorage
         (#/endEditing textstorage)
+        ;; This isn't really right.  It should abort the entire command in progress,
+        ;; e.g. c-x ..., etc. and should do it before event start... Basically it
+        ;; should be handled as if it was a regular key event, except for the
+        ;; extra string argument.
         (for-each-textview-using-storage
          textstorage
          (lambda (tv)
            (hi::disable-self-insert
-            (hemlock-frame-event-queue (#/window tv)))))
+            (hi:hemlock-view tv))))
         (#/ensureSelectionVisible textstorage)))))
 
@@ -777 +783 @@
               (process-kill p)))
           (when (eq buffer hi::*current-buffer*)
-            (setf (hi::current-buffer)
-                  (car (last hi::*buffer-list*))))
-          (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer)
-          (hi::invoke-hook hemlock::delete-buffer-hook buffer)
-          (setq hi::*buffer-list* (delq buffer hi::*buffer-list*))
-         (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*))))))
+            (setf hi::*current-buffer* nil))
+          (hi::delete-buffer buffer :force t))))))
 
 
@@ -812 +814 @@
 (declaim (special hemlock-textstorage-text-view))
 
+(defmethod hi:hemlock-view ((self hemlock-textstorage-text-view))
+  ;; Not sure when any of this can fail, but at least try to make sure that if hemlock-view
+  ;; returns non-nil, then callers don't have to check for any other marginal situations.
+  (let ((frame (#/window self)))
+    (unless (%null-ptr-p frame)
+      (let ((view (hi:hemlock-view frame)))
+        (when view
+          (when (eq (hi::hemlock-view-buffer view) (text-view-buffer self))
+            view))))))
+
+
+(defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view))
+  ;; Return true if cmd-. is in the queue.  Not sure what to do about c-g:
+  ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe
+  ;; c-g will need to be synchronous meaning just end current command,
+  ;; while cmd-. is the real abort.
+  #|
+   (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0)))
+    (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue:
+                         target (logior #$whatever) now #&NSDefaultRunLoopMode t)))
+            (when (%null-ptr-p event) (return)))))
+  "target" can either be an NSWindow or the global shared application object;
+  |#
+  nil)
+
+(defvar *buffer-being-edited* nil)
+
+(objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event)
+  #+debug (#_NSLog #@"Key down event = %@" :address event)
+  (let* ((view (hi:hemlock-view self))
+         ;; quote-p means handle characters natively
+         (quote-p (and view (hi::hemlock-view-quote-next-p view))))
+    #+GZ (log-debug "~&quote-p ~s event ~s" quote-p event)
+    (if (or (null view)
+            (#/hasMarkedText self)
+            (and quote-p (zerop (#/length (#/characters event))))) ;; dead key, e.g. option-E
+      (call-next-method event)
+      (unless (eventqueue-abort-pending-p self)
+        (let ((hemlock-key (nsevent-to-key-event event quote-p)))
+          (when hemlock-key
+            #+GZ (log-debug "Handle key ~s" hemlock-key)
+            (hi::handle-hemlock-event view hemlock-key)))))))
+
+(defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
+  (declare (ignore event))
+  (with-autorelease-pool
+   (call-next-method)))
+
+;;; Translate a keyDown NSEvent to a Hemlock key-event.
+(defun nsevent-to-key-event (event quote-p)
+  (let* ((modifiers (#/modifierFlags event)))
+    (unless (logtest #$NSCommandKeyMask modifiers)
+      (let* ((chars (if quote-p
+                      (#/characters event)
+                      (#/charactersIgnoringModifiers event)))
+             (n (if (%null-ptr-p chars)
+                  0
+                  (#/length chars)))
+             (c (and (eql n 1)
+                     (#/characterAtIndex: chars 0))))
+        (when c
+          (let* ((bits 0)
+                 (useful-modifiers (logandc2 modifiers
+                                             (logior
+                                              ;#$NSShiftKeyMask
+                                              #$NSAlphaShiftKeyMask))))
+            (unless quote-p
+              (dolist (map hemlock-ext::*modifier-translations*)
+                (when (logtest useful-modifiers (car map))
+                  (setq bits (logior bits
+                                     (hemlock-ext:key-event-modifier-mask (cdr map)))))))
+            (let* ((char (code-char c)))
+              (when (and char (standard-char-p char))
+                (setq bits (logandc2 bits hi::+shift-event-mask+))))
+            (hemlock-ext:make-key-event c bits)))))))
+
+;; For now, this is only used to abort i-search.  All actual mouse handling is done
+;; by Cocoa.   In the future might want to allow users to extend via hemlock, e.g.
+;; to implement mouse-copy.
+;; Also -- shouldn't this happen on mouse up?
+(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
+  ;; If no modifier keys are pressed, send hemlock a no-op.
+  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
+    (let* ((view (hi:hemlock-view self)))
+      (when view
+        (unless (eventqueue-abort-pending-p self)
+          (hi::handle-hemlock-event view #k"leftdown")))))
+  (call-next-method event))
+
+#+GZ
+(objc:defmethod  (#/mouseUp: :void) ((self hemlock-textstorage-text-view) event)
+  (log-debug "~&MOUSE UP!!")
+  (call-next-method event))
 
 (defmethod assume-not-editing ((tv hemlock-textstorage-text-view))
@@ -1157 +1252 @@
 
 
-  
-
-
-;;; Translate a keyDown NSEvent to a Hemlock key-event.
-(defun nsevent-to-key-event (nsevent &optional quoted)
-  (let* ((modifiers (#/modifierFlags nsevent)))
-    (unless (logtest #$NSCommandKeyMask modifiers)
-      (let* ((chars (if quoted
-                      (#/characters nsevent)
-                      (#/charactersIgnoringModifiers nsevent)))
-             (n (if (%null-ptr-p chars)
-                  0
-                  (#/length chars)))
-             (c (if (eql n 1)
-                  (#/characterAtIndex: chars 0))))
-        (when c
-          (let* ((bits 0)
-                 (useful-modifiers (logandc2 modifiers
-                                             (logior ;#$NSShiftKeyMask
-                                                     #$NSAlphaShiftKeyMask))))
-            (unless quoted
-              (dolist (map hemlock-ext::*modifier-translations*)
-                (when (logtest useful-modifiers (car map))
-                  (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
-                                         (cdr map)))))))
-            (let* ((char (code-char c)))
-              (when (and char (standard-char-p char))
-                (setq bits (logandc2 bits hi::+shift-event-mask+))))
-            (hemlock-ext::make-key-event c bits)))))))
-
-(defun pass-key-down-event-to-hemlock (self event q)
-  #+debug
-  (#_NSLog #@"Key down event = %@" :address event)
-  (let* ((buffer (text-view-buffer self)))
-    (when buffer
-      (let* ((hemlock-event (nsevent-to-key-event event (hi::frame-event-queue-quoted-insert q ))))
-        (when hemlock-event
-          (hi::enqueue-key-event q hemlock-event))))))
-
-(defun hi::enqueue-buffer-operation (buffer thunk)
-  (dolist (w (hi::buffer-windows buffer))
-    (let* ((q (hemlock-frame-event-queue (#/window w)))
-           (op (hi::make-buffer-operation :thunk thunk)))
-      (hi::event-queue-insert q op))))
-
-
-
-;;; Process a key-down NSEvent in a Hemlock text view by translating it
-;;; into a Hemlock key event and passing it into the Hemlock command
-;;; interpreter. 
-
-(defun handle-key-down (self event)
-  (let* ((q (hemlock-frame-event-queue (#/window self))))
-    (if (or (and (zerop (#/length (#/characters event)))
-                 (hi::frame-event-queue-quoted-insert q))
-            (#/hasMarkedText self))
-      nil
-      (progn
-        (pass-key-down-event-to-hemlock self event q)
-        t))))
-  
-
-(objc:defmethod (#/keyDown: :void) ((self hemlock-text-view) event)
-  (or (handle-key-down self event)
-      (call-next-method event)))
-
-(objc:defmethod (#/mouseDown: :void) ((self hemlock-text-view) event)
-  ;; If no modifier keys are pressed, send hemlock a no-op.
-  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
-    (let* ((q (hemlock-frame-event-queue (#/window self))))
-      (hi::enqueue-key-event q #k"leftdown")))
-  (call-next-method event))
+(defun append-output (view string)
+  (assume-cocoa-thread)
+  ;; Arrange to do the append in command context
+  (when view
+    (hi::handle-hemlock-event view #'(lambda ()
+                                       (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string)))))
+
 
 ;;; Update the underlying buffer's point (and "active region", if appropriate.
@@ -1685 +1715 @@
 (objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document)))
 
-(objc:defmethod (#/keyDown: :void) ((self echo-area-view) event)
-  (or (handle-key-down self event)
-      (call-next-method event)))
-
-
 (defloadvar *hemlock-frame-count* 0)
 
@@ -1713 +1738 @@
               (progn
                 ;; What's the reason for sharing this?  Is it just the lock?
-                (setf (hi::buffer-gap-context buffer) (hi::buffer-gap-context main-buffer))
+                (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer))
                 (make-textstorage-for-hemlock-buffer buffer)))
              (doc (make-instance 'echo-area-document))
@@ -1764 +1789 @@
     ((echo-area-view :foreign-type :id)
      (pane :foreign-type :id)
-     (event-queue :initform (ccl::init-dll-header (hi::make-frame-event-queue))
-                  :reader hemlock-frame-event-queue)
-     (command-thread :initform nil)
+     (hemlock-view :initform nil :reader hemlock-frame-hemlock-view)
      (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer)
      (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream))
   (:metaclass ns:+ns-object))
 (declaim (special hemlock-frame))
+
+(defmethod hi:hemlock-view ((self hemlock-frame))
+  (hemlock-frame-hemlock-view self))
+
 
 (defun double-%-in (string)
@@ -1825 +1852 @@
                                     :count 2))
              #|(*debug-io* *typeout-stream*)|#)
-        (stream-clear-output *debug-io*)
-        (ignore-errors (print-call-history :detailed-p t))
         (#/performSelectorOnMainThread:withObject:waitUntilDone:
          frame (@selector #/runErrorSheet:) params t)
-        (wait-on-semaphore semaphore)))))
+        (unless (eq *current-process* *initial-process*)
+          (wait-on-semaphore semaphore))))))
 
 (defun hi::report-hemlock-error (condition)
@@ -1836 +1862 @@
       (report-condition-in-hemlock-frame condition (#/window pane)))))
                        
-
-(defun hemlock-thread-function (q buffer pane echo-buffer echo-window)
-  (let* ((hi::*real-editor-input* q)
-         (hi::*editor-input* q)
-         (hi::*current-buffer* hi::*current-buffer*)
-         (hi::*current-window* pane)
-         (hi::*echo-area-window* echo-window)
-         (hi::*echo-area-buffer* echo-buffer)
-         (region (hi::buffer-region echo-buffer))
-         (hi::*echo-area-region* region)
-         (hi::*echo-area-stream* (hi::make-hemlock-output-stream
-                              (hi::region-end region) :full))
-         (hi::*parse-starting-mark*
-          (hi::copy-mark (hi::buffer-point hi::*echo-area-buffer*)
-                         :right-inserting))
-         (hi::*parse-input-region*
-          (hi::region hi::*parse-starting-mark*
-                      (hi::region-end region)))
-         (hi::*cache-modification-tick* -1)
-         (hi::*disembodied-buffer-counter* 0)
-         (hi::*in-a-recursive-edit* nil)
-         (hi::*last-key-event-typed* nil)
-         (hi::*input-transcript* nil)
-         (hemlock::*target-column* 0)
-         (hemlock::*last-comment-start* " ")
-         (hi::*translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-         (hi::*current-command* (make-array 10 :fill-pointer 0 :adjustable t))
-         (hi::*current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
-         (hi::*prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
-         (hi::*command-key-event-buffer* buffer))
-    
-    (setf (hi::current-buffer) buffer)
-    (unwind-protect
-         (loop
-           (catch 'hi::editor-top-level-catcher
-             (handler-bind ((error #'(lambda (condition)
-                                       (hi::lisp-error-error-handler condition
-                                                                     :internal))))
-               (hi::invoke-hook hemlock::abort-hook)
-               (hi::%command-loop))))
-      (hi::invoke-hook hemlock::exit-hook))))
-
-
 (objc:defmethod (#/close :void) ((self hemlock-frame))
   (let* ((content-view (#/contentView self))
@@ -1885 +1868 @@
          ((< i 0))
       (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i))))
-  (let* ((proc (slot-value self 'command-thread)))
-    (when proc
-      (setf (slot-value self 'command-thread) nil)
-      (process-kill proc)))
   (let* ((buf (hemlock-frame-echo-area-buffer self))
          (echo-doc (if buf (hi::buffer-document buf))))
@@ -1929 +1908 @@
     (nsstring-to-buffer nsstring buffer)))
 
-(defun %nsstring-to-mark (nsstring mark)
+(defun %nsstring-to-hemlock-string (nsstring)
   "returns line-termination of string"
   (let* ((string (lisp-string-from-nsstring nsstring))
@@ -1936 +1915 @@
          (line-termination (if crpos
                              (if (eql lfpos (1+ crpos))
-                               :cp/m
-                               :macos)
-                             :unix)))
-    (hi::insert-string mark
-                           (case line-termination
-                             (:cp/m (remove #\return string))
-                             (:macos (nsubstitute #\linefeed #\return string))
-                             (t string)))
-    line-termination))
-  
+                               :crlf
+                               :cr)
+                             :lf))
+         (hemlock-string (case line-termination
+                           (:crlf (remove #\return string))
+                           (:cr (nsubstitute #\linefeed #\return string))
+                           (t string))))
+    (values hemlock-string line-termination)))
+
+;: TODO: I think this is jumping through hoops because it want to be invokable outside the main
+;; cocoa thread.
 (defun nsstring-to-buffer (nsstring buffer)
   (let* ((document (hi::buffer-document buffer))
          (hi::*current-buffer* buffer)
          (region (hi::buffer-region buffer)))
-    (setf (hi::buffer-document buffer) nil)
-    (unwind-protect
-         (progn
-           (hi::delete-region region)
-           (hi::modifying-buffer buffer
-                                 (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting))
-                                   (setf (hi::buffer-line-termination buffer)
-                                         (%nsstring-to-mark nsstring mark)))
-                                 (setf (hi::buffer-modified buffer) nil)
-                                 (hi::buffer-start (hi::buffer-point buffer))
-                                 (hi::renumber-region region)
-                                 buffer))
-      (setf (hi::buffer-document buffer) document))))
-
+    (multiple-value-bind (hemlock-string line-termination)
+                         (%nsstring-to-hemlock-string nsstring)
+      (setf (hi::buffer-line-termination buffer) line-termination)
+
+      (setf (hi::buffer-document buffer) nil) ;; What's this about??
+      (unwind-protect
+          (let ((point (hi::buffer-point buffer)))
+            (hi::delete-region region)
+            (hi::insert-string point hemlock-string)
+            (setf (hi::buffer-modified buffer) nil)
+            (hi::buffer-start point)
+            ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping.
+            (hi::renumber-region region)
+            buffer)
+        (setf (hi::buffer-document buffer) document)))))
 
 
@@ -1984 +1965 @@
       (setq peer tv))
     (hi::activate-hemlock-view pane)
+    (setf (slot-value frame 'hemlock-view)
+          (make-instance 'hi:hemlock-view
+            :buffer buffer
+            :pane pane
+            :echo-area-buffer (hemlock-frame-echo-area-buffer frame)
+            :echo-area-pane echo-area))
     (setf (slot-value frame 'echo-area-view) echo-area
           (slot-value frame 'pane) pane)
-    (setf (slot-value frame 'command-thread)
-          (process-run-function (format nil "Hemlock window thread for ~s"
-                                        (hi::buffer-name buffer))
-                                #'(lambda ()
-                                    (hemlock-thread-function
-                                     (hemlock-frame-event-queue frame)
-                                     buffer
-                                     pane
-                                     (hemlock-frame-echo-area-buffer frame)
-                                     (slot-value frame 'echo-area-view)))))
     frame))
-         
-    
-
-
-(defun hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
-  (process-interrupt *cocoa-event-process*
-                     #'%hemlock-frame-for-textstorage
-                     class ts  ncols nrows container-tracks-text-view-width color style))
-
 
 
@@ -2014 +1982 @@
   (release-lock (hi::buffer-lock b))) 
 
-(defun hi::document-begin-editing (document)
-  (#/performSelectorOnMainThread:withObject:waitUntilDone:
-   (slot-value document 'textstorage)
-   (@selector #/beginEditing)
-   +null-ptr+
-   t))
+(defun invoke-modifying-buffer-storage (buffer thunk)
+  (assume-cocoa-thread)
+  (when buffer ;; nil means just get rid of any prior buffer
+    (setq buffer (require-type buffer 'hi::buffer)))
+  (let ((old *buffer-being-edited*))
+    (if (eq buffer old)
+      (funcall thunk)
+      (unwind-protect
+          (progn
+            (buffer-document-end-editing old)
+            (buffer-document-begin-editing buffer)
+            (funcall thunk))
+        (buffer-document-end-editing buffer)
+        (buffer-document-begin-editing old)))))
+
+(defun buffer-document-end-editing (buffer)
+  (when buffer
+    (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer))))
+      (when document
+        (setq *buffer-being-edited* nil)
+        (let ((ts (slot-value document 'textstorage)))
+          (#/endEditing ts)
+          ;; TODO: no reason for this to be an objC function!!
+          (#/updateHemlockSelection ts))))))
+
+(defun buffer-document-begin-editing (buffer)
+  (when buffer
+    (let* ((document (hi::buffer-document buffer)))
+      (when document
+        (setq *buffer-being-edited* buffer)
+        (#/beginEditing (slot-value document 'textstorage))))))
 
 (defun document-edit-level (document)
@@ -2025 +2018 @@
   (slot-value (slot-value document 'textstorage) 'edit-count))
 
-(defun hi::document-end-editing (document)
-  (#/performSelectorOnMainThread:withObject:waitUntilDone:
-   (slot-value document 'textstorage)
-   (@selector #/endEditing)
-   +null-ptr+
-   t))
-
+#|
 (defun hi::document-set-point-position (document)
   (declare (ignorable document))
@@ -2039 +2026 @@
     (#/performSelectorOnMainThread:withObject:waitUntilDone:
      textstorage (@selector #/updateHemlockSelection) +null-ptr+ t)))
-
-
+|#
 
 (defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
@@ -2194 +2180 @@
   (:metaclass ns:+ns-object))
 
+(defmethod hi:hemlock-view ((self hemlock-editor-window-controller))
+  (let ((frame (#/window self)))
+    (unless (%null-ptr-p frame)
+      (hi:hemlock-view frame))))
 
 ;;; Map *default-file-character-encoding* to an :<NSS>tring<E>ncoding
@@ -2283 +2273 @@
 (defvar *encoding-name-hash* (make-hash-table))
 
-(defmethod hi::document-encoding-name ((doc hemlock-editor-document))
+(defmethod document-encoding-name ((doc hemlock-editor-document))
   (with-slots (encoding) doc
     (if (eql encoding 0)
@@ -2291 +2281 @@
                 (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding)))))))
 
-
+(defun hi::buffer-encoding-name (buffer)
+  (let ((doc (hi::buffer-document buffer)))
+    (and doc (document-encoding-name doc))))
+
+;; TODO: make each buffer have a slot, and this is just the default value.
 (defmethod textview-background-color ((doc hemlock-editor-document))
   *editor-background-color*)
@@ -2344 +2338 @@
     (hi::queue-buffer-change buffer)
     t))
-         
-            
-  
+
+
 (objc:defmethod #/init ((self hemlock-editor-document))
   (let* ((doc (call-next-method)))
@@ -2358 +2351 @@
 
   
+(defun make-buffer-for-document (ns-document pathname)
+  (let* ((buffer-name (hi::pathname-to-buffer-name pathname))
+         (buffer (make-hemlock-buffer buffer-name)))
+    (setf (slot-value ns-document 'textstorage)
+          (make-textstorage-for-hemlock-buffer buffer))
+    (setf (hi::buffer-pathname buffer) pathname)
+    buffer))
+
 (objc:defmethod (#/readFromURL:ofType:error: :<BOOL>)
     ((self hemlock-editor-document) url type (perror (:* :id)))
@@ -2367 +2368 @@
                (#/path url)
                (#/absoluteString url))))
-           (buffer-name (hi::pathname-to-buffer-name pathname))
-           (buffer (or
-                    (hemlock-document-buffer self)
-                    (let* ((b (make-hemlock-buffer buffer-name)))
-                      (setf (hi::buffer-pathname b) pathname)
-                      (setf (slot-value self 'textstorage)
-                            (make-textstorage-for-hemlock-buffer b))
-                      b)))
+           (buffer (or (hemlock-document-buffer self)
+                       (make-buffer-for-document self pathname)))
            (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
            (string
@@ -2397 +2392 @@
       (unless (%null-ptr-p string)
         (with-slots (encoding) self (setq encoding selected-encoding))
-        (hi::queue-buffer-change buffer)
-        (hi::document-begin-editing self)
-        (nsstring-to-buffer string buffer)
-
         (let* ((textstorage (slot-value self 'textstorage))
                (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
+
+          (hi::queue-buffer-change buffer)
+          (#/beginEditing textstorage)
+
+          (nsstring-to-buffer string buffer)
 
           (reset-buffer-cache display) 
@@ -2413 +2409 @@
            textstorage
            0
-           (hemlock-buffer-length buffer)))
-
-        (hi::document-end-editing self)
+           (hemlock-buffer-length buffer))
+
+          (#/endEditing textstorage))
 
         (setf (hi::buffer-modified buffer) nil)
         (hi::process-file-options buffer pathname)
         t))))
-
-
 
 
@@ -2464 +2458 @@
         (when cache (buffer-cache-buffer cache))))))
 
-(defmethod hi:window-buffer ((frame hemlock-frame))
+(defmethod hi::window-buffer ((frame hemlock-frame))
   (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
          (doc (#/documentForWindow: dc frame)))
@@ -2473 +2467 @@
       (hemlock-document-buffer doc))))
 
-(defmethod hi:window-buffer ((pane text-pane))
-  (hi:window-buffer (#/window pane)))
+(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)))
+                          (hi::window-buffer win)))
                    (windows)))
 
@@ -2524 +2518 @@
            (buffer (hemlock-document-buffer self)))
       (case (when buffer (hi::buffer-line-termination buffer))
-        (:cp/m (unless (typep string 'ns:ns-mutable-string)
-                 (setq string (make-instance 'ns:ns-mutable-string :with string string))
-               (#/replaceOccurrencesOfString:withString:options:range:
-                string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
-        (:macos (setq string (if (typep string 'ns:ns-mutable-string)
-                              string
-                              (make-instance 'ns:ns-mutable-string :with string string)))
-                (#/replaceOccurrencesOfString:withString:options:range:
-                string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
+        (:crlf (unless (typep string 'ns:ns-mutable-string)
+                 (setq string (make-instance 'ns:ns-mutable-string :with string string))
+                 (#/replaceOccurrencesOfString:withString:options:range:
+                  string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
+        (:cr (setq string (if (typep string 'ns:ns-mutable-string)
+                            string
+                            (make-instance 'ns:ns-mutable-string :with string string)))
+             (#/replaceOccurrencesOfString:withString:options:range:
+              string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
       (when (#/writeToURL:atomically:encoding:error:
              string url t encoding error)
@@ -3022 +3016 @@
           ((or (typep arg 'string)
                (typep arg 'pathname))
-           (unless (probe-file arg)
-             (ccl::touch arg))
+           #+no (unless (probe-file arg)
+                  (ccl::touch arg))
            (with-autorelease-pool
              (let* ((url (pathname-to-url arg))

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

@@ -163 +163 @@
     (let* ((data (#/objectForKey: (#/userInfo notification)
                                   #&NSFileHandleNotificationDataItem))
-           (document (#/document self))
            (encoding (load-time-value (get-character-encoding :utf-8)))
            (data-length (#/length data))
-           (buffer (hemlock-document-buffer document))
            (n nextra)
            (cursize bufsize)
@@ -200 +198 @@
                       (%get-unsigned-byte xlate (+ noctets-used i)))))
             (setq nextra n)
-            (hi::enqueue-buffer-operation
-             buffer
-             #'(lambda ()
-                 (unwind-protect
-                      (progn
-                        (hi::buffer-document-begin-editing buffer)
-                        (hemlock::append-buffer-output buffer string))
-                   (hi::buffer-document-end-editing buffer))))
+            (let ((view (hi::hemlock-view self)))
+              (queue-for-cocoa-thread #'(lambda () (append-output view string))))
             (#/readInBackgroundAndNotify fh)))))))
              
@@ -239 +231 @@
   (declare (ignore buffer)))
 
-(defmethod hi::document-encoding-name ((doc hemlock-listener-document))
+(defmethod document-encoding-name ((doc hemlock-listener-document))
   "UTF-8")
 
@@ -398 +390 @@
   (let* ((buffer (hemlock-document-buffer self))
          (process (if buffer (hi::buffer-process buffer))))
+    (log-debug  "~&exitBreak buffer ~s process ~s" buffer process)
     (when (typep process 'cocoa-listener-process)
       (process-interrupt process #'abort-break))))
@@ -471 +464 @@
     (if (typep process 'cocoa-listener-process)
       (let* ((action (#/action item)))
+        #+GZ (log-debug "Validate menu item buffer: ~s process: ~s action: ~s context ~s" buffer process
+                        (cond ((eql action (@selector #/revertDocumentToSaved:))
+                               "revertDocumentToSaved:")
+                              ((eql action (@selector #/saveDocument:))
+                               "saveDocument:")
+                              ((eql action (@selector #/saveDocumentAs:))
+                               "saveDocumentAs:")
+                              ((eql action (@selector #/interrupt:))
+                               "interrupt")
+                              ((eql action (@selector #/continue:))
+                               "continue")
+                              ((eql action (@selector #/backtrace:))
+                               "backtrace")
+                              ((eql action (@selector #/exitBreak:))
+                               "exitBreak:")
+                              ((eql action (@selector #/restarts:))
+                               "restarts:")
+                              (t action))
+                        (cocoa-listener-process-backtrace-contexts process))
         (cond
           ((or (eql action (@selector #/revertDocumentToSaved:))

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

@@ -115 +115 @@
     (nreverse ret)))
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; utilities for executing in the cocoa event thread
+
+(defstatic *cocoa-thread-arg-id-map* (make-id-map))
+
+;; This is for debugging, it's preserved across queue-for-cocoa-thread and bound
+;; so it can be seen in backtraces.
+(defvar *invoking-event-context* "unknown")
+(defvar *invoking-event-process* nil)
+
+(defun register-cocoa-thread-function (thunk result-handler context)
+  (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk
+                                                     result-handler
+                                                     (or context *invoking-event-context*)
+                                                     *current-process*)))
+
+(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
+  (invoke-lisp-function self id))
+
+(defmethod invoke-lisp-function ((self ns:ns-application) id)
+  (destructuring-bind (thunk result-handler context . invoking-process)
+                      (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id)))
+    (handle-invoking-lisp-function thunk result-handler context invoking-process)))
+
+;; This immediately executes the thunk in the cocoa thread, via performSelectorOnMainThread.
+;; It should only be used for relatively quick and safe stuff.
+(defun execute-in-cocoa-thread (thunk &key result-handler context)
+  "Execute thunk in the main cocoa thread, waiting for it to return."
+  (if (eq *current-process* ccl::*initial-process*)
+    (handle-invoking-lisp-function thunk result-handler context)
+    (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
+      (error "cocoa thread not available")
+      (let ((arg (make-instance 'ns:ns-number
+                   :with-long (register-cocoa-thread-function thunk result-handler context))))
+        (#/performSelectorOnMainThread:withObject:waitUntilDone:
+         *nsapp*
+         (@selector #/invokeLispFunction:)
+         arg
+         t)))))
+
+(defconstant $lisp-function-event-subtype 17)
+
+(defclass lisp-application (ns:ns-application)
+    ((termp :foreign-type :<BOOL>))
+  (:metaclass ns:+ns-object))
+
+;;; I'm not sure if there's another way to recognize events whose
+;;; type is #$NSApplicationDefined.
+(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
+  (if (and (eql (#/type e) #$NSApplicationDefined)
+           (eql (#/subtype e) $lisp-function-event-subtype))
+    (invoke-lisp-function self (#/data1 e))
+    (call-next-method e)))
+
+;; This queues an event rather than just doing performSelectorOnMainThread.
+(defun queue-for-cocoa-thread (thunk &key result-handler context at-start)
+  "Queue thunk for execution in main cocoa thread and return immediately."
+  (execute-in-cocoa-thread
+   #'(lambda () 
+       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
+                  ns:ns-event
+                  #$NSApplicationDefined
+                  (ns:make-ns-point 0 0)
+                  0
+                  0.0d0
+                  0
+                  +null-ptr+
+                  $lisp-function-event-subtype
+                  (register-cocoa-thread-function thunk result-handler context)
+                  0)))
+         ;(#/retain e)
+         (#/postEvent:atStart: *nsapp* e (not (null at-start)))))))
+
+(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*))
+  ;; TODO: the point is to execute result-handler in the original process, but this will do for now.
+  (let* ((*invoking-event-process* invoking-process)
+         (*invoking-event-context* context))
+    (if result-handler
+      (multiple-value-call result-handler (funcall thunk))
+      (funcall thunk))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; debugging
+
 (defun log-debug (format-string &rest args)
   (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args))))
 
+(defun nslog-condition (c)
+  (let* ((rep (format nil "~a" c)))
+    (with-cstrs ((str rep))
+      (with-nsstr (nsstr str (length rep))
+        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
+
+
+
 (defun assume-cocoa-thread ()
   #+debug (assert (eq *current-process* *initial-process*)))

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

@@ -50 +50 @@
                  :void))
 
-(defstatic *appkit-process-interrupt-ids* (make-id-map))
-(defun register-appkit-process-interrupt (thunk)
-  (assign-id-map-id *appkit-process-interrupt-ids* thunk))
-(defun appkit-interrupt-function (id)
-  (id-map-free-object *appkit-process-interrupt-ids* id))
-
 (defclass appkit-process (process) ())
-
-(defconstant process-interrupt-event-subtype 17)
-
-
-
-
-(defclass lisp-application (ns:ns-application)
-    ((termp :foreign-type :<BOOL>))
-  (:metaclass ns:+ns-object))
-
-
-(objc:defmethod (#/postEventAtStart: :void) ((self  ns:ns-application) e)
-  (#/postEvent:atStart: self e t))
 
 ;;; Interrupt the AppKit event process, by enqueing an event (if the
@@ -76 +57 @@
 ;;; case, the application's probably already in the process of
 ;;; exiting, and isn't that different from the case where asynchronous
-;;; interrupts are used.  An attribute of the event is used to identify
-;;; the thunk which the event handler needs to funcall.
+;;; interrupts are used.
 (defmethod process-interrupt ((process appkit-process) function &rest args)
   (if (eq process *current-process*)
     (apply function args)
-    (if (or (not *NSApp*) (not (#/isRunning *NSApp*)))
-      (call-next-method)
-        (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
-                   ns:ns-event
-                   #$NSApplicationDefined
-                   (ns:make-ns-point 0 0)
-                   0
-                   0.0d0
-                   0
-                   +null-ptr+
-                   process-interrupt-event-subtype
-                   (register-appkit-process-interrupt
-                    #'(lambda () (apply function args))) 0)))
-        (#/retain e)
-        (#/performSelectorOnMainThread:withObject:waitUntilDone:
-         *NSApp* (@selector "postEventAtStart:") e  t)))))
-
+    (if (and *NSApp* (#/isRunning *NSApp*))
+      (queue-for-cocoa-thread #'(lambda () (apply function args))
+                              :at-start t)
+      (call-next-method))))
 
 (defparameter *debug-in-event-process* t)
@@ -147 +114 @@
     (eql 0 (#_SetFrontProcess psn))))
 
-;;; I'm not sure if there's another way to recognize events whose
-;;; type is #$NSApplicationDefined.
-(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
-  (if (and (eql (#/type e) #$NSApplicationDefined)
-           (eql (#/subtype e)  process-interrupt-event-subtype))
-    ;;; The thunk to funcall is identified by the value
-    ;;; of the event's data1 attribute.
-    (funcall (appkit-interrupt-function (#/data1 e)))
-    (call-next-method e)))
-
 #+nil
 (objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
@@ -166 +123 @@
   (#/show (#/sharedPanel typeout-window)))
 
-(defun nslog-condition (c)
-  (let* ((rep (format nil "~a" c)))
-    (with-cstrs ((str rep))
-      (with-nsstr (nsstr str (length rep))
-        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
-
-
 (defmethod ccl::process-exit-application ((process appkit-process) thunk)
   (when (eq process ccl::*initial-process*)
@@ -181 +131 @@
   (%set-toplevel nil)
   (change-class *cocoa-event-process* 'appkit-process)
-  (let* ((app *NSApp*))
+  (event-loop))
+
+(defun stop-event-loop ()
+  (#/stop: *nsapp* +null-ptr+))
+
+(defun event-loop (&optional end-test)
+  (let ((app *NSApp*))
     (loop
-        (handler-case (let* ((*event-process-reported-conditions* nil))
-                        (#/run app))
-          (error (c) (nslog-condition c)))
-        (unless (#/isRunning app)
-          (return)))))
-
-
+      (handler-case (let* ((*event-process-reported-conditions* nil))
+                      (if end-test
+                        (#/run app)
+                        #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
+                                               #&NSDefaultRunLoopMode
+                                               (#/distantFuture ns:ns-date))|#
+                        (#/run app)))
+        (error (c) (nslog-condition c)))
+      #+GZ (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
+      (when (or (and end-test (funcall end-test))
+                (and ccl::*quitting* (not (#/isRunning app))))
+        (return)))))
 
 (defun start-cocoa-application (&key

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

@@ -1 +1 @@
 (in-package "CCL")
 
-(defvar *cocoa-application-path* "ccl:temp bundle.app;")
+(defvar *cocoa-application-path* #+gz "ccl:GZ temp bundle.app;" #-gz "ccl:temp bundle.app;")
 (defvar *cocoa-application-copy-headers-p* nil)
 (load "ccl:cocoa-ide;defsystem.lisp")

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

@@ -47 +47 @@
 
     "macros"
+
+    "views"
     "line"
     "ring"
@@ -77 +79 @@
     "killcoms"
     "searchcoms"
+    "isearchcoms"
     "filecoms"
     "doccoms"
@@ -85 +88 @@
     "comments"
     "icom"
-    "kbdmac"
     "defsyn"
     "edit-defs"

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

@@ -75 +75 @@
 (bind-key "Scroll Window Up" #k"meta-v")
 (bind-key "Scroll Window Up" #k"pageup")
-(bind-key "Scroll Next Window Down" #k"control-meta-v")
-(bind-key "Scroll Next Window Up" #k"control-meta-V")
+;(bind-key "Scroll Next Window Down" #k"control-meta-v")
+;(bind-key "Scroll Next Window Up" #k"control-meta-V")
 
 (bind-key "Do Nothing" #k"leftdown")
-
+;(bind-key "Do Nothing" #k"leftup")
+
+(bind-key "Abort Command" #k"control-g")
+(bind-key "Abort Command" #k"control-G")
 
 (bind-key "Process File Options" #k"control-x m" :global)
@@ -116 +119 @@
 (bind-key "Buffer Not Modified" #k"meta-~")
 ;(bind-key "Check Buffer Modified" #k"control-x ~")
-(bind-key "Select Buffer" #k"control-x b")
+;(bind-key "Select Buffer" #k"control-x b")
 ;(bind-key "Select Previous Buffer" #k"control-meta-l")
 ;(bind-key "Circulate Buffers" #k"control-meta-L")
@@ -134 +137 @@
 ;(bind-key "Top of Window" #k"meta-,")
 ;(bind-key "Bottom of Window" #k"meta-.")
-
-(bind-key "Exit Recursive Edit" #k"control-meta-z")
-(bind-key "Abort Recursive Edit" #k"control-]")
 
 (bind-key "Delete Previous Character" #k"delete")
@@ -193 +193 @@
 ;;;; Argument Digit and Negative Argument.
 
-(bind-key "Negative Argument" #k"meta-\-")
+(bind-key "Argument Digit" #k"meta-\-")
 (bind-key "Argument Digit" #k"meta-0")
 (bind-key "Argument Digit" #k"meta-1")
@@ -204 +204 @@
 (bind-key "Argument Digit" #k"meta-8")
 (bind-key "Argument Digit" #k"meta-9")
-(bind-key "Negative Argument" #k"control-\-")
+(bind-key "Argument Digit" #k"control-\-")
 (bind-key "Argument Digit" #k"control-0")
 (bind-key "Argument Digit" #k"control-1")
@@ -215 +215 @@
 (bind-key "Argument Digit" #k"control-8")
 (bind-key "Argument Digit" #k"control-9")
-(bind-key "Negative Argument" #k"control-meta-\-")
+(bind-key "Argument Digit" #k"control-meta-\-")
 (bind-key "Argument Digit" #k"control-meta-0")
 (bind-key "Argument Digit" #k"control-meta-1")
@@ -226 +226 @@
 (bind-key "Argument Digit" #k"control-meta-8")
 (bind-key "Argument Digit" #k"control-meta-9")
+
+(bind-key "Digit" #k"\-")
+(bind-key "Digit" #k"0")
+(bind-key "Digit" #k"1")
+(bind-key "Digit" #k"2")
+(bind-key "Digit" #k"3")
+(bind-key "Digit" #k"4")
+(bind-key "Digit" #k"5")
+(bind-key "Digit" #k"6")
+(bind-key "Digit" #k"7")
+(bind-key "Digit" #k"8")
+(bind-key "Digit" #k"9")
 
 
@@ -247 +259 @@
 (bind-key "Self Insert" #k"+")
 (bind-key "Self Insert" #k"~")
-(bind-key "Self Insert" #k"1")
-(bind-key "Self Insert" #k"2")
-(bind-key "Self Insert" #k"3")
-(bind-key "Self Insert" #k"4")
-(bind-key "Self Insert" #k"5")
-(bind-key "Self Insert" #k"6")
-(bind-key "Self Insert" #k"7")
-(bind-key "Self Insert" #k"8")
-(bind-key "Self Insert" #k"9")
-(bind-key "Self Insert" #k"0")
 (bind-key "Self Insert" #k"[")
 (bind-key "Self Insert" #k"]")
@@ -265 +267 @@
 (bind-key "Self Insert" #k"\"")
 (bind-key "Self Insert" #k"'")
-(bind-key "Self Insert" #k"\-")
 (bind-key "Self Insert" #k"=")
 (bind-key "Self Insert" #k"`")
@@ -521 +522 @@
 
 
+#|
 ;;;; Keyboard macro bindings.
 
@@ -529 +531 @@
 (bind-key "Last Keyboard Macro" #k"control-x e")
 (bind-key "Keyboard Macro Query" #k"control-x q")
+|#
 
 
@@ -933 +936 @@
 
 
+;;;; I-Search mode.
+;;;;
+;;;; Anything that's not explicitly bound here will exit i-search.
+
+(dotimes (n hemlock::char-code-limit)
+  (when (standard-char-p (code-char n))
+    (let ((key (hemlock-ext:make-key-event n)))
+      (bind-key "I-Search Self Insert" key :mode "I-Search"))))
+
+(bind-key "I-Search Repeat Forward" #k"control-s" :mode "I-Search")
+(bind-key "I-Search Repeat Backward" #k"control-r" :mode "I-Search")
+(bind-key "I-Search Backup" #k"backspace" :mode "I-Search")
+(bind-key "I-Search Backup" #k"delete" :mode "I-Search")
+(bind-key "I-Search Abort" #k"control-g" :mode "I-Search")
+(bind-key "I-Search Abort" #k"control-G" :mode "I-Search")
+(bind-key "I-Search Exit or Search" #k"escape" :mode "I-Search")
+(bind-key "I-Search Yank Word" #k"control-w" :mode "I-Search")
+(bind-key "Quoted Insert" #k"control-q" :mode "I-Search")
+
+
 ;;;; Logical characters.
-
-(setf (logical-key-event-p #k"control-s" :forward-search) t)
-(setf (logical-key-event-p #k"control-r" :backward-search) t)
-(setf (logical-key-event-p #k"control-r" :recursive-edit) t)
-(setf (logical-key-event-p #k"delete" :cancel) t)
-(setf (logical-key-event-p #k"backspace" :cancel) t)
+ 
 (setf (logical-key-event-p #k"control-g" :abort) t)
-(setf (logical-key-event-p #k"escape" :exit) t)
-(setf (logical-key-event-p #k"leftdown" :mouse-exit) t)
 (setf (logical-key-event-p #k"y" :yes) t)
 (setf (logical-key-event-p #k"space" :yes) t)
@@ -957 +973 @@
 (setf (logical-key-event-p #k"control-q" :quote) t)
 (setf (logical-key-event-p #k"k" :keep) t)
-(setf (logical-key-event-p #k"control-w" :extend-search-word) t)

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

@@ -133 +133 @@
 ;;;; Variable binding -- winding and unwinding.
 
-(eval-when (:compile-toplevel :execute)
-
 (defmacro unbind-variable-bindings (bindings)
   `(do ((binding ,bindings (binding-across binding)))
@@ -149 +147 @@
              (car cons) object))))
 
-) ;eval-when
-
 ;;; UNWIND-BINDINGS  --  Internal
 ;;;
@@ -158 +154 @@
 ;;; unwind all bindings.
 ;;;
-(defun unwind-bindings (mode)
-  (unbind-variable-bindings (buffer-var-values *current-buffer*))
-  (do ((curmode (buffer-mode-objects *current-buffer*))
+(defun unwind-bindings (buffer mode)
+  #+gz (assert (buffer-bindings-wound-p buffer))
+  (setf (buffer-bindings-wound-p buffer) nil)
+  (unbind-variable-bindings (buffer-var-values buffer))
+  (do ((curmode (buffer-mode-objects buffer))
        (unwound ()) cw)
       (())
@@ -166 +164 @@
     (unbind-variable-bindings (mode-object-var-values (car unwound)))
     (when (or (null curmode) (eq (car unwound) mode))
-      (setf (buffer-mode-objects *current-buffer*) curmode)
+      (setf (buffer-mode-objects buffer) curmode)
       (return unwound))))
 
@@ -173 +171 @@
 ;;;    Add "modes" to the mode bindings currently in effect.
 ;;;
-(defun wind-bindings (modes)
-  (do ((curmode (buffer-mode-objects *current-buffer*)) cw)
-      ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode))
+(defun wind-bindings (buffer modes)
+  #+gz (assert (not (buffer-bindings-wound-p buffer)))
+  (setf (buffer-bindings-wound-p buffer) t)
+  (do ((curmode (buffer-mode-objects buffer)) cw)
+      ((null modes) (setf (buffer-mode-objects buffer) curmode))
     (bind-variable-bindings (mode-object-var-values (car modes)))
     (setf cw modes  modes (cdr modes)  (cdr cw) curmode  curmode cw))
-  (bind-variable-bindings (buffer-var-values *current-buffer*)))
-
-
+  (bind-variable-bindings (buffer-var-values buffer)))
+
+
+
+(defun setup-buffer-bindings (buffer)
+  (wind-bindings buffer (shiftf (buffer-mode-objects buffer) nil)))
+
+(defun revert-buffer-bindings (buffer)
+  (setf (buffer-mode-objects buffer) (unwind-bindings buffer nil)))
 
 
 ;;;; BUFFER-MAJOR-MODE.
 
-(eval-when (:compile-toplevel :execute)
 (defmacro with-mode-and-buffer ((name major-p buffer) &body forms)
   `(let ((mode (get-mode-object name)))
@@ -193 +198 @@
     (check-type ,buffer buffer)
     ,@forms))
-) ;eval-when
 
 ;;; BUFFER-MAJOR-MODE  --  Public
@@ -217 +221 @@
     (invoke-hook hemlock::buffer-major-mode-hook buffer name)
     (cond
-     ((eq buffer *current-buffer*)
+     ((buffer-bindings-wound-p buffer)
       (let ((old-mode (car (last (buffer-mode-objects buffer)))))
         (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
         (funcall (mode-object-cleanup-function old-mode) buffer)
-        (swap-char-attributes old-mode)
-        (wind-bindings (cons mode (cdr (unwind-bindings old-mode))))
-        (swap-char-attributes mode)))
+        (wind-bindings buffer (cons mode (cdr (unwind-bindings buffer old-mode))))))
      (t
       (let ((old-mode (car (buffer-mode-objects buffer))))
@@ -229 +231 @@
         (funcall (mode-object-cleanup-function old-mode) buffer))
       (setf (car (buffer-mode-objects buffer)) mode)))
+    (invalidate-shadow-attributes buffer)
     (setf (car (buffer-modes buffer)) name)
     (funcall (mode-object-setup-function mode) buffer)
@@ -265 +268 @@
        ;; Adding a new mode.
        (new-value
-        (cond
-         ((eq buffer *current-buffer*)
-          ;;
-          ;; Unwind bindings having higher precedence, cons on the new
-          ;; mode and then wind them back on again.
-          (do ((m objects (cdr m))
-               (prev nil (car m)))
-              ((or (null (cdr m))
-                   (< (mode-object-precedence (car m))
-                      (mode-object-precedence mode)))
-               (wind-bindings
-                (cons mode (if prev
-                               (unwind-bindings prev)
-                               (unbind-variable-bindings
-                                (buffer-var-values *current-buffer*))))))))
-         (t
+        (let ((wound-p (buffer-bindings-wound-p buffer)))
+          (when wound-p
+            (revert-buffer-bindings buffer))
           (do ((m (cdr objects) (cdr m))
                (prev objects m))
@@ -286 +276 @@
                    (>= (mode-object-precedence (car m))
                        (mode-object-precedence mode)))
-               (setf (cdr prev) (cons mode m))))))
+               (setf (cdr prev) (cons mode m))))
+          (when wound-p
+            (setup-buffer-bindings buffer)))
         ;;
         ;; Add the mode name.
@@ -303 +295 @@
         ;; In the current buffer, unwind buffer and any mode bindings on top
         ;; pop off the mode and wind the rest back on.
-        (cond ((eq buffer *current-buffer*)
-               (wind-bindings (cdr (unwind-bindings mode))))
+        (cond ((buffer-bindings-wound-p buffer)
+               (wind-bindings buffer (cdr (unwind-bindings buffer mode))))
               (t
                (setf (buffer-mode-objects buffer)
@@ -384 +376 @@
       (unless region
         point))))
-
-;;; %SET-CURRENT-BUFFER  --  Internal
-;;;
-;;;    Undo previous buffer and mode specific variables and character 
-;;;attributes and set up the new ones.  Set *current-buffer*.
-;;;
-(defun %set-current-buffer (buffer)
-  (let ((old-buffer *current-buffer*))
-    (check-type buffer buffer)
-    (invoke-hook hemlock::set-buffer-hook buffer)
-    ;; Undo old bindings.
-    (setf (buffer-mode-objects *current-buffer*)
-          (unwind-bindings nil))
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
-    (setq *current-buffer* buffer)
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
-    ;; Make new bindings.
-    (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))
-    (invoke-hook hemlock::after-set-buffer-hook old-buffer))
-  buffer)
-
-;;; USE-BUFFER-SET-UP  --  Internal
-;;;
-;;;    This function is called by the use-buffer macro to wind on the
-;;; new buffer's variable and key bindings and character attributes.
-;;;
-(defun use-buffer-set-up (old-buffer)
-  (unless (eq old-buffer *current-buffer*)
-    ;; Let new char attributes overlay old ones.
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
-    ;; Wind on bindings of new current buffer.
-    (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))))
-
-;;; USE-BUFFER-CLEAN-UP  --  Internal
-;;;
-;;;    This function is called by use-buffer to clean up after it is done.
-;;;
-(defun use-buffer-clean-up (old-buffer)
-  (unless (eq old-buffer *current-buffer*)
-    ;; When we leave, unwind the bindings,
-    (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil))
-    ;; Restore the character attributes,
-    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))))
-
-
-
-
-;;;; Recursive editing.
-
-(defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.")
-
-(declaim (inline in-recursive-edit))
-
-(defun in-recursive-edit ()
-  "Returns whether the calling point is dynamically within a recursive edit
-   context."
-  *in-a-recursive-edit*)
-
-;;; RECURSIVE-EDIT  --  Public
-;;;
-;;;    Call the command interpreter recursively, winding on new state as 
-;;; necessary. 
-;;;
-(defun recursive-edit (&optional (handle-abort t))
-  "Call the command interpreter recursively.  If Handle-Abort is true
-  then an abort caused by a control-g or a lisp error does not cause
-  the recursive edit to be aborted."
-  (invoke-hook hemlock::enter-recursive-edit-hook)
-  (multiple-value-bind (flag args)
-                       (let ((*in-a-recursive-edit* t)
-                             #+nil (doc (buffer-document *current-buffer*))
-                             )
-                         (catch 'leave-recursive-edit
-                           (unwind-protect
-                                (progn
-                                  #+nil (when doc (document-end-editing doc))
-                                  (if handle-abort
-                                    (loop (catch 'editor-top-level-catcher
-                                            (%command-loop)))
-                                    (%command-loop)))
-                             #+nil
-                             (when doc (document-begin-editing doc)))))
-                             
-    (case flag
-      (:abort (apply #'editor-error args))
-      (:exit (values-list args))
-      (t (error "Bad thing ~S thrown out of recursive edit." flag)))))
-
-;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context
-;;; of RECURSIVE-EDIT, causing return from that function with values returned
-;;; as multiple values.  When not in a recursive edit, signal an error.
-;;; 
-(defun exit-recursive-edit (&optional values)
-  "Exit from a recursive edit.  Values is a list of things which are
-   to be the return values from Recursive-Edit."
-  (unless *in-a-recursive-edit*
-    (error "Not in a recursive edit!"))
-  (invoke-hook hemlock::exit-recursive-edit-hook values)
-  (throw 'leave-recursive-edit (values :exit values)))
-
-;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context
-;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args.  When not
-;;; in a recursive edit, signal an error.
-;;; 
-(defun abort-recursive-edit (&rest args)
-  "Abort a recursive edit, causing an Editor-Error with the args given in
-   the calling context."
-  (unless *in-a-recursive-edit* 
-    (error "Not in a recursive edit!"))
-  (invoke-hook hemlock::abort-recursive-edit-hook args)
-  (throw 'leave-recursive-edit (values :abort args)))
-
-
 
 ;;;; WITH-WRITABLE-BUFFER
@@ -530 +409 @@
 (defun defmode (name &key (setup-function #'identity) 
                      (cleanup-function #'identity) major-p transparent-p
-                     precedence documentation hidden)
+                     precedence documentation hidden default-command)
   "Define a new mode, specifying whether it is a major mode, and what the
    setup and cleanup functions are.  Precedence, which defaults to 0.0, and is
@@ -565 +444 @@
       (setf (getstring name *mode-names*) mode)))
 
+    (when (eq precedence :highest)
+      (setq precedence most-positive-double-float))
     (if precedence
         (if major-p
@@ -571 +452 @@
         (setq precedence 0))
     
+    (when default-command
+      (setf (mode-object-default-command mode) default-command))
+
     (setf (mode-object-major-p mode) major-p
           (mode-object-documentation mode) documentation
@@ -611 +495 @@
    and Modeline-fields is a list of modeline field objects.  Delete-hook is a
    list of functions that take a buffer as the argument."
-  (cond ((getstring name *buffer-names*) nil)
+  #+GZ
+  (when (getstring name *buffer-names*)
+    (warn "~s already exists, trying to delete" name *buffer-names*)
+    (let ((buffer (getstring name *buffer-names*)))
+      (when (buffer-windows buffer)
+        (delete-buffer buffer))))
+  (cond ((getstring name *buffer-names*)
+         nil)
         (t
          (unless (listp delete-hook)
@@ -638 +529 @@
            buffer))))
 
-(defun delete-buffer (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."
   (when (eq buffer *current-buffer*)
     (error "Cannot delete current buffer ~S." buffer))
-  (when (buffer-windows buffer)
-    (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
-           buffer (length (buffer-windows 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)
@@ -693 +585 @@
   (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
                                       :modeline-fields nil))
+  (wind-bindings *current-buffer* nil)
+
   ;; Make the bogus variable go away...
   (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value)

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

@@ -7 +7 @@
 (in-package :hemlock-internals)
 
-(defstruct (frame-event-queue (:include ccl::locked-dll-header))
-  (signal (ccl::make-semaphore))
-  (quoted-insert nil))
-
-(defstruct (buffer-operation (:include ccl::dll-node))
-  (thunk nil))
-
-(defstruct (event-queue-node (:include ccl::dll-node)
-                             (:constructor make-event-queue-node (event)))
-  event)
-
-(defun event-queue-insert (q node)
-  (ccl::locked-dll-header-enqueue node q)
-  (ccl::signal-semaphore (frame-event-queue-signal q)))
-
-(defun enqueue-key-event (q event)
-  (event-queue-insert q (make-event-queue-node event)))
-
-(defun dequeue-key-event (q)
-  (unless (listen-editor-input q)
-    (let* ((document (buffer-document (current-buffer))))
-      (when document
-        (document-set-point-position document))))
-  (ccl::wait-on-semaphore (frame-event-queue-signal q))
-  (ccl::locked-dll-header-dequeue q))
-
-
-(defun unget-key-event (event q)
-  (ccl::with-locked-dll-header (q)
-    (ccl::insert-dll-node-after (make-event-queue-node  event) q))
-  (ccl::signal-semaphore (frame-event-queue-signal q)))
-
-(defun timed-wait-for-key-event (q seconds)
-  (let* ((signal (frame-event-queue-signal q)))
-    (when (ccl:timed-wait-on-semaphore signal seconds)
-      (ccl:signal-semaphore signal)
-      t)))
-
-(defvar *command-key-event-buffer* nil)
-
-  
-
 (defun buffer-windows (buffer)
   (let* ((doc (buffer-document buffer)))
@@ -54 +12 @@
       (document-panes doc))))
 
-(defvar *current-window* ())
+(defvar *window-list* ())
 
-(defvar *window-list* ())
 (defun current-window ()
   "Return the current window.  The current window is specially treated by
@@ -62 +19 @@
   recentering, ensuring that the Buffer-Point of the current window's
   Window-Buffer is always displayed.  This may be set with Setf."
-  *current-window*)
+  (hemlock-view-pane *current-view*))
 
 (defun %set-current-window (new-window)
@@ -68 +25 @@
   (invoke-hook hemlock::set-window-hook new-window)
   (activate-hemlock-view new-window)
-  (setq *current-window* new-window))
+  (setf (hemlock-view-pane *current-view*) new-window))
 
 ;;; This is a public variable.
 ;;;
-(defvar *last-key-event-typed* ()
-  "This variable contains the last key-event typed by the user and read as
-   input.")
 
-(defvar *input-transcript* ())
+(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"))
 
-(defmacro abort-key-event-p (key-event)
-  `(member (event-queue-node-event ,key-event) editor-abort-key-events))
-
 (defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift"))
     
-(defun get-key-event (q &optional ignore-pending-aborts)
-  (do* ((e (dequeue-key-event q) (dequeue-key-event q)))
-       ((typep e 'event-queue-node)
-        (unless ignore-pending-aborts
-          (when (abort-key-event-p e)
-            (beep)
-            (clear-echo-area)
-            (throw 'editor-top-level-catcher nil)))
-        (values (setq *last-key-event-typed* (event-queue-node-event e))
-                (prog1 (frame-event-queue-quoted-insert q)
-                  (setf (frame-event-queue-quoted-insert q) nil))))
-    (if (typep e 'buffer-operation)
-      (catch 'command-loop-catcher
-        (funcall (buffer-operation-thunk e))))))
-
-(defun recursive-get-key-event (q &optional ignore-pending-aborts)
-  (let* ((buffer *command-key-event-buffer*)
-         (doc (when buffer (buffer-document buffer))))
-    (if (null doc)
-      (get-key-event q ignore-pending-aborts)
-      (unwind-protect
-           (progn
-             (document-end-editing doc)
-             (get-key-event q ignore-pending-aborts))
-        (document-begin-editing doc)))))
-
-
 (defun listen-editor-input (q)
   (ccl::with-locked-dll-header (q)
@@ -123 +57 @@
       (setf (font-region-node region) node)
       region)))
-
-(defun enable-self-insert (q)
-  (setf (frame-event-queue-quoted-insert q) t))
-
-(defmethod disable-self-insert ((q frame-event-queue))
-  (setf (frame-event-queue-quoted-insert q) nil))
 
 (defun remove-font-region (region)

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

@@ -42 +42 @@
   With prefix argument insert the character that many times."
   "Implements ``Self Insert'', calling this function is not meaningful."
-  (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)))
+  (let ((char (last-char-typed)))
     (unless char (editor-error "Can't insert that character."))
     (if (and p (> p 1))
@@ -53 +53 @@
   "Causes the next character typed to be inserted in the current
    buffer, even if would normally be interpreted as an editor command."
-  "Reads a key-event from *editor-input* and inserts it at the point."
   (declare (ignore p))
-  (hi::enable-self-insert hi::*editor-input*))
+  (setf (hi::hemlock-view-quote-next-p hi::*current-view*) t))
 
 (defcommand "Forward Character" (p)
@@ -182 +181 @@
          (t
           (move-mark
-           mark (buffer-start-mark (line-buffer (mark-line mark)))))))
+           mark (buffer-start-mark (mark-buffer mark))))))
       (do ((cnt offset (1- cnt)))
           ((zerop cnt) mark)
@@ -234 +233 @@
 ;;;; Moving around:
 
-(defvar *target-column* 0)
-
 (defun set-target-column (mark)
   (if (eq (last-command-type) :line-motion)
-      *target-column*
-      (setq *target-column* (mark-column mark))))
+    (hi::hemlock-target-column hi::*current-view*)
+    (setf (hi::hemlock-target-column hi::*current-view*) (mark-column mark))))
 
 (defhvar "Next Line Inserts Newlines"
@@ -430 +427 @@
 
 
-
-;;;
-(defun reset-window-display-recentering (window &optional buffer)
-  (declare (ignore buffer))
-  (setf (window-display-recentering window) nil))
-;;;
-(add-hook window-buffer-hook #'reset-window-display-recentering)
-
-
 (defcommand "Extended Command" (p)
   "Prompts for and executes an extended command."
   "Prompts for and executes an extended command.  The prefix argument is
   passed to the command."
-  (let* ((name (prompt-for-keyword (list *command-names*)
+  (let* ((name (prompt-for-keyword :tables (list *command-names*)
                                    :prompt "Extended Command: "
                                    :help "Name of a Hemlock command"))
@@ -453 +441 @@
   :value 4)
 
+(defstruct (prefix-argument-state (:conc-name "PS-"))
+  sign
+  multiplier
+  read-some-digit-p
+  ;; This is NIL if haven't started and don't have a universal argument, else a number
+  result
+  ;; This is cleared by prefix-argument-resetting-state (called at the start of each
+  ;; command) and can be set by a command to avoid the state being reset at
+  ;; the end of the command.
+  set-p)
+
+(defun prefix-argument-resetting-state (&optional (ps (current-prefix-argument-state)))
+  "Fetches the prefix argument and uses it up, i.e. marks it as not being set"
+  (unless (ps-set-p ps)
+    (setf (ps-sign ps) 1
+          (ps-multiplier ps) 1
+          (ps-read-some-digit-p ps) nil
+          (ps-result ps) nil))
+  (setf (ps-set-p ps) nil) ;; mark it for death unless explicitly revived.
+  (when (ps-result ps)
+    (* (ps-sign ps)
+       (expt (value universal-argument-default) (ps-multiplier ps))
+       (if (ps-read-some-digit-p ps)
+         (ps-result ps)
+         1))))
+
+(defun note-prefix-argument-set (ps)
+  (assert (ps-result ps))
+  (setf (ps-set-p ps) t)
+  #+GZ (gui::log-debug "Note prefix argument set: ~s" ps)
+  (message (with-output-to-string (s)
+             (dotimes (i (ps-multiplier ps))
+               (write-string "C-U " s))
+             (cond ((ps-read-some-digit-p ps)
+                    (format s "~d" (* (ps-sign ps) (ps-result ps))))
+                   ((< (ps-sign ps) 0)
+                    (write-string "-" s))))))
+
 (defcommand "Universal Argument" (p)
   "Sets prefix argument for next command.
-  Typing digits, regardless of any modifier keys, specifies the argument.
-  Optionally, you may first type a sign (- or +).  While typing digits, if you
-  type C-U or C-u, the digits following the C-U form a number this command
-  multiplies by the digits preceding the C-U.  The default value for this
-  command and any number following a C-U is the value of \"Universal Argument
-  Default\"."
-  "You probably don't want to use this as a function."
-  (declare (ignore p))
-  (clear-echo-area)
-  (write-string "C-U " *echo-area-stream*)
-  (let* ((key-event (get-key-event hi::*editor-input*))
-         (char (hemlock-ext:key-event-char key-event)))
-    (if char
-        (case char
-          (#\-
-           (write-char #\- *echo-area-stream*)
-           (universal-argument-loop (get-key-event hi::*editor-input*) -1))
-          (#\+
-           (write-char #\+ *echo-area-stream*)
-           (universal-argument-loop (get-key-event hi::*editor-input*) -1))
-          (t
-           (universal-argument-loop key-event 1)))
-        (universal-argument-loop key-event 1))))
-
-(defcommand "Negative Argument" (p)
-  "This command is equivalent to invoking \"Universal Argument\" and typing
-   a minus sign (-).  It waits for more digits and a command to which to give
-   the prefix argument."
-  "Don't call this as a function."
-  (when p (editor-error "Must type minus sign first."))
-  (clear-echo-area)
-  (write-string "C-U -" *echo-area-stream*)
-  (universal-argument-loop (get-key-event hi::*editor-input*) -1))
+   Typing digits, regardless of any modifier keys, specifies the argument.
+   Optionally, you may first type a sign (- or +).  While typing digits, if you
+   type C-U or C-u, the digits following the C-U form a number this command
+   multiplies by the digits preceding the C-U.  The default value for this
+   command and any number following a C-U is the value of \"Universal Argument
+   Default\"."
+  (declare (ignore p)) ;; we operate on underlying state instead
+  (let ((ps (current-prefix-argument-state)))
+    (if (ps-result ps)
+      (incf (ps-multiplier ps))
+      (setf (ps-result ps) 0))
+    (note-prefix-argument-set ps)))
 
 (defcommand "Argument Digit" (p)
   "This command is equivalent to invoking \"Universal Argument\" and typing
-   the digit used to invoke this command.  It waits for more digits and a
+   the key used to invoke this command.  It waits for more digits and a
    command to which to give the prefix argument."
-  "Don't call this as a function."
-  (declare (ignore p))
-  (clear-echo-area)
-  (write-string "C-U " *echo-area-stream*)
-  (universal-argument-loop *last-key-event-typed* 1))
-
-(defun universal-argument-loop (key-event sign &optional (multiplier 1))
-  (flet ((prefix (sign multiplier read-some-digit-p result)
-           ;; read-some-digit-p and (zerop result) are not
-           ;; equivalent if the user invokes this and types 0.
-           (* sign multiplier
-              (if read-some-digit-p
-                  result
-                  (value universal-argument-default)))))
-    (let* ((stripped-key-event (if key-event (hemlock-ext:make-key-event key-event)))
-           (char (hemlock-ext:key-event-char stripped-key-event))
-           (digit (if char (digit-char-p char)))
-           (result 0)
-           (read-some-digit-p nil))
-      (loop
-        (cond (digit
-               (setf read-some-digit-p t)
-               (write-char char *echo-area-stream*)
-               (setf result (+ digit (* 10 result)))
-               (setf key-event (get-key-event hi::*editor-input*))
-               (setf stripped-key-event (if key-event
-                                            (hemlock-ext:make-key-event key-event)))
-               (setf char (hemlock-ext:key-event-char stripped-key-event))
-               (setf digit (if char (digit-char-p char))))
-              ((or (eq key-event #k"C-u") (eq key-event #k"C-U"))
-               (write-string " C-U " *echo-area-stream*)
-               (universal-argument-loop
-                (get-key-event hi::*editor-input*) 1
-                (prefix sign multiplier read-some-digit-p result))
-               (return))
-              (t
-               (unget-key-event key-event hi::*editor-input*)
-               (setf (prefix-argument)
-                     (prefix sign multiplier read-some-digit-p result))
-               (return))))))
-  (setf (last-command-type) (last-command-type)))
+  (declare (ignore p)) ;; we operate on underlying state instead
+  (let* ((ps (current-prefix-argument-state))
+         (key-event (last-key-event-typed))
+         (stripped-key-event (hemlock-ext:make-key-event key-event))
+         (char (hemlock-ext:key-event-char stripped-key-event))
+         (digit (if char (digit-char-p char))))
+    (when (null (ps-result ps))
+      (setf (ps-result ps) 0))
+    (case char
+      (#\-
+       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
+         (editor-error "Must type minus sign first."))
+       (setf (ps-sign ps) (- (ps-sign ps))))
+      (#\+
+       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
+         (editor-error "Must type plus sign first.")))
+      (t
+       (unless digit
+         (editor-error "Argument Digit must be bound to a digit!"))
+       (setf (ps-read-some-digit-p ps) t)
+       (setf (ps-result ps) (+ digit (* (ps-result ps) 10)))))
+    (note-prefix-argument-set ps)))
+
+(defcommand "Digit" (p)
+  "With a numeric argument, this command extends the argument.
+   Otherwise it does self insert"
+  (if p
+    (argument-digit-command p)
+    (self-insert-command p)))

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

@@ -223 +223 @@
   "Implements \"Completion Self Insert\". Calling this function is not
    meaningful."
-  (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)))
+  (let ((char (last-char-typed)))
     (unless char (editor-error "Can't insert that character."))
     (cond ((completion-char-p char)

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

@@ -62 +62 @@
 ;;; Some special variables are forward-referenced, and we don't even
 ;;; need to invent a new language to advise the compiler of that ...
-(declaim (special *mode-names* *current-buffer* *echo-area-buffer*
+(declaim (special *mode-names* *current-buffer*
                   *the-sentinel*
                   *in-the-editor* *buffer-list* *things-to-do-once*

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

@@ -59 +59 @@
   (declare (ignore p))
   (multiple-value-bind (nam cmd)
-                       (prompt-for-keyword (list *command-names*)
+                       (prompt-for-keyword :tables (list *command-names*)
                                            :prompt "Command: "
                                            :help "Name of command to look for.")
@@ -150 +150 @@
   (multiple-value-bind (nam com)
                        (prompt-for-keyword
-                        (list *command-names*)
+                        :tables (list *command-names*)
                         :prompt "Describe command: "
                         :help "Name of a command to document.")
@@ -176 +176 @@
   which is prompted for."
   (declare (ignore p))
-  (let ((old-window (current-window)))
-    (unwind-protect
-        (progn
-          (setf (current-window) hi::*echo-area-window*)
-          (hi::display-prompt-nicely "Describe key: " nil)
-          (setf (fill-pointer hi::*prompt-key*) 0)
-          (loop
-            (let ((key-event (get-key-event hi::*editor-input*)))
-              (vector-push-extend key-event hi::*prompt-key*)
-              (let ((res (get-command hi::*prompt-key* :current)))
-                (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
-                (write-char #\space *echo-area-stream*)
-                (cond ((commandp res)
-                       (with-pop-up-display (s :title "Key documentation")
-                         (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s)
-                         (format s " is bound to ~S.~%" (command-name res))
-                         (format s "Documentation for this command:~%   ~A"
-                                 (command-documentation res)))
-                       (return))
-                      ((not (eq res :prefix))
-                       (with-pop-up-display (s :height 1)
-                         (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s)
-                         (write-string " is not bound to anything." s))
-                       (return)))))))
-      (setf (current-window) old-window))))
-
-
-
+  (multiple-value-bind (key res) (prompt-for-command-key)
+    (cond ((commandp res)
+           (with-pop-up-display (s :title "Key documentation")
+             (hemlock-ext:print-pretty-key key s)
+             (format s " is bound to ~S.~%" (command-name res))
+             (format s "Documentation for this command:~%   ~A"
+                     (command-documentation res))))
+          (t
+           (with-pop-up-display (s :height 1)
+             (hemlock-ext:print-pretty-key key s)
+             (write-string " is not bound to anything." s))))))
 
 ;;;; Generic describe variable, command, key, attribute.
@@ -222 +205 @@
   (declare (ignore p))
   (multiple-value-bind (ignore kwd)
-                       (prompt-for-keyword *generic-describe-kinds*
+                       (prompt-for-keyword :tables *generic-describe-kinds*
                                            :default "Variable"
                                            :help "Kind of thing to describe."
@@ -235 +218 @@
        (multiple-value-bind (name attr)
                             (prompt-for-keyword
-                             (list *character-attribute-names*)
+                             :tables (list *character-attribute-names*)
                              :help "Name of character attribute to describe."
                              :prompt "Attribute: ")
@@ -309 +292 @@
   (declare (ignore p))
   (let ((name (or name
-                  (prompt-for-keyword (list *mode-names*)
+                  (prompt-for-keyword :tables (list *mode-names*)
                                       :prompt "Mode: "
                                       :help "Enter mode to describe."

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

@@ -14 +14 @@
 ;;; Modified by Bill Chiles.
 ;;;
+;;; Totally rewritten for Clozure CL.
+
 (in-package :hemlock-internals)
 
-(defmode "Echo Area" :major-p t)
-(defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area"))
-  "Buffer used to hack text for the echo area.")
-(defvar *echo-area-region* (buffer-region *echo-area-buffer*)
-  "Internal thing that's the *echo-area-buffer*'s region.")
-(defvar *echo-area-stream*
-  (make-hemlock-output-stream (region-end *echo-area-region*) :full)
-  "Buffered stream that prints into the echo area.")
-(defvar *echo-area-window* ()
-  "Window used to display stuff in the echo area.")
-(defvar *parse-starting-mark*
-  (copy-mark (buffer-point *echo-area-buffer*) :right-inserting)
-  "Mark that points to the beginning of the text that'll be parsed.")
-(defvar *parse-input-region*
-  (region *parse-starting-mark* (region-end *echo-area-region*))
-  "Region that contains the text typed in.")
-
-
-
-
-;;;; Variables that control parsing:
-
-(defvar *parse-verification-function* '%not-inside-a-parse
-  "Function that verifies what's being parsed.")
-
 (defmacro modifying-echo-buffer (&body body)
-  `(unwind-protect
-    (progn
-      (buffer-document-begin-editing *echo-area-buffer*)
-      (modifying-buffer *echo-area-buffer* ,@body))
-    (buffer-document-end-editing *echo-area-buffer*)))
-;;; %Not-Inside-A-Parse  --  Internal
-;;;
-;;;    This function is called if someone does stuff in the echo area when
-;;; we aren't inside a parse.  It tries to put them back in a reasonable place.
-;;;
-(defun %not-inside-a-parse (quaz)
-  "Thing that's called when somehow we get called to confirm a parse that's
-  not in progress."
-  (declare (ignore quaz))
-  (let* ((bufs (remove *echo-area-buffer* *buffer-list*))
-         (buf (or (find-if #'buffer-windows bufs)
-                  (car bufs)
-                  (make-buffer "Main"))))
-    (setf (current-buffer) buf)
-    (dolist (w *window-list*)
-      (when (and (eq (window-buffer w) *echo-area-buffer*)
-                 (not (eq w *echo-area-window*)))
-        (setf (window-buffer w) buf)))
-    (setf (current-window)
-          (or (car (buffer-windows buf))
-              (make-window (buffer-start-mark buf)))))
-  (editor-error "Wham!  We tried to confirm a parse that wasn't in progress?"))
-
-(defvar *parse-string-tables* ()
-  "String tables being used in the current parse.")
-
-(defvar *parse-value-must-exist* ()
-  "You know.")
-
-(defvar *parse-default* ()
-  "When the user attempts to default a parse, we call the verification function
-  on this string.  This is not the :Default argument to the prompting function,
-  but rather a string representation of it.")
-
-(defvar *parse-default-string* ()
-  "String that we show the user to inform him of the default.  If this
-  is NIL then we just use *Parse-Default*.")
-
-(defvar *parse-prompt* ()
-  "Prompt for the current parse.")
-
-(defvar *parse-help* ()
-  "Help string for the current parse.")
-
-(defvar *parse-type* :string "A hack. :String, :File or :Keyword.") 
-
-
-
-
-;;;; MESSAGE and CLEAR-ECHO-AREA:
-
-(defhvar "Message Pause" "The number of seconds to pause after a Message."
-  :value 0.0s0)
-
-(defvar *last-message-time* 0
-  "Internal-Real-Time the last time we displayed a message.") 
-
-(defun maybe-wait ()
-  (let* ((now (get-internal-real-time))
-         (delta (/ (float (- now *last-message-time*))
-                   (float internal-time-units-per-second)))
-         (pause (value hemlock::message-pause)))
-    (when (< delta pause)
-      (sleep (- pause delta)))))
+  `(modifying-buffer-storage ((hemlock-echo-area-buffer *current-view*))
+     ,@body))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; Echo area output.
+
+(defvar *last-message-time* (get-internal-real-time))
 
 (defun clear-echo-area ()
   "You guessed it."
-  ;;(maybe-wait)
-  (let* ((b (current-buffer)))
-    (unwind-protect
-         (progn
-           (setf (current-buffer) *echo-area-buffer*)
-           (modifying-echo-buffer
-            (delete-region *echo-area-region*))
-           (setf (buffer-modified *echo-area-buffer*) nil))
-      (setf (current-buffer) b))))
+  (modifying-echo-buffer
+   (delete-region (buffer-region *current-buffer*))))
 
 ;;; Message  --  Public
@@ -131 +40 @@
 (defun message (string &rest args)
   "Nicely display a message in the echo-area.
-  Put the message on a fresh line and wait for \"Message Pause\" seconds
-  to give the luser a chance to see it.  String and Args are a format 
-  control string and format arguments, respectively."
-  ;(maybe-wait)
-  (modifying-echo-buffer
-   (cond ((eq *current-window* *echo-area-window*)
-          (let ((point (buffer-point *echo-area-buffer*)))
-            (with-mark ((m point :left-inserting))
-              (line-start m)
-              (with-output-to-mark (s m :full)
-                (apply #'format s string args)
-                (fresh-line s)))))
-         (t
-          (let ((mark (region-end *echo-area-region*)))
-            (cond ((buffer-modified *echo-area-buffer*)
-                   (clear-echo-area))
-                  ((not (zerop (mark-charpos mark)))
-                   (insert-character mark #\newline)
-                   (clear-echo-area)))
-            (write-string (apply #'format nil string args)
-                          *echo-area-stream*)
-            ;; keep command loop from clearing the echo area,
-            ;; by asserting that the echo area buffer's unmodified.
-            (setf (buffer-modified *echo-area-buffer*) t))))
-   (force-output *echo-area-stream*)
-   (setq *last-message-time* (get-internal-real-time)))
-  nil)
-
+  String and Args are a format control string and format arguments, respectively."
+  ;; TODO: used to do something cleverish if in the middle of reading prompted input, might
+  ;; want to address that.
+  (let ((message (apply #'format nil string args)))
+    (modifying-echo-buffer
+     (delete-region (buffer-region *current-buffer*))
+     (insert-string (buffer-point *current-buffer*) message)
+     (setq *last-message-time* (get-internal-real-time))
+     )))
 
 ;;; LOUD-MESSAGE -- Public.
@@ -168 +58 @@
    doing anything else."
   (beep)
-  (clear-echo-area)
   (apply #'message args))
 
-
-
-
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Echo area input
+
+(defmode "Echo Area" :major-p t)
+
+
+(defstruct (echo-parse-state (:conc-name "EPS-"))
+  (parse-verification-function nil)
+  (parse-string-tables ())
+  (parse-value-must-exist ())
+  ;; When the user attempts to default a parse, we call the verification function
+  ;; on this string.  This is not the :Default argument to the prompting function,
+  ;; but rather a string representation of it.
+  (parse-default ())
+  ;; String that we show the user to inform him of the default.  If this
+  ;; is NIL then we just use Parse-Default.
+  (parse-default-string ())
+  ;; Prompt for the current parse.
+  (parse-prompt ())
+  ;; Help string for the current parse.
+  (parse-help ())
+  ;; A hack. :String, :File or :Keyword.
+  (parse-type :string)
+  ;; input region
+  parse-starting-mark
+  parse-input-region
+  ;; Store result here
+  (parse-results ()))
+
+(defun current-echo-parse-state (&key (must-exist t))
+  (or (hemlock-prompted-input-state *current-view*)
+      (and must-exist (error "Can't do that when not in echo area input"))))
 
 
@@ -180 +98 @@
 ;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
 
-(defun display-prompt-nicely (&optional (prompt *parse-prompt*)
-                                        (default (or *parse-default-string*
-                                                     *parse-default*)))
-  (clear-echo-area)
+(defun display-prompt-nicely (eps &optional (prompt (eps-parse-prompt eps))
+                                            (default (or (eps-parse-default-string eps)
+                                                         (eps-parse-default eps))))
   (modifying-echo-buffer 
-   (let ((point (buffer-point *echo-area-buffer*)))
-     (if (listp prompt)
-       (apply #'format *echo-area-stream* prompt)
-       (insert-string point prompt))
+   (let* ((buffer *current-buffer*)
+          (point (buffer-point buffer)))
+     (delete-region (buffer-region buffer))
+     (insert-string point (if (listp prompt)
+                            (apply #'format nil prompt)
+                            prompt))
      (when default
        (insert-character point #\[)
        (insert-string point default)
-       (insert-string point "] ")))))
-
-(defun parse-for-something ()
-  (display-prompt-nicely)
-  (let ((start-window (current-window)))
-    (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
-    (setf (current-window) *echo-area-window*)
-    (unwind-protect
-     (use-buffer *echo-area-buffer*
-       (recursive-edit nil))
-      
-     (setf (current-window) start-window))))
-
-
-
+       (insert-string point "] "))
+     (move-mark (eps-parse-starting-mark eps) point))))
+
+;; This is used to prevent multiple buffers trying to do echo area input
+;; at the same time - there would be no way to exit the earlier one
+;; without exiting the later one, because they're both on the same stack.
+(defvar *recursive-edit-view* nil)
+
+(defun parse-for-something (&key verification-function
+                                 type
+                                 string-tables
+                                 value-must-exist
+                                 default-string
+                                 default
+                                 prompt
+                                 help)
+  ;; We can't do a "recursive" edit in more than one view, because if the earlier
+  ;; one wants to exit first, we'd have to unwind the stack to allow it to exit,
+  ;; which would force the later one to exit whether it wants to or not.
+  (when (and *recursive-edit-view* (not (eq *recursive-edit-view* *current-view*)))
+    (editor-error "~s is already waiting for input"
+                  (buffer-name (hemlock-view-buffer *recursive-edit-view*))))
+  (modifying-echo-buffer
+   (let* ((old-eps (hemlock-prompted-input-state *current-view*))
+          (parse-mark (copy-mark (buffer-point *current-buffer*) :right-inserting))
+          (end-mark (buffer-end-mark *current-buffer*))
+          (eps (make-echo-parse-state
+                :parse-starting-mark parse-mark
+                :parse-input-region (region parse-mark end-mark)
+                :parse-verification-function verification-function
+                :parse-type type
+                :parse-string-tables string-tables
+                :parse-value-must-exist value-must-exist
+                :parse-default-string default-string
+                :parse-default default
+                :parse-prompt prompt
+                :parse-help help)))
+     ;; TODO: There is really no good reason to disallow recursive edits in the same
+     ;; buffer, I'm just too lazy.  Should save contents, starting mark, and point,
+     ;; and restore them at the end.
+     (when old-eps
+       (editor-error "Attempt to recursively use echo area"))
+     (unwind-protect
+         (let ((*recursive-edit-view* *current-view*))
+           (setf (hemlock-prompted-input-state *current-view*) eps)
+           (display-prompt-nicely eps)
+           (modifying-buffer-storage (nil)
+             (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)
+       (delete-mark parse-mark))
+     (let ((results (eps-parse-results eps)))
+       (if (listp results)
+         (apply #'values results)
+         (abort-to-toplevel))))))
+
+(defun exit-echo-parse (eps results)
+  #+gz (gui::log-debug "~&exit echo parse, results = ~s" results)
+  ;; Must be set to non-nil to indicate parse done.
+  (setf (eps-parse-results eps) (or results '(nil)))
+  (gui::stop-event-loop) ;; this just marks it for dead then returns.
+  ;; this exits current event, and since the event loop is stopped, it
+  ;; will exit the event loop, which will return to parse-for-something,
+  ;; which will notice we have the result set and will handle it accordingly.
+  (exit-event-handler))
 
 ;;;; Buffer prompting.
 
-(defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t)
-                               default
-                               ((:default-string *parse-default-string*))
-                               ((:prompt *parse-prompt*) "Buffer: ")
-                               ((:help *parse-help*) "Type a buffer name."))
+(defun prompt-for-buffer (&key (must-exist t)
+                                default
+                                default-string
+                               (prompt "Buffer: ")
+                               (help "Type a buffer name."))
   "Prompts for a buffer name and returns the corresponding buffer.  If
    :must-exist is nil, then return the input string.  This refuses to accept
@@ -221 +190 @@
    when :must-exist is non-nil, :default-string must be the name of an existing
    buffer."
-    (let ((*parse-string-tables* (list *buffer-names*))
-          (*parse-type* :keyword)
-          (*parse-default* (cond
-                            (default (buffer-name default))
-                            (*parse-default-string*
-                             (when (and *parse-value-must-exist*
-                                        (not (getstring *parse-default-string*
-                                                        *buffer-names*)))
-                               (error "Default-string must name an existing ~
-                                       buffer when must-exist is non-nil -- ~S."
-                                      *parse-default-string*))
-                             *parse-default-string*)
-                            (t nil)))
-          (*parse-verification-function* #'buffer-verification-function))
-      (parse-for-something)))
-
-(defun buffer-verification-function (string)
+  (when (and must-exist
+             (not default)
+             (not (getstring default-string *buffer-names*)))
+    (error "Default-string must name an existing buffer when must-exist is non-nil -- ~S."
+           default-string))
+  (parse-for-something
+   :verification-function #'buffer-verification-function
+   :type :keyword
+   :string-tables (list *buffer-names*)
+   :value-must-exist must-exist
+   :default-string default-string
+   :default (if default (buffer-name default) default-string)
+   :prompt prompt
+   :help help))
+
+(defun buffer-verification-function (eps string)
   (declare (simple-string string))
   (modifying-echo-buffer
    (cond ((string= string "") nil)
-         (*parse-value-must-exist*
+         ((eps-parse-value-must-exist eps)
           (multiple-value-bind
               (prefix key value field ambig)
-              (complete-string string *parse-string-tables*)
+              (complete-string string (eps-parse-string-tables eps))
             (declare (ignore field))
             (ecase key
@@ -251 +219 @@
                (list value))
               (:ambiguous
-               (delete-region *parse-input-region*)
-               (insert-string (region-start *parse-input-region*) prefix)
-               (let ((point (current-point)))
-                 (move-mark point (region-start *parse-input-region*))
-                 (unless (character-offset point ambig)
-                   (buffer-end point)))
-               nil))))
+               (let ((input-region (eps-parse-input-region eps)))
+                 (delete-region input-region)
+                 (insert-string (region-start input-region) prefix)
+                 (let ((point (current-point)))
+                   (move-mark point (region-start input-region))
+                   (unless (character-offset point ambig)
+                     (buffer-end point)))
+                 nil)))))
          (t
           (list (or (getstring string *buffer-names*) string))))))
@@ -266 +235 @@
 ;;;; File Prompting.
 
-(defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t)
+(defun prompt-for-file (&key (must-exist t)
                              default
-                             ((:default-string *parse-default-string*))
-                             ((:prompt *parse-prompt*) "Filename: ")
-                             ((:help *parse-help*) "Type a file name."))
+                             default-string
+                             (prompt "Filename: ")
+                             (help "Type a file name."))
   "Prompts for a filename."
-  (let ((*parse-verification-function* #'file-verification-function)
-        (*parse-default* (if default (namestring default)))
-        (*parse-type* :file))
-    (parse-for-something)))
-
-(defun file-verification-function (string)
-  (let ((pn (pathname-or-lose string)))
+  (parse-for-something
+   :verification-function #'file-verification-function
+   :type :file
+   :string-tables nil
+   :value-must-exist must-exist
+   :default-string default-string
+   :default (if default (namestring default))
+   :prompt prompt
+   :help help))
+
+(defun file-verification-function (eps string)
+  (let ((pn (pathname-or-lose eps string)))
     (if pn
         (let ((merge
-               (cond ((not *parse-default*) nil)
+               (cond ((not (eps-parse-default eps)) nil)
                      ((directoryp pn)
-                      (merge-pathnames pn *parse-default*))
+                      (merge-pathnames pn (eps-parse-default eps)))
                      (t
                       (merge-pathnames pn
                                        (or (directory-namestring
-                                            *parse-default*)
+                                            (eps-parse-default eps))
                                            ""))))))
           (cond ((probe-file pn) (list pn))
                 ((and merge (probe-file merge)) (list merge))
-                ((not *parse-value-must-exist*) (list (or merge pn)))
+                ((not (eps-parse-value-must-exist eps)) (list (or merge pn)))
                 (t nil))))))
 
@@ -299 +273 @@
 ;;; an editor-error.
 ;;;
-(defun pathname-or-lose (string)
-  (declare (simple-string string))
+(defun pathname-or-lose (eps string)
   (multiple-value-bind (pn idx)
                        (parse-namestring string nil *default-pathname-defaults*
@@ -306 +279 @@
     (cond (pn)
           (t (modifying-echo-buffer
-              (delete-characters (region-end *echo-area-region*)
-                                (- idx (length string))))
+              (delete-characters (region-end (eps-input-region eps))
+                                 (- idx (length string))))
              nil))))
 
@@ -315 +288 @@
 ;;;; Keyword and variable prompting.
 
-(defun prompt-for-keyword (*parse-string-tables* 
-                           &key
-                           ((:must-exist *parse-value-must-exist*) t)
-                           ((:default *parse-default*))
-                           ((:default-string *parse-default-string*))
-                           ((:prompt *parse-prompt*) "Keyword: ")
-                           ((:help *parse-help*) "Type a keyword."))
+(defun prompt-for-keyword (&key
+                           tables
+                           (must-exist t)
+                           default
+                           default-string
+                           (prompt "Keyword: ")
+                           (help "Type a keyword."))
   "Prompts for a keyword using the String Tables."
-  (let ((*parse-verification-function* #'keyword-verification-function)
-        (*parse-type* :keyword))
-    (parse-for-something)))
-
-(defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t)
-                                 ((:default *parse-default*))
-                                 ((:default-string *parse-default-string*))
-                                 ((:prompt *parse-prompt*) "Variable: ")
-                                 ((:help *parse-help*)
-                                  "Type the name of a variable."))
+  (parse-for-something
+   :verification-function #'keyword-verification-function
+   :type :keyword
+   :string-tables tables
+   :value-must-exist must-exist
+   :default-string default-string
+   :default default
+   :prompt prompt
+   :help help))
+
+
+
+(defun prompt-for-variable (&key (must-exist t)
+                                 default
+                                 default-string
+                                 (prompt "Variable: ")
+                                 (help "Type the name of a variable."))
   "Prompts for a variable defined in the current scheme of things."
-  (let ((*parse-string-tables* (current-variable-tables))
-        (*parse-verification-function* #'keyword-verification-function)
-        (*parse-type* :keyword))
-    (parse-for-something)))
+  (parse-for-something
+   :verification-function  #'keyword-verification-function
+   :type :keyword
+   :string-tables (current-variable-tables)
+   :value-must-exist must-exist
+   :default-string default-string
+   :default default
+   :prompt prompt
+   :help help))
 
 (defun current-variable-tables ()
@@ -348 +333 @@
       ((null mode) tables)))
 
-(defun keyword-verification-function (string)
+(defun keyword-verification-function (eps string)
   (declare (simple-string string))
   (multiple-value-bind
       (prefix key value field ambig)
-      (complete-string string *parse-string-tables*)
+      (complete-string string (eps-parse-string-tables eps))
     (declare (ignore field))
     (modifying-echo-buffer
-     (cond (*parse-value-must-exist*
+     (cond ((eps-parse-value-must-exist eps)
             (ecase key
               (:none nil)
@@ -361 +346 @@
                (list prefix value))
               (:ambiguous
-               (delete-region *parse-input-region*)
-               (insert-string (region-start *parse-input-region*) prefix)
-               (let ((point (current-point)))
-                 (move-mark point (region-start *parse-input-region*))
-                 (unless (character-offset point ambig)
-                   (buffer-end point)))
-               nil)))
+               (let ((input-region (eps-parse-input-region eps)))
+                 (delete-region input-region)
+                 (insert-string (region-start input-region) prefix)
+                 (let ((point (current-point)))
+                   (move-mark point (region-start input-region))
+                   (unless (character-offset point ambig)
+                     (buffer-end point)))
+                 nil))))
            (t
             ;; HACK: If it doesn't have to exist, and the completion does not
@@ -379 +365 @@
 ;;;; Integer, expression, and string prompting.
 
-(defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t)
+(defun prompt-for-integer (&key (must-exist t)
                                 default
-                                ((:default-string *parse-default-string*))
-                                ((:prompt *parse-prompt*) "Integer: ")
-                                ((:help *parse-help*) "Type an integer."))
+                                default-string
+                                (prompt "Integer: ")
+                                (help "Type an integer."))
   "Prompt for an integer.  If :must-exist is Nil, then we return as a string
   whatever was input if it is not a valid integer."
-  (let ((*parse-verification-function*
-         #'(lambda (string)
-             (let ((number (parse-integer string  :junk-allowed t)))
-               (if *parse-value-must-exist*
-                   (if number (list number))
-                   (list (or number string))))))
-        (*parse-default* (if default (write-to-string default :base 10))))
-    (parse-for-something)))
+
+  (parse-for-something
+   :verification-function #'(lambda (eps string)
+                              (let ((number (parse-integer string  :junk-allowed t)))
+                                (if (eps-parse-value-must-exist eps)
+                                  (if number (list number))
+                                  (list (or number string)))))
+   :type :string
+   :string-tables nil
+   :value-must-exist must-exist
+   :default-string default-string
+   :default (if default (write-to-string default :base 10))
+   :prompt prompt
+   :help help))
 
 
@@ -399 +391 @@
   "An object that won't be EQ to anything read.")
 
-(defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t)
+(defun prompt-for-expression (&key (must-exist t)
                                    (default nil defaultp)
-                                   ((:default-string *parse-default-string*))
-                                   ((:prompt *parse-prompt*) "Expression: ")
-                                   ((:help *parse-help*)
-                                    "Type a Lisp expression."))
+                                   default-string
+                                   (prompt "Expression: ")
+                                   (help "Type a Lisp expression."))
   "Prompts for a Lisp expression."
-  (let ((*parse-verification-function*
-         #'(lambda (string)
-             (let ((expr (with-input-from-region (stream *parse-input-region*)
-                           (handler-case (read stream nil hemlock-eof)
-                             (error () hemlock-eof)))))
-               (if *parse-value-must-exist*
-                   (if (not (eq expr hemlock-eof)) (values (list expr) t))
-                   (if (eq expr hemlock-eof)
-                       (list string) (values (list expr) t))))))
-        (*parse-default* (if defaultp (prin1-to-string default))))
-      (parse-for-something)))
-
-
-(defun prompt-for-string (&key ((:default *parse-default*))
-                               ((:default-string *parse-default-string*))
+  (parse-for-something
+   :verification-function #'(lambda (eps string)
+                              (let* ((input-region (eps-parse-input-region eps))
+                                     (expr (with-input-from-region (stream input-region)
+                                             (handler-case (read stream nil hemlock-eof)
+                                               (error () hemlock-eof)))))
+                                (if (eq expr hemlock-eof)
+                                  (unless (eps-parse-value-must-exist eps) (list string))
+                                  (values (list expr) t))))
+   :type :string
+   :string-tables nil
+   :value-must-exist must-exist
+   :default-string default-string
+   :default (if defaultp (prin1-to-string default))
+   :prompt prompt
+   :help help))
+
+
+(defun prompt-for-string (&key default
+                               default-string
                                (trim ())
-                               ((:prompt *parse-prompt*) "String: ")
-                               ((:help *parse-help*) "Type a string."))
+                               (prompt "String: ")
+                               (help "Type a string."))
   "Prompts for a string.  If :trim is t, then leading and trailing whitespace
    is removed from input, otherwise it is interpreted as a Char-Bag argument
    to String-Trim."
-  (let ((*parse-verification-function*
-         #'(lambda (string)
-             (list (string-trim (if (eq trim t) '(#\space #\tab) trim)
-                                string)))))
-    (parse-for-something)))
-
+  (when (eq trim t) (setq trim '(#\space #\tab)))
+  (parse-for-something
+   :verification-function #'(lambda (eps string)
+                              (declare (ignore eps))
+                              (list (string-trim trim string)))
+   :type :string
+   :string-tables nil
+   :value-must-exist nil
+   :default-string default-string
+   :default default
+   :prompt prompt
+   :help help))
 
 
@@ -447 +449 @@
 
 #||
-(defun prompt-for-package (&key ((:must-exist *parse-value-must-exist*) t)
-                                  (default nil defaultp)
-                                  ((:default-string *parse-default-string*))
-                                  ((:prompt *parse-prompt*) "Package Name:")
-                                  ((:help *parse-help*) "Type a package name."))
+(defun prompt-for-package (&key (must-exist t)
+                                (default nil defaultp)
+                                default-string
+                                (prompt "Package Name:")
+                                (help "Type a package name."))
+)
 ||#
 
@@ -461 +464 @@
   (make-string-table :initial-contents '(("Yes" . t) ("No" . nil))))
 
-(defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t)
+(defun prompt-for-yes-or-no (&key (must-exist t)
                                   (default nil defaultp)
-                                  ((:default-string *parse-default-string*))
-                                  ((:prompt *parse-prompt*) "Yes or No? ")
-                                  ((:help *parse-help*) "Type Yes or No."))
+                                  default-string
+                                  (prompt "Yes or No? ")
+                                  (help "Type Yes or No."))
   "Prompts for Yes or No."
-  (let* ((*parse-string-tables* (list *yes-or-no-string-table*))
-         (*parse-default* (if defaultp (if default "Yes" "No")))
-         (*parse-verification-function*
-          #'(lambda (string)
-              (multiple-value-bind
-                  (prefix key value field ambig)
-                  (complete-string string *parse-string-tables*)
-                (declare (ignore prefix field ambig))
-                (let ((won (or (eq key :complete) (eq key :unique))))
-                  (if *parse-value-must-exist*
-                      (if won (values (list value) t))
-                      (list (if won (values value t) string)))))))
-         (*parse-type* :keyword))
-    (parse-for-something)))
+  (parse-for-something
+   :verification-function #'(lambda (eps string)
+                              (multiple-value-bind
+                                  (prefix key value field ambig)
+                                  (complete-string string (eps-parse-string-tables eps))
+                                (declare (ignore prefix field ambig))
+                                (let ((won (or (eq key :complete) (eq key :unique))))
+                                  (if (eps-parse-value-must-exist eps)
+                                    (if won (values (list value) t))
+                                    (list (if won (values value t) string))))))
+   :type :keyword
+   :string-tables (list *yes-or-no-string-table*)
+   :value-must-exist must-exist
+   :default-string default-string
+   :default (if defaultp (if default "Yes" "No"))
+   :prompt prompt
+   :help help))
 
 (defun prompt-for-y-or-n (&key ((:must-exist must-exist) t)
@@ -532 +538 @@
       (when change-window (setf (current-window) old-window)))))
 
-(defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
 (defun prompt-for-key (&key ((:must-exist must-exist) t)
                             default default-string
@@ -547 +552 @@
           (setf (current-window) *echo-area-window*)
           (display-prompt-nicely prompt string)
-          (setf (fill-pointer *prompt-key*) 0)
-          (prog ((key *prompt-key*) key-event)
+          (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event)
                 (declare (vector key))
                 TOP
@@ -587 +591 @@
       (setf (current-window) old-window))))
 
+(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))))
+
 
 
@@ -693 +713 @@
 (define-logical-key-event "Backward Search"
   "This key-event is used to indicate that a backward search should be made.")
-(define-logical-key-event "Recursive Edit"
-  "This key-event indicates that a recursive edit should be entered.")
 (define-logical-key-event "Cancel"
   "This key-event is used  to cancel a previous key-event of input.")

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

@@ -23 +23 @@
   "File types to ignore when trying to complete a filename."
   :value
-  (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err"
+  (list "fasl" "cfsl" "dfsl" "cfasl"
+        "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err"
         "x86f" "lbytef" "core" "trace"      ; Lisp
         "BAK" "CKP"                         ; Backups & Checkpoints
@@ -56 +57 @@
       ((null table) res)))
 
+(defun get-parse-input-string (eps)
+  (region-to-string (eps-parse-input-region eps)))
+
+(defun replace-parse-input-string (eps string)
+  (delete-region (eps-parse-input-region eps))
+  (insert-string (eps-parse-starting-mark eps) string))
+
 (defcommand "Help on Parse" (p)
   "Display help for parse in progress.
@@ -62 +70 @@
   input."
   (declare (ignore p))
-  (let ((help (typecase *parse-help*
-                (list (unless *parse-help* (error "There is no parse help."))
-                      (apply #'format nil *parse-help*))
-                (string *parse-help*)
-                (t (error "Parse help is not a string or list: ~S" *parse-help*))))
-        (input (region-to-string *parse-input-region*)))
+  (let* ((eps (current-echo-parse-state))
+         (raw-help (eps-parse-help eps))
+         (help (typecase raw-help
+                 (null (error "There is no parse help."))
+                 (list (apply #'format nil raw-help))
+                 (string raw-help)
+                 (t (error "Parse help is not a string or list: ~S" raw-help))))
+         (input (get-parse-input-string eps)))
     (cond
-     ((eq *parse-type* :keyword)
-      (let ((strings (find-all-completions input *parse-string-tables*)))
+     ((eq (eps-parse-type eps) :keyword)
+      (let ((strings (find-all-completions input (eps-parse-string-tables eps))))
         (with-pop-up-display (s :title "input help" :height (+ (length strings) 2))
           (write-line help s)
@@ -78 +88 @@
                    (write-line string s)))
                 (t
-                 (write-line 
- "There are no possible completions of what you have typed." s))))))
-     ((and (eq *parse-type* :file) (not (zerop (length input))))
-      (let ((pns (ambiguous-files (region-to-string *parse-input-region*)
-                                  *parse-default*)))
+                 (write-line "There are no possible completions of what you have typed." s))))))
+     ((and (eq (eps-parse-type eps) :file) (not (zerop (length input))))
+      (let ((pns (ambiguous-files input (eps-parse-default eps))))
         (declare (list pns))
         (with-pop-up-display(s :title "Completion help" :height (+ (length pns) 2))
@@ -103 +111 @@
                                (file-namestring pn) dir)))))
                 (t
-                 (write-line 
- "There are no possible completions of what you have typed." s))))))
+                 (write-line  "There are no possible completions of what you have typed." s))))))
      (t
-      (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting))
-        (insert-string m help)
-        (insert-character m #\newline))))))
-
-(defun file-completion-action (typein)
+      (with-pop-up-display (s :title "input help" :height 2)
+        (write-line help s))))))
+
+(defun file-completion-action (eps typein)
   (declare (simple-string typein))
   (when (zerop (length typein)) (editor-error))
@@ -116 +122 @@
       (result win)
       (hemlock-ext:complete-file typein
-                                 :defaults (directory-namestring *parse-default*)
+                                 :defaults (directory-namestring (eps-parse-default eps))
                                  :ignore-types (value ignore-file-types))
     (when result
-      (delete-region *parse-input-region*)
-      (insert-string (region-start *parse-input-region*)
-                     (namestring result)))
+      (replace-parse-input-string eps (namestring result)))
     (when (and (not win) (value beep-on-ambiguity))
       (editor-error))))
@@ -131 +135 @@
   If it is ambiguous and ``Beep On Ambiguity'' true beep."
   (declare (ignore p))
-  (let ((typein (region-to-string *parse-input-region*)))
+  (let* ((eps (current-echo-parse-state))
+         (typein (get-parse-input-string eps)))
     (declare (simple-string typein))
-    (case *parse-type*
+    (case (eps-parse-type eps)
       (:keyword
-       (multiple-value-bind
-           (prefix key value field ambig)
-           (complete-string typein *parse-string-tables*)
+       (multiple-value-bind (prefix key value field ambig)
+                            (complete-string typein (eps-parse-string-tables eps))
          (declare (ignore value field))
          (when prefix
-           (delete-region *parse-input-region*)
-           (insert-string (region-start *parse-input-region*) prefix)
+           (replace-parse-input-string eps prefix)
            (when (eq key :ambiguous)
              (let ((point (current-point)))
-               (move-mark point (region-start *parse-input-region*))
+               (move-mark point (eps-parse-starting-mark eps))
                (unless (character-offset point ambig)
                  (buffer-end point)))))
@@ -151 +154 @@
            (editor-error))))
       (:file
-       (file-completion-action typein))
+       (file-completion-action eps typein))
       (t
        (editor-error "Cannot complete input for this prompt.")))))
@@ -166 +169 @@
   separated by characters having a non-zero :parse-field-separator attribute,
   and this command should only be bound to characters having that attribute."
-  (let ((typein (region-to-string *parse-input-region*)))
+  (let* ((eps (current-echo-parse-state))
+         (typein (get-parse-input-string eps)))
     (declare (simple-string typein))
-    (case *parse-type*
+    (case (eps-parse-type eps)
       (:string
        (self-insert-command p))
       (:file
-       (file-completion-action typein))
+       (file-completion-action eps typein))
       (:keyword
        (let ((point (current-point)))
          (unless (blank-after-p point)
-           (insert-character point
-                             (hemlock-ext:key-event-char *last-key-event-typed*))))
+           (insert-character point (last-char-typed))))
        (multiple-value-bind
            (prefix key value field ambig)
-           (complete-string typein *parse-string-tables*)
+           (complete-string typein (eps-parse-string-tables eps))
          (declare (ignore value ambig))
          (when (eq key :none) (editor-error "No possible completion."))
-         (delete-region *parse-input-region*)
          (let ((new-typein (if (and (eq key :unique) (null field))
                                (subseq prefix 0 field)
                                (concatenate 'string
                                             (subseq prefix 0 field)
-                                            (string
-                                             (hemlock-ext:key-event-char
-                                              *last-key-event-typed*))))))
-           (insert-string (region-start *parse-input-region*) new-typein))))
+                                            (string (last-char-typed))))))
+           (replace-parse-input-string eps new-typein))))
       (t
        (editor-error "Cannot complete input for this prompt.")))))
@@ -197 +197 @@
 
 
+;;; *** TODO: this needs to be view-local
 (defvar *echo-area-history* (make-ring 10)
   "This ring-buffer contains strings which were previously input in the
@@ -203 +204 @@
 (defvar *echo-history-pointer* 0
   "This is our current position to the ring during a historical exploration.")
+
 
 (defcommand "Confirm Parse" (p)
@@ -210 +212 @@
   otherwise calls the verification function."
   (declare (ignore p))
-  (let* ((string (region-to-string *parse-input-region*))
+  (let* ((eps (current-echo-parse-state))
+         (string (get-parse-input-string eps))
          (empty (zerop (length string))))
     (declare (simple-string string))
     (if empty
-        (when *parse-default* (setq string *parse-default*))
+        (when (eps-parse-default eps) (setq string (eps-parse-default eps)))
         (when (or (zerop (ring-length *echo-area-history*))
                   (string/= string (ring-ref *echo-area-history* 0)))
           (ring-push string *echo-area-history*)))
     (multiple-value-bind (res flag)
-                         (funcall *parse-verification-function* string)
+                         (funcall (eps-parse-verification-function eps) eps string)
       (unless (or res flag) (editor-error))
-      (exit-recursive-edit res))))
+      (exit-echo-parse eps res))))
 
 (defcommand "Previous Parse" (p)
@@ -228 +231 @@
   of the ring then push it on the ring before inserting the new input."
   "Pop the *echo-area-history* ring buffer."
-  (let ((length (ring-length *echo-area-history*))
-        (p (or p 1)))
+  (let* ((eps (current-echo-parse-state))
+         (length (ring-length *echo-area-history*))
+         (p (or p 1)))
     (when (zerop length) (editor-error))
     (cond
      ((eq (last-command-type) :echo-history)
       (let ((base (mod (+ *echo-history-pointer* p) length)))
-        (delete-region *parse-input-region*)
-        (insert-string (region-end *parse-input-region*)
-                       (ring-ref *echo-area-history* base))
+        (replace-parse-input-string eps (ring-ref *echo-area-history* base))
         (setq *echo-history-pointer* base)))
      (t
-      (let ((current (region-to-string *parse-input-region*))
+      (let ((current (get-parse-input-string eps))
             (base (mod (if (minusp p) p (1- p)) length)))
-        (delete-region *parse-input-region*)
-        (insert-string (region-end *parse-input-region*)
-                       (ring-ref *echo-area-history* base))     
+        (replace-parse-input-string eps (ring-ref *echo-area-history* base))
         (when (and (plusp (length current))
                    (string/= (ring-ref *echo-area-history* 0) current))
@@ -266 +266 @@
   (editor-error))
 
-(add-hook window-buffer-hook
-          #'(lambda (window new-buff)
-              (when (and (eq window *echo-area-window*)
-                         (not (eq new-buff *echo-area-buffer*)))
-                (editor-error "Can't change echo area window."))))
-
 (defcommand "Beginning Of Parse" (p)
   "Moves to immediately after the prompt when in the echo area."
   "Move the point of the echo area buffer to *parse-starting-mark*."
   (declare (ignore p))
-  (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*))
+  (let* ((eps (current-echo-parse-state))
+         (start (eps-parse-starting-mark eps)))
+    (move-mark (current-point) start)))
 
 (defcommand "Echo Area Delete Previous Character" (p)
-  "Delete the previous character.
-  Don't let the luser rub out the prompt."
-  "Signal an editor-error if we would nuke the prompt,
-  otherwise do a normal delete."
-  (with-mark ((tem (buffer-point *echo-area-buffer*)))
-    (unless (character-offset tem (- (or p 1))) (editor-error))
-    (when (mark< tem *parse-starting-mark*) (editor-error))
-    (delete-previous-character-command p)))
+  "Delete the previous character, up to the prompt."
+  (let* ((eps (current-echo-parse-state))
+         (start (eps-parse-starting-mark eps)))
+    (with-mark ((tem (current-point)))
+      (unless (character-offset tem (- (or p 1))) (editor-error))
+      (when (mark< tem start) (editor-error))
+      (delete-previous-character-command p))))
 
 (defcommand "Echo Area Kill Previous Word" (p)
-  "Kill the previous word.
-  Don't let the luser rub out the prompt."
-  "Signal an editor-error if we would mangle the prompt, otherwise
-  do a normal kill-previous-word."
-  (with-mark ((tem (buffer-point *echo-area-buffer*)))
-    (unless (word-offset tem (- (or p 1))) (editor-error))
-    (when (mark< tem *parse-starting-mark*) (editor-error))
-    (kill-previous-word-command p)))
+  "Kill the previous word, up to the prompt."
+  (let* ((eps (current-echo-parse-state))
+         (start (eps-parse-starting-mark eps)))
+    (with-mark ((tem (current-point)))
+      (unless (word-offset tem (- (or p 1))) (editor-error))
+      (when (mark< tem start) (editor-error))
+      (kill-previous-word-command p))))
 
 (declaim (special *kill-ring*))
@@ -304 +298 @@
   "Kills *parse-input-region*."
   (declare (ignore p))
-  (if (end-line-p (current-point))
-      (kill-region *parse-input-region* :kill-backward)
-      (ring-push (delete-and-save-region *parse-input-region*)
-                 *kill-ring*)))
+  (let* ((eps (current-echo-parse-state)))
+    (if (end-line-p (current-point))
+      (kill-region (eps-parse-input-region eps) :kill-backward)
+      (ring-push (delete-and-save-region (eps-parse-input-region eps))
+                 *kill-ring*))))
 
 (defcommand "Insert Parse Default" (p)
   "Inserts the default for the parse in progress.
   The text is inserted at the point."
-  "Inserts *parse-default* at the point of the *echo-area-buffer*.
-  If there is no default an editor-error is signalled."
-  (declare (ignore p))
-  (unless *parse-default* (editor-error))
-  (insert-string (buffer-point *echo-area-buffer*) *parse-default*))
+  (declare (ignore p))
+  (let* ((eps (current-echo-parse-state))
+         (default (eps-parse-default eps)))
+    (unless default (editor-error))
+    (insert-string (current-point) default)))
 
 (defcommand "Echo Area Backward Character" (p)
   "Go back one character.
-  Don't let the luser move into the prompt."
+   Don't let the luser move into the prompt."
   "Signal an editor-error if we try to go into the prompt, otherwise
-  do a backward-character command."
-  (backward-character-command p)
-  (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
-    (beginning-of-parse-command ())
-    (editor-error)))
+   do a backward-character command."
+  (let* ((eps (current-echo-parse-state))
+         (start (eps-parse-starting-mark eps))
+         (point (current-point)))
+    (when (mark<= point start)
+      (editor-error))
+    (backward-character-command p)
+    (when (mark< point start)
+      (beginning-of-parse-command nil))))
 
 (defcommand "Echo Area Backward Word" (p)
@@ -333 +332 @@
   "Signal an editor-error if we try to go into the prompt, otherwise
   do a backward-word command."
-  (backward-word-command p)
-  (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
-    (beginning-of-parse-command ())
-    (editor-error)))
+  (let* ((eps (current-echo-parse-state))
+         (start (eps-parse-starting-mark eps))
+         (point (current-point)))
+    (when (mark<= point start)
+      (editor-error))
+    (backward-word-command p)
+    (when (mark< point start)
+      (beginning-of-parse-command nil))))

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

@@ -106 +106 @@
             (declare (ignore key))
             (values (command-name cmd) cmd))
-          (prompt-for-keyword (list *command-names*)
+          (prompt-for-keyword :tables (list *command-names*)
                               :prompt "Command to edit: "))
     (go-to-definition (fun-defined-from-pathname (command-function command))

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

@@ -379 +379 @@
 ;;;; Find file.
 
-
-(defcommand "Old Find File" (p &optional pathname)
-  "Visit a file in its own buffer.
-   If the file is already in some buffer, select that buffer,
-   otherwise make a new buffer with the same name as the file and
-   read the file into it."
-  "Make a buffer containing the file Pathname current, creating a buffer
-   if necessary.  The buffer is returned."
-  (declare (ignore p))
-  (let* ((pn (or pathname
-                 (prompt-for-file 
-                  :prompt "Find File: "
-                  :must-exist nil
-                  :help "Name of file to read into its own buffer."
-                  :default (buffer-default-pathname (current-buffer)))))
-         (buffer (find-file-buffer pn)))
-    (change-to-buffer buffer)
-    buffer))
 
 (defcommand "Find File" (p &optional pathname)
@@ -633 +615 @@
   "Writes the contents of the current buffer to the associated file."
   (declare (ignore p))
-  (let* ((document (hi::buffer-document buffer)))
-    (when document
-      (when (buffer-modified buffer)
+  (when (buffer-modified buffer)
+    (let* ((document (hi::buffer-document buffer)))
+      (when document
         (hi::save-hemlock-document document)))))
 
@@ -668 +650 @@
         (message "Saved ~S file~:P." saved-count))))
 
-(defcommand "Save All Files and Exit" (p)
-  "Save all modified buffers in their associated files and exit;
-  a combination of \"Save All Files\" and \"Exit Hemlock\"."
-  "Do a save-all-files-command and then an exit-hemlock."
-  (declare (ignore p))
-  (save-all-files-command ())
-  (exit-hemlock))
-
 (defcommand "Backup File" (p)
   "Write the buffer to a file without changing the associated name."
@@ -693 +667 @@
 ;;;; Buffer hacking commands:
 
-(defvar *buffer-history* ()
-  "A list of buffers, in order from most recently to least recently selected.")
-
-(defun previous-buffer ()
-  "Returns some previously selected buffer that is not the current buffer.
-   Returns nil if no such buffer exists."
-  (let ((b (car *buffer-history*)))
-    (or (if (eq b (current-buffer)) (cadr *buffer-history*) b)
-        (find-if-not #'(lambda (x)
-                         (or (eq x (current-buffer))
-                             (eq x *echo-area-buffer*)))
-                     (the list *buffer-list*)))))
-
-;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by
-;;; "Circulate Buffers" even if it has never been before.
-;;;
-(defun add-buffer-history-hook (buffer)
-  (let ((ele (last *buffer-history*))
-        (new-stuff (list buffer)))
-    (if ele
-        (setf (cdr ele) new-stuff)
-        (setf *buffer-history* new-stuff))))
-;;;
-(add-hook make-buffer-hook 'add-buffer-history-hook)
-
-;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer.
-;;;
-(defun delete-buffer-history-hook (buffer)
-  (setq *buffer-history* (delq buffer *buffer-history*)))
-;;;
-(add-hook delete-buffer-hook 'delete-buffer-history-hook)
-  
-(defun change-to-buffer (buffer)
-  "Switches to buffer in the current window maintaining *buffer-history*."
-  (setq *buffer-history*
-        (cons (current-buffer) (delq (current-buffer) *buffer-history*)))
-  (setf (current-buffer) buffer)
-  (setf (window-buffer (current-window)) buffer))
-
-(defun delete-buffer-if-possible (buffer)
-  "Deletes a buffer if at all possible.  If buffer is the only buffer, other
-   than the echo area, signals an error.  Otherwise, find some recently current
-   buffer, and make all of buffer's windows display this recent buffer.  If
-   buffer is current, set the current buffer to be this recently current
-   buffer."
-  (let ((new-buf (flet ((frob (b)
-                          (or (eq b buffer) (eq b *echo-area-buffer*))))
-                   (or (find-if-not #'frob (the list *buffer-history*))
-                       (find-if-not #'frob (the list *buffer-list*))))))
-    (unless new-buf
-      (error "Cannot delete only buffer ~S." buffer))
-    (dolist (w (buffer-windows buffer))
-      (setf (window-buffer w) new-buf))
-    (when (eq buffer (current-buffer))
-      (setf (current-buffer) new-buf)))
-  (delete-buffer buffer))
-
-
-(defvar *create-buffer-count* 0)
-
-(defcommand "Create Buffer" (p &optional buffer-name)
-  "Create a new buffer.  If a buffer with the specified name already exists,
-   then go to it."
-  "Create or go to the buffer with the specifed name."
-  (declare (ignore p))
-  (let ((name (or buffer-name
-                  (prompt-for-buffer :prompt "Create Buffer: "
-                                     :default-string
-                                     (format nil "Buffer ~D"
-                                             (incf *create-buffer-count*))
-                                     :must-exist nil))))
-    (if (bufferp name)
-        (change-to-buffer name)
-        (change-to-buffer (or (getstring name *buffer-names*)
-                              (make-buffer name))))))
-
-(defcommand "Select Buffer" (p)
-  "Select a different buffer.
-   The buffer to go to is prompted for."
-  "Select a different buffer.
-   The buffer to go to is prompted for."
-  (declare (ignore p))
-  (let ((buf (prompt-for-buffer :prompt "Select Buffer: "
-                                :default (previous-buffer))))
-    (when (eq buf *echo-area-buffer*)
-      (editor-error "Cannot select Echo Area buffer."))
-    (change-to-buffer buf)))
-
-
-(defvar *buffer-history-ptr* ()
-  "The successively previous buffer to the current buffer.")
-
-(defcommand "Select Previous Buffer" (p)
-  "Select the buffer selected before this one.  If called repeatedly
-   with an argument, select the successively previous buffer to the
-   current one leaving the buffer history as it is."
-  "Select the buffer selected before this one."
-  (if p
-      (circulate-buffers-command nil)
-      (let ((b (previous-buffer)))
-        (unless b (editor-error "No previous buffer."))
-        (change-to-buffer b)
-        ;;
-        ;; If the pointer goes to nil, then "Circulate Buffers" will keep doing
-        ;; "Select Previous Buffer".
-        (setf *buffer-history-ptr* (cddr *buffer-history*))
-        (setf (last-command-type) :previous-buffer))))
-
-(defcommand "Circulate Buffers" (p)
-  "Advance through buffer history, selecting successively previous buffer."
-  "Advance through buffer history, selecting successively previous buffer."
-  (declare (ignore p))
-  (if (and (eq (last-command-type) :previous-buffer)
-           *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER.
-      (let ((b (pop *buffer-history-ptr*)))
-        (when (eq b (current-buffer))
-          (setf b (pop *buffer-history-ptr*)))
-        (unless b
-          (setf *buffer-history-ptr*
-                (or (cdr *buffer-history*) *buffer-history*))
-          (setf b (car *buffer-history*)))
-        (setf (current-buffer) b)
-        (setf (window-buffer (current-window)) b)
-        (setf (last-command-type) :previous-buffer))
-      (select-previous-buffer-command nil)))
-  
 
 (defcommand "Buffer Not Modified" (p)

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

@@ -33 +33 @@
            (buffer (line-%buffer first-line)))
       (modifying-buffer buffer)
-      (cocoa-read-file pathname mark buffer))))
-      
-
+      (with-open-file (input pathname :direction :input :element-type 'character)
+        (do ((line (read-line input nil :eof) (read-line input nil :eof)))
+            ((eql line :eof))
+          (insert-string mark line)
+          (insert-character mark #\newline))))))
 
 

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

@@ -665 +665 @@
       (return i))))
 
+#-clozure
 (defun delq (item list)
   (delete item list :test #'eq))
 
+#-clozure
 (defun memq (item list)
   (member item list :test #'eq))
 
+#-clozure
 (defun assq (item alist)
   (assoc item alist :test #'eq))

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

@@ -114 +114 @@
 (defvar *cache-modification-tick* -1
   "The counter for the fixnums we stick in the chars of the cached line.")
+
+(defun next-cache-modification-tick ()
+  (ccl::atomic-decf *cache-modification-tick*))
 
 (defun open-line (line mark)
@@ -171 +174 @@
     (unless (and (= (mark-charpos ,mark) (current-left-open-pos)) (current-open-line-p ,line))
       (open-line ,line ,mark))
-    (setf (line-chars (current-open-line)) (decf *cache-modification-tick*))))
+    (setf (line-chars (current-open-line)) (next-cache-modification-tick))))
 
 ;;; Now-Tick tells us when now is and isn't.
@@ -182 +185 @@
 
   
-(defun buffer-document-begin-editing (buffer)
-  (when (bufferp buffer)
-    (let* ((document (buffer-document buffer)))
-      (when document
-        (lock-buffer buffer)
-        (document-begin-editing document)))))
-
-(defun buffer-document-end-editing (buffer)
-  (when (bufferp buffer)
-    (let* ((document (buffer-document buffer)))
-      (when document
-        (unlock-buffer buffer)
-        (document-end-editing document)))))
-
-
-
 ;;; Yeah, the following is kind of obscure, but at least it doesn't
 ;;; call Bufferp twice.  The without-interrupts is just to prevent
@@ -422 +409 @@
            (error "~S is an invalid mark type." kind)))))
 
+(defun mark-buffer (mark)
+  (line-buffer (mark-line mark)))
+
 (defun copy-mark (mark &optional (kind (mark-%kind mark)))
   "Returns a new mark pointing to the same position as Mark.  The kind
@@ -469 +459 @@
   "``Buffer'' given to lines in regions not in any buffer.")
 
+(defun next-disembodied-buffer-counter ()
+  (ccl::atomic-incf *disembodied-buffer-counter*))
+
 (defun make-empty-region ()
   "Returns a region with start and end marks pointing to the start of one empty
   line.  The start mark is right-inserting and the end mark is left-inserting."
   (let* ((line (make-line :chars ""  :number 0
-                          :%buffer (incf *disembodied-buffer-counter*)))
+                          :%buffer (next-disembodied-buffer-counter)))
          (start (mark line 0 :right-inserting))
          (end (mark line 0 :left-inserting)))

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

@@ -67 +67 @@
     (declare (simple-string string))
     (do* ((index 0)
-          (buffer (incf *disembodied-buffer-counter*))
+          (buffer (next-disembodied-buffer-counter))
           (previous-line)
           (line (make-line :%buffer buffer))
@@ -243 +243 @@
   mark)
 
-(defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark))))
+(defun buffer-start (mark &optional (buffer (mark-buffer mark)))
   "Change Mark to point to the beginning of Buffer, which defaults to
   the buffer Mark is currently in."
@@ -249 +249 @@
   (move-mark mark (buffer-start-mark buffer)))
 
-(defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark))))
+(defun buffer-end (mark &optional (buffer (mark-buffer mark)))
   "Change Mark to point to the end of Buffer, which defaults to
   the buffer Mark is currently in."
@@ -392 +392 @@
 
 (defun %print-before-mark (mark stream)
-  (let* ((hi::*current-buffer* (line-buffer (mark-line mark))))
+  (let* ((hi::*current-buffer* (mark-buffer mark)))
     (if (mark-line mark)
         (let* ((line (mark-line mark))
@@ -415 +415 @@
 
 (defun %print-after-mark (mark stream)
-  (let* ((hi::*current-buffer* (line-buffer (mark-line mark))))
+  (let* ((hi::*current-buffer* (mark-buffer mark)))
     (if (mark-line mark)
         (let* ((line (mark-line mark))
@@ -446 +446 @@
 (defun %print-hmark (structure stream d)
   (declare (ignore d))
-  (let ((hi::*current-buffer* (line-buffer (mark-line structure))))
+  (let ((hi::*current-buffer* (mark-buffer structure)))
     (write-string "#<Hemlock Mark \"" stream)
     (%print-before-mark structure stream)
@@ -461 +461 @@
   (let* ((start (region-start region))
          (end (region-end region))
-         (hi::*current-buffer* (line-buffer (mark-line start)))
+         (hi::*current-buffer* (mark-buffer start))
          (first-line (mark-line start))
          (last-line (mark-line end)))

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

@@ -56 +56 @@
                                                        0 (current-left-open-pos)))
                                     (new-line (make-line :%buffer buffer
-                                                         :chars (decf *cache-modification-tick*)
+                                                         :chars (next-cache-modification-tick)
                                                          :previous line
                                                          :next next)))

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

@@ -128 +128 @@
                  ;;line-%buffer:
                  (do* ((line (line-next first-line) (line-next line))
-                       (count (incf *disembodied-buffer-counter*)))
+                       (count (next-disembodied-buffer-counter)))
                       ((eq line last-line)
                        (setf (line-%buffer last-line) count))
@@ -181 +181 @@
                           (new-line (make-line
                                      :chars new-chars  :number 0
-                                     :%buffer (incf *disembodied-buffer-counter*))))
+                                     :%buffer (next-disembodied-buffer-counter))))
                      (declare (simple-string new-chars))
                      (%sp-byte-blt (current-open-chars) (current-right-open-pos) new-chars 0 num) 
@@ -205 +205 @@
                           (saved-first-chars (make-string saved-first-length))
                           (saved-last-chars (make-string last-charpos))
-                          (count (incf *disembodied-buffer-counter*))
+                          (count (next-disembodied-buffer-counter))
                           (saved-line (make-line :chars saved-first-chars
                                                  :%buffer count)))
@@ -275 +275 @@
          (first-charpos (mark-charpos start))
          (last-charpos (mark-charpos end))
-         (count (incf *disembodied-buffer-counter*)))
+         (count (next-disembodied-buffer-counter)))
     (cond
      ((eq first-line last-line)

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

@@ -40 +40 @@
 ;;; our purposes it is presently used to look up commands and key-translations.
 ;;;
-(defun get-table-entry (table key)
+(defun get-table-entry (table key &key (end (length key)))
   (let ((foo nil))
-    (dotimes (i (length key) foo)
+    (dotimes (i end foo)
       (let ((key-event (aref key i)))
         (setf foo (gethash key-event table))
@@ -74 +74 @@
 
 (defvar *key-translations* (make-hash-table))
-(defvar *translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-
 
 ;;; TRANSLATE-KEY  --  Internal
@@ -87 +85 @@
 (defun translate-key (key &optional (result (make-array (length key)
                                                         :fill-pointer 0
-                                                        :adjustable t)))
+                                                        :adjustable t))
+                                    (temp (make-array 10 :fill-pointer 0 :adjustable t)))
   (let ((key-len (length key))
-        (temp *translate-key-temp*)
         (start 0)
         (try-pos 0)
@@ -100 +98 @@
         (vector-push-extend
          (hemlock-ext:make-key-event key-event (logior (hemlock-ext:key-event-bits key-event)
-                                               prefix))
+                                                       prefix))
          temp)
         (setf prefix 0))
@@ -222 +220 @@
                               "~&Error while trying to bind key ~A: ~A~%"
                               key condition)
-                      (return-from bind-key nil))))
+                      (message (format nil "~a" condition))
+                      #-GZ (return-from bind-key nil)
+                      )))
                 (let ((cmd (getstring name *command-names*))
                       (table (get-right-table kind where))
@@ -262 +262 @@
                    (nreverse t-bindings)))
         (declare (list t-bindings))
-        (let ((res (get-table-entry (mode-object-bindings (car mode)) key)))
+        (let* ((res (or (get-table-entry (mode-object-bindings (car mode)) key)
+                        (let ((default (mode-object-default-command (car mode))))
+                          (and default (getstring default *command-names*))))))
           (when res
-            (if (mode-object-transparent-p (car mode))
+            (if (or (mode-object-transparent-p (car mode))
+                    (and (commandp res) (command-transparent-p res)))
                 (push res t-bindings)
                 (return (values res (nreverse t-bindings)))))))))))
@@ -308 +311 @@
 ;;; otherwise, make a new command object and enter it into the *command-names*.
 ;;;
-(defun make-command (name documentation function)
+(defun make-command (name documentation function &key transparent-p)
   "Create a new Hemlock command with Name and Documentation which is
    implemented by calling the function-value of the symbol Function"
@@ -316 +319 @@
       (setf (command-name entry) name)
       (setf (command-documentation entry) documentation)
-      (setf (command-function entry) function))
+      (setf (command-function entry) function)
+      (setf (command-transparent-p entry) transparent-p))
      (t
       (setf (getstring name *command-names*)
-            (internal-make-command name documentation function))))))
+            (internal-make-command name documentation function transparent-p))))))
 
 
@@ -366 +370 @@
 
 
-(defvar *last-command-type* ()
-  "The command-type of the last command invoked.")
-(defvar *command-type-set* ()
-  "True if the last command set the command-type.")
-
 ;;; LAST-COMMAND-TYPE  --  Public
 ;;;
@@ -378 +377 @@
   If no command-type has been set then return NIL.  Setting this with
   Setf sets the value for the next command."
-  *last-command-type*)
+  *last-last-command-type*)
 
 ;;; %SET-LAST-COMMAND-TYPE  --  Internal
 ;;;
-;;;    Set the flag so we know not to clear the command-type.
-;;;
 (defun %set-last-command-type (type)
-  (setq *last-command-type* type *command-type-set* t))
-
-
-(defvar *prefix-argument* nil "The prefix argument or NIL.")
-(defvar *prefix-argument-supplied* nil
-  "Should be set by functions which supply a prefix argument.")
+  (setf (hemlock-last-command-type *current-view*) type))
+
 
 ;;; PREFIX-ARGUMENT  --  Public
@@ -396 +389 @@
 ;;;
 (defun prefix-argument ()
-  "Return the current value of prefix argument.  This can be set with SETF."
-  *prefix-argument*)
-
-;;; %SET-PREFIX-ARGUMENT  --  Internal
-;;;
-(defun %set-prefix-argument (argument)
-  "Set the prefix argument for the next command to Argument."
-  (unless (or (null argument) (integerp argument))
-    (error "Prefix argument ~S is neither an integer nor Nil." argument))
-  (setq *prefix-argument* argument  *prefix-argument-supplied* t))
-
-
-;;;; The Command Loop:
-
-;;; Buffers we use to read and translate keys.
-;;;
-(defvar *current-command* (make-array 10 :fill-pointer 0 :adjustable t))
-(defvar *current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
-
+  "Return the current value of prefix argument."
+  *last-prefix-argument*)
+
+;;;
 (defvar *invoke-hook* #'(lambda (command p)
                           (funcall (command-function command) p))
@@ -422 +400 @@
 
 
-
-(defvar *self-insert-command* nil)
-
-(defun self-insert-command ()
-  (or *self-insert-command*
-      (setq *self-insert-command* (getstring "Self Insert" *command-names*))))
-
-    
-;;; %COMMAND-LOOP  --  Internal
-;;;
-;;;    Read commands from the terminal and execute them, forever.
-;;;
-(defun %command-loop ()
-  (let  ((cmd *current-command*)
-         (trans *current-translation*)
-         (*last-command-type* nil)
-         (*command-type-set* nil)
-         (*prefix-argument* nil)
-         (*prefix-argument-supplied* nil))
-    (declare (special *last-command-type* *command-type-set*
-                      *prefix-argument* *prefix-argument-supplied*))
-    (setf (fill-pointer cmd) 0)
-    (handler-bind
-        ;; Bind this outside the invocation loop to save consing.
-        ((editor-error #'(lambda (condx)
-                           (beep)
-                           (let ((string (editor-error-format-string condx)))
-                             (when string
-                               (apply #'message string
-                                      (editor-error-format-arguments condx)))
-                             (throw 'command-loop-catcher nil)))))
-      (loop
-        (let* ((temporary-object-pool (allocate-temporary-object-pool)))
-          (unwind-protect
-               (progn
-                 (unless (eq *current-buffer* *echo-area-buffer*)
-                   (unless (or (zerop (length cmd))
-                               (not (value hemlock::key-echo-delay)))
-                     (editor-sleep (value hemlock::key-echo-delay))
-                     (unless (listen-editor-input *editor-input*)
-                       (clear-echo-area)
-                       (dotimes (i (length cmd))
-                         (hemlock-ext:print-pretty-key (aref cmd i) *echo-area-stream*)
-                         (write-char #\space *echo-area-stream*)))))
-                 (multiple-value-bind (key self-insert)
-                     (get-key-event *editor-input*)
-                   (unless (eq *current-buffer* *echo-area-buffer*)
-                     (when (buffer-modified *echo-area-buffer*)
-                       (clear-echo-area)))
-                   (vector-push-extend key cmd)
-                   (multiple-value-bind (trans-result prefix-p)
-                       (unless self-insert (translate-key cmd trans))
-                     (multiple-value-bind (res t-bindings)
-                         (if self-insert
-                           (self-insert-command)
-                           (get-current-binding trans-result))
-                       (etypecase res
-                         (command 
-                          (let ((punt t))
-                            (catch 'command-loop-catcher
-                              (let* ((buffer *current-buffer*)
-                                     (*command-key-event-buffer* buffer)
-                                     (doc (buffer-document buffer)))
-                                (unwind-protect
-                                     (progn
-                                       (when doc
-                                         (hi::document-begin-editing doc))
-                                       (dolist (c t-bindings)
-                                         (funcall *invoke-hook* c *prefix-argument*))
-                                       (funcall *invoke-hook* res *prefix-argument*)
-                                       (setf punt nil))
-                                  (when doc
-                                    (hi::document-end-editing doc)))))
-                            (when punt (invoke-hook hemlock::command-abort-hook)))
-                          (if *command-type-set*
-                            (setq *command-type-set* nil)
-                            (setq *last-command-type* nil))
-                          (if *prefix-argument-supplied*
-                            (setq *prefix-argument-supplied* nil)
-                            (setq *prefix-argument* nil))
-                          (setf (fill-pointer cmd) 0))
-                         (null
-                          (unless prefix-p
-                            (beep)
-                            (setq *prefix-argument* nil)
-                            (setf (fill-pointer cmd) 0)))
-                         (hash-table)))))
-                 (free-temporary-objects temporary-object-pool))))))))
-
-
-
-
-    
-
-
-
-;;; EXIT-HEMLOCK  --  Public
-;;;
-
+(defun get-self-insert-command ()
+  ;; Get the command used to implement normal character insertion in current buffer.
+  (getstring (value hemlock::self-insert-command-name) *command-names*))
+
+(defun get-default-command ()
+  ;; Get the command used when no binding is present in current buffer.
+  (getstring (value hemlock::default-command-name) *command-names*))

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

@@ -128 +128 @@
 
 (defun %buffer-push-buffer-mark (b mark activate-region)
-  (cond ((eq (line-buffer (mark-line mark)) b)
+  (cond ((eq (mark-buffer mark) b)
          (setf (mark-kind mark) :right-inserting)
          (let* ((old-mark (hi::buffer-%mark b)))

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

@@ -554 +554 @@
    ignored."
   (declare (ignore p))
-  (clear-echo-area)
-  (write-string "Evaluating buffer in the editor ..." *echo-area-stream*)
-  (finish-output *echo-area-stream*)
+  (message "Evaluating buffer in the editor ...")
   (with-input-from-region (stream (buffer-region (current-buffer)))
     (let ((*standard-output* *echo-area-stream*))

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

@@ -71 +71 @@
          ,@unsets))))
 
-
+;; WITH-BUFFER-BINDINGS
+;;
+;; Execute body with buffer's bindings in effect.  Also binds *current-buffer*,
+;; (unless buffer _is_ *current-buffer*) because anything that looks at bindings
+;; probably looks at *current-buffer* as well.
+
+(defmacro with-buffer-bindings ((buffer) &body body)
+  (let ((buffer-var (gensym)))
+    `(let ((,buffer-var ,buffer)
+           ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var))))
+       (unwind-protect
+           (progn
+             (setup-buffer-bindings ,buffer-var)
+             ,@body)
+         (revert-buffer-bindings ,buffer-var)))))
+
+
+;; MODIFYING-BUFFER-STORAGE
+;;
+;; This is kinda Cocoa-specific, but we'll pretend it's not. It gets wrapped around
+;; possible multiple modifications of the buffer's text, so that the OS can defer
+;; layout and redisplay until the end.
+;; Buffer can be NIL to temporarily turn off the grouping.
+
+(defmacro modifying-buffer-storage ((buffer) &body body)
+  (if (eq buffer '*current-buffer*)
+    `(gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))
+    `(let ((*current-buffer* ,buffer))
+       (gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)))))
 
 
@@ -186 +214 @@
   (when (atom lambda-list)
     (error "Command argument list is not a list: ~S." lambda-list))
-  (let (command-name function-name)
+  (let (command-name function-name extra-args)
     (cond ((listp name)
-           (setq command-name (car name)  function-name (cadr name))
+           (setq command-name (car name) function-name (cadr name))
            (unless (symbolp function-name)
-             (error "Function name is not a symbol: ~S" function-name)))
+             (error "Function name is not a symbol: ~S" function-name))
+           (if (keywordp function-name)
+             (setq function-name nil extra-args (cdr name))
+             (setq extra-args (cddr name))))
           (t
-           (setq command-name name
-                 function-name (bash-string-to-symbol name '-command))))
+           (setq command-name name)))
+    (when (null function-name)
+      (setq function-name (bash-string-to-symbol command-name '-command)))
     (unless (stringp command-name)
       (error "Command name is not a string: ~S." name))
@@ -199 +231 @@
        (defun ,function-name ,lambda-list ,function-doc
               ,@forms)
-       (make-command ',name ,command-doc ',function-name)
+       (make-command ,command-name ,command-doc ',function-name ,@extra-args)
        ',function-name)))
 
@@ -319 +351 @@
 
 
-(defmacro use-buffer (buffer &body forms)
-  "Use-Buffer Buffer {Form}*
-  Has The effect of making Buffer the current buffer during the evaluation
-  of the Forms.  For restrictions see the manual."
-  (let ((gensym (gensym)))
-    `(let ((,gensym *current-buffer*)
-           (*current-buffer* ,buffer))
-      (unwind-protect
-           (progn
-             (use-buffer-set-up ,gensym)
-             ,@forms)
-        (use-buffer-clean-up ,gensym)))))
-
-
-
-
-
 ;;;; EDITOR-ERROR.
-
-(defun print-editor-error (condx s)
-    (apply #'format s (editor-error-format-string condx)
-            (editor-error-format-arguments condx)))
-
-(define-condition editor-error (error)
-  ((format-string :initform "" :initarg :format-string
-                  :reader editor-error-format-string)
-   (format-arguments :initform '() :initarg :format-arguments
-                     :reader editor-error-format-arguments))
-  (:report print-editor-error))
-;;;
-(setf (documentation 'editor-error-format-string 'function)
-      "Returns the FORMAT control string of the given editor-error condition.")
-(setf (documentation 'editor-error-format-arguments 'function)
-      "Returns the FORMAT arguments for the given editor-error condition.")
 
 (defun editor-error (&rest args)
   "This function is called to signal minor errors within Hemlock;
    these are errors that a normal user could encounter in the course of editing
-   such as a search failing or an attempt to delete past the end of the buffer.
-   This function SIGNAL's an editor-error condition formed from args.  Hemlock
-   invokes commands in a dynamic context with an editor-error condition handler
-   bound.  This default handler beeps or flashes (or both) the display.  If
-   args were supplied, it also invokes MESSAGE on them.  The command in
-   progress is always aborted, and this function never returns."
-  (let ((condx (make-condition 'editor-error
-                               :format-string (car args)
-                               :format-arguments (cdr args))))
-    (signal condx)
-    (error "Unhandled editor-error was signaled -- ~A." condx)))
-
-    
+   such as a search failing or an attempt to delete past the end of the buffer."
+  (let ((message (and args (apply #'format nil args))))
+    (abort-current-command message)))
 
 
@@ -447 +436 @@
                       `(progn
                          (setf ,',bind
-                               (prompt-for-key-event* ,',n-prompt ,',n-change))
+                               (prompt-for-key-event :prompt ,',n-prompt :change-window ,',n-change))
                          (setf ,',bind-char (hemlock-ext:key-event-char ,',bind))
                          (go ,',again))))
@@ -453 +442 @@
              (let* ((,n-prompt ,prompt)
                     (,n-change ,change-window)
-                    (,bind (prompt-for-key-event* ,n-prompt ,n-change))
+                    (,bind (prompt-for-key-event :prompt ,n-prompt :change-window ,n-change))
                     (,bind-char (hemlock-ext:key-event-char ,bind)))
                (declare (ignorable ,n-prompt ,n-change ,bind ,bind-char))
@@ -577 +566 @@
 
 
-
-
 ;;;; Error handling stuff.
-
-(declaim (special *echo-area-stream*))
-
-;;; LISP-ERROR-ERROR-HANDLER is in Macros.Lisp instead of Rompsite.Lisp because
-;;; it uses WITH-POP-UP-DISPLAY, and Macros is compiled after Rompsite.  It
-;;; binds an error condition handler to get us out of here on a recursive error
-;;; (we are already handling one if we are here).  Since COMMAND-CASE uses
-;;; EDITOR-ERROR for logical :abort characters, and this is a subtype of ERROR,
-;;; we bind an editor-error condition handler just inside of the error handler.
-;;; This keeps us from being thrown out into the debugger with supposedly
-;;; recursive errors occuring.  What we really want in this case is to simply
-;;; get back to the command loop and forget about the error we are currently
-;;; handling.
-;;;
-
-(defun lisp-error-error-handler (condition &optional internalp)
-  (declare (ignore internalp))
-  (report-hemlock-error condition)
-  (throw 'editor-top-level-catcher nil))
 
 (defmacro handle-lisp-errors (&body body)

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

@@ -135 +135 @@
   (defhvar "Delete Buffer Hook"
     "This hook is called with the buffer whenever a buffer is deleted.")
-  (defhvar "Enter Recursive Edit Hook"
-    "This hook is called with the new buffer when a recursive edit is
-     entered.")
-  (defhvar "Exit Recursive Edit Hook"
-    "This hook is called with the value returned when a recursive edit
-     is exited.")
-  (defhvar "Abort Recursive Edit Hook"
-    "This hook is called with the editor-error args when a recursive
-     edit is aborted.")
   (defhvar "Buffer Major Mode Hook"
     "This hook is called with the buffer and the new mode when a buffer's
@@ -166 +157 @@
   (defhvar "Buffer Package Hook"
       "This hook is called with the new package name whenever a (Lisp) buffer's package changes")
-  (defhvar "Set Buffer Hook"
-    "This hook is called with the new buffer when the current buffer is set.")
-  (defhvar "After Set Buffer Hook"
-    "This hook is invoked with the old buffer after the current buffer has
-     been changed.")
   (defhvar "Set Window Hook"
     "This hook is called with the new window when the current window
@@ -236 +222 @@
      the pathname fits.  \"...\" indicates a truncated pathname."
     :value nil
-    :hooks (list 'maximum-modeline-pathname-length-hook)))
+    :hooks (list 'maximum-modeline-pathname-length-hook))
+  (defhvar "Self Insert Command Name"
+    "The name of the command to invoke to handle quoted input (i.e. after c-q).
+     By default, this is \"Self Insert\"."
+    :value "Self Insert")
+  (defhvar "Default Command Name"
+    "The name of the command to invoke to handle keys that have no binding
+     defined.  By default, this is \"Illegal\"."
+    :value "Illegal")
+  )
 
 

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

@@ -108 +108 @@
                (let* ((line-termination-string
                        (case (buffer-line-termination buffer)
-                         ((:unix nil))
-                         (:macos "CR")
-                         (:cp/m "CRLF")))
-                      (doc (buffer-document buffer))
-                      (encoding-name (if doc
-                                       (document-encoding-name doc)
-                                       "Default")))
+                         ((:lf nil))
+                         ((:cr) "CR")
+                         ((:crlf) "CRLF")))
+                      (encoding-name (or (buffer-encoding-name buffer)
+                                         "Default")))
                  (format nil "[~a~@[ ~a~]] "
                          encoding-name line-termination-string))))
@@ -253 +251 @@
   ;; 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::window-buffer-hook 'queue-window-change)
 )
 

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

@@ -39 +39 @@
   (declare (ignore p)))
 
+
+(defcommand "Abort Command" (p)
+  "Abort reading a command in current view"
+  "Aborts c-q, multi-key commands (e.g. c-x), prefix translation (e.g.
+ESC as Meta-), prefix arguments (e.g. c-u), ephemeral modes such as
+i-search, and prompted input (e.g. m-x)"
+  (declare (ignore p))
+  (abort-to-toplevel))
 
 ;;;; Casing commands...
@@ -175 +183 @@
 (defun prompt-for-place (prompt help)
   (multiple-value-bind (word val)
-                       (prompt-for-keyword *scope-table* :prompt prompt
+                       (prompt-for-keyword :tables *scope-table*
+                                           :prompt prompt
                                            :help help :default "Global")
     (declare (ignore word))
@@ -184 +193 @@
       (:mode
        (values :mode (prompt-for-keyword 
-                      (list *mode-names*)
+                      :tables (list *mode-names*)
                       :prompt "Mode: "
                       :help "Mode to be local to."
@@ -197 +206 @@
   (multiple-value-call #'bind-key 
     (values (prompt-for-keyword
-             (list *command-names*)
+             :tables (list *command-names*)
              :prompt "Command to bind: "
              :help "Name of command to bind to a key."))
@@ -259 +268 @@
           (defhvar name doc :value val :hooks hooks)
           (defhvar name doc kind where :value val :hooks hooks)))))
-
-
-
-
-
-;;; This is used by the :edit-level modeline field which is defined in Main.Lisp.
-;;;
-(defvar *recursive-edit-count* 0)
-
-(defun do-recursive-edit ()
-  "Does a recursive edit, wrapping []'s around the modeline of the current
-  window during its execution.  The current window and buffer are saved
-  beforehand and restored afterward.  If they have been deleted by the
-  time the edit is done then an editor-error is signalled."
-  (let* ((win (current-window))
-         (buf (current-buffer)))
-    (unwind-protect
-        (let ((*recursive-edit-count* (1+ *recursive-edit-count*)))
-          (update-modeline-field *echo-area-buffer* *echo-area-window*
-                                 (modeline-field :edit-level))
-          (recursive-edit))
-      (update-modeline-field *echo-area-buffer* *echo-area-window*
-                             (modeline-field :edit-level))
-      (unless (and (member win *window-list*) (memq buf *buffer-list*))
-        (editor-error "Old window or buffer has been deleted."))
-      (setf (current-window) win)
-      (unless (eq (window-buffer win) buf)
-        (setf (window-buffer win) buf))
-      (setf (current-buffer) buf))))
-
-(defcommand "Exit Recursive Edit" (p)
-  "Exit a level of recursive edit.  Signals an error when not in a
-   recursive edit."
-  "Exit a level of recursive edit.  Signals an error when not in a
-   recursive edit."
-  (declare (ignore p))
-  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
-  (exit-recursive-edit ()))
-
-(defcommand "Abort Recursive Edit" (p)
-  "Abort the current recursive edit.  Signals an error when not in a
-   recursive edit."
-  "Abort the current recursive edit.  Signals an error when not in a
-   recursive edit."
-  (declare (ignore p))
-  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
-  (abort-recursive-edit "Recursive edit aborted."))
 
 
@@ -416 +378 @@
 
 
-
-
-
-
-
-;;;; Mouse Commands.
-
-(defcommand "Do Nothing" (p)
-  "Do nothing.
-  With prefix argument, do it that many times."
-  "Do nothing p times."
-  (dotimes (i (or p 1)))
-  (setf (last-command-type) (last-command-type)))
-
-(defun do-nothing (&rest args)
-  (declare (ignore args))
-  nil)
-
-(defun maybe-change-window (window)
-  (unless (eq window (current-window))
-    (when (or (eq window *echo-area-window*)
-              (eq (current-window) *echo-area-window*)
-              (member window *random-typeout-buffers*
-                      :key #'(lambda (cons)
-                               (hi::random-typeout-stream-window (cdr cons)))))
-      (supply-generic-pointer-up-function #'do-nothing)
-      (editor-error "I'm afraid I can't let you do that Dave."))
-    (setf (current-window) window)
-    (let ((buffer (window-buffer window)))
-      (unless (eq (current-buffer) buffer)
-        (setf (current-buffer) buffer)))))
-
-(defcommand "Top Line to Here" (p)
-  "Move the top line to the line the mouse is on.
-  If in the first two columns then scroll continuously until the button is
-  released."
-  "Move the top line to the line the mouse is on."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-                       (last-key-event-cursorpos)
-    (unless y (editor-error))
-    (cond ((< x 2)
-           (loop
-             (when (listen-editor-input hi::*editor-input*) (return))
-             (scroll-window window -1)
-             (redisplay)
-             (editor-finish-output window)))
-          (t
-           (scroll-window window (- y))))))
-
-(defcommand "Here to Top of Window" (p)
-  "Move the line the mouse is on to the top of the window.
-  If in the first two columns then scroll continuously until the button is
-  released."
-  "Move the line the mouse is on to the top of the window."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-                       (last-key-event-cursorpos)
-    (unless y (editor-error))
-    (cond ((< x 2)
-           (loop
-             (when (listen-editor-input hi::*editor-input*) (return))
-             (scroll-window window 1)
-             (redisplay)
-             (editor-finish-output window)))
-          (t
-           (scroll-window window y)))))
-
-
-(defvar *generic-pointer-up-fun* nil
-  "This is the function for the \"Generic Pointer Up\" command that defines
-   its action.  Other commands set this in preparation for this command's
-   invocation.")
-;;;
-(defun supply-generic-pointer-up-function (fun)
-  "This provides the action \"Generic Pointer Up\" command performs."
-  (check-type fun function)
-  (setf *generic-pointer-up-fun* fun))
-
-(defcommand "Generic Pointer Up" (p)
-  "Other commands determine this command's action by supplying functions that
-   this command invokes.  The following built-in commands supply the following
-   generic up actions:
-      \"Point to Here\"
-         When the position of the pointer is different than the current
-         point, the action pushes a buffer mark at point and moves point
-         to the pointer's position.
-      \"Bufed Goto and Quit\"
-         The action is a no-op."
-  "Invoke whatever is on *generic-pointer-up-fun*."
-  (declare (ignore p))
-  (unless *generic-pointer-up-fun*
-    (editor-error "No commands have supplied a \"Generic Pointer Up\" action."))
-  (funcall *generic-pointer-up-fun*))
-
-
-(defcommand "Point to Here" (p)
-  "Move the point to the position of the mouse.
-   If in the modeline, move to the absolute position in the file indicated by
-   the position within the modeline, pushing the old position on the mark
-   stack.  This supplies a function \"Generic Pointer Up\" invokes if it runs
-   without any intervening generic pointer up predecessors running.  If the
-   position of the pointer is different than the current point when the user
-   invokes \"Generic Pointer Up\", then this function pushes a buffer mark at
-   point and moves point to the pointer's position.  This allows the user to
-   mark off a region with the mouse."
-  "Move the point to the position of the mouse."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-                       (last-key-event-cursorpos)
-    (unless x (editor-error))
-    (maybe-change-window window)
-    (if y
-        (let ((m (cursorpos-to-mark x y window)))
-          (unless m (editor-error))
-          (move-mark (current-point) m))
-        (let* ((buffer (window-buffer window))
-               (region (buffer-region buffer))
-               (point (buffer-point buffer)))
-          (push-buffer-mark (copy-mark point))
-          (move-mark point (region-start region))
-          (line-offset point (round (* (1- (count-lines region)) x)
-                                    (1- (window-width window)))))))
-  (supply-generic-pointer-up-function #'point-to-here-up-action))
-
-(defun point-to-here-up-action ()
-  (multiple-value-bind (x y window)
-                       (last-key-event-cursorpos)
-    (unless x (editor-error))
-    (when y
-      (maybe-change-window window)
-      (let ((m (cursorpos-to-mark x y window)))
-        (unless m (editor-error))
-        (when (eq (line-buffer (mark-line (current-point)))
-                  (line-buffer (mark-line m)))
-          (unless (mark= m (current-point))
-            (push-buffer-mark (copy-mark (current-point)) t)))
-        (move-mark (current-point) m)))))
-
-
-(defcommand "Insert Kill Buffer" (p)
-  "Move current point to the mouse location and insert the kill buffer."
-  "Move current point to the mouse location and insert the kill buffer."
-  (declare (ignore p))
-  (multiple-value-bind (x y window)
-                       (last-key-event-cursorpos)
-    (unless x (editor-error))
-    (maybe-change-window window)
-    (if y
-        (let ((m (cursorpos-to-mark x y window)))
-          (unless m (editor-error))
-          (move-mark (current-point) m)
-          (un-kill-command nil))
-        (editor-error "Can't insert kill buffer in modeline."))))
-
-
-
-
 ;;;; Page commands & stuff.
 
@@ -595 +399 @@
                   (name (prompt-for-string :prompt "Substring of page title: "
                                            :default (if againp
-                                                        *goto-page-last-string*
-                                                        *parse-default*)))
+                                                        *goto-page-last-string*)))
                   (dir (page-directory (current-buffer)))
                   (i 1))
@@ -720 +523 @@
    If the last character was an alphabetic character, then insert its
    capital form."
-  (let ((char (char-upcase (hemlock-ext:key-event-char *last-key-event-typed*))))
+  (let ((char (char-upcase (last-char-typed))))
     (if (and p (> p 1))
         (insert-string (current-point) (make-string p :initial-element char))

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

@@ -30 +30 @@
    #:mark-charpos
    #:mark-kind
+   #:mark-buffer
    #:previous-character
    #:next-character
@@ -69 +70 @@
    #:push-buffer-mark
    #:change-to-buffer
-   #:previous-buffer
    #:make-buffer
    #:bufferp
@@ -89 +89 @@
    #:buffer-package
    #:delete-buffer
-   #:delete-buffer-if-possible
    #:make-modeline-field
    #:modeline-field-p
@@ -185 +184 @@
    #:reverse-find-not-attribute
    #:character-attribute-hooks
-   #:current-window
    #:make-window
    #:windowp
    #:delete-window
-   #:window-buffer
    #:window-display-start
    #:window-display-end
@@ -238 +235 @@
    #:find-file-buffer
    ;;   #:ed
-   #:exit-hemlock
    #:pause-hemlock
-   #:get-key-event
-   #:unget-key-event
-   #:recursive-get-key-event
    #:clear-editor-input
    #:listen-editor-input
@@ -330 +323 @@
   (:import-from :ext #:complete-file)
   (:shadow #:char-code-limit)
+  #+clozure
+  (:import-from :ccl #:memq #:assq #:delq)
   ;;
   (:export
@@ -390 +385 @@
    #+sbcl  :sb-gray
    #+scl   :ext
-   #+openmcl :gray
+   #+clozure :gray
    ;;
    ;; Note the pacth i received from DTC mentions character-output and
@@ -417 +412 @@
    
    ;; rompsite.lisp
-   #:show-mark #:editor-sleep #:*input-transcript* #:fun-defined-from-pathname
+   #:show-mark #:editor-sleep #:fun-defined-from-pathname
    #:editor-describe-function #:pause-hemlock #:store-cut-string
    #:fetch-cut-string #:schedule-event #:remove-scheduled-event
@@ -438 +433 @@
 
    ;; from input.lisp
-   #:get-key-event #:unget-key-event #:clear-editor-input #:listen-editor-input
-   #:*last-key-event-typed* #:*key-event-history*
+   #:clear-editor-input #:listen-editor-input
+   #:last-key-event-typed #:*key-event-history*
    #:input-waiting #:last-key-event-cursorpos
 
@@ -448 +443 @@
    #:command-case #:reprompt #:with-output-to-mark #:with-input-from-region
    #:handle-lisp-errors #:with-pop-up-display #:*random-typeout-buffers*
+
+   ;; from views.lisp
+   #:hemlock-view #:current-prefix-argument-state
+   #:abort-to-toplevel #:abort-current-command
 
    ;; from line.lisp
@@ -489 +488 @@
 
    ;; echo.lisp
-   #:*echo-area-buffer* #:*echo-area-stream* #:*echo-area-window*
-   #:*parse-starting-mark* #:*parse-input-region*
-   #:*parse-verification-function* #:*parse-string-tables*
-   #:*parse-value-must-exist* #:*parse-default* #:*parse-default-string*
-   #:*parse-prompt* #:*parse-help* #:clear-echo-area #:message #:loud-message
+   #:*echo-area-stream*
+   #:clear-echo-area #:message #:loud-message
+   #:current-echo-parse-state #:exit-echo-parse
+   #:eps-parse-type #:eps-parse-starting-mark #:eps-parse-input-region
+   #:eps-parse-verification-function #:eps-parse-string-tables
+   #:eps-parse-default #:eps-parse-help
    #:prompt-for-buffer #:prompt-for-file #:prompt-for-integer
    #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string
    #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n
-   #:prompt-for-key-event #:prompt-for-key #:*logical-key-event-names*
+   #:prompt-for-key-event #:prompt-for-key #:prompt-for-command-key
+   #:*logical-key-event-names*
    #:logical-key-event-p #:logical-key-event-documentation
    #:logical-key-event-name #:logical-key-event-key-events
-   #:define-logical-key-event #:*parse-type* #:current-variable-tables
-
+   #:define-logical-key-event #:current-variable-tables
+
+
+   ;; commands
+   #:make-prefix-argument-state #:prefix-argument-resetting-state
+
+  
    ;; files.lisp
    #:read-file #:write-file
@@ -540 +546 @@
    #:bind-key #:delete-key-binding #:get-command #:map-bindings
    #:make-command #:command-name #:command-bindings #:last-command-type
-   #:prefix-argument #:exit-hemlock #:*invoke-hook* #:key-translation
+   #:prefix-argument #:*invoke-hook* #:key-translation
 
 
@@ -546 +552 @@
    #:*global-variable-names* #:*mode-names* #:*buffer-names*
    #:*character-attribute-names* #:*command-names* #:*buffer-list*
-   #:*window-list* #:*last-key-event-typed* #:after-editor-initializations
+   #:*window-list* #:last-key-event-typed #:after-editor-initializations
 
    ;; screen.lisp
@@ -575 +581 @@
 
    ;; window.lisp
-   #:current-window #:window-buffer #:modeline-field-width
+   #:modeline-field-width
    #:modeline-field-function #:make-modeline-field #:update-modeline-fields
    #:update-modeline-field #:modeline-field-name #:modeline-field

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

@@ -75 +75 @@
   (do-registers (name value)
     (etypecase value
-      (mark (when (eq (line-buffer (mark-line value)) buffer)
+      (mark (when (eq (mark-buffer value) buffer)
               (free-register name)))
       (cons (free-register-value value buffer)))))
@@ -90 +90 @@
   (etypecase value
     (mark
-     (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer))
+     (when (or (not buffer) (eq (mark-buffer value) buffer))
        (delete-mark value)))
     (cons
@@ -121 +121 @@
     (unless (markp val)
       (editor-error "Register ~A does not hold a location." reg-name))
-    (change-to-buffer (line-buffer (mark-line val)))
+    (change-to-buffer (mark-buffer val))
     (move-mark (current-point) val)))
 

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

@@ -87 +87 @@
              (editor-error)))
     (clear-echo-area)))
-
-
-
-
-;;;; Incremental searching.
-
-(defun i-search-pattern (string direction)
-  (setq *last-search-pattern*
-        (new-search-pattern (if (value string-search-ignore-case)
-                                :string-insensitive
-                                :string-sensitive)
-                            direction string *last-search-pattern*)))
-
-;;;      %I-SEARCH-ECHO-REFRESH refreshes the echo buffer for incremental
-;;; search.
-;;;
-(defun %i-search-echo-refresh (string direction failure)
-  (when (interactive)
-    (clear-echo-area)
-    (format *echo-area-stream* 
-            "~:[~;Failing ~]~:[~;Overwrapped ~]~:[Reverse I-Search~;I-Search~]: ~A"
-            failure *search-wrapped-p* (eq direction :forward) string)))
-
-(defcommand "Incremental Search" (p)
-  "Searches for input string as characters are provided.
-  These are the default I-Search command characters:  ^Q quotes the
-  next character typed.  Backspace cancels the last character typed.  ^S
-  repeats forward, and ^R repeats backward.  ^R or ^S with empty string
-  either changes the direction or yanks the previous search string.
-  Escape exits the search unless the string is empty.  Escape with 
-  an empty search string calls the non-incremental search command.  
-  Other control characters cause exit and execution of the appropriate 
-  command.  If the search fails at some point, ^G and backspace may be 
-  used to backup to a non-failing point; also, ^S and ^R may be used to
-  look the other way.  ^W extends the search string to include the the word 
-  after the point. ^G during a successful search aborts and returns
-  point to where it started."
-  "Search for input string as characters are typed in.
-  It sets up for the recursive searching and checks return values."
-  (declare (ignore p))
-  (setf (last-command-type) nil)
-  (%i-search-echo-refresh "" :forward nil)
-  (let* ((*search-wrapped-p* nil)
-         (point (current-point))
-         (save-start (copy-mark point :temporary)))
-    (with-mark ((here point))
-      (when (eq (catch 'exit-i-search
-                  (%i-search "" point here :forward nil))
-                :control-g)
-        (move-mark point save-start)
-        (invoke-hook abort-hook)
-        (editor-error))
-      (if (region-active-p)
-          (delete-mark save-start)
-          (push-buffer-mark save-start)))))
-
-
-(defcommand "Reverse Incremental Search" (p)
-  "Searches for input string as characters are provided.
-  These are the default I-Search command characters:  ^Q quotes the
-  next character typed.  Backspace cancels the last character typed.  ^S
-  repeats forward, and ^R repeats backward.  ^R or ^S with empty string
-  either changes the direction or yanks the previous search string.
-  Altmode exits the search unless the string is empty.  Altmode with 
-  an empty search string calls the non-incremental search command.  
-  Other control characters cause exit and execution of the appropriate 
-  command.  If the search fails at some point, ^G and backspace may be 
-  used to backup to a non-failing point; also, ^S and ^R may be used to
-  look the other way.  ^G during a successful search aborts and returns
-  point to where it started."
-  "Search for input string as characters are typed in.
-  It sets up for the recursive searching and checks return values."
-  (declare (ignore p))
-  (setf (last-command-type) nil)
-  (%i-search-echo-refresh "" :backward nil)
-  (let* ((*search-wrapped-p* nil)
-         (point (current-point))
-         (save-start (copy-mark point :temporary)))
-    (with-mark ((here point))
-      (when (eq (catch 'exit-i-search
-                  (%i-search "" point here :backward nil))
-                :control-g)
-        (move-mark point save-start)
-        (invoke-hook abort-hook)
-        (editor-error))
-      (if (region-active-p)
-          (delete-mark save-start)
-          (push-buffer-mark save-start)))))
-
-;;;      %I-SEARCH recursively (with support functions) searches to provide
-;;; incremental searching.  There is a loop in case the recursion is ever
-;;; unwound to some call.  curr-point must be saved since point is clobbered
-;;; with each recursive call, and the point must be moved back before a
-;;; different letter may be typed at a given call.  In the CASE at :cancel
-;;; and :control-g, if the string is not null, an accurate pattern for this
-;;; call must be provided when %I-SEARCH-CHAR-EVAL is called a second time
-;;; since it is possible for ^S or ^R to be typed.
-;;;
-(defun %i-search (string point trailer direction failure)
-  (do* ((curr-point (copy-mark point :temporary))
-        (curr-trailer (copy-mark trailer :temporary)))
-       (nil)
-    (let* ((next-key-event (recursive-get-key-event hi::*editor-input* t))
-           (val (%i-search-char-eval next-key-event string point trailer
-                                 direction failure))
-           (empty-string-p (zerop (length string))))
-      (case val 
-        (:mouse-exit
-         (clear-echo-area)
-         (throw 'exit-i-search nil))
-        (:cancel
-         (%i-search-echo-refresh string direction failure)
-         (unless empty-string-p
-           (i-search-pattern string direction))) ;sets *last-search-pattern*
-        (:return-cancel ;backspace was typed
-         (if empty-string-p
-             (beep)
-             (return :cancel)))
-        (:control-g
-         (when failure (return :control-g))
-         (%i-search-echo-refresh string direction nil)
-         (unless empty-string-p
-           (i-search-pattern string direction)))) ;*last-search-pattern*
-      (move-mark point curr-point)
-      (move-mark trailer curr-trailer))))
-
-;;;      %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes
-;;; necessary actions.
-;;;
-(defun %i-search-char-eval (key-event string point trailer direction failure)
-  (declare (simple-string string))
-  (cond ((let ((character (key-event-char key-event)))
-           (and character (standard-char-p character)))
-         (%i-search-printed-char key-event string point trailer
-                                 direction failure))
-        ((or (logical-key-event-p key-event :forward-search)
-             (logical-key-event-p key-event :backward-search))
-         (%i-search-control-s-or-r key-event string point trailer
-                                   direction failure))
-        ((logical-key-event-p key-event :cancel) :return-cancel)
-        ((logical-key-event-p key-event :extend-search-word)
-         (with-mark ((end point))
-           (word-offset end 1)
-           (let ((extension (region-to-string (region point end))))
-             (%i-search-extend-string string extension point trailer direction failure))))           
-        ((logical-key-event-p key-event :abort)
-         (unless failure
-           (clear-echo-area)
-           (message "Search aborted.")
-           (throw 'exit-i-search :control-g))
-         :control-g)
-        ((logical-key-event-p key-event :quote)
-         (%i-search-printed-char (get-key-event hi::*editor-input* t)
-                                 string point trailer direction failure))
-        ((and (zerop (length string)) (logical-key-event-p key-event :exit))
-         (if (eq direction :forward)
-             (forward-search-command nil)
-             (reverse-search-command nil))
-         (throw 'exit-i-search nil))
-        (t
-         (unless (logical-key-event-p key-event :exit)
-           (unget-key-event key-event hi::*editor-input*))
-         (unless (zerop (length string))
-           (setf *last-search-string* string))
-         (throw 'exit-i-search nil))))
-
-;;;      %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search.  Note
-;;; that there cannot be failure in the last COND branch: since the direction
-;;; has just been changed, there cannot be a failure before trying a new
-;;; direction.
-;;;
-(defun %i-search-control-s-or-r (key-event string point trailer
-                                           direction failure)
-  (let ((forward-direction-p (eq direction :forward))
-        (forward-character-p (logical-key-event-p key-event :forward-search)))
-    (cond ((zerop (length string))
-           (%i-search-empty-string point trailer direction forward-direction-p
-                                   forward-character-p))
-          ((eq forward-direction-p forward-character-p) ;keep searching in the same direction
-           (cond ((eq failure :first-failure)
-                  (cond (forward-direction-p
-                         (buffer-start point)
-                         (buffer-start trailer)
-                         (character-offset trailer (length string)))
-                        (t
-                         (buffer-end point)
-                         (buffer-end trailer)))
-                  (push-buffer-mark (copy-mark point))
-                  (let ((*search-wrapped-p* t))
-                    (%i-search-echo-refresh string direction nil)
-                    (%i-search-find-pattern string point trailer direction)))
-                  (failure
-                   (%i-search string point trailer direction t))
-                  (t
-                   (%i-search-find-pattern string point (move-mark trailer point)
-                                           direction))))
-          (t
-           (let ((new-direction (if forward-character-p :forward :backward)))
-             (%i-search-echo-refresh string new-direction nil)
-             (i-search-pattern string new-direction) ;sets *last-search-pattern*
-             (%i-search-find-pattern string point (move-mark trailer point)
-                                     new-direction))))))
-
-
-;;;      %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S
-;;; or ^R is typed.  If the direction and character typed do not agree,
-;;; then merely switch directions.  If there was a previous string, search
-;;; for it, else flash at the guy.
-;;;
-(defun %i-search-empty-string (point trailer direction forward-direction-p
-                                     forward-character-p)
-  (cond ((eq forward-direction-p (not forward-character-p))
-         (let ((direction (if forward-character-p :forward :backward)))
-           (%i-search-echo-refresh "" direction nil)
-           (%i-search "" point trailer direction nil)))
-        (*last-search-string*
-         (%i-search-echo-refresh *last-search-string* direction nil)
-         (i-search-pattern *last-search-string* direction) ;sets *last-search-pattern*
-         (%i-search-find-pattern *last-search-string* point trailer direction))
-        (t (beep))))
-
-
-;;;      %I-SEARCH-PRINTED-CHAR handles the case of standard character input.
-;;; If the direction is backwards, we have to be careful not to MARK-AFTER
-;;; the end of the buffer or to include the next character at the beginning
-;;; of the search.
-;;;
-(defun %i-search-printed-char (key-event string point trailer direction failure)
-  (let ((tchar (hemlock-ext:key-event-char key-event)))
-    (unless tchar (editor-error "Not a text character -- ~S" (key-event-char
-                                                              key-event)))
-    (when (interactive)
-      (insert-character (buffer-point *echo-area-buffer*) tchar)
-      (force-output *echo-area-stream*))
-    (let ((new-string (concatenate 'simple-string string (string tchar))))
-      (i-search-pattern new-string direction) ;sets *last-search-pattern*
-      (cond (failure (%i-search new-string point trailer direction failure))
-            ((and (eq direction :backward) (next-character trailer))
-             (%i-search-find-pattern new-string point (mark-after trailer)
-                                     direction))
-            (t
-             (%i-search-find-pattern new-string point trailer direction))))))
-
-(defun %i-search-extend-string (string extension point trailer direction failure)
-  (when (interactive)
-    (insert-string (buffer-point *echo-area-buffer*) extension)
-    (force-output *echo-area-stream*))
-  (let ((new-string (concatenate 'simple-string string extension)))
-    (i-search-pattern new-string direction) ;sets *last-search-pattern*
-    (cond (failure (%i-search new-string point trailer direction failure))
-          ((and (eq direction :backward) (next-character trailer))
-           (%i-search-find-pattern new-string point (mark-after trailer)
-                                   direction))
-          (t
-           (%i-search-find-pattern new-string point trailer direction)))))
-
-
-;;;      %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction
-;;; and finds it, updating necessary pointers for the next call to %I-SEARCH.
-;;; If the search failed, tell the user and do not move any pointers.
-;;;
-(defun %i-search-find-pattern (string point trailer direction)
-  (let ((found-offset (find-pattern trailer *last-search-pattern*)))
-    (cond (found-offset
-            (cond ((eq direction :forward)
-                   (character-offset (move-mark point trailer) found-offset))
-                  (t
-                   (move-mark point trailer)
-                   (character-offset trailer found-offset)))
-            (push-buffer-mark (copy-mark trailer) t)
-            (hi::note-selection-set-by-search)
-            (%i-search string point trailer direction nil))
-          (t
-           (%i-search-echo-refresh string direction t)
-           (if (interactive)
-               (beep)
-               (editor-error "I-Search failed."))
-           (%i-search string point trailer direction :first-failure)))))
 
 
@@ -545 +267 @@
                                               dumb)
                            (return nil))
-                 (:recursive-edit
-                  "Go into a recursive edit at the current position."
-                  (do-recursive-edit)
-                  (get-search-pattern target :forward))
                  (:exit "Exit immediately."
                         (return nil))

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

@@ -76 +76 @@
   stream)
 
-(defmacro with-left-inserting-mark ((var form) &body forms)
-  (let ((change (gensym)))
-    `(let* ((,var ,form)
-            (,change (eq (mark-kind ,var) :right-inserting)))
-       (unwind-protect
-           (progn
-             (when ,change
-               (setf (mark-kind ,var) :left-inserting))
-             ,@forms)
-         (when ,change
-           (setf (mark-kind ,var) :right-inserting))))))
-
 (defun hemlock-output-unbuffered-out (stream character)
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (let* ((buffer (line-%buffer (mark-line mark))))
-      (buffer-document-begin-editing buffer)
-      (unwind-protect
-           (insert-character mark character)
-        (buffer-document-end-editing buffer)))))
+  (let ((mark (hemlock-output-stream-mark stream)))
+    (modifying-buffer-storage ((mark-buffer mark))
+      (insert-character mark character)
+      (unless (eq (mark-kind mark) :left-inserting)
+        (character-offset mark 1)))))
 
 (defun hemlock-output-unbuffered-sout (stream string start end)
-  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
-    (unless (and (eql start 0)
-                 (eql end (length string)))
-      (setq string (subseq string start end)))
-    (let* ((buffer (line-%buffer (mark-line mark))))
-      (buffer-document-begin-editing buffer)
-      (unwind-protect
-           (insert-string mark string)
-        (buffer-document-end-editing buffer)))))
+  (unless (and (eql start 0)
+               (eql end (length string)))
+    (setq string (subseq string start end)))
+  (let ((mark (hemlock-output-stream-mark stream)))
+    (modifying-buffer-storage ((mark-buffer mark))
+      (insert-string mark string)
+      (unless (eq (mark-kind mark) :left-inserting)
+        (character-offset mark (- end start))))))
 
 (defun hemlock-output-buffered-out (stream character)
@@ -242 +228 @@
   (let ((index (kbdmac-stream-index stream)))
     (setf (kbdmac-stream-index stream) (1+ index))
-    (setq *last-key-event-typed*
-          (svref (kbdmac-stream-buffer stream) index))))
+    (setf (last-key-event-typed) (svref (kbdmac-stream-buffer stream) index))))
 
 (defun kbdmac-unget (ignore stream)

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

@@ -93 +93 @@
   mode-objects                ; list of buffer's mode objects
   bindings                    ; buffer's command table
+  bindings-wound-p            ; true if all the mode bindings have been wound.
+  (shadow-syntax nil)         ; buffer's changes to syntax attributes.
   point                       ; current position in buffer
   %mark                       ; a saved buffer position
@@ -109 +111 @@
   %modeline-fields            ; List of modeline-field-info's.
   (delete-hook nil)           ; List of functions to call upon deletion.
-  (line-termination :unix) ; Line-termination, for the time being
+  (line-termination :lf)      ; Line-termination, for the time being
   process                     ; Maybe a listener
   (gap-context )              ; The value of *buffer-gap-context*
@@ -172 +174 @@
   cleanup-function       ; Cleanup function for this mode
   bindings               ; The mode's command table.
+  default-command        ; If non-nil, default command
   transparent-p          ; Are key-bindings transparent?
   hook-name              ; The name of the mode hook.
@@ -318 +321 @@
   keyword
   documentation
-  vector
+  (vector #() :type (simple-array * (*)))
   hooks
   end-value)
@@ -328 +331 @@
 
 (defstruct (command (:constructor internal-make-command
-                                  (%name documentation function))
+                                  (%name documentation function transparent-p))
                     (:copier nil)
                     (:predicate commandp)
@@ -335 +338 @@
   documentation                    ;Command documentation string or function
   function                         ;The function which implements the command
+  transparent-p                    ;If true, this command is transparent
   %bindings)                       ;Places where command is bound
 
@@ -384 +388 @@
           (ignore-errors
             (buffer-name
-             (line-buffer (mark-line (random-typeout-stream-mark object)))))))
+             (mark-buffer (random-typeout-stream-mark object))))))
 
 
@@ -531 +535 @@
   (format stream "#<Hemlock Window Group>"))
 
-;;; Device-hunks are used to claim a piece of the screen and for ordering
-;;; pieces of the screen.  Window motion primitives and splitting/merging
-;;; primitives use hunks.  Hunks are somewhat of an interface between the
-;;; portable and non-portable parts of screen management, between what the
-;;; user sees on the screen and how Hemlock internals deal with window
-;;; sequencing and creation.  Note: the echo area hunk is not hooked into
-;;; the ring of other hunks via the next and previous fields.
-;;;
-(defstruct (device-hunk (:print-function %print-device-hunk))
-  "This structure is used internally by Hemlock's screen management system."
-  window                ; Window displayed in this hunk.
-  position              ; Bottom Y position of hunk.
-  height                ; Height of hunk in pixels or lines.
-  next                  ; Next and previous hunks.
-  previous
-  device)               ; Display device hunk is on.
-
-(defun %print-device-hunk (object stream depth)
-  (declare (ignore depth))
-  (format stream "#<Hemlock Device-Hunk ~D+~D~@[, ~S~]>"
-          (device-hunk-position object)
-          (device-hunk-height object)
-          (let* ((window (device-hunk-window object))
-                 (buffer (if window (window-buffer window))))
-            (if buffer (buffer-name buffer)))))
-
-
-;;; Bitmap hunks.
-;;;
-;;; The lock field is no longer used.  If events could be handled while we
-;;; were in the middle of something with the hunk, then this could be set
-;;; for exclusion purposes.
-;;;
-(defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|#
-                        (:include device-hunk))
-  width                       ; Pixel width.
-  char-height                 ; Height of text body in characters.
-  char-width                  ; Width in characters.
-  xwindow                     ; X window for this hunk.
-  gcontext                    ; X gcontext for xwindow.
-  start                       ; Head of dis-line list (no dummy).
-  end                         ; Exclusive end, i.e. nil if nil-terminated.
-  modeline-dis-line           ; Dis-line for modeline, or NIL if none.
-  modeline-pos                ; Position of modeline in pixels.
-  (lock t)                    ; Something going on, set trashed if we're changed.
-  trashed                     ; Something bad happened, recompute image.
-  font-family                 ; Font-family used in this window.
-  input-handler               ; Gets hunk, char, x, y when char read.
-  changed-handler             ; Gets hunk when size changed.
-  (thumb-bar-p nil)           ; True if we draw a thumb bar in the top border.
-  window-group)               ; The window-group to which this hunk belongs.
-
-
-;;; Terminal hunks.
-;;; 
-(defstruct (tty-hunk #|(:print-function %print-device-hunk)|#
-                     (:include device-hunk))
-  text-position         ; Bottom Y position of text in hunk.
-  text-height)          ; Number of lines of text.
-
-
-
 
 ;;;; Some defsetfs:
@@ -647 +589 @@
 (defsetf ring-ref %set-ring-ref "Set an element in a ring.")
 (defsetf current-window %set-current-window "Set the current window.")
-(defsetf current-buffer %set-current-buffer
-  "Set the current buffer, doing necessary stuff.")
 (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.")
@@ -657 +597 @@
 (defsetf last-command-type %set-last-command-type
   "Set the Last-Command-Type for use by the next command.")
-(defsetf prefix-argument %set-prefix-argument
-  "Set the prefix argument for the next command.")
+(defsetf last-key-event-typed %set-last-key-event-typed
+  "Set the last key event typed")
 (defsetf logical-key-event-p %set-logical-key-event-p
   "Change what Logical-Char= returns for the specified arguments.")

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

@@ -34 +34 @@
   attribute-vector/mask pairs for find-attribute and reverse-find-attribute.")
 
-(eval-when (:compile-toplevel :execute :load-toplevel)
 (defconstant character-attribute-cache-size 13
   "The number of buckets in the *character-attribute-cache*.")
@@ -40 +39 @@
   "The number of bits to use in each bucket of the
   *character-attribute-cache*.")
-); eval-when (:compile-toplevel :execute :load-toplevel)
-
-;;;    In addition, since a common pattern in code which uses find-attribute
-;;; is to repeatedly call it with the same function and attribute, we
-;;; remember the last attribute/test-function pair that was used, and check
-;;; if it is the same pair beforehand, thus often avoiding the hastable lookup.
-;;;
-(defvar *last-find-attribute-attribute* ()
-  "The attribute which we last did a find-attribute on.")
-(defvar *last-find-attribute-function* ()
-  "The last test-function used for find-attribute.")
-(defvar *last-find-attribute-vector* ()
-  "The %SP-Find-Character-With-Attribute vector corresponding to the last
-  attribute/function pair used for find-attribute.")
-(defvar *last-find-attribute-mask* ()
-  "The the mask to use with *last-find-attribute-vector* to do a search
-  for the last attribute/test-function pair.")
-(defvar *last-find-attribute-end-wins* ()
-  "The the value of End-Wins for the last attribute/test-function pair.")
-
+
+
+(defconstant character-attribute-cache-size 13
+  "The number of buckets in the character-attribute-cache.")
+(defconstant character-attribute-bucket-size 3
+  "The number of bits to use in each bucket of the character-attribute-cache.")
+
+(defstruct (shadow-syntax (:conc-name "SS-"))
+  ;;;    In addition, since a common pattern in code which uses find-attribute
+  ;;; is to repeatedly call it with the same function and attribute, we
+  ;;; remember the last attribute/test-function pair that was used, and check
+  ;;; if it is the same pair beforehand, thus often avoiding the hastable lookup.
+  ;; TODO: another common pattern is to use the same attribute but
+  ;;       different functions (toggling between zerop and not-zerop), so
+  ;;       should use a scheme that handles that - this doesn't.
+  ;; The attribute which we last did a find-attribute on
+  (last-find-attribute-attribute ())
+  ;; The last test-function used for find-attribute.
+  (last-find-attribute-function ())
+  ;; The %SP-Find-Character-With-Attribute vector corresponding to the last
+  ;; attribute/function pair used for find-attribute.
+  (last-find-attribute-vector ())
+  ;; The the mask to use with *last-find-attribute-vector* to do a search
+  ;; for the last attribute/test-function pair.
+  (last-find-attribute-mask ())
+  ;; The the value of End-Wins for the last attribute/test-function pair.
+  (last-find-attribute-end-wins ())
+
+  ;; The last character attribute which was asked for
+  (last-character-attribute-requested nil)
+  ;; The value of the most recent character attribute
+  (value-of-last-character-attribute-requested #() :type (simple-array * (*)))
+
+  ;; list of shadowed bits.
+  (shadow-bit-descriptors ())
+  ;; List of shadowed attribute vectors
+  (shadow-attributes ())
+  ;; Syntax tick count at the time shadow info was computed.
+  (global-syntax-tick -1))
+
+(defvar *global-syntax-tick* 0 "Tick count noting changes in global syntax settings")
+
+(declaim (special *current-buffer*))
+
+
+(declaim (inline current-buffer-shadow-syntax))
+(defun current-buffer-shadow-syntax ()
+  (let ((buffer *current-buffer*))
+    (when buffer
+      (let ((ss (buffer-shadow-syntax buffer)))
+        (if (and ss (eql (ss-global-syntax-tick ss) *global-syntax-tick*))
+          ss
+          (progn
+            (%init-shadow-attributes buffer)
+            (buffer-shadow-syntax buffer)))))))
 
 (defvar *character-attributes* (make-hash-table :test #'eq)
   "A hash table which translates character attributes to their values.")
-(defvar *last-character-attribute-requested* nil
-  "The last character attribute which was asked for, Do Not Bind.")
-(defvar *value-of-last-character-attribute-requested* nil
-  "The value of the most recent character attribute, Do Not Bind.")
 
 (declaim (special *character-attribute-names*))
@@ -91 +121 @@
 
 
-(eval-when (:compile-toplevel :execute)
+
 (defmacro allocate-bit (vec bit-num)
   `(progn
@@ -99 +129 @@
                 :vector ,vec
                 :mask (ash 1 (prog1 ,bit-num (incf ,bit-num))))
-               *all-bit-descriptors*)))))
+               *all-bit-descriptors*))))
 ;;;    
 (defun %init-syntax-table ()
@@ -113 +143 @@
 
 
-(eval-when (:compile-toplevel :execute)
 #+NIL
 (defmacro hash-it (attribute function)
@@ -133 +162 @@
 ;;;
 (defmacro cached-attribute-lookup (attribute function vector mask end-wins)
-  `(if (and (eq ,function *last-find-attribute-function*)
-            (eq ,attribute *last-find-attribute-attribute*))
-       (setq ,vector *last-find-attribute-vector*
-             ,mask *last-find-attribute-mask*
-             ,end-wins *last-find-attribute-end-wins*)
-       (let ((bit (svref *character-attribute-cache*
-                         (hash-it ,attribute ,function))))
-         ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins)
-                       (new-cache-attribute ,attribute ,function))
-                    `(let ((b (car bit)))
-                       (cond
-                        ((and (eq (bit-descriptor-function b)
-                                  ,function)
-                              (eq (bit-descriptor-attribute b)
-                                  ,attribute))
-                         (setq ,vector (bit-descriptor-vector b)
-                               ,mask (bit-descriptor-mask b)
-                               ,end-wins (bit-descriptor-end-wins b)))
-                        (t
-                         (setq bit (cdr bit)) ,res))))
-               (count 0 (1+ count)))
-              ((= count character-attribute-bucket-size) res))
-         (setq *last-find-attribute-attribute* ,attribute
-               *last-find-attribute-function* ,function
-               *last-find-attribute-vector* ,vector
-               *last-find-attribute-mask* ,mask
-               *last-find-attribute-end-wins* ,end-wins))))
-); eval-when (:compile-toplevel :execute)
+  `(let ((ss (current-buffer-shadow-syntax)))
+     (if (and (eq ,function (ss-last-find-attribute-function ss))
+              (eq ,attribute (ss-last-find-attribute-attribute ss)))
+       (setq ,vector (ss-last-find-attribute-vector ss)
+             ,mask (ss-last-find-attribute-mask ss)
+             ,end-wins (ss-last-find-attribute-end-wins ss))
+       (let ((b (or (loop for b in (ss-shadow-bit-descriptors ss)
+                      when (and (eq (bit-descriptor-attribute b) ,attribute)
+                                (eq (bit-descriptor-function b) ,function))
+                      return b)
+                    (loop for b in (svref *character-attribute-cache*
+                                          (hash-it ,attribute ,function))
+                      when (and (eq (bit-descriptor-attribute b) ,attribute)
+                                (eq (bit-descriptor-function b) ,function))
+                      return b))))
+         (cond (b 
+                (setq ,vector (bit-descriptor-vector b)
+                      ,mask (bit-descriptor-mask b)
+                      ,end-wins (bit-descriptor-end-wins b)))
+               (t
+                (multiple-value-setq (,vector ,mask ,end-wins)
+                  (new-cache-attribute ,attribute ,function))))
+         (setf (ss-last-find-attribute-attribute ss) ,attribute
+               (ss-last-find-attribute-function ss) ,function
+               (ss-last-find-attribute-vector ss) ,vector
+               (ss-last-find-attribute-mask ss) ,mask
+               (ss-last-find-attribute-end-wins ss) ,end-wins)))))
 
 ;;; NEW-CACHE-ATTRIBUTE  --  Internal
@@ -182 +210 @@
           (bit-descriptor-function bit) function
           (bit-descriptor-end-wins bit) end-wins)
+    (incf *global-syntax-tick*)
     (setq values (attribute-descriptor-vector values))
     (do ((mask (bit-descriptor-mask bit))
@@ -190 +219 @@
       (declare (type (simple-array (mod 256)) vec))
       (if (funcall fun (aref (the simple-array values) i))
-          (setf (aref vec i) (logior (aref vec i) mask))
-          (setf (aref vec i) (logandc2 (aref vec i) mask))))))
+        (setf (aref vec i) (logior (aref vec i) mask))
+        (setf (aref vec i) (logandc2 (aref vec i) mask))))))
 
 
@@ -222 +251 @@
     (setf (getstring name *character-attribute-names*) attribute)
     (setf (gethash attribute *character-attributes*) new))
+    (incf *global-syntax-tick*)
   name)
 
@@ -229 +259 @@
 ;;; giving error if it is not a defined attribute.
 ;;;
-(eval-when (:compile-toplevel :execute)
-(defmacro with-attribute (symbol &body forms)
-  `(let ((obj (gethash ,symbol *character-attributes*)))
-     (unless obj
+(defmacro with-attribute ((obj symbol) &body forms)
+  `(let ((,obj (gethash ,symbol *character-attributes*)))
+     (unless ,obj
        (error "~S is not a defined character attribute." ,symbol))
      ,@forms))
-); eval-when (:compile-toplevel :execute)
 
 (defun character-attribute-name (attribute)
   "Return the string-name of the character-attribute Attribute."
-  (with-attribute attribute
+  (with-attribute (obj attribute)
     (attribute-descriptor-name obj)))
 
 (defun character-attribute-documentation (attribute)
   "Return the documentation for the character-attribute Attribute."
-  (with-attribute attribute
+  (with-attribute (obj attribute)
     (attribute-descriptor-documentation obj)))
 
@@ -250 +278 @@
   "Return the hook-list for the character-attribute Attribute.  This can
   be set with Setf."
-  (with-attribute attribute
+  (with-attribute (obj attribute)
     (attribute-descriptor-hooks obj)))
 
 (defun %set-character-attribute-hooks (attribute new-value)
-  (with-attribute attribute
+  (with-attribute (obj attribute)
     (setf (attribute-descriptor-hooks obj) new-value)))
 
-(declaim (special *last-character-attribute-requested*
-                    *value-of-last-character-attribute-requested*))
-
 ;;; CHARACTER-ATTRIBUTE  --  Public
 ;;;
 ;;;    Return the value of a character attribute for some character.
 ;;;
-(declaim (inline character-attribute))
 (defun character-attribute (attribute character)
   "Return the value of the the character-attribute Attribute for Character.
   If Character is Nil then return the end-value."
-  (if (and (eq attribute *last-character-attribute-requested*) character)
-      (aref (the simple-array *value-of-last-character-attribute-requested*)
-            (syntax-char-code character))
-      (sub-character-attribute attribute character)))
+  (let ((ss (current-buffer-shadow-syntax)))
+    (if (and character ss (eq attribute (ss-last-character-attribute-requested ss)))
+      (aref (ss-value-of-last-character-attribute-requested ss) (syntax-char-code character))
+      (sub-character-attribute attribute character))))
 ;;;
 (defun sub-character-attribute (attribute character)
-  (with-attribute attribute
-    (setq *last-character-attribute-requested* attribute)
-    (setq *value-of-last-character-attribute-requested*
-          (attribute-descriptor-vector obj))
-    (if character
-        (aref (the simple-array *value-of-last-character-attribute-requested*)
-              (syntax-char-code character))
-        (attribute-descriptor-end-value obj))))
+  (with-attribute (obj attribute)
+    (let* ((ss (current-buffer-shadow-syntax))
+           (cell (and ss (cdr (assoc obj (ss-shadow-attributes ss) :test #'eq)))))
+      (if character
+        (let ((vec (if cell (car cell) (attribute-descriptor-vector obj))))
+          (when ss
+            (setf (ss-last-character-attribute-requested ss) attribute)
+            (setf (ss-value-of-last-character-attribute-requested ss) vec))
+          (aref (the simple-array vec) (syntax-char-code character)))
+        (if cell (cdr cell) (attribute-descriptor-end-value obj))))))
 
 ;;; CHARACTER-ATTRIBUTE-P
@@ -296 +322 @@
 ;;; %SET-CHARACTER-ATTRIBUTE  --  Internal
 ;;;
-;;;    Set the value of a character attribute.
+;;;    Set the global value of a character attribute.
 ;;;
 (defun %set-character-attribute (attribute character new-value)
-  (with-attribute attribute
+  (with-attribute (obj attribute)
     (invoke-hook hemlock::character-attribute-hook attribute character new-value)
     (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value)
@@ -325 +351 @@
         (when (eq (bit-descriptor-attribute bit) attribute)
           (setf (bit-descriptor-end-wins bit)
-                (funcall (bit-descriptor-function bit) new-value))))
-      new-value))))
-
-
-(eval-when (:compile-toplevel :execute)
-;;; swap-one-attribute  --  Internal
-;;;
-;;;    Install the mode-local values described by Vals for Attribute, whose
-;;; representation vector is Value.
-;;;
- (defmacro swap-one-attribute (attribute value vals hooks)
-  `(progn
-    ;; Fix up any cached attribute vectors.
-    (dolist (bit *all-bit-descriptors*)
-      (when (eq ,attribute (bit-descriptor-attribute bit))
-        (let ((fun (bit-descriptor-function bit))
-              (vec (bit-descriptor-vector bit))
-              (mask (bit-descriptor-mask bit)))
-          (declare (type (simple-array (mod 256)) vec)
-                   (fixnum mask))
-          (dolist (char ,vals)
-            (setf (aref vec (car char))
-                  (if (funcall fun (cdr char))
-                      (logior mask (aref vec (car char)))
-                      (logandc1 mask (aref vec (car char)))))))))
-    ;; Invoke the attribute-hook.
-    (dolist (hook ,hooks)
-      (dolist (char ,vals)
-        (funcall hook ,attribute (code-char (car char)) (cdr char))))
-    ;; Fix up the value vector.
-    (dolist (char ,vals)
-      (rotatef (aref ,value (car char)) (cdr char)))))
-); eval-when (:compile-toplevel :execute)
-
-
-;;; SWAP-CHAR-ATTRIBUTES  --  Internal
-;;;
-;;;    Swap the current values of character attributes and the ones
-;;;specified by "mode".  This is used in Set-Major-Mode.
-;;;
-(defun swap-char-attributes (mode)
-  (dolist (attribute (mode-object-character-attributes mode))
-    (let* ((obj (car attribute))
-           (sym (attribute-descriptor-keyword obj))
-           (value (attribute-descriptor-vector obj))
-           (hooks (attribute-descriptor-hooks obj)))
-      (declare (simple-array value))
-      (swap-one-attribute sym value (cdr attribute) hooks))))
-
-
-
-
-(declaim (special *mode-names* *current-buffer*))
+                (funcall (bit-descriptor-function bit) new-value))))))
+    (incf *global-syntax-tick*)
+    new-value))
+
+
+;; This is called when change buffer mode.  It used to invoke attribute-descriptor-hooks on
+;; all the shadowed attributes.  We don't do that any more, should update doc if any.
+(defun invalidate-shadow-attributes (buffer)
+  (let ((ss (buffer-shadow-syntax buffer)))
+    (when ss (setf (ss-global-syntax-tick ss) -1))))
+
+(defun %init-one-shadow-attribute (ss desc vals)
+  ;; Shadow all bits for this attribute
+  (loop with key = (attribute-descriptor-keyword desc)
+    for bit in *all-bit-descriptors*
+    when (eq key (bit-descriptor-attribute bit))
+    do (let* ((fun (bit-descriptor-function bit))
+              (b (or (find-if #'(lambda (b)
+                                  (and (eq (bit-descriptor-function b) fun)
+                                       (eq (bit-descriptor-attribute b) key)))
+                              (ss-shadow-bit-descriptors ss))
+                     (let ((new (make-bit-descriptor
+                                 :attribute key
+                                 :function fun
+                                 :vector (copy-seq (bit-descriptor-vector bit))
+                                 :mask (bit-descriptor-mask bit))))
+                       (push new (ss-shadow-bit-descriptors ss))
+                       new)))
+              (vec (bit-descriptor-vector b)))
+         (loop for (code . value) in vals
+           ;; Since we don't share the shadow vecs, no need to preserve other bits.
+           do (setf (aref vec code) (if (funcall fun value) #xFF #x00)))))
+  ;; Shadow the attribute values
+  (let ((vec (cadr (or (assoc desc (ss-shadow-attributes ss) :test #'eq)
+                       (let ((new (list* desc 
+                                         (copy-seq (attribute-descriptor-vector desc))
+                                         (attribute-descriptor-end-value desc))))
+                         (push new (ss-shadow-attributes ss))
+                         new)))))
+    (loop for (code . value) in vals do (setf (aref vec code) value))))
+
+(defun %init-shadow-attributes (buffer)
+  (let* ((mode (car (if (buffer-bindings-wound-p buffer)
+                      (last (buffer-mode-objects buffer))
+                      (buffer-mode-objects buffer))))
+         (ss (or (buffer-shadow-syntax buffer)
+                 (setf (buffer-shadow-syntax buffer) (make-shadow-syntax)))))
+    (loop for (desc .  vals) in (mode-object-character-attributes mode)
+      do (%init-one-shadow-attribute ss desc vals))))
+           
+(declaim (special *mode-names*))
 
 ;;; SHADOW-ATTRIBUTE  --  Public
@@ -393 +417 @@
     (let* ((current (assoc desc (mode-object-character-attributes obj)))
            (code (syntax-char-code character))
-           (hooks (attribute-descriptor-hooks desc))
-           (vec (attribute-descriptor-vector desc))
            (cons (cons code value)))
-      (declare (simple-array vec))
       (if current
           (let ((old (assoc code (cdr current))))
@@ -404 +425 @@
           (push (list desc cons)
                 (mode-object-character-attributes obj)))
-      (when (member obj (buffer-mode-objects *current-buffer*))
-        (let ((vals (list cons)))
-          (swap-one-attribute attribute vec vals hooks)))
+      (incf *global-syntax-tick*)
       (invoke-hook hemlock::shadow-attribute-hook attribute character value mode)))
   attribute)
@@ -423 +442 @@
       (error "~S is not a defined Mode." mode))
     (invoke-hook hemlock::shadow-attribute-hook mode attribute character)
-    (let* ((value (attribute-descriptor-vector desc))
-           (hooks (attribute-descriptor-hooks desc))
-           (current (assoc desc (mode-object-character-attributes obj)))
+    (let* ((current (assoc desc (mode-object-character-attributes obj)))
            (char (assoc (syntax-char-code character) (cdr current))))
-      (declare (simple-array value))
       (unless char
         (error "Character Attribute ~S is not defined for character ~S ~
                in Mode ~S." attribute character mode))
-      (when (member obj (buffer-mode-objects *current-buffer*))
-        (let ((vals (list char)))
-          (swap-one-attribute attribute value vals hooks)))
+      (incf *global-syntax-tick*)
       (setf (cdr current) (delete char (the list (cdr current))))))
   attribute)
@@ -449 +463 @@
 ;;; vector that we can use to do the search.
 ;;;
-(eval-when (:compile-toplevel :execute)
 (defmacro normal-find-attribute (line start result vector mask)
   `(let ((chars (line-chars ,line)))
@@ -471 +484 @@
               (current-open-chars) (current-right-open-pos) (current-line-cache-length) ,vector ,mask))
        (when ,result (decf ,result gap))))))
-); eval-when (:compile-toplevel :execute)
+
 ;;;
 (defun find-attribute (mark attribute &optional (test #'not-zerop))
@@ -519 +532 @@
 ;;;    Line find-attribute, only goes backwards.
 ;;;
-(eval-when (:compile-toplevel :execute)
 (defmacro rev-normal-find-attribute (line start result vector mask)
   `(let ((chars (line-chars ,line)))
@@ -544 +556 @@
               (current-open-chars) 0 (current-left-open-pos) ,vector ,mask))))))
 
-); eval-when (:compile-toplevel :execute)
 ;;;
 ;;; This moves the mark so that previous-character satisfies the test.

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

@@ -210 +210 @@
            (let ((mark (region-start region)))
              (delete-mark mark-or-region)
-             (when (line-buffer (mark-line mark))
+             (when (mark-buffer mark)
                (delete-mark mark)
                (delete-mark (region-end region)))))

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

@@ -210 +210 @@
            (let ((binding (make-binding prop new-binding vars symbol-name)))
              (cond ((member obj (buffer-mode-objects *current-buffer*))
-                    (let ((l (unwind-bindings obj)))
+                    (let ((l (unwind-bindings *current-buffer* obj)))
                       (setf (mode-object-var-values obj) binding)
-                      (wind-bindings l)))
+                      (wind-bindings *current-buffer* l)))
                    (t
                     (setf (mode-object-var-values obj) binding)))))))
@@ -222 +222 @@
            (let ((binding (make-binding prop new-binding vars symbol-name)))
              (setf (buffer-var-values buffer) binding)
-             (when (eq buffer *current-buffer*)
+             (when (buffer-bindings-wound-p buffer)
                (setf (variable-object-down new-binding) (car prop)
                      (car prop) new-binding))))))
@@ -229 +229 @@
        (unless (hemlock-bound-p symbol-name :global)
          (setf (variable-object-down new-binding) :global)
-         (let ((l (unwind-bindings nil)))
-           (setf (car prop) new-binding)
-           (wind-bindings l)))))
+         (when *current-buffer*
+           (let ((l (unwind-bindings *current-buffer* nil)))
+             (setf (car prop) new-binding)
+             (wind-bindings *current-buffer* l))))))
     (setf (getstring name string-table) symbol-name)
     (when hook-p
@@ -269 +270 @@
          (delete-string sname (buffer-variables where))
          (setf (buffer-var-values where) (delete-binding binding values))
-         (when (eq where *current-buffer*)
+         (when (buffer-bindings-wound-p where)
            (setf (car (binding-cons binding)) (variable-object-down obj)))))
       (:mode
@@ -278 +279 @@
          (delete-string sname (mode-object-variables mode))
          (if (member mode (buffer-mode-objects *current-buffer*))
-             (let ((l (unwind-bindings mode)))
+             (let ((l (unwind-bindings *current-buffer* mode)))
                (setf (mode-object-var-values mode)
                      (delete-binding binding values))
-               (wind-bindings l))
+               (wind-bindings *current-buffer* l))
              (setf (mode-object-var-values mode)
                    (delete-binding binding values)))))
@@ -287 +288 @@
        (invoke-hook hemlock::delete-variable-hook name :global nil)
        (delete-string sname *global-variable-names*)
-       (let ((l (unwind-bindings nil)))
+       (let ((l (unwind-bindings *current-buffer* nil)))
          (setf (get name 'hemlock-variable-value) nil)
-         (wind-bindings l)))
+         (wind-bindings *current-buffer* l)))
       (t (error "Invalid variable kind: ~S" kind)))
     nil))