Changeset 8428


Ignore:
Timestamp:
Feb 5, 2008, 11:01:48 PM (12 years ago)
Author:
gz
Message:

Merge of the 'event-ide' branch. Hemlock's thread model has been changed
so that Hemlock commands now run in the Cocoa event thread -- see the
Hemlock file view.lisp for an overview.

IDE compilation has also been reorganized. Hemlock is now more fully
integrated into the IDE and cannot be compiled separately, sorry.

The hemlock-ext package has been repurposed to contain all interfaces
to window-system specific functionality.

There are also many many assorted other changes, cleanups and fixes.

The Hemlock documentation (Hemlock Command Implementor's Manual) in
http://trac.clozure.com/openmcl/wiki now correctly reflects the
implementation, although it doesn't (yet) describe the integration
with Cocoa or the threading model.

Location:
trunk/source/cocoa-ide
Files:
5 deleted
52 edited
5 copied

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-editor.lisp

    r7804 r8428  
    2626
    2727(def-cocoa-default *use-screen-fonts* :bool t "Use bitmap screen fonts when available")
     28
     29
     30(defgeneric hemlock-view (ns-object))
     31
     32(defmethod hemlock-view ((unknown t))
     33  nil)
     34
     35(defgeneric hemlock-buffer (ns-object))
     36
     37(defmethod hemlock-buffer ((unknown t))
     38  (let ((view (hemlock-view unknown)))
     39    (when view (hi::hemlock-view-buffer view))))
    2840
    2941(defmacro nsstring-encoding-to-nsinteger (n)
     
    145157    buf))
    146158
    147 ;;; Define some key event modifiers.
    148 
    149 ;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use
    150 ;;; it to map NSEvent modifier keys to key-event modifiers.
    151 
    152 (hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift")
    153 (hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control")
    154 (hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta")
    155 (hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock")
     159;;; Define some key event modifiers and keysym codes
     160
     161(hi:define-modifier-bit #$NSShiftKeyMask "Shift")
     162(hi:define-modifier-bit #$NSControlKeyMask "Control")
     163(hi:define-modifier-bit #$NSAlternateKeyMask "Meta")
     164(hi:define-modifier-bit #$NSAlphaShiftKeyMask "Lock")
     165
     166(hi:define-keysym-code :F1 #$NSF1FunctionKey)
     167(hi:define-keysym-code :F2 #$NSF2FunctionKey)
     168(hi:define-keysym-code :F3 #$NSF3FunctionKey)
     169(hi:define-keysym-code :F4 #$NSF4FunctionKey)
     170(hi:define-keysym-code :F5 #$NSF5FunctionKey)
     171(hi:define-keysym-code :F6 #$NSF6FunctionKey)
     172(hi:define-keysym-code :F7 #$NSF7FunctionKey)
     173(hi:define-keysym-code :F8 #$NSF8FunctionKey)
     174(hi:define-keysym-code :F9 #$NSF9FunctionKey)
     175(hi:define-keysym-code :F10 #$NSF10FunctionKey)
     176(hi:define-keysym-code :F11 #$NSF11FunctionKey)
     177(hi:define-keysym-code :F12 #$NSF12FunctionKey)
     178(hi:define-keysym-code :F13 #$NSF13FunctionKey)
     179(hi:define-keysym-code :F14 #$NSF14FunctionKey)
     180(hi:define-keysym-code :F15 #$NSF15FunctionKey)
     181(hi:define-keysym-code :F16 #$NSF16FunctionKey)
     182(hi:define-keysym-code :F17 #$NSF17FunctionKey)
     183(hi:define-keysym-code :F18 #$NSF18FunctionKey)
     184(hi:define-keysym-code :F19 #$NSF19FunctionKey)
     185(hi:define-keysym-code :F20 #$NSF20FunctionKey)
     186(hi:define-keysym-code :F21 #$NSF21FunctionKey)
     187(hi:define-keysym-code :F22 #$NSF22FunctionKey)
     188(hi:define-keysym-code :F23 #$NSF23FunctionKey)
     189(hi:define-keysym-code :F24 #$NSF24FunctionKey)
     190(hi:define-keysym-code :F25 #$NSF25FunctionKey)
     191(hi:define-keysym-code :F26 #$NSF26FunctionKey)
     192(hi:define-keysym-code :F27 #$NSF27FunctionKey)
     193(hi:define-keysym-code :F28 #$NSF28FunctionKey)
     194(hi:define-keysym-code :F29 #$NSF29FunctionKey)
     195(hi:define-keysym-code :F30 #$NSF30FunctionKey)
     196(hi:define-keysym-code :F31 #$NSF31FunctionKey)
     197(hi:define-keysym-code :F32 #$NSF32FunctionKey)
     198(hi:define-keysym-code :F33 #$NSF33FunctionKey)
     199(hi:define-keysym-code :F34 #$NSF34FunctionKey)
     200(hi:define-keysym-code :F35 #$NSF35FunctionKey)
     201
     202;;; Upper right key bank.
     203;;;
     204(hi:define-keysym-code :Printscreen #$NSPrintScreenFunctionKey)
     205;; Couldn't type scroll lock.
     206(hi:define-keysym-code :Pause #$NSPauseFunctionKey)
     207
     208;;; Middle right key bank.
     209;;;
     210(hi:define-keysym-code :Insert #$NSInsertFunctionKey)
     211(hi:define-keysym-code :Del #$NSDeleteFunctionKey)
     212(hi:define-keysym-code :Home #$NSHomeFunctionKey)
     213(hi:define-keysym-code :Pageup #$NSPageUpFunctionKey)
     214(hi:define-keysym-code :End #$NSEndFunctionKey)
     215(hi:define-keysym-code :Pagedown #$NSPageDownFunctionKey)
     216
     217;;; Arrows.
     218;;;
     219(hi:define-keysym-code :Leftarrow #$NSLeftArrowFunctionKey)
     220(hi:define-keysym-code :Uparrow #$NSUpArrowFunctionKey)
     221(hi:define-keysym-code :Downarrow #$NSDownArrowFunctionKey)
     222(hi:define-keysym-code :Rightarrow #$NSRightArrowFunctionKey)
     223
     224;;;
     225
     226;(hi:define-keysym-code :linefeed 65290)
     227
     228
     229
     230
    156231
    157232
     
    196271  (:metaclass ns:+ns-object))
    197272
     273(defmethod hemlock-buffer ((self hemlock-buffer-string))
     274  (let ((cache (hemlock-buffer-string-cache self)))
     275    (when cache
     276      (hemlock-buffer cache))))
     277
    198278;;; Cocoa wants to treat the buffer as a linear array of characters;
    199279;;; Hemlock wants to treat it as a doubly-linked list of lines, so
     
    216296  workline-start-font-index             ; current font index at start of workline
    217297  )
     298
     299(defmethod hemlock-buffer ((self buffer-cache))
     300  (buffer-cache-buffer self))
    218301
    219302;;; Initialize (or reinitialize) a buffer cache, so that it points
     
    304387;;; offset on the appropriate line.
    305388(defun move-hemlock-mark-to-absolute-position (mark cache abspos)
     389  ;; TODO: figure out if updating the cache matters, and if not, use hi:move-to-absolute-position.
    306390  (let* ((hi::*current-buffer* (buffer-cache-buffer cache)))
    307391    (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos)
    308392      #+debug
    309393      (#_NSLog #@"Moving point from current pos %d to absolute position %d"
    310                :int (mark-absolute-position mark)
     394               :int (hi:mark-absolute-position mark)
    311395               :int abspos)
    312396      (hemlock::move-to-position mark idx line)
    313397      #+debug
    314       (#_NSLog #@"Moved mark to %d" :int (mark-absolute-position mark)))))
    315 
    316 ;;; Return the absolute position of the mark in the containing buffer.
    317 ;;; This doesn't use the caching mechanism, so it's always linear in the
    318 ;;; number of preceding lines.
    319 (defun mark-absolute-position (mark)
    320   (let* ((hi::*current-buffer* (hi::line-%buffer (hi::mark-line mark)))
    321          (pos (hi::mark-charpos mark)))
    322     (+ (hi::get-line-origin (hi::mark-line mark)) pos)))
     398      (#_NSLog #@"Moved mark to %d" :int (hi:mark-absolute-position mark)))))
    323399
    324400;;; Return the length of the abstract string, i.e., the number of
     
    429505(declaim (special hemlock-text-storage))
    430506
     507(defmethod hemlock-buffer ((self hemlock-text-storage))
     508  (let ((string (slot-value self 'hemlock-string)))
     509    (unless (%null-ptr-p string)
     510      (hemlock-buffer string))))
    431511
    432512;;; This is only here so that calls to it can be logged for debugging.
     
    453533
    454534(defmethod assume-not-editing ((ts hemlock-text-storage))
    455   #+debug (assert (eql (slot-value ts 'edit-count) 0)))
     535  #+debug NIL (assert (eql (slot-value ts 'edit-count) 0)))
    456536
    457537(defun textstorage-note-insertion-at-position (self pos n)
     
    471551  (assume-cocoa-thread)
    472552  (let* ((mirror (#/mirror self))
    473         (hemlock-string (#/hemlockString self))
     553        (hemlock-string (#/hemlockString self))
    474554         (display (hemlock-buffer-string-cache hemlock-string))
    475555         (buffer (buffer-cache-buffer display))
    476556         (hi::*current-buffer* buffer)
    477          (font (buffer-active-font buffer))
     557         (attributes (buffer-active-font-attributes buffer))
    478558         (document (#/document self))
    479559         (undo-mgr (and document (#/undoManager document))))
     
    492572         (#/prepareWithInvocationTarget: undo-mgr self)
    493573         pos n #@"")))
    494     (#/setAttributes:range: mirror font (ns:make-ns-range pos n))   
     574    (#/setAttributes:range: mirror attributes (ns:make-ns-range pos n))
    495575    (textstorage-note-insertion-at-position self pos n)))
    496576
     
    656736  (with-slots (mirror styles) self
    657737    (when (>= index (#/length mirror))
    658       (#_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))
    659       (for-each-textview-using-storage self
    660                                        (lambda (tv)
    661                                          (let* ((w (#/window tv))
    662                                                 (proc (slot-value w 'command-thread)))
    663                                            (process-interrupt proc #'ccl::dbg))))
     738      (#_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))
    664739      (ccl::dbg))
    665740    (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr)))
     
    685760      (#/replaceCharactersInRange:withString: self r string))))
    686761
     762;; In theory (though not yet in practice) we allow for a buffer to be shown in multiple
     763;; windows, and any change to a buffer through one window has to be reflected in all of
     764;; them.  Once hemlock really supports multiple views of a buffer, it will have some
     765;; mechanims to ensure that.
     766;; In Cocoa, we get some messages for the buffer (i.e. the document or the textstorage)
     767;; with no reference to a view.  There used to be code here that tried to do special-
     768;; case stuff for all views on the buffer, but that's not necessary, because as long
     769;; as hemlock doesn't support it, there will only be one view, and as soon as hemlock
     770;; does support it, will take care of updating all other views.  So all we need is to
     771;; get our hands on one of the views and do whatever it is through it.
     772(defun front-view-for-buffer (buffer)
     773  (loop
     774     with win-arr =  (#/orderedWindows *NSApp*)
     775     for i from 0 below (#/count win-arr) as w = (#/objectAtIndex: win-arr i)
     776     thereis (and (eq (hemlock-buffer w) buffer) (hemlock-view w))))
     777
    687778(objc:defmethod (#/replaceCharactersInRange:withString: :void)
    688779    ((self hemlock-text-storage) (r :<NSR>ange) string)
    689   #+debug (#_NSLog #@"Replace in range %ld/%ld with %@"
    690                     :<NSI>nteger (pref r :<NSR>ange.location)
    691                     :<NSI>nteger (pref r :<NSR>ange.length)
    692                     :id string)
    693   (let* ((cache (hemlock-buffer-string-cache (#/hemlockString  self)))
    694          (buffer (if cache (buffer-cache-buffer cache)))
    695          (hi::*current-buffer* buffer)
    696          (location (pref r :<NSR>ange.location))
     780  (let* ((buffer (hemlock-buffer self))
     781         (position (pref r :<NSR>ange.location))
    697782         (length (pref r :<NSR>ange.length))
    698          (point (hi::buffer-point buffer)))
    699     (let* ((lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string)))
    700            (document (if buffer (hi::buffer-document buffer)))
    701            (textstorage (if document (slot-value document 'textstorage))))
    702       #+gz (unless (eql textstorage self) (break "why is self.ne.textstorage?"))
    703       (when textstorage
    704         (assume-cocoa-thread)
    705         (#/beginEditing textstorage))
    706       (setf (hi::buffer-region-active buffer) nil)
    707       (hi::with-mark ((start point :right-inserting))
    708         (move-hemlock-mark-to-absolute-position start cache location)
    709         (unless (zerop length)
    710           (hi::delete-characters start length))
    711         (when lisp-string
    712           (hi::insert-string start lisp-string)))
    713       (when textstorage
    714         (#/endEditing textstorage)
    715         (for-each-textview-using-storage
    716          textstorage
    717          (lambda (tv)
    718            (hi::disable-self-insert
    719             (hemlock-frame-event-queue (#/window tv)))))
    720         (#/ensureSelectionVisible textstorage)))))
    721 
     783         (lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string)))
     784         (view (front-view-for-buffer buffer)))
     785    (when view
     786      (hi::handle-hemlock-event view #'(lambda ()
     787                                         (hi:paste-characters position length
     788                                                              lisp-string))))))
    722789
    723790(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
     
    746813(objc:defmethod #/description ((self hemlock-text-storage))
    747814  (#/stringWithFormat: ns:ns-string #@"%s : string %@" (#_object_getClassName self) (slot-value self 'hemlock-string)))
    748 
    749 ;;; This needs to happen on the main thread.
    750 (objc:defmethod (#/ensureSelectionVisible :void) ((self hemlock-text-storage))
    751   (assume-cocoa-thread)
    752   (for-each-textview-using-storage
    753    self
    754    #'(lambda (tv)
    755        (assume-not-editing tv)
    756        (#/scrollRangeToVisible: tv (#/selectedRange tv)))))
    757 
    758815
    759816(defun close-hemlock-textstorage (ts)
     
    772829                (slot-value hemlock-string 'cache) nil
    773830                (hi::buffer-document buffer) nil)
    774           (let* ((p (hi::buffer-process buffer)))
    775             (when p
    776               (setf (hi::buffer-process buffer) nil)
    777               (process-kill p)))
    778831          (when (eq buffer hi::*current-buffer*)
    779             (setf (hi::current-buffer)
    780                   (car (last hi::*buffer-list*))))
    781           (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer)
    782           (hi::invoke-hook hemlock::delete-buffer-hook buffer)
    783           (setq hi::*buffer-list* (delq buffer hi::*buffer-list*))
    784          (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*))))))
     832            (setf hi::*current-buffer* nil))
     833          (hi::delete-buffer buffer))))))
    785834
    786835
     
    812861(declaim (special hemlock-textstorage-text-view))
    813862
     863(defmethod hemlock-view ((self hemlock-textstorage-text-view))
     864  (let ((frame (#/window self)))
     865    (unless (%null-ptr-p frame)
     866      (hemlock-view frame))))
     867
     868(defmethod activate-hemlock-view ((self hemlock-textstorage-text-view))
     869  (assume-cocoa-thread)
     870  (let* ((the-hemlock-frame (#/window self)))
     871    #+debug (log-debug "Activating ~s" self)
     872    (with-slots ((echo peer)) self
     873      (deactivate-hemlock-view echo))
     874    (#/setEditable: self t)
     875    (#/makeFirstResponder: the-hemlock-frame self)))
     876
     877(defmethod deactivate-hemlock-view ((self hemlock-textstorage-text-view))
     878  (assume-cocoa-thread)
     879  #+debug (log-debug "deactivating ~s" self)
     880  (assume-not-editing self)
     881  (#/setSelectable: self nil))
     882
     883(defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view))
     884  ;; Return true if cmd-. is in the queue.  Not sure what to do about c-g:
     885  ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe
     886  ;; c-g will need to be synchronous meaning just end current command,
     887  ;; while cmd-. is the real abort.
     888  #|
     889   (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0)))
     890    (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue:
     891                         target (logior #$whatever) now #&NSDefaultRunLoopMode t)))
     892            (when (%null-ptr-p event) (return)))))
     893  "target" can either be an NSWindow or the global shared application object;
     894  |#
     895  nil)
     896
     897(defvar *buffer-being-edited* nil)
     898
     899(objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event)
     900  #+debug (#_NSLog #@"Key down event = %@" :address event)
     901  (let* ((view (hemlock-view self))
     902         ;; quote-p means handle characters natively
     903         (quote-p (and view (hi::hemlock-view-quote-next-p view))))
     904    #+GZ (log-debug "~&quote-p ~s event ~s" quote-p event)
     905    (if (or (null view)
     906            (#/hasMarkedText self)
     907            (and quote-p (zerop (#/length (#/characters event))))) ;; dead key, e.g. option-E
     908      (call-next-method event)
     909      (unless (eventqueue-abort-pending-p self)
     910        (let ((hemlock-key (nsevent-to-key-event event quote-p)))
     911          (when hemlock-key
     912            (hi::handle-hemlock-event view hemlock-key)))))))
     913
     914(defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
     915  (declare (ignore event))
     916  (with-autorelease-pool
     917   (call-next-method)))
     918
     919(defconstant +shift-event-mask+ (hi:key-event-modifier-mask "Shift"))
     920
     921;;; Translate a keyDown NSEvent to a Hemlock key-event.
     922(defun nsevent-to-key-event (event quote-p)
     923  (let* ((modifiers (#/modifierFlags event)))
     924    (unless (logtest #$NSCommandKeyMask modifiers)
     925      (let* ((chars (if quote-p
     926                      (#/characters event)
     927                      (#/charactersIgnoringModifiers event)))
     928             (n (if (%null-ptr-p chars)
     929                  0
     930                  (#/length chars)))
     931             (c (and (eql n 1)
     932                     (#/characterAtIndex: chars 0))))
     933        (when c
     934          (let* ((bits 0)
     935                 (useful-modifiers (logandc2 modifiers
     936                                             (logior
     937                                              ;#$NSShiftKeyMask
     938                                              #$NSAlphaShiftKeyMask))))
     939            (unless quote-p
     940              (dolist (map hi:*modifier-translations*)
     941                (when (logtest useful-modifiers (car map))
     942                  (setq bits (logior bits
     943                                     (hi:key-event-modifier-mask (cdr map)))))))
     944            (let* ((char (code-char c)))
     945              (when (and char (standard-char-p char))
     946                (setq bits (logandc2 bits +shift-event-mask+))))
     947            (hi:make-key-event c bits)))))))
     948
     949;; For now, this is only used to abort i-search.  All actual mouse handling is done
     950;; by Cocoa.   In the future might want to allow users to extend via hemlock, e.g.
     951;; to implement mouse-copy.
     952;; Also -- shouldn't this happen on mouse up?
     953(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
     954  ;; If no modifier keys are pressed, send hemlock a no-op.
     955  ;; (Or almost a no-op - this does an update-hemlock-selection as a side-effect)
     956  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
     957    (let* ((view (hemlock-view self)))
     958      (when view
     959        (unless (eventqueue-abort-pending-p self)
     960          (hi::handle-hemlock-event view #k"leftdown")))))
     961  (call-next-method event))
     962
     963#+GZ
     964(objc:defmethod  (#/mouseUp: :void) ((self hemlock-textstorage-text-view) event)
     965  (log-debug "~&MOUSE UP!!")
     966  (call-next-method event))
    814967
    815968(defmethod assume-not-editing ((tv hemlock-textstorage-text-view))
     
    8951048(defmethod update-blink ((self hemlock-textstorage-text-view))
    8961049  (disable-blink self)
    897   (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
    898          (buffer (buffer-cache-buffer d)))
     1050  (let* ((buffer (hemlock-buffer self)))
    8991051    (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
    9001052      (let* ((hi::*current-buffer* buffer)
     
    9091061                     #+debug (#_NSLog #@"enable blink, forward")
    9101062                     (setf (text-view-blink-location self)
    911                            (1- (mark-absolute-position temp))
     1063                           (1- (hi:mark-absolute-position temp))
    9121064                           (text-view-blink-enabled self) #$YES)))))
    9131065              ((eql (hi::previous-character point) #\))
     
    9181070                     #+debug (#_NSLog #@"enable blink, backward")
    9191071                     (setf (text-view-blink-location self)
    920                            (mark-absolute-position temp)
     1072                           (hi:mark-absolute-position temp)
    9211073                           (text-view-blink-enabled self) #$YES))))))))))
    9221074
     
    9431095                                 nil)
    9441096    (assume-not-editing self)
    945     (#/scrollRangeToVisible: self range)
    9461097    (when (> length 0)
    9471098      (let* ((ts (#/textStorage self)))
     
    9671118    ((pane :foreign-type :id :accessor text-view-pane)
    9681119     (char-width :foreign-type :<CGF>loat :accessor text-view-char-width)
    969      (char-height :foreign-type :<CGF>loat :accessor text-view-char-height))
     1120     (line-height :foreign-type :<CGF>loat :accessor text-view-line-height))
    9701121  (:metaclass ns:+ns-object))
     1122(declaim (special hemlock-text-view))
     1123
     1124(defmethod hemlock-view ((self hemlock-text-view))
     1125  (let ((pane (text-view-pane self)))
     1126    (when pane (hemlock-view pane))))
    9711127
    9721128(objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender)
    9731129  (declare (ignore sender))
    974   (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
    975          (doc (#/documentForWindow: dc (#/window self)))
    976          (buffer (hemlock-document-buffer doc))
     1130  (let* ((buffer (hemlock-buffer self))
    9771131         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
    9781132         (pathname (hi::buffer-pathname buffer))
     
    9871141(objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender)
    9881142  (declare (ignore sender))
    989   (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
    990          (doc (#/documentForWindow: dc (#/window self)))
    991          (buffer (hemlock-document-buffer doc))
     1143  (let* ((buffer (hemlock-buffer self))
    9921144         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
    9931145         (pathname (hi::buffer-pathname buffer)))
     
    9961148(objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender)
    9971149  (declare (ignore sender))
    998   (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
    999          (doc (#/documentForWindow: dc (#/window self)))
    1000          (buffer (hemlock-document-buffer doc))
     1150  (let* ((buffer (hemlock-buffer self))
    10011151         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
    10021152         (pathname (hi::buffer-pathname buffer)))
     
    10051155(objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender)
    10061156  (declare (ignore sender))
    1007   (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
    1008          (doc (#/documentForWindow: dc (#/window self)))
    1009          (buffer (hemlock-document-buffer doc))
     1157  (let* ((buffer (hemlock-buffer self))
    10101158         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
    10111159         (pathname (hi::buffer-pathname buffer)))
     
    11091257
    11101258
    1111 
    1112 ;;; Access the underlying buffer in one swell foop.
    1113 (defmethod text-view-buffer ((self hemlock-textstorage-text-view))
    1114   (buffer-cache-buffer (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))))
    1115 
    1116 
    1117 
     1259(defmethod text-view-string-cache ((self hemlock-textstorage-text-view))
     1260  (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
    11181261
    11191262(objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range)
     
    11411284                            (hi::with-mark ((m2 m1))
    11421285                              (when (hemlock::list-offset m2 1)
    1143                                 (ns:init-ns-range r index (- (mark-absolute-position m2) index))
     1286                                (ns:init-ns-range r index (- (hi:mark-absolute-position m2) index))
    11441287                                (return-from HANDLED r))))
    11451288                           ((eql (hi::previous-character m1) #\))
    11461289                            (hi::with-mark ((m2 m1))
    11471290                              (when (hemlock::list-offset m2 -1)
    1148                                 (ns:init-ns-range r (mark-absolute-position m2) (- index (mark-absolute-position m2)))
     1291                                (ns:init-ns-range r (hi:mark-absolute-position m2) (- index (hi:mark-absolute-position m2)))
    11491292                                (return-from HANDLED r))))))))))))
    11501293       (call-next-method proposed g)
     
    11571300
    11581301
    1159  
    1160 
    1161 
    1162 ;;; Translate a keyDown NSEvent to a Hemlock key-event.
    1163 (defun nsevent-to-key-event (nsevent &optional quoted)
    1164   (let* ((modifiers (#/modifierFlags nsevent)))
    1165     (unless (logtest #$NSCommandKeyMask modifiers)
    1166       (let* ((chars (if quoted
    1167                       (#/characters nsevent)
    1168                       (#/charactersIgnoringModifiers nsevent)))
    1169              (n (if (%null-ptr-p chars)
    1170                   0
    1171                   (#/length chars)))
    1172              (c (if (eql n 1)
    1173                   (#/characterAtIndex: chars 0))))
    1174         (when c
    1175           (let* ((bits 0)
    1176                  (useful-modifiers (logandc2 modifiers
    1177                                              (logior ;#$NSShiftKeyMask
    1178                                                      #$NSAlphaShiftKeyMask))))
    1179             (unless quoted
    1180               (dolist (map hemlock-ext::*modifier-translations*)
    1181                 (when (logtest useful-modifiers (car map))
    1182                   (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
    1183                                          (cdr map)))))))
    1184             (let* ((char (code-char c)))
    1185               (when (and char (standard-char-p char))
    1186                 (setq bits (logandc2 bits hi::+shift-event-mask+))))
    1187             (hemlock-ext::make-key-event c bits)))))))
    1188 
    1189 (defun pass-key-down-event-to-hemlock (self event q)
    1190   #+debug
    1191   (#_NSLog #@"Key down event = %@" :address event)
    1192   (let* ((buffer (text-view-buffer self)))
    1193     (when buffer
    1194       (let* ((hemlock-event (nsevent-to-key-event event (hi::frame-event-queue-quoted-insert q ))))
    1195         (when hemlock-event
    1196           (hi::enqueue-key-event q hemlock-event))))))
    1197 
    1198 (defun hi::enqueue-buffer-operation (buffer thunk)
    1199   (dolist (w (hi::buffer-windows buffer))
    1200     (let* ((q (hemlock-frame-event-queue (#/window w)))
    1201            (op (hi::make-buffer-operation :thunk thunk)))
    1202       (hi::event-queue-insert q op))))
    1203 
    1204 
    1205 
    1206 ;;; Process a key-down NSEvent in a Hemlock text view by translating it
    1207 ;;; into a Hemlock key event and passing it into the Hemlock command
    1208 ;;; interpreter.
    1209 
    1210 (defun handle-key-down (self event)
    1211   (let* ((q (hemlock-frame-event-queue (#/window self))))
    1212     (if (or (and (zerop (#/length (#/characters event)))
    1213                  (hi::frame-event-queue-quoted-insert q))
    1214             (#/hasMarkedText self))
    1215       nil
    1216       (progn
    1217         (pass-key-down-event-to-hemlock self event q)
    1218         t))))
    1219  
    1220 
    1221 (objc:defmethod (#/keyDown: :void) ((self hemlock-text-view) event)
    1222   (or (handle-key-down self event)
    1223       (call-next-method event)))
    1224 
    1225 (objc:defmethod (#/mouseDown: :void) ((self hemlock-text-view) event)
    1226   ;; If no modifier keys are pressed, send hemlock a no-op.
    1227   (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
    1228     (let* ((q (hemlock-frame-event-queue (#/window self))))
    1229       (hi::enqueue-key-event q #k"leftdown")))
    1230   (call-next-method event))
     1302(defun append-output (view string)
     1303  (assume-cocoa-thread)
     1304  ;; Arrange to do the append in command context
     1305  (when view
     1306    (hi::handle-hemlock-event view #'(lambda ()
     1307                                       (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string)))))
     1308
    12311309
    12321310;;; Update the underlying buffer's point (and "active region", if appropriate.
     
    12861364             ;; In all cases, activate Hemlock selection.
    12871365             (unless still-selecting
    1288                 (let* ((pointpos (mark-absolute-position point))
     1366                (let* ((pointpos (hi:mark-absolute-position point))
    12891367                       (selection-end (+ location len))
    12901368                       (mark (hi::copy-mark point :right-inserting)))
     
    13691447      (let* ((tv (text-pane-text-view pane)))
    13701448        (unless (%null-ptr-p tv)
    1371           (text-view-buffer tv))))))
     1449          (hemlock-buffer tv))))))
    13721450
    13731451;;; Draw a string in the modeline view.  The font and other attributes
     
    13761454;;; used in the event dispatch mechanism,
    13771455(defun draw-modeline-string (the-modeline-view)
    1378   (with-slots (pane text-attributes) the-modeline-view
     1456  (with-slots (text-attributes) the-modeline-view
    13791457    (let* ((buffer (buffer-for-modeline-view the-modeline-view)))
    13801458      (when buffer
     
    13831461                       (mapcar
    13841462                        #'(lambda (field)
    1385                             (funcall (hi::modeline-field-function field)
    1386                                      buffer pane))
     1463                            (funcall (hi::modeline-field-function field) buffer))
    13871464                        (hi::buffer-modeline-fields buffer)))))
    13881465          (#/drawAtPoint:withAttributes: (%make-nsstring string)
     
    14811558
    14821559(defclass text-pane (ns:ns-box)
    1483     ((text-view :foreign-type :id :accessor text-pane-text-view)
     1560    ((hemlock-view :initform nil :reader text-pane-hemlock-view)
     1561     (text-view :foreign-type :id :accessor text-pane-text-view)
    14841562     (mode-line :foreign-type :id :accessor text-pane-mode-line)
    14851563     (scroll-view :foreign-type :id :accessor text-pane-scroll-view))
    14861564  (:metaclass ns:+ns-object))
    14871565
    1488 ;;; Mark the pane's modeline as needing display.  This is called whenever
     1566(defmethod hemlock-view ((self text-pane))
     1567  (text-pane-hemlock-view self))
     1568
     1569;;; Mark the buffer's modeline as needing display.  This is called whenever
    14891570;;; "interesting" attributes of a buffer are changed.
    1490 
    1491 (defun hi::invalidate-modeline (pane)
    1492   (#/setNeedsDisplay: (text-pane-mode-line pane) t))
     1571(defun hemlock-ext:invalidate-modeline (buffer)
     1572  (let* ((doc (hi::buffer-document buffer)))
     1573    (when doc
     1574      (document-invalidate-modeline doc))))
    14931575
    14941576(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
     
    16031685      tv)))
    16041686
    1605 
    1606 (objc:defmethod (#/activateHemlockView :void) ((self text-pane))
    1607   (let* ((the-hemlock-frame (#/window self))
    1608          (text-view (text-pane-text-view self)))
    1609     #+debug (#_NSLog #@"Activating text pane")
    1610     (with-slots ((echo peer)) text-view
    1611       (deactivate-hemlock-view echo))
    1612     (#/setEditable: text-view t)
    1613     (#/makeFirstResponder: the-hemlock-frame text-view)))
    1614 
    1615 (defmethod hi::activate-hemlock-view ((view text-pane))
    1616   (#/performSelectorOnMainThread:withObject:waitUntilDone:
    1617    view
    1618    (@selector #/activateHemlockView)
    1619    +null-ptr+
    1620    t))
    1621 
    1622 
    1623 
    1624 (defmethod deactivate-hemlock-view ((self hemlock-text-view))
    1625   #+debug (#_NSLog #@"deactivating text view")
    1626   (#/setSelectable: self nil))
     1687(defmethod hemlock-ext:change-active-pane ((view hi:hemlock-view) new-pane)
     1688  #+GZ (log-debug "change active pane to ~s" new-pane)
     1689  (let* ((pane (hi::hemlock-view-pane view))
     1690         (text-view (text-pane-text-view pane))
     1691         (tv (ecase new-pane
     1692               (:echo (slot-value text-view 'peer))
     1693               (:text text-view))))
     1694    (activate-hemlock-view tv)))
    16271695
    16281696(defclass echo-area-view (hemlock-textstorage-text-view)
    16291697    ()
    16301698  (:metaclass ns:+ns-object))
    1631 
    1632 (objc:defmethod (#/activateHemlockView :void) ((self echo-area-view))
    1633   (assume-cocoa-thread)
    1634   (let* ((the-hemlock-frame (#/window self)))
    1635     #+debug
    1636     (#_NSLog #@"Activating echo area")
    1637     (with-slots ((pane peer)) self
    1638       (deactivate-hemlock-view pane))
    1639     (#/setEditable: self t)
    1640   (#/makeFirstResponder: the-hemlock-frame self)))
    1641 
    1642 (defmethod hi::activate-hemlock-view ((view echo-area-view))
    1643   (#/performSelectorOnMainThread:withObject:waitUntilDone:
    1644    view
    1645    (@selector #/activateHemlockView)
    1646    +null-ptr+
    1647    t))
    1648 
    1649 (defmethod deactivate-hemlock-view ((self echo-area-view))
    1650   (assume-cocoa-thread)
    1651   #+debug (#_NSLog #@"deactivating echo area")
    1652   (let* ((ts (#/textStorage self)))
    1653     #+debug 0
    1654     (when (#/editingInProgress ts)
    1655       (#_NSLog #@"deactivating %@, edit-count = %d" :id self :int (slot-value ts 'edit-count)))
    1656     (do* ()
    1657          ((not (#/editingInProgress ts)))
    1658       (#/endEditing ts))
    1659 
    1660     (#/setSelectable: self nil)))
    1661 
     1699(declaim (special echo-area-view))
     1700
     1701(defmethod hemlock-view ((self echo-area-view))
     1702  (let ((text-view (slot-value self 'peer)))
     1703    (when text-view
     1704      (hemlock-view text-view))))
    16621705
    16631706;;; The "document" for an echo-area isn't a real NSDocument.
     
    16661709  (:metaclass ns:+ns-object))
    16671710
     1711(defmethod hemlock-buffer ((self echo-area-document))
     1712  (let ((ts (slot-value self 'textstorage)))
     1713    (unless (%null-ptr-p ts)
     1714      (hemlock-buffer ts))))
     1715
    16681716(objc:defmethod (#/undoManager :<BOOL>) ((self echo-area-document))
    16691717  nil) ;For now, undo is not supported for echo-areas
     
    16711719(defmethod update-buffer-package ((doc echo-area-document) buffer)
    16721720  (declare (ignore buffer)))
     1721
     1722(defmethod document-invalidate-modeline ((self echo-area-document))
     1723  nil)
    16731724
    16741725(objc:defmethod (#/close :void) ((self echo-area-document))
     
    16781729      (close-hemlock-textstorage ts))))
    16791730
    1680 (objc:defmethod (#/updateChangeCount: :void)
    1681     ((self echo-area-document)
    1682      (change :<NSD>ocument<C>hange<T>ype))
     1731(objc:defmethod (#/updateChangeCount: :void) ((self echo-area-document) (change :<NSD>ocument<C>hange<T>ype))
    16831732  (declare (ignore change)))
    1684 
    1685 (objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document)))
    1686 
    1687 (objc:defmethod (#/keyDown: :void) ((self echo-area-view) event)
    1688   (or (handle-key-down self event)
    1689       (call-next-method event)))
    1690 
    1691 
    1692 (defloadvar *hemlock-frame-count* 0)
    16931733
    16941734(defun make-echo-area (the-hemlock-frame x y width height main-buffer color)
     
    17051745      (#/setAutoresizesSubviews: box t)
    17061746      (#/release clipview)
    1707       (let* ((buffer (hi:make-buffer (format nil "Echo Area ~d"
    1708                                              (prog1
    1709                                                  *hemlock-frame-count*
    1710                                                (incf *hemlock-frame-count*)))
    1711                                      :modes '("Echo Area")))
     1747      (let* ((buffer (hi::make-echo-buffer))
    17121748             (textstorage
    17131749              (progn
    17141750                ;; What's the reason for sharing this?  Is it just the lock?
    1715                 (setf (hi::buffer-gap-context buffer) (hi::buffer-gap-context main-buffer))
     1751                (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer))
    17161752                (make-textstorage-for-hemlock-buffer buffer)))
    17171753             (doc (make-instance 'echo-area-document))
     
    17641800    ((echo-area-view :foreign-type :id)
    17651801     (pane :foreign-type :id)
    1766      (event-queue :initform (ccl::init-dll-header (hi::make-frame-event-queue))
    1767                   :reader hemlock-frame-event-queue)
    1768      (command-thread :initform nil)
    17691802     (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer)
    17701803     (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream))
    17711804  (:metaclass ns:+ns-object))
    17721805(declaim (special hemlock-frame))
     1806
     1807(defmethod hemlock-view ((self hemlock-frame))
     1808  (let ((pane (slot-value self 'pane)))
     1809    (unless (%null-ptr-p pane)
     1810      (hemlock-view pane))))
    17731811
    17741812(defun double-%-in (string)
     
    17811819
    17821820(defun nsstring-for-lisp-condition (cond)
    1783   (%make-nsstring (double-%-in (princ-to-string cond))))
    1784 
    1785 (objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) info)
    1786   (let* ((message (#/objectAtIndex: info 0))
    1787          (signal (#/objectAtIndex: info 1)))
    1788     #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
    1789     (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
    1790                          (if (logbitp 0 (random 2))
    1791                            #@"Not OK, but what can you do?"
    1792                            #@"The sky is falling. FRED never did this!")
    1793                          +null-ptr+
    1794                          +null-ptr+
    1795                          self
    1796                          self
    1797                          (@selector #/sheetDidEnd:returnCode:contextInfo:)
    1798                          (@selector #/sheetDidDismiss:returnCode:contextInfo:)
    1799                          signal
    1800                          message)))
    1801 
    1802 (objc:defmethod (#/sheetDidEnd:returnCode:contextInfo: :void) ((self hemlock-frame))
    1803  (declare (ignore sheet code info))
    1804   #+debug
    1805   (#_NSLog #@"Sheet did end"))
    1806 
    1807 (objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void)
    1808     ((self hemlock-frame) sheet code info)
    1809   (declare (ignore sheet code))
    1810   #+debug (#_NSLog #@"dismiss sheet: semaphore = %lx" :unsigned-doubleword (#/unsignedLongValue info))
    1811   (ccl::%signal-semaphore-ptr (%int-to-ptr (#/unsignedLongValue info))))
    1812  
     1821  (%make-nsstring (double-%-in (or (ignore-errors (princ-to-string cond))
     1822                                   "#<error printing error message>"))))
     1823
     1824(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) message)
     1825  #+debug (#_NSLog #@"runErrorSheet: signal = %@" :id signal)
     1826  (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
     1827                       (if (logbitp 0 (random 2))
     1828                         #@"Not OK, but what can you do?"
     1829                         #@"The sky is falling. FRED never did this!")
     1830                       +null-ptr+
     1831                       +null-ptr+
     1832                       self
     1833                       self
     1834                       +null-ptr+
     1835                       +null-ptr+
     1836                       +null-ptr+
     1837                       message))
     1838
    18131839(defun report-condition-in-hemlock-frame (condition frame)
    1814   (let* ((semaphore (make-semaphore))
    1815          (message (nsstring-for-lisp-condition condition))
    1816          (sem-value (make-instance 'ns:ns-number
    1817                                    :with-unsigned-long (%ptr-to-int (ccl::semaphore.value semaphore)))))
    1818     #+debug
    1819     (#_NSLog #@"created semaphore with value %lx" :address (semaphore.value semaphore))
    1820     (rlet ((paramptrs (:array :id 2)))
    1821       (setf (paref paramptrs (:array :id) 0) message
    1822             (paref paramptrs (:array :id) 1) sem-value)
    1823       (let* ((params (make-instance 'ns:ns-array
    1824                                     :with-objects paramptrs
    1825                                     :count 2))
    1826              #|(*debug-io* *typeout-stream*)|#)
    1827         (stream-clear-output *debug-io*)
    1828         (ignore-errors (print-call-history :detailed-p t))
    1829         (#/performSelectorOnMainThread:withObject:waitUntilDone:
    1830          frame (@selector #/runErrorSheet:) params t)
    1831         (wait-on-semaphore semaphore)))))
    1832 
    1833 (defun hi::report-hemlock-error (condition)
    1834   (let ((pane (hi::current-window)))
     1840  (assume-cocoa-thread)
     1841  (let ((message (nsstring-for-lisp-condition condition)))
     1842    (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1843     frame
     1844     (@selector #/runErrorSheet:)
     1845     message
     1846     t)))
     1847
     1848(defmethod hemlock-ext:report-hemlock-error ((view hi:hemlock-view) condition debug-p)
     1849  (when debug-p (maybe-log-callback-error condition))
     1850  (let ((pane (hi::hemlock-view-pane view)))
    18351851    (when (and pane (not (%null-ptr-p pane)))
    18361852      (report-condition-in-hemlock-frame condition (#/window pane)))))
    18371853                       
    1838 
    1839 (defun hemlock-thread-function (q buffer pane echo-buffer echo-window)
    1840   (let* ((hi::*real-editor-input* q)
    1841          (hi::*editor-input* q)
    1842          (hi::*current-buffer* hi::*current-buffer*)
    1843          (hi::*current-window* pane)
    1844          (hi::*echo-area-window* echo-window)
    1845          (hi::*echo-area-buffer* echo-buffer)
    1846          (region (hi::buffer-region echo-buffer))
    1847          (hi::*echo-area-region* region)
    1848          (hi::*echo-area-stream* (hi::make-hemlock-output-stream
    1849                               (hi::region-end region) :full))
    1850          (hi::*parse-starting-mark*
    1851           (hi::copy-mark (hi::buffer-point hi::*echo-area-buffer*)
    1852                          :right-inserting))
    1853          (hi::*parse-input-region*
    1854           (hi::region hi::*parse-starting-mark*
    1855                       (hi::region-end region)))
    1856          (hi::*cache-modification-tick* -1)
    1857          (hi::*disembodied-buffer-counter* 0)
    1858          (hi::*in-a-recursive-edit* nil)
    1859          (hi::*last-key-event-typed* nil)
    1860          (hi::*input-transcript* nil)
    1861          (hemlock::*target-column* 0)
    1862          (hemlock::*last-comment-start* " ")
    1863          (hi::*translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t))
    1864          (hi::*current-command* (make-array 10 :fill-pointer 0 :adjustable t))
    1865          (hi::*current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
    1866          (hi::*prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
    1867          (hi::*command-key-event-buffer* buffer))
    1868    
    1869     (setf (hi::current-buffer) buffer)
    1870     (unwind-protect
    1871          (loop
    1872            (catch 'hi::editor-top-level-catcher
    1873              (handler-bind ((error #'(lambda (condition)
    1874                                        (hi::lisp-error-error-handler condition
    1875                                                                      :internal))))
    1876                (hi::invoke-hook hemlock::abort-hook)
    1877                (hi::%command-loop))))
    1878       (hi::invoke-hook hemlock::exit-hook))))
    1879 
    1880 
    18811854(objc:defmethod (#/close :void) ((self hemlock-frame))
    18821855  (let* ((content-view (#/contentView self))
     
    18851858         ((< i 0))
    18861859      (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i))))
    1887   (let* ((proc (slot-value self 'command-thread)))
    1888     (when proc
    1889       (setf (slot-value self 'command-thread) nil)
    1890       (process-kill proc)))
    18911860  (let* ((buf (hemlock-frame-echo-area-buffer self))
    18921861         (echo-doc (if buf (hi::buffer-document buf))))
     
    19291898    (nsstring-to-buffer nsstring buffer)))
    19301899
    1931 (defun %nsstring-to-mark (nsstring mark)
     1900(defun %nsstring-to-hemlock-string (nsstring)
    19321901  "returns line-termination of string"
    19331902  (let* ((string (lisp-string-from-nsstring nsstring))
     
    19361905         (line-termination (if crpos
    19371906                             (if (eql lfpos (1+ crpos))
    1938                                :cp/m
    1939                                :macos)
    1940                              :unix)))
    1941     (hi::insert-string mark
    1942                            (case line-termination
    1943                              (:cp/m (remove #\return string))
    1944                              (:macos (nsubstitute #\linefeed #\return string))
    1945                              (t string)))
    1946     line-termination))
    1947  
     1907                               :crlf
     1908                               :cr)
     1909                             :lf))
     1910         (hemlock-string (case line-termination
     1911                           (:crlf (remove #\return string))
     1912                           (:cr (nsubstitute #\linefeed #\return string))
     1913                           (t string))))
     1914    (values hemlock-string line-termination)))
     1915
     1916;: TODO: I think this is jumping through hoops because it want to be invokable outside the main
     1917;; cocoa thread.
    19481918(defun nsstring-to-buffer (nsstring buffer)
    19491919  (let* ((document (hi::buffer-document buffer))
    19501920         (hi::*current-buffer* buffer)
    19511921         (region (hi::buffer-region buffer)))
    1952     (setf (hi::buffer-document buffer) nil)
    1953     (unwind-protect
    1954          (progn
    1955            (hi::delete-region region)
    1956            (hi::modifying-buffer buffer
    1957                                  (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting))
    1958                                    (setf (hi::buffer-line-termination buffer)
    1959                                          (%nsstring-to-mark nsstring mark)))
    1960                                  (setf (hi::buffer-modified buffer) nil)
    1961                                  (hi::buffer-start (hi::buffer-point buffer))
    1962                                  (hi::renumber-region region)
    1963                                  buffer))
    1964       (setf (hi::buffer-document buffer) document))))
    1965 
     1922    (multiple-value-bind (hemlock-string line-termination)
     1923                         (%nsstring-to-hemlock-string nsstring)
     1924      (setf (hi::buffer-line-termination buffer) line-termination)
     1925
     1926      (setf (hi::buffer-document buffer) nil) ;; What's this about??
     1927      (unwind-protect
     1928          (let ((point (hi::buffer-point buffer)))
     1929            (hi::delete-region region)
     1930            (hi::insert-string point hemlock-string)
     1931            (setf (hi::buffer-modified buffer) nil)
     1932            (hi::buffer-start point)
     1933            ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping.
     1934            (hi::renumber-region region)
     1935            buffer)
     1936        (setf (hi::buffer-document buffer) document)))))
    19661937
    19671938
     
    19751946  (assume-cocoa-thread)
    19761947  (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style))
     1948         (buffer (hemlock-buffer ts))
    19771949         (frame (#/window pane))
    1978          (buffer (text-view-buffer (text-pane-text-view pane)))
    19791950         (echo-area (make-echo-area-for-window frame buffer color))
     1951         (echo-buffer (hemlock-buffer (#/textStorage echo-area)))
    19801952         (tv (text-pane-text-view pane)))
     1953    #+GZ (assert echo-buffer)
    19811954    (with-slots (peer) tv
    19821955      (setq peer echo-area))
    19831956    (with-slots (peer) echo-area
    19841957      (setq peer tv))
    1985     (hi::activate-hemlock-view pane)
    19861958    (setf (slot-value frame 'echo-area-view) echo-area
    19871959          (slot-value frame 'pane) pane)
    1988     (setf (slot-value frame 'command-thread)
    1989           (process-run-function (format nil "Hemlock window thread for ~s"
    1990                                         (hi::buffer-name buffer))
    1991                                 #'(lambda ()
    1992                                     (hemlock-thread-function
    1993                                      (hemlock-frame-event-queue frame)
    1994                                      buffer
    1995                                      pane
    1996                                      (hemlock-frame-echo-area-buffer frame)
    1997                                      (slot-value frame 'echo-area-view)))))
    1998     frame))
    1999          
    2000    
    2001 
    2002 
    2003 (defun hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
    2004   (process-interrupt *cocoa-event-process*
    2005                      #'%hemlock-frame-for-textstorage
    2006                      class ts  ncols nrows container-tracks-text-view-width color style))
    2007 
     1960    (setf (slot-value pane 'hemlock-view)
     1961          (make-instance 'hi:hemlock-view
     1962            :buffer buffer
     1963            :pane pane
     1964            :echo-area-buffer echo-buffer))
     1965    (activate-hemlock-view tv)
     1966   frame))
    20081967
    20091968
     
    20141973  (release-lock (hi::buffer-lock b)))
    20151974
    2016 (defun hi::document-begin-editing (document)
    2017   (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2018    (slot-value document 'textstorage)
    2019    (@selector #/beginEditing)
    2020    +null-ptr+
    2021    t))
     1975(defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk)
     1976  (assume-cocoa-thread)
     1977  (when buffer ;; nil means just get rid of any prior buffer
     1978    (setq buffer (require-type buffer 'hi::buffer)))
     1979  (let ((old *buffer-being-edited*))
     1980    (if (eq buffer old)
     1981      (funcall thunk)
     1982      (unwind-protect
     1983          (progn
     1984            (buffer-document-end-editing old)
     1985            (buffer-document-begin-editing buffer)
     1986            (funcall thunk))
     1987        (buffer-document-end-editing buffer)
     1988        (buffer-document-begin-editing old)))))
     1989
     1990(defun buffer-document-end-editing (buffer)
     1991  (when buffer
     1992    (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer))))
     1993      (when document
     1994        (setq *buffer-being-edited* nil)
     1995        (let ((ts (slot-value document 'textstorage)))
     1996          (#/endEditing ts)
     1997          (update-hemlock-selection ts))))))
     1998
     1999(defun buffer-document-begin-editing (buffer)
     2000  (when buffer
     2001    (let* ((document (hi::buffer-document buffer)))
     2002      (when document
     2003        (setq *buffer-being-edited* buffer)
     2004        (#/beginEditing (slot-value document 'textstorage))))))
    20222005
    20232006(defun document-edit-level (document)
    20242007  (assume-cocoa-thread) ;; see comment in #/editingInProgress
    20252008  (slot-value (slot-value document 'textstorage) 'edit-count))
    2026 
    2027 (defun hi::document-end-editing (document)
    2028   (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2029    (slot-value document 'textstorage)
    2030    (@selector #/endEditing)
    2031    +null-ptr+
    2032    t))
    2033 
    2034 (defun hi::document-set-point-position (document)
    2035   (declare (ignorable document))
    2036   #+debug
    2037   (#_NSLog #@"Document set point position called")
    2038   (let* ((textstorage (slot-value document 'textstorage)))
    2039     (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2040      textstorage (@selector #/updateHemlockSelection) +null-ptr+ t)))
    2041 
    2042 
    20432009
    20442010(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
     
    20722038    (let* ((document (hi::buffer-document buffer))
    20732039           (textstorage (if document (slot-value document 'textstorage)))
    2074            (pos (mark-absolute-position (hi::region-start region)))
    2075            (n (- (mark-absolute-position (hi::region-end region)) pos)))
     2040           (pos (hi:mark-absolute-position (hi::region-start region)))
     2041           (n (- (hi:mark-absolute-position (hi::region-end region)) pos)))
    20762042      (perform-edit-change-notification textstorage
    20772043                                        (@selector #/noteHemlockAttrChangeAtPosition:length:)
     
    20802046                                        font))))
    20812047
    2082 (defun buffer-active-font (buffer)
     2048(defun buffer-active-font-attributes (buffer)
    20832049  (let* ((style 0)
    20842050         (region (hi::buffer-active-font-region buffer))
     
    20972063           (textstorage (if document (slot-value document 'textstorage))))
    20982064      (when textstorage
    2099         (let* ((pos (mark-absolute-position mark)))
     2065        (let* ((pos (hi:mark-absolute-position mark)))
    21002066          (when (eq (hi::mark-%kind mark) :left-inserting)
    21012067            ;; Make up for the fact that the mark moved forward with the insertion.
     
    21142080            (perform-edit-change-notification textstorage
    21152081                                              (@selector #/noteHemlockModificationAtPosition:length:)
    2116                                               (mark-absolute-position mark)
     2082                                              (hi:mark-absolute-position mark)
    21172083                                              n)))))
    21182084 
     
    21232089           (textstorage (if document (slot-value document 'textstorage))))
    21242090      (when textstorage
    2125         (let* ((pos (mark-absolute-position mark)))
     2091        (let* ((pos (hi:mark-absolute-position mark)))
    21262092          (perform-edit-change-notification textstorage
    21272093                                            (@selector #/noteHemlockDeletionAtPosition:length:)
     
    21312097
    21322098
    2133 (defun hi::set-document-modified (document flag)
    2134   (unless flag
    2135     (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2136      document
    2137      (@selector #/documentChangeCleared)
    2138      +null-ptr+
    2139      t)))
    2140 
    2141 
    2142 (defmethod hi::document-panes ((document t))
    2143   )
    2144 
    2145 
    2146 
    2147    
     2099(defun hemlock-ext:note-buffer-saved (buffer)
     2100  (assume-cocoa-thread)
     2101  (let* ((document (hi::buffer-document buffer)))
     2102    (when document
     2103      ;; Hmm... I guess this is always done by the act of saving.
     2104      nil)))
     2105
     2106(defun hemlock-ext:note-buffer-unsaved (buffer)
     2107  (assume-cocoa-thread)
     2108  (let* ((document (hi::buffer-document buffer)))
     2109    (when document
     2110      (#/updateChangeCount: document #$NSChangeCleared))))
     2111
    21482112
    21492113(defun size-of-char-in-font (f)
     
    21582122
    21592123
    2160 (defun size-text-pane (pane char-height char-width nrows ncols)
     2124(defun size-text-pane (pane line-height char-width nrows ncols)
    21612125  (let* ((tv (text-pane-text-view pane))
    2162          (height (fceiling (* nrows char-height)))
     2126         (height (fceiling (* nrows line-height)))
    21632127         (width (fceiling (* ncols char-width)))
    21642128         (scrollview (text-pane-scroll-view pane))
     
    21702134                      height)
    21712135      (when has-vertical-scroller
    2172         (#/setVerticalLineScroll: scrollview char-height)
    2173         (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|char-height|#))
     2136        (#/setVerticalLineScroll: scrollview line-height)
     2137        (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|line-height|#))
    21742138      (when has-horizontal-scroller
    21752139        (#/setHorizontalLineScroll: scrollview char-width)
     
    21852149        (#/setContentSize: window sv-size)
    21862150        (setf (slot-value tv 'char-width) char-width
    2187               (slot-value tv 'char-height) char-height)
     2151              (slot-value tv 'line-height) line-height)
    21882152        (#/setResizeIncrements: window
    2189                                 (ns:make-ns-size char-width char-height))))))
     2153                                (ns:make-ns-size char-width line-height))))))
    21902154                                   
    21912155 
     
    21942158  (:metaclass ns:+ns-object))
    21952159
     2160(defmethod hemlock-view ((self hemlock-editor-window-controller))
     2161  (let ((frame (#/window self)))
     2162    (unless (%null-ptr-p frame)
     2163      (hemlock-view frame))))
    21962164
    21972165;;; Map *default-file-character-encoding* to an :<NSS>tring<E>ncoding
     
    22292197  (:metaclass ns:+ns-object))
    22302198
    2231 (objc:defmethod (#/documentChangeCleared :void) ((self hemlock-editor-document))
    2232   (#/updateChangeCount: self #$NSChangeCleared))
     2199(defmethod hemlock-buffer ((self hemlock-editor-document))
     2200  (let ((ts (slot-value self 'textstorage)))
     2201    (unless (%null-ptr-p ts)
     2202      (hemlock-buffer ts))))
    22332203
    22342204(defmethod assume-not-editing ((doc hemlock-editor-document))
    22352205  (assume-not-editing (slot-value doc 'textstorage)))
     2206
     2207(defmethod document-invalidate-modeline ((self hemlock-editor-document))
     2208  (for-each-textview-using-storage
     2209   (slot-value self 'textstorage)
     2210   #'(lambda (tv)
     2211       (let* ((pane (text-view-pane tv)))
     2212         (unless (%null-ptr-p pane)
     2213           (#/setNeedsDisplay: (text-pane-mode-line pane) t))))))
    22362214
    22372215(defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
     
    22462224          (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
    22472225
    2248 (defun hi::document-note-selection-set-by-search (doc)
    2249   (with-slots (textstorage) doc
    2250     (when textstorage
    2251       (with-slots (selection-set-by-search) textstorage
    2252         (setq selection-set-by-search #$YES)))))
     2226(defun hemlock-ext:note-selection-set-by-search (buffer)
     2227  (let* ((doc (hi::buffer-document buffer)))
     2228    (when doc
     2229      (with-slots (textstorage) doc
     2230        (when textstorage
     2231          (with-slots (selection-set-by-search) textstorage
     2232            (setq selection-set-by-search #$YES)))))))
    22532233
    22542234(objc:defmethod (#/validateMenuItem: :<BOOL>)
     
    22722252               (eql action (@selector #/compileBuffer:))
    22732253               (eql action (@selector #/compileAndLoadBuffer:)))
    2274            (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
    2275                   (buffer (buffer-cache-buffer d))
     2254           (let* ((buffer (hemlock-buffer self))
    22762255                  (pathname (hi::buffer-pathname buffer)))
    22772256             (not (null pathname))))
     
    22832262(defvar *encoding-name-hash* (make-hash-table))
    22842263
    2285 (defmethod hi::document-encoding-name ((doc hemlock-editor-document))
     2264(defmethod document-encoding-name ((doc hemlock-editor-document))
    22862265  (with-slots (encoding) doc
    22872266    (if (eql encoding 0)
     
    22912270                (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding)))))))
    22922271
    2293 
     2272(defun hi::buffer-encoding-name (buffer)
     2273  (let ((doc (hi::buffer-document buffer)))
     2274    (and doc (document-encoding-name doc))))
     2275
     2276;; TODO: make each buffer have a slot, and this is just the default value.
    22942277(defmethod textview-background-color ((doc hemlock-editor-document))
    22952278  *editor-background-color*)
     
    23182301                                  :encoding encoding
    23192302                                  :error +null-ptr+))
    2320          (buffer (hemlock-document-buffer self))
     2303         (buffer (hemlock-buffer self))
    23212304         (old-length (hemlock-buffer-length buffer))
    23222305         (hi::*current-buffer* buffer)
    23232306         (textstorage (slot-value self 'textstorage))
    23242307         (point (hi::buffer-point buffer))
    2325          (pointpos (mark-absolute-position point)))
    2326     (#/beginEditing textstorage)
    2327     (#/edited:range:changeInLength:
    2328      textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
    2329     (nsstring-to-buffer nsstring buffer)
    2330     (let* ((newlen (hemlock-buffer-length buffer)))
    2331       (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
    2332       (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
    2333       (let* ((ts-string (#/hemlockString textstorage))
    2334              (display (hemlock-buffer-string-cache ts-string)))
    2335         (reset-buffer-cache display)
    2336         (update-line-cache-for-index display 0)
    2337         (move-hemlock-mark-to-absolute-position point
    2338                                                 display
    2339                                                 (min newlen pointpos))))
    2340     (#/updateMirror textstorage)
    2341     (#/endEditing textstorage)
    2342     (hi::document-set-point-position self)
    2343     (setf (hi::buffer-modified buffer) nil)
    2344     (hi::queue-buffer-change buffer)
     2308         (pointpos (hi:mark-absolute-position point)))
     2309    (hemlock-ext:invoke-modifying-buffer-storage
     2310     buffer
     2311     #'(lambda ()
     2312         (#/edited:range:changeInLength:
     2313          textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
     2314         (nsstring-to-buffer nsstring buffer)
     2315         (let* ((newlen (hemlock-buffer-length buffer)))
     2316           (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
     2317           (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
     2318           (let* ((ts-string (#/hemlockString textstorage))
     2319                  (display (hemlock-buffer-string-cache ts-string)))
     2320             (reset-buffer-cache display)
     2321             (update-line-cache-for-index display 0)
     2322             (move-hemlock-mark-to-absolute-position point
     2323                                                     display
     2324                                                     (min newlen pointpos))))
     2325         (#/updateMirror textstorage)
     2326         (setf (hi::buffer-modified buffer) nil)
     2327         (hi::note-modeline-change buffer)))
    23452328    t))
    2346          
    2347            
    2348  
     2329
     2330
     2331(defvar *last-document-created* nil)
     2332
    23492333(objc:defmethod #/init ((self hemlock-editor-document))
    23502334  (let* ((doc (call-next-method)))
     
    23552339                                (#/displayName doc))
    23562340                               :modes '("Lisp" "Editor")))))
     2341    (setq *last-document-created* doc)
    23572342    doc))
    23582343
    23592344 
     2345(defun make-buffer-for-document (ns-document pathname)
     2346  (let* ((buffer-name (hi::pathname-to-buffer-name pathname))
     2347         (buffer (make-hemlock-buffer buffer-name)))
     2348    (setf (slot-value ns-document 'textstorage)
     2349          (make-textstorage-for-hemlock-buffer buffer))
     2350    (setf (hi::buffer-pathname buffer) pathname)
     2351    buffer))
     2352
    23602353(objc:defmethod (#/readFromURL:ofType:error: :<BOOL>)
    23612354    ((self hemlock-editor-document) url type (perror (:* :id)))
    23622355  (declare (ignorable type))
    2363   (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
    2364     (let* ((pathname
    2365             (lisp-string-from-nsstring
    2366              (if (#/isFileURL url)
    2367                (#/path url)
    2368                (#/absoluteString url))))
    2369            (buffer-name (hi::pathname-to-buffer-name pathname))
    2370            (buffer (or
    2371                     (hemlock-document-buffer self)
    2372                     (let* ((b (make-hemlock-buffer buffer-name)))
    2373                       (setf (hi::buffer-pathname b) pathname)
    2374                       (setf (slot-value self 'textstorage)
    2375                             (make-textstorage-for-hemlock-buffer b))
    2376                       b)))
    2377            (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
    2378            (string
     2356  (with-callback-context "readFromURL"
     2357    (rlet ((pused-encoding :<NSS>tring<E>ncoding 0))
     2358      (let* ((pathname
     2359              (lisp-string-from-nsstring
     2360               (if (#/isFileURL url)
     2361                 (#/path url)
     2362                 (#/absoluteString url))))
     2363             (buffer (or (hemlock-buffer self)
     2364                         (make-buffer-for-document self pathname)))
     2365             (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
     2366             (string
     2367              (if (zerop selected-encoding)
     2368                (#/stringWithContentsOfURL:usedEncoding:error:
     2369                 ns:ns-string
     2370                 url
     2371                 pused-encoding
     2372                 perror)
     2373                +null-ptr+)))
     2374       
     2375        (if (%null-ptr-p string)
     2376          (progn
    23792377            (if (zerop selected-encoding)
    2380               (#/stringWithContentsOfURL:usedEncoding:error:
    2381                ns:ns-string
    2382                url
    2383                pused-encoding
    2384                perror)
    2385               +null-ptr+)))
    2386 
    2387       (if (%null-ptr-p string)
    2388         (progn
    2389           (if (zerop selected-encoding)
    2390             (setq selected-encoding (get-default-encoding)))
    2391           (setq string (#/stringWithContentsOfURL:encoding:error:
    2392                         ns:ns-string
    2393                         url
    2394                         selected-encoding
    2395                         perror)))
    2396         (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
    2397       (unless (%null-ptr-p string)
    2398         (with-slots (encoding) self (setq encoding selected-encoding))
    2399         (hi::queue-buffer-change buffer)
    2400         (hi::document-begin-editing self)
    2401         (nsstring-to-buffer string buffer)
    2402 
    2403         (let* ((textstorage (slot-value self 'textstorage))
    2404                (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
    2405 
    2406           (reset-buffer-cache display)
    2407 
    2408           (#/updateMirror textstorage)
    2409 
    2410           (update-line-cache-for-index display 0)
    2411 
    2412           (textstorage-note-insertion-at-position
    2413            textstorage
    2414            0
    2415            (hemlock-buffer-length buffer)))
    2416 
    2417         (hi::document-end-editing self)
    2418 
    2419         (setf (hi::buffer-modified buffer) nil)
    2420         (hi::process-file-options buffer pathname)
    2421         t))))
    2422 
     2378              (setq selected-encoding (get-default-encoding)))
     2379            (setq string (#/stringWithContentsOfURL:encoding:error:
     2380                          ns:ns-string
     2381                          url
     2382                          selected-encoding
     2383                          perror)))
     2384          (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
     2385        (unless (%null-ptr-p string)
     2386          (with-slots (encoding) self (setq encoding selected-encoding))
     2387
     2388          ;; ** TODO: Argh.  How about we just let hemlock insert it.
     2389          (let* ((textstorage (slot-value self 'textstorage))
     2390                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
     2391                 (hi::*current-buffer* buffer))
     2392            (hemlock-ext:invoke-modifying-buffer-storage
     2393             buffer
     2394             #'(lambda ()
     2395                 (nsstring-to-buffer string buffer)
     2396                 (reset-buffer-cache display)
     2397                 (#/updateMirror textstorage)
     2398                 (update-line-cache-for-index display 0)
     2399                 (textstorage-note-insertion-at-position
     2400                  textstorage
     2401                  0
     2402                  (hemlock-buffer-length buffer))
     2403                 (hi::note-modeline-change buffer)
     2404                 (setf (hi::buffer-modified buffer) nil))))
     2405          t)))))
    24232406
    24242407
     
    24582441             
    24592442
    2460 (defmethod hemlock-document-buffer (document)
    2461   (let* ((string (#/hemlockString (slot-value document 'textstorage))))
    2462     (unless (%null-ptr-p string)
    2463       (let* ((cache (hemlock-buffer-string-cache string)))
    2464         (when cache (buffer-cache-buffer cache))))))
    2465 
    2466 (defmethod hi:window-buffer ((frame hemlock-frame))
    2467   (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
    2468          (doc (#/documentForWindow: dc frame)))
    2469     ;; Sometimes doc is null.  Why?  What would cause a hemlock frame to
    2470     ;; not have a document?  (When it happened, there seemed to be a hemlock
    2471     ;; frame in (windows) that didn't correspond to any visible window).
    2472     (unless (%null-ptr-p doc)
    2473       (hemlock-document-buffer doc))))
    2474 
    2475 (defmethod hi:window-buffer ((pane text-pane))
    2476   (hi:window-buffer (#/window pane)))
    2477 
    2478 (defun ordered-hemlock-windows ()
    2479   (delete-if-not #'(lambda (win)
    2480                      (and (typep win 'hemlock-frame)
    2481                           (hi:window-buffer win)))
    2482                    (windows)))
     2443(defmethod hemlock-view ((frame hemlock-frame))
     2444  (let ((pane (slot-value frame 'pane)))
     2445    (when (and pane (not (%null-ptr-p pane)))
     2446      (hemlock-view pane))))
     2447
     2448(defun hemlock-ext:all-hemlock-views ()
     2449  "List of all hemlock views, in z-order, frontmost first"
     2450  (loop for win in (windows)
     2451    as buf = (and (typep win 'hemlock-frame) (hemlock-view win))
     2452    when buf collect buf))
    24832453
    24842454(defmethod hi::document-panes ((document hemlock-editor-document))
     
    24972467  (with-slots (encoding) self
    24982468    (setq encoding (nsinteger-to-nsstring-encoding (#/selectedTag popup)))
    2499     ;; Force modeline update.
    2500     (hi::queue-buffer-change (hemlock-document-buffer self))))
     2469    (hi::note-modeline-change (hemlock-buffer self))))
    25012470
    25022471(objc:defmethod (#/prepareSavePanel: :<BOOL>) ((self hemlock-editor-document)
     
    25222491  (with-slots (encoding textstorage) self
    25232492    (let* ((string (#/string textstorage))
    2524            (buffer (hemlock-document-buffer self)))
     2493           (buffer (hemlock-buffer self)))
    25252494      (case (when buffer (hi::buffer-line-termination buffer))
    2526         (:cp/m (unless (typep string 'ns:ns-mutable-string)
    2527                 (setq string (make-instance 'ns:ns-mutable-string :with string string))
    2528               (#/replaceOccurrencesOfString:withString:options:range:
    2529                 string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
    2530         (:macos (setq string (if (typep string 'ns:ns-mutable-string)
    2531                               string
    2532                               (make-instance 'ns:ns-mutable-string :with string string)))
    2533                 (#/replaceOccurrencesOfString:withString:options:range:
    2534                 string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
     2495        (:crlf (unless (typep string 'ns:ns-mutable-string)
     2496                (setq string (make-instance 'ns:ns-mutable-string :with string string))
     2497                (#/replaceOccurrencesOfString:withString:options:range:
     2498                  string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
     2499        (:cr (setq string (if (typep string 'ns:ns-mutable-string)
     2500                            string
     2501                            (make-instance 'ns:ns-mutable-string :with string string)))
     2502             (#/replaceOccurrencesOfString:withString:options:range:
     2503              string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
    25352504      (when (#/writeToURL:atomically:encoding:error:
    25362505             string url t encoding error)
     
    25472516                                        url)
    25482517  (call-next-method url)
    2549   (let* ((buffer (hemlock-document-buffer self)))
     2518  (let* ((buffer (hemlock-buffer self)))
    25502519    (when buffer
    25512520      (let* ((new-pathname (lisp-string-from-nsstring (#/path url))))
     
    25822551  #+debug
    25832552  (#_NSLog #@"Make window controllers")
    2584   (let* ((textstorage  (slot-value self 'textstorage))
    2585          (window (%hemlock-frame-for-textstorage
    2586                   hemlock-frame
    2587                   textstorage
    2588                   *editor-columns*
    2589                   *editor-rows*
    2590                   nil
    2591                   (textview-background-color self)
    2592                   (user-input-style self)))
    2593          (controller (make-instance
    2594                       'hemlock-editor-window-controller
    2595                       :with-window window)))
    2596     (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
    2597     (#/addWindowController: self controller)
    2598     (#/release controller)
    2599     (ns:with-ns-point  (current-point
    2600                         (or *next-editor-x-pos*
    2601                             (x-pos-for-window window *initial-editor-x-pos*))
    2602                         (or *next-editor-y-pos*
    2603                             (y-pos-for-window window *initial-editor-y-pos*)))
    2604       (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
    2605         (setq *next-editor-x-pos* (ns:ns-point-x new-point)
    2606               *next-editor-y-pos* (ns:ns-point-y new-point))))))
     2553  (with-callback-context "makeWindowControllers"
     2554    (let* ((textstorage  (slot-value self 'textstorage))
     2555           (window (%hemlock-frame-for-textstorage
     2556                    hemlock-frame
     2557                    textstorage
     2558                    *editor-columns*
     2559                    *editor-rows*
     2560                    nil
     2561                    (textview-background-color self)
     2562                    (user-input-style self)))
     2563           (controller (make-instance
     2564                           'hemlock-editor-window-controller
     2565                         :with-window window)))
     2566      (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
     2567      (#/addWindowController: self controller)
     2568      (#/release controller)
     2569      (ns:with-ns-point  (current-point
     2570                          (or *next-editor-x-pos*
     2571                              (x-pos-for-window window *initial-editor-x-pos*))
     2572                          (or *next-editor-y-pos*
     2573                              (y-pos-for-window window *initial-editor-y-pos*)))
     2574        (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
     2575          (setq *next-editor-x-pos* (ns:ns-point-x new-point)
     2576                *next-editor-y-pos* (ns:ns-point-y new-point))))
     2577      (let ((view (hemlock-view window)))
     2578        (hi::handle-hemlock-event view #'(lambda ()
     2579                                           (hi::process-file-options)))))))
    26072580
    26082581
     
    26212594  (call-next-method))
    26222595
    2623 (defun window-visible-range (text-view)
    2624   (let* ((rect (#/visibleRect text-view))
    2625          (layout (#/layoutManager text-view))
    2626          (text-container (#/textContainer text-view))
    2627          (container-origin (#/textContainerOrigin text-view)))
     2596(defmethod view-screen-lines ((view hi:hemlock-view))
     2597    (let* ((pane (hi::hemlock-view-pane view)))
     2598      (floor (ns:ns-size-height (#/contentSize (text-pane-scroll-view pane)))
     2599             (text-view-line-height (text-pane-text-view pane)))))
     2600
     2601;; Beware this doesn't seem to take horizontal scrolling into account.
     2602(defun visible-charpos-range (tv)
     2603  (let* ((rect (#/visibleRect tv))
     2604         (container-origin (#/textContainerOrigin tv))
     2605         (layout (#/layoutManager tv)))
    26282606    ;; Convert from view coordinates to container coordinates
    26292607    (decf (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
    26302608    (decf (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y))
    26312609    (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
    2632                          layout rect text-container))
    2633            (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
    2634                         layout glyph-range +null-ptr+)))
     2610                         layout rect (#/textContainer tv)))
     2611           (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
     2612                        layout glyph-range +null-ptr+)))
    26352613      (values (pref char-range :<NSR>ange.location)
    2636               (pref char-range :<NSR>ange.length)))))
    2637    
    2638 (defun hi::scroll-window (textpane n)
    2639   (when n
    2640     (let* ((sv (text-pane-scroll-view textpane))
    2641            (tv (text-pane-text-view textpane))
    2642            (char-height (text-view-char-height tv))
    2643            (sv-height (ns:ns-size-height (#/contentSize sv)))
    2644            (nlines (floor sv-height char-height))
    2645            (count (case n
    2646                     (:page-up (- nlines))
    2647                     (:page-down nlines)
    2648                     (t n))))
    2649       (multiple-value-bind (pages lines) (floor (abs count) nlines)
    2650         (dotimes (i pages)
    2651           (if (< count 0)
    2652               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2653                tv
    2654                (@selector #/scrollPageUp:)
    2655                +null-ptr+
    2656                t)
    2657               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2658                tv
    2659                (@selector #/scrollPageDown:)
    2660                +null-ptr+
    2661                t)))
    2662         (dotimes (i lines)
    2663           (if (< count 0)
    2664               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2665                tv
    2666                (@selector #/scrollLineUp:)
    2667                +null-ptr+
    2668                t)
    2669               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2670                tv
    2671                (@selector #/scrollLineDown:)
    2672                +null-ptr+
    2673                t))))
    2674       ;; If point is not on screen, move it.
    2675       (let* ((point (hi::current-point))
    2676              (point-pos (mark-absolute-position point)))
    2677         (multiple-value-bind (win-pos win-len) (window-visible-range tv)
    2678           (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len)))
    2679             (let* ((point (hi::current-point-collapsing-selection))
    2680                    (cache (hemlock-buffer-string-cache
    2681                            (#/hemlockString (#/textStorage tv)))))
    2682               (move-hemlock-mark-to-absolute-position point cache win-pos)
    2683               ;; We should be done, but unfortunately, well, we're not.
    2684               ;; Something insists on recentering around point, so fake it out
    2685               #-work-around-overeager-centering
    2686               (or (hi::line-offset point (floor nlines 2))
    2687                   (if (< count 0)
    2688                       (hi::buffer-start point)
    2689                       (hi::buffer-end point))))))))))
    2690 
    2691 
    2692 (defmethod hemlock::center-text-pane ((pane text-pane))
    2693   (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2694    (text-pane-text-view pane)
    2695    (@selector #/centerSelectionInVisibleArea:)
    2696    +null-ptr+
    2697    t))
    2698 
     2614              (pref char-range :<NSR>ange.length)))))
     2615
     2616(defun charpos-xy (tv charpos)
     2617  (let* ((layout (#/layoutManager tv))
     2618         (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
     2619                       layout
     2620                       (ns:make-ns-range charpos 0)
     2621                       +null-ptr+))
     2622         (rect (#/boundingRectForGlyphRange:inTextContainer:
     2623                layout
     2624                glyph-range
     2625                (#/textContainer tv)))
     2626         (container-origin (#/textContainerOrigin tv)))
     2627    (values (+ (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
     2628            (+ (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y)))))
     2629
     2630;;(nth-value 1 (charpos-xy tv (visible-charpos-range tv))) - this is smaller as it
     2631;; only includes lines fully scrolled off...
     2632(defun text-view-vscroll (tv)
     2633  ;; Return the number of pixels scrolled off the top of the view.
     2634  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
     2635         (clip-view (#/contentView scroll-view))
     2636         (bounds (#/bounds clip-view)))
     2637    (ns:ns-rect-y bounds)))
     2638
     2639(defun set-text-view-vscroll (tv vscroll)
     2640  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
     2641         (clip-view (#/contentView scroll-view))
     2642         (bounds (#/bounds clip-view)))
     2643    (decf vscroll (mod vscroll (text-view-line-height tv))) ;; show whole line
     2644    (ns:with-ns-point (new-origin (ns:ns-rect-x bounds) vscroll)
     2645      (#/scrollToPoint: clip-view (#/constrainScrollPoint: clip-view new-origin))
     2646      (#/reflectScrolledClipView: scroll-view clip-view))))
     2647
     2648(defun scroll-by-lines (tv nlines)
     2649  "Change the vertical origin of the containing scrollview's clipview"
     2650  (set-text-view-vscroll tv (+ (text-view-vscroll tv)
     2651                               (* nlines (text-view-line-height tv)))))
     2652
     2653;; TODO: should be a hemlock variable..
     2654(defvar *next-screen-context-lines* 2)
     2655
     2656(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) how &optional where)
     2657  (assume-cocoa-thread)
     2658  (let* ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
     2659    (when (eq how :line)
     2660      (setq where (require-type where '(integer 0)))
     2661      (let* ((line-y (nth-value 1 (charpos-xy tv where)))
     2662             (top-y (text-view-vscroll tv))
     2663             (nlines (floor (- line-y top-y) (text-view-line-height tv))))
     2664        (setq how :lines-down where nlines)))
     2665    (ecase how
     2666      (:center-selection
     2667       (#/centerSelectionInVisibleArea: tv +null-ptr+))
     2668      (:page-up
     2669       (require-type where 'null)
     2670       ;; TODO: next-screen-context-lines
     2671       (scroll-by-lines tv (- *next-screen-context-lines* (view-screen-lines view))))
     2672      (:page-down
     2673       (require-type where 'null)
     2674       (scroll-by-lines tv (- (view-screen-lines view) *next-screen-context-lines*)))
     2675      (:lines-up
     2676       (scroll-by-lines tv (- (require-type where 'integer))))
     2677      (:lines-down
     2678       (scroll-by-lines tv (require-type where 'integer))))
     2679    ;; If point is not on screen, move it.
     2680    (let* ((point (hi::current-point))
     2681           (point-pos (hi::mark-absolute-position point)))
     2682      (multiple-value-bind (win-pos win-len) (visible-charpos-range tv)
     2683        (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len)))
     2684          (let* ((point (hi::current-point-collapsing-selection))
     2685                 (cache (hemlock-buffer-string-cache (#/hemlockString (#/textStorage tv)))))
     2686            (move-hemlock-mark-to-absolute-position point cache win-pos)
     2687            (update-hemlock-selection (#/textStorage tv))))))))
    26992688
    27002689(defun iana-charset-name-of-nsstringencoding (ns)
     
    27882777  (make-editor-style-map))
    27892778
    2790 ;;; This needs to run on the main thread.
    2791 (objc:defmethod (#/updateHemlockSelection :void) ((self hemlock-text-storage))
     2779;;; This needs to run on the main thread.  Sets the cocoa selection from the
     2780;;; hemlock selection.
     2781(defmethod update-hemlock-selection ((self hemlock-text-storage))
    27922782  (assume-cocoa-thread)
    2793   (let* ((string (#/hemlockString self))
    2794          (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string)))
    2795          (hi::*current-buffer* buffer)
    2796          (point (hi::buffer-point buffer))
    2797          (pointpos (mark-absolute-position point))
    2798          (location pointpos)
    2799          (len 0))
    2800     (when (hemlock::%buffer-region-active-p buffer)
    2801       (let* ((mark (hi::buffer-%mark buffer)))
    2802         (when mark
    2803           (let* ((markpos (mark-absolute-position mark)))
    2804             (if (< markpos pointpos)
    2805               (setq location markpos len (- pointpos markpos))
    2806               (if (< pointpos markpos)
    2807                 (setq location pointpos len (- markpos pointpos))))))))
    2808     #+debug
    2809     (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
    2810              :int (hi::mark-charpos point) :int pointpos)
    2811     (for-each-textview-using-storage
    2812      self
    2813      #'(lambda (tv)
    2814          (#/updateSelection:length:affinity: tv location len (if (eql location 0) #$NSSelectionAffinityUpstream #$NSSelectionAffinityDownstream))))))
    2815 
    2816 
    2817 (defun hi::allocate-temporary-object-pool ()
    2818   (create-autorelease-pool))
    2819 
    2820 (defun hi::free-temporary-objects (pool)
    2821   (release-autorelease-pool pool))
    2822 
     2783  (let ((buffer (hemlock-buffer self)))
     2784    (multiple-value-bind (start end) (hi:buffer-selection-range buffer)
     2785      #+debug
     2786      (#_NSLog #@"update Hemlock selection: charpos = %d, abspos = %d"
     2787               :int (hi::mark-charpos (hi::buffer-point buffer)) :int start)
     2788      (for-each-textview-using-storage
     2789       self
     2790       #'(lambda (tv)
     2791           (#/updateSelection:length:affinity: tv
     2792                                               start
     2793                                               (- end start)
     2794                                               (if (eql start 0)
     2795                                                 #$NSSelectionAffinityUpstream
     2796                                                 #$NSSelectionAffinityDownstream)))))))
     2797
     2798;; This should be invoked by any command that modifies the buffer, so it can show the
     2799;; user what happened...  This ensures the Cocoa selection is made visible, so it
     2800;; assumes the Cocoa selection has already been synchronized with the hemlock one.
     2801(defmethod hemlock-ext:ensure-selection-visible ((view hi:hemlock-view))
     2802  (let ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
     2803    (#/scrollRangeToVisible: tv (#/selectedRange tv))))
    28232804
    28242805(defloadvar *general-pasteboard* nil)
     
    28612842  (let* ((pb (general-pasteboard))
    28622843         (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType))))
     2844    #+GZ (log-debug "   string = ~s" string)
    28632845    (unless (%null-ptr-p string)
    28642846      (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*)))
     
    28842866
    28852867
    2886 (defun hi::edit-definition (name)
    2887   (let* ((info (ccl::get-source-files-with-types&classes name)))
    2888     (when (null info)
    2889       (let* ((seen (list name))
    2890              (found ())
    2891              (pname (symbol-name name)))
    2892         (dolist (pkg (list-all-packages))
    2893           (let ((sym (find-symbol pname pkg)))
    2894             (when (and sym (not (member sym seen)))
    2895               (let ((new (ccl::get-source-files-with-types&classes sym)))
    2896                 (when new
    2897                   (setq info (append new info))
    2898                   (push sym found)))
    2899               (push sym seen))))
    2900         (when found
    2901           ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
    2902           (hi::loud-message "No definitions for ~s, using ~s instead"
    2903                             name (if (cdr found) found (car found))))))
    2904     (if info
    2905       (if (cdr info)
    2906         (edit-definition-list name info)
    2907         (edit-single-definition name (car info)))
    2908       (hi::editor-error "No known definitions for ~s" name))))
    2909 
    2910 
    2911 (defun find-definition-in-document (name indicator document)
    2912   (let* ((buffer (hemlock-document-buffer document))
    2913          (hi::*current-buffer* buffer))
    2914     (hemlock::find-definition-in-buffer buffer name indicator)))
    2915 
    2916 
    2917 (defstatic *edit-definition-id-map* (make-id-map))
    2918 
    2919 ;;; Need to force things to happen on the main thread.
    2920 (defclass cocoa-edit-definition-request (ns:ns-object)
    2921     ((name-id :foreign-type :int)
    2922      (info-id :foreign-type :int))
    2923   (:metaclass ns:+ns-object))
    2924 
    2925 (objc:defmethod #/initWithName:info:
    2926     ((self cocoa-edit-definition-request)
    2927      (name :int) (info :int))
    2928   (#/init self)
    2929   (setf (slot-value self 'name-id) name
    2930         (slot-value self 'info-id) info)
    2931   self)
    2932 
    2933 (objc:defmethod (#/editDefinition: :void)
    2934     ((self hemlock-document-controller) request)
    2935   (let* ((name (id-map-free-object *edit-definition-id-map* (slot-value request 'name-id)))
    2936          (info (id-map-free-object *edit-definition-id-map* (slot-value request 'info-id))))
    2937     (destructuring-bind (indicator . pathname) info
    2938       (let* ((namestring (native-translated-namestring pathname))
    2939              (url (#/initFileURLWithPath:
    2940                    (#/alloc ns:ns-url)
    2941                    (%make-nsstring namestring)))
    2942              (document (#/openDocumentWithContentsOfURL:display:error:
    2943                         self
    2944                         url
    2945                         nil
    2946                         +null-ptr+)))
    2947         (unless (%null-ptr-p document)
    2948           (if (= (#/count (#/windowControllers document)) 0)
    2949             (#/makeWindowControllers document))
    2950           (find-definition-in-document name indicator document)
    2951           (#/updateHemlockSelection (slot-value document 'textstorage))
    2952           (#/showWindows document))))))
    2953 
    2954 (defun edit-single-definition (name info)
    2955   (let* ((request (make-instance 'cocoa-edit-definition-request
    2956                                  :with-name (assign-id-map-id *edit-definition-id-map* name)
    2957                                  :info (assign-id-map-id *edit-definition-id-map* info))))
    2958     (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2959      (#/sharedDocumentController ns:ns-document-controller)
    2960      (@selector #/editDefinition:)
    2961      request
    2962      t)))
    2963 
    2964                                        
    2965 (defun edit-definition-list (name infolist)
     2868;; This is called by stuff that makes a window programmatically, e.g. m-. or grep.
     2869;; But the Open and New menus invoke the cocoa fns below directly. So just changing
     2870;; things here will not change how the menus create views.  Instead,f make changes to
     2871;; the subfunctions invoked by the below, e.g. #/readFromURL or #/makeWindowControllers.
     2872(defun find-or-make-hemlock-view (&optional pathname)
     2873  (assume-cocoa-thread)
     2874  (rlet ((perror :id +null-ptr+))
     2875    (let* ((doc (if pathname
     2876                  (#/openDocumentWithContentsOfURL:display:error:
     2877                   (#/sharedDocumentController ns:ns-document-controller)
     2878                   (pathname-to-url pathname)
     2879                   #$YES
     2880                   perror)
     2881                  (let ((*last-document-created* nil))
     2882                    (#/newDocument:
     2883                     (#/sharedDocumentController hemlock-document-controller)
     2884                     +null-ptr+)
     2885                    *last-document-created*))))
     2886      #+gz (log-debug "created ~s" doc)
     2887      (when (%null-ptr-p doc)
     2888        (error "Couldn't open ~s: ~a" pathname
     2889               (let ((error (pref perror :id)))
     2890                 (if (%null-ptr-p error)
     2891                   "unknown error encountered"
     2892                   (lisp-string-from-nsstring (#/localizedDescription error))))))
     2893      (front-view-for-buffer (hemlock-buffer doc)))))
     2894
     2895(defun cocoa-edit-single-definition (name info)
     2896  (assume-cocoa-thread)
     2897  (destructuring-bind (indicator . pathname) info
     2898    (let ((view (find-or-make-hemlock-view pathname)))
     2899      (hi::handle-hemlock-event view
     2900                                #'(lambda ()
     2901                                    (hemlock::find-definition-in-buffer name indicator))))))
     2902
     2903(defun hemlock-ext:edit-single-definition (name info)
     2904  (execute-in-gui #'(lambda () (cocoa-edit-single-definition name info))))
     2905
     2906(defun hemlock-ext:open-sequence-dialog (&key title sequence action (printer #'prin1))
    29662907  (make-instance 'sequence-window-controller
    2967                  :sequence infolist
    2968                  :result-callback #'(lambda (info)
    2969                                       (edit-single-definition name info))
    2970                  :display #'(lambda (item stream)
    2971                               (prin1 (car item) stream))
    2972                  :title (format nil "Definitions of ~s" name)))
    2973 
    2974                                        
     2908    :title title
     2909    :sequence sequence
     2910    :result-callback action
     2911    :display printer))
     2912
    29752913(objc:defmethod (#/documentClassForType: :<C>lass) ((self hemlock-document-controller)
    29762914                                                    type)
     
    30102948   t))
    30112949
     2950(defun hemlock-ext:raise-buffer-view (buffer &optional action)
     2951  "Bring a window containing buffer to front and then execute action in
     2952   the window.  Returns before operation completes."
     2953  ;; Queue for after this event, so don't screw up current context.
     2954  (queue-for-gui #'(lambda ()
     2955                     (let ((doc (hi::buffer-document buffer)))
     2956                       (unless (and doc (not (%null-ptr-p doc)))
     2957                         (hi:editor-error "Deleted buffer: ~s" buffer))
     2958                       (#/showWindows doc)
     2959                       (when action
     2960                         (hi::handle-hemlock-event (front-view-for-buffer buffer) action))))))
    30122961
    30132962;;; Enable CL:ED
    30142963(defun cocoa-edit (&optional arg)
    3015   (let* ((document-controller (#/sharedDocumentController hemlock-document-controller)))
    3016     (cond ((null arg)
    3017            (#/performSelectorOnMainThread:withObject:waitUntilDone:
    3018             document-controller
    3019             (@selector #/newDocument:)
    3020             +null-ptr+
    3021             t))
    3022           ((or (typep arg 'string)
    3023                (typep arg 'pathname))
    3024            (unless (probe-file arg)
    3025              (ccl::touch arg))
    3026            (with-autorelease-pool
    3027              (let* ((url (pathname-to-url arg))
    3028                     (signature (#/methodSignatureForSelector:
    3029                                 document-controller
    3030                                 (@selector #/openDocumentWithContentsOfURL:display:error:)))
    3031                     (invocation (#/invocationWithMethodSignature: ns:ns-invocation
    3032                                                                   signature)))
    3033              
    3034                (#/setTarget: invocation document-controller)
    3035                (#/setSelector: invocation (@selector #/openDocumentWithContentsOfURL:display:error:))
    3036                (rlet ((p :id)
    3037                       (q :<BOOL>)
    3038                       (perror :id +null-ptr+))
    3039                  (setf (pref p :id) url
    3040                        (pref q :<BOOL>) #$YES)
    3041                  (#/setArgument:atIndex: invocation p 2)
    3042                  (#/setArgument:atIndex: invocation q 3)
    3043                  (#/setArgument:atIndex: invocation perror 4)
    3044                  (#/performSelectorOnMainThread:withObject:waitUntilDone:
    3045                   invocation
    3046                   (@selector #/invoke)
    3047                   +null-ptr+
    3048                   t)))))
    3049           ((ccl::valid-function-name-p arg)
    3050            (hi::edit-definition arg))
    3051           (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p)))))
    3052     t))
     2964  (cond ((or (null arg)
     2965             (typep arg 'string)
     2966             (typep arg 'pathname))
     2967         (execute-in-gui #'(lambda () (find-or-make-hemlock-view arg))))
     2968        ((ccl::valid-function-name-p arg)
     2969         (hemlock::edit-definition arg)
     2970         nil)
     2971        (t (report-bad-arg arg '(or null string pathname (satisfies ccl::valid-function-name-p))))))
    30532972
    30542973(setq ccl::*resident-editor-hook* 'cocoa-edit)
  • trunk/source/cocoa-ide/cocoa-grep.lisp

    r7804 r8428  
    77(defvar *grep-program* "grep")
    88
    9 (defclass cocoa-edit-grep-line-request (ns:ns-object)
    10   ((file-id :foreign-type :int)
    11    (line-num :foreign-type :int))
    12   (:metaclass ns:+ns-object))
    13 
    14 (objc:defmethod #/initWithFile:line:
    15                 ((self cocoa-edit-grep-line-request) (file :int) (line :int))
    16   (#/init self)
    17   (setf (slot-value self 'file-id) file
    18         (slot-value self 'line-num) line)
    19   self)
    20 
    21 (objc:defmethod (#/editGrepLine: :void)
    22     ((self hemlock-document-controller) request)
    23   (let* ((file (id-map-free-object *edit-definition-id-map* (slot-value request 'file-id)))
    24          (line-num (slot-value request 'line-num))
    25          (namestring (native-translated-namestring file))
    26          (url (#/initFileURLWithPath:
    27                (#/alloc ns:ns-url)
    28                (%make-nsstring namestring)))
    29          (document (#/openDocumentWithContentsOfURL:display:error:
    30                     self
    31                     url
    32                     nil
    33                     +null-ptr+)))
    34     (unless (%null-ptr-p document)
    35       (when (= (#/count (#/windowControllers document)) 0)
    36         (#/makeWindowControllers document))
    37       (let* ((buffer (hemlock-document-buffer document))
    38              (hi::*current-buffer* buffer))
    39         (edit-grep-line-in-buffer line-num))
    40       (#/updateHemlockSelection (slot-value document 'textstorage))
    41       (#/showWindows document))))
     9(defun cocoa-edit-grep-line (file line-num)
     10  (assume-cocoa-thread)
     11  (let ((view (find-or-make-hemlock-view file)))
     12    (hi::handle-hemlock-event view #'(lambda ()
     13                                       (edit-grep-line-in-buffer line-num)))))
    4214
    4315(defun edit-grep-line-in-buffer (line-num)
     
    6032  (multiple-value-bind (file line-num) (parse-grep-line line)
    6133    (when file
    62       (let* ((request (make-instance 'cocoa-edit-grep-line-request
    63                                      :with-file (assign-id-map-id *edit-definition-id-map* file)
    64                                      :line line-num)))
    65         (#/performSelectorOnMainThread:withObject:waitUntilDone:
    66          (#/sharedDocumentController ns:ns-document-controller)
    67          (@selector #/editGrepLine:)
    68          request
    69          t)))))
     34      (execute-in-gui #'(lambda ()
     35                          (cocoa-edit-grep-line file line-num))))))
    7036
    7137(defun grep-comment-line-p (line)
  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r8149 r8428  
    2727(def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output")
    2828
    29 ;;; Setup the server end of a pty pair.
    30 (defun setup-server-pty (pty)
    31   (set-tty-raw pty)
    32   pty)
    33 
    34 ;;; Setup the client end of a pty pair.
    35 (defun setup-client-pty (pty)
    36   ;; Since the same (Unix) process will be reading from and writing
    37   ;; to the pty, it's critical that we make the pty non-blocking.
    38   ;; Has this been true for the last few years (native threads) ?
    39   ;(fd-set-flag pty #$O_NONBLOCK)
    40   (set-tty-raw pty)
    41   #+no
    42   (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG))
    43   #+no
    44   (disable-tty-output-modes pty #$ONLCR) 
    45   pty)
     29(defun hemlock-ext:read-only-listener-p ()
     30  *read-only-listener*)
     31
     32
     33(defclass cocoa-listener-input-stream (fundamental-character-input-stream)
     34  ((queue :initform ())
     35   (queue-lock :initform (make-lock))
     36   (read-lock :initform (make-lock))
     37   (queue-semaphore :initform (make-semaphore)) ;; total queue count
     38   (text-semaphore :initform (make-semaphore))  ;; text-only queue count
     39   (cur-string :initform nil)
     40   (cur-string-pos :initform 0)
     41   (cur-env :initform nil)
     42   (cur-sstream :initform nil)))
     43
     44(defmethod dequeue-listener-char ((stream cocoa-listener-input-stream) wait-p)
     45  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
     46    (with-lock-grabbed (read-lock)
     47      (or (with-lock-grabbed (queue-lock)
     48            (when (< cur-string-pos (length cur-string))
     49              (prog1 (aref cur-string cur-string-pos) (incf cur-string-pos))))
     50          (loop
     51            (unless (if wait-p
     52                      (wait-on-semaphore text-semaphore nil "Listener Input")
     53                      (timed-wait-on-semaphore text-semaphore 0))
     54              (return nil))
     55            (assert (timed-wait-on-semaphore queue-semaphore 0) () "queue/text mismatch!")
     56            (with-lock-grabbed (queue-lock)
     57              (let* ((s (find-if #'stringp queue)))
     58                (assert s () "queue/semaphore mismatch!")
     59                (setq queue (delq s queue 1))
     60                (when (< 0 (length s))
     61                  (setf cur-string s cur-string-pos 1)
     62                  (return (aref s 0))))))))))
     63
     64(defmethod ccl::read-toplevel-form ((stream cocoa-listener-input-stream) eof-value)
     65  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos cur-sstream cur-env) stream
     66    (with-lock-grabbed (read-lock)
     67      (loop
     68        (when cur-sstream
     69          #+gz (log-debug "About to recursively read from sstring in env: ~s" cur-env)
     70          (let* ((env cur-env)
     71                 (form (progv (car env) (cdr env)
     72                         (ccl::read-toplevel-form cur-sstream eof-value)))
     73                 (last-form-in-selection (not (listen cur-sstream))))
     74            #+gz (log-debug " --> ~s" form)
     75            (when last-form-in-selection
     76              (setf cur-sstream nil cur-env nil))
     77            (return (values form env (or last-form-in-selection ccl::*verbose-eval-selection*)))))
     78        (when (with-lock-grabbed (queue-lock)
     79                (loop
     80                  unless (< cur-string-pos (length cur-string)) return nil
     81                  unless (whitespacep (aref cur-string cur-string-pos)) return t
     82                  do (incf cur-string-pos)))
     83          (return (values (call-next-method) nil t)))
     84        (wait-on-semaphore queue-semaphore nil "Toplevel Read")
     85        (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
     86          (cond ((stringp val)
     87                 (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
     88                 (setq cur-string val cur-string-pos 0))
     89                (t
     90                 (destructuring-bind (string package-name pathname) val
     91                   (let ((env (cons '(*loading-file-source-file*) (list pathname))))
     92                     (when package-name
     93                       (push '*package* (car env))
     94                       (push (ccl::pkg-arg package-name) (cdr env)))
     95                     (setf cur-sstream (make-string-input-stream string) cur-env env))))))))))
     96
     97(defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname)
     98  (with-slots (queue-lock queue queue-semaphore) stream
     99    (with-lock-grabbed (queue-lock)
     100      (setq queue (nconc queue (list (list string package-name pathname))))
     101      (signal-semaphore queue-semaphore))))
     102
     103(defmethod enqueue-listener-input ((stream cocoa-listener-input-stream) string)
     104  (with-slots (queue-lock queue queue-semaphore text-semaphore) stream
     105    (with-lock-grabbed (queue-lock)
     106      (setq queue (nconc queue (list string)))
     107      (signal-semaphore queue-semaphore)
     108      (signal-semaphore text-semaphore))))
     109
     110(defmethod stream-read-char-no-hang ((stream cocoa-listener-input-stream))
     111  (dequeue-listener-char stream nil))
     112
     113(defmethod stream-read-char ((stream cocoa-listener-input-stream))
     114  (dequeue-listener-char stream t))
     115
     116(defmethod stream-unread-char ((stream cocoa-listener-input-stream) char)
     117  ;; Can't guarantee the right order of reads/unreads, just make sure not to
     118  ;; introduce any internal inconsistencies (and dtrt for the non-conflict case).
     119  (with-slots (queue queue-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
     120    (with-lock-grabbed (queue-lock)
     121      (cond ((>= cur-string-pos (length cur-string))
     122             (push (string char) queue)
     123             (signal-semaphore queue-semaphore)
     124             (signal-semaphore text-semaphore))
     125            ((< 0 cur-string-pos)
     126             (decf cur-string-pos)
     127             (setf (aref cur-string cur-string-pos) char))
     128            (t (setf cur-string (concatenate 'string (string char) cur-string)))))))
     129
     130(defmethod ccl::stream-eof-transient-p ((stream cocoa-listener-input-stream))
     131  t)
     132
     133(defmethod stream-clear-input ((stream cocoa-listener-input-stream))
     134  (with-slots (queue-lock cur-string cur-string-pos cur-sstream cur-env) stream
     135    (with-lock-grabbed (queue-lock)
     136      (setf cur-string nil cur-string-pos 0 cur-sstream nil cur-env nil))))
     137
     138(defparameter $listener-flush-limit 100)
     139
     140(defclass cocoa-listener-output-stream (fundamental-character-output-stream)
     141  ((lock :initform (make-lock))
     142   (hemlock-view :initarg :hemlock-view)
     143   (data :initform (make-array (1+ $listener-flush-limit)
     144                               :adjustable t :fill-pointer 0
     145                               :element-type 'character))))
     146
     147(defmethod stream-element-type ((stream cocoa-listener-output-stream))
     148  (with-slots (data) stream
     149    (array-element-type data)))
     150
     151(defmethod ccl:stream-write-char ((stream cocoa-listener-output-stream) char)
     152  (with-slots (data lock) stream
     153    (when (with-lock-grabbed (lock)
     154            (>= (vector-push-extend char data) $listener-flush-limit))
     155      (stream-force-output stream))))
     156
     157;; This isn't really thread safe, but it's not too bad...  I'll take a chance - trying
     158;; to get it to execute in the gui thread is too deadlock-prone.
     159(defmethod hemlock-listener-output-mark-column ((view hi::hemlock-view))
     160  (let* ((output-region (hi::variable-value 'hemlock::current-output-font-region
     161                                            :buffer (hi::hemlock-view-buffer view))))
     162    (hi::mark-charpos (hi::region-end output-region))))
     163
     164;; TODO: doesn't do the right thing for embedded tabs (in buffer or data)
     165(defmethod ccl:stream-line-column ((stream cocoa-listener-output-stream))
     166  (with-slots (hemlock-view data lock) stream
     167    (with-lock-grabbed (lock)
     168      (let* ((n (length data))
     169             (pos (position #\Newline data :from-end t)))
     170        (if (null pos)
     171          (+ (hemlock-listener-output-mark-column hemlock-view) n)
     172          (- n pos 1))))))
     173
     174(defmethod ccl:stream-fresh-line  ((stream cocoa-listener-output-stream))
     175  (with-slots (hemlock-view data lock) stream
     176    (when (with-lock-grabbed (lock)
     177            (let ((n (length data)))
     178              (unless (if (= n 0)
     179                        (= (hemlock-listener-output-mark-column hemlock-view) 0)
     180                        (eq (aref data (1- n)) #\Newline))
     181                (>= (vector-push-extend #\Newline data) $listener-flush-limit))))
     182      (stream-force-output stream))))
     183
     184(defmethod ccl::stream-finish-output ((stream cocoa-listener-output-stream))
     185  (stream-force-output stream))
     186
     187(defmethod ccl:stream-force-output ((stream cocoa-listener-output-stream))
     188  (if (typep *current-process* 'appkit-process)
     189    (with-slots (hemlock-view data lock) stream
     190      (with-lock-grabbed (lock)
     191        (when (> (fill-pointer data) 0)
     192          (append-output hemlock-view data)
     193          (setf (fill-pointer data) 0))))
     194    (with-slots (data) stream
     195      (when (> (fill-pointer data) 0)
     196        (queue-for-gui #'(lambda () (stream-force-output stream)))))))
     197
     198(defmethod ccl:stream-clear-output ((stream cocoa-listener-output-stream))
     199  (with-slots (data lock) stream
     200    (with-lock-grabbed (lock)
     201      (setf (fill-pointer data) 0))))
     202
     203(defmethod ccl:stream-line-length ((stream cocoa-listener-output-stream))
     204  ;; TODO: ** compute length from window size **
     205  80)
    46206
    47207
     
    51211    ((input-stream :reader cocoa-listener-process-input-stream)
    52212     (output-stream :reader cocoa-listener-process-output-stream)
    53      (input-peer-stream :reader cocoa-listener-process-input-peer-stream)
    54213     (backtrace-contexts :initform nil
    55214                         :accessor cocoa-listener-process-backtrace-contexts)
    56      (window :reader cocoa-listener-process-window)
    57      (buffer :initform nil :reader cocoa-listener-process-buffer)))
     215     (window :reader cocoa-listener-process-window)))
    58216 
    59217
    60 (defun new-cocoa-listener-process (procname input-fd output-fd peer-fd window buffer)
    61   (let* ((input-stream (ccl::make-selection-input-stream
    62                         input-fd
    63                         :peer-fd peer-fd
    64                         :elements-per-buffer (#_fpathconf
    65                                               input-fd
    66                                               #$_PC_MAX_INPUT)
    67                         :encoding :utf-8))
    68          (output-stream (ccl::make-fd-stream output-fd :direction :output
    69                                              :sharing :lock
    70                                              :elements-per-buffer
    71                                              (#_fpathconf
    72                                               output-fd
    73                                               #$_PC_MAX_INPUT)
    74                                              :encoding :utf-8))
    75          (peer-stream (ccl::make-fd-stream peer-fd :direction :output
    76                                            :sharing :lock
    77                                            :elements-per-buffer
    78                                            (#_fpathconf
    79                                             peer-fd
    80                                             #$_PC_MAX_INPUT)
    81                                            :encoding :utf-8))
     218(defun new-cocoa-listener-process (procname window)
     219  (let* ((input-stream (make-instance 'cocoa-listener-input-stream))
     220         (output-stream (make-instance 'cocoa-listener-output-stream
     221                          :hemlock-view (hemlock-view window)))
     222         
    82223         (proc
    83224          (ccl::make-mcl-listener-process
     
    85226           input-stream
    86227           output-stream
     228           ;; cleanup function
    87229           #'(lambda ()
    88                (let* ((buf (find *current-process* hi:*buffer-list*
    89                                  :key #'hi::buffer-process))
    90                       (doc (if buf (hi::buffer-document buf))))
    91                  (when doc
    92                    (setf (hi::buffer-process buf) nil)
    93                    (#/performSelectorOnMainThread:withObject:waitUntilDone:
    94                     doc
    95                     (@selector #/close)
    96                     +null-ptr+
    97                     nil))))
     230               (mapcar #'(lambda (buf)
     231                           (when (eq (buffer-process buf) *current-process*)
     232                             (let ((doc (hi::buffer-document buf)))
     233                               (when doc
     234                                 (setf (hemlock-document-process doc) nil) ;; so #/close doesn't kill it.
     235                                 (#/performSelectorOnMainThread:withObject:waitUntilDone:
     236                                  doc
     237                                  (@selector #/close)
     238                                  +null-ptr+
     239                                  nil)))))
     240                       hi:*buffer-list*))
    98241           :initial-function
    99242           #'(lambda ()
    100243               (setq ccl::*listener-autorelease-pool* (create-autorelease-pool))
    101244               (ccl::listener-function))
     245           :echoing nil
    102246           :class 'cocoa-listener-process)))
    103247    (setf (slot-value proc 'input-stream) input-stream)
    104248    (setf (slot-value proc 'output-stream) output-stream)
    105     (setf (slot-value proc 'input-peer-stream) peer-stream)
    106249    (setf (slot-value proc 'window) window)
    107     (setf (slot-value proc 'buffer) buffer)
    108250    proc))
    109          
    110 
     251 
    111252(defclass hemlock-listener-frame (hemlock-frame)
    112253    ()
     
    116257
    117258(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
    118     ((filehandle :foreign-type :id)     ;Filehandle for I/O
    119      (clientfd :foreign-type :int)      ;Client (listener)'s side of pty
    120      (nextra :foreign-type :int)        ;count of untranslated bytes remaining
    121      (translatebuf :foreign-type :address) ;buffer for utf8 translation
    122      (bufsize :foreign-type :int)       ;size of translatebuf
    123      )
     259    ()
    124260  (:metaclass ns:+ns-object)
    125261  )
     
    133269 
    134270
    135 (objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w)
    136   (let* ((new (call-next-method w)))
    137     (unless (%null-ptr-p new)
    138       (multiple-value-bind (server client) (ignore-errors (open-pty-pair))
    139         (when server
    140           (let* ((fh (make-instance
    141                       'ns:ns-file-handle
    142                       :with-file-descriptor (setup-server-pty server)
    143                       :close-on-dealloc t)))
    144             (setf (slot-value new 'filehandle) fh)
    145             (setf (slot-value new 'clientfd) (setup-client-pty client))
    146             (let* ((bufsize #$BUFSIZ)
    147                    (buffer (#_malloc bufsize)))
    148               (setf (slot-value new 'translatebuf) buffer
    149                     (slot-value new 'bufsize) bufsize
    150                     (slot-value new 'nextra) 0))
    151             (#/addObserver:selector:name:object:
    152              (#/defaultCenter ns:ns-notification-center)
    153              new
    154              (@selector #/gotData:)
    155              #&NSFileHandleReadCompletionNotification
    156              fh)
    157             (#/readInBackgroundAndNotify fh)))))
    158     new))
    159 
    160 (objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller)
    161                                     notification)
    162   (with-slots (filehandle nextra translatebuf bufsize) self
    163     (let* ((data (#/objectForKey: (#/userInfo notification)
    164                                   #&NSFileHandleNotificationDataItem))
    165            (document (#/document self))
    166            (encoding (load-time-value (get-character-encoding :utf-8)))
    167            (data-length (#/length data))
    168            (buffer (hemlock-document-buffer document))
    169            (n nextra)
    170            (cursize bufsize)
    171            (need (+ n data-length))
    172            (xlate translatebuf)
    173            (fh filehandle))
    174       (when (> need cursize)
    175         (let* ((new (#_malloc need)))
    176           (dotimes (i n) (setf (%get-unsigned-byte new i)
    177                                (%get-unsigned-byte xlate i)))
    178           (#_free xlate)
    179           (setq xlate new translatebuf new bufsize need)))
    180       #+debug (#_NSLog #@"got %d bytes of data" :int data-length)
    181       (with-macptrs ((target (%inc-ptr xlate n)))
    182         (#/getBytes:range: data target (ns:make-ns-range 0 data-length)))
    183       (let* ((total (+ n data-length)))
    184         (multiple-value-bind (nchars noctets-used)
    185             (funcall (ccl::character-encoding-length-of-memory-encoding-function encoding)
    186                      xlate
    187                      total
    188                      0)
    189           (let* ((string (make-string nchars)))
    190             (funcall (ccl::character-encoding-memory-decode-function encoding)
    191                      xlate
    192                      noctets-used
    193                      0
    194                      string)
    195             (unless (zerop (setq n (- total noctets-used)))
    196               ;; By definition, the number of untranslated octets
    197               ;; can't be more than 3.
    198               (dotimes (i n)
    199                 (setf (%get-unsigned-byte xlate i)
    200                       (%get-unsigned-byte xlate (+ noctets-used i)))))
    201             (setq nextra n)
    202             (hi::enqueue-buffer-operation
    203              buffer
    204              #'(lambda ()
    205                  (unwind-protect
    206                       (progn
    207                         (hi::buffer-document-begin-editing buffer)
    208                         (hemlock::append-buffer-output buffer string))
    209                    (hi::buffer-document-end-editing buffer))))
    210             (#/readInBackgroundAndNotify fh)))))))
    211              
    212 
    213 
    214 (objc:defmethod (#/dealloc :void) ((self hemlock-listener-window-controller))
    215   (#/removeObserver: (#/defaultCenter ns:ns-notification-center) self)
    216   (call-next-method))
    217 
    218271(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
    219272  (let* ((doc (#/document self)))
     
    221274            (not (%null-ptr-p (#/fileURL doc))))
    222275      (call-next-method name)
    223       (let* ((buffer (hemlock-document-buffer doc))
     276      (let* ((buffer (hemlock-buffer doc))
    224277             (bufname (if buffer (hi::buffer-name buffer))))
    225278        (if bufname
     
    232285
    233286(defclass hemlock-listener-document (hemlock-editor-document)
    234     ()
     287  ((process :reader %hemlock-document-process :writer (setf hemlock-document-process)))
    235288  (:metaclass ns:+ns-object))
    236289(declaim (special hemlock-listener-document))
    237290
     291(defgeneric hemlock-document-process (doc)
     292  (:method ((unknown t)) nil)
     293  (:method ((doc hemlock-listener-document)) (%hemlock-document-process doc)))
     294
     295;; Nowadays this is nil except for listeners.
     296(defun buffer-process (buffer)
     297  (hemlock-document-process (hi::buffer-document buffer)))
     298
    238299(defmethod update-buffer-package ((doc hemlock-listener-document) buffer)
    239300  (declare (ignore buffer)))
    240301
    241 (defmethod hi::document-encoding-name ((doc hemlock-listener-document))
     302(defmethod document-encoding-name ((doc hemlock-listener-document))
    242303  "UTF-8")
    243304
     
    248309  *listener-background-color*)
    249310
    250 
    251 (defun hemlock::listener-document-send-string (document string)
    252   (let* ((buffer (hemlock-document-buffer document))
    253          (process (if buffer (hi::buffer-process buffer))))
    254     (if process
    255       (hi::send-string-to-listener-process process string))))
    256 
     311;; For use with the :process-info listener modeline field
     312(defmethod hemlock-ext:buffer-process-description (buffer)
     313  (let ((proc (buffer-process buffer)))
     314    (when proc
     315      (format nil "~a(~d) [~a]"
     316              (ccl:process-name proc)
     317              (ccl::process-serial-number proc)
     318              ;; TODO: this doesn't really work as a modeline item, because the modeline
     319              ;; doesn't get notified when it changes.
     320              (ccl:process-whostate proc)))))
    257321
    258322(objc:defmethod #/topListener ((self +hemlock-listener-document))
     
    264328
    265329(defun symbol-value-in-top-listener-process (symbol)
    266   (let* ((listenerdoc (#/topListener hemlock-listener-document))
    267          (buffer (unless (%null-ptr-p listenerdoc)
    268                    (hemlock-document-buffer listenerdoc)))
    269          (process (if buffer (hi::buffer-process buffer))))
     330  (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document))))
    270331     (if process
    271332       (ignore-errors (symbol-value-in-process symbol process))
    272333       (values nil t))))
    273334 
    274 (defun hi::top-listener-output-stream ()
    275   (let* ((doc (#/topListener hemlock-listener-document)))
    276     (unless (%null-ptr-p doc)
    277       (let* ((buffer (hemlock-document-buffer doc))
    278              (process (if buffer (hi::buffer-process buffer))))
    279         (when (typep process 'cocoa-listener-process)
    280           (cocoa-listener-process-output-stream process))))))
     335(defun hemlock-ext:top-listener-output-stream ()
     336  (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document))))
     337    (when process
     338      (setq process (require-type process 'cocoa-listener-process))
     339      (cocoa-listener-process-output-stream process))))
    281340
    282341
     
    294353                            (format nil
    295354                                    "Listener-~d" *cocoa-listener-count*)))
    296              (buffer (hemlock-document-buffer doc)))
     355             (buffer (hemlock-buffer doc)))
    297356        (setf (hi::buffer-pathname buffer) nil
    298357              (hi::buffer-minor-mode buffer "Listener") t
    299358              (hi::buffer-name buffer) listener-name)
    300         (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
     359        (hi::set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
    301360    doc))
    302361
     
    312371    (setq *next-listener-x-pos* nil
    313372          *next-listener-y-pos* nil))
     373  (let* ((p (shiftf (hemlock-document-process self) nil)))
     374    (when p
     375      (process-kill p)))
    314376  (call-next-method))
    315377
     
    333395                      'hemlock-listener-window-controller
    334396                      :with-window window))
    335          (listener-name (hi::buffer-name (hemlock-document-buffer self))))
     397         (listener-name (hi::buffer-name (hemlock-buffer self))))
    336398    (with-slots (styles) textstorage
    337399      ;; We probably should be more disciplined about
     
    358420        (setf *next-listener-x-pos* (ns:ns-point-x new-point)
    359421              *next-listener-y-pos* (ns:ns-point-y new-point))))
    360     (setf (hi::buffer-process (hemlock-document-buffer self))
    361           (let* ((tty (slot-value controller 'clientfd))
    362                  (peer-tty (#/fileDescriptor (slot-value controller 'filehandle))))
    363             (new-cocoa-listener-process listener-name tty tty peer-tty window (hemlock-document-buffer self))))
     422    (setf (hemlock-document-process self)
     423          (new-cocoa-listener-process listener-name window))
    364424    controller))
    365425
     
    372432  (let* ((range-start (ns:ns-range-location range))
    373433         (range-end (+ range-start (ns:ns-range-length range)))
    374          (buffer (hemlock-document-buffer self))
     434         (buffer (hemlock-buffer self))
    375435         (protected-region (hi::buffer-protected-region buffer)))
    376436    (if protected-region
    377       (let* ((prot-start (mark-absolute-position (hi::region-start protected-region)))
    378              (prot-end (mark-absolute-position (hi::region-end protected-region))))
     437      (let* ((prot-start (hi:mark-absolute-position (hi::region-start protected-region)))
     438             (prot-end (hi:mark-absolute-position (hi::region-end protected-region))))
    379439        (not (or (and (>= range-start prot-start)
    380440                      (< range-start prot-end))
     
    387447(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender)
    388448  (declare (ignore sender))
    389   (let* ((buffer (hemlock-document-buffer self))
    390          (process (if buffer (hi::buffer-process buffer))))
    391     (when (typep process 'cocoa-listener-process)
     449  (let* ((process (hemlock-document-process self)))
     450    (when process
    392451      (ccl::force-break-in-listener process))))
    393452
     
    396455(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender)
    397456  (declare (ignore sender))
    398   (let* ((buffer (hemlock-document-buffer self))
    399          (process (if buffer (hi::buffer-process buffer))))
    400     (when (typep process 'cocoa-listener-process)
     457  (let* ((process (hemlock-document-process self)))
     458    (log-debug  "~&exitBreak process ~s" process)
     459    (when process
    401460      (process-interrupt process #'abort-break))))
    402461
     
    405464
    406465(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
    407   (let* ((buffer (hemlock-document-buffer self))
    408          (process (if buffer (hi::buffer-process buffer))))
    409     (when (typep process 'cocoa-listener-process)
     466  (let* ((process (hemlock-document-process self)))
     467    (when process
    410468      (let* ((context (listener-backtrace-context process)))
    411469        (when context
     
    438496                           
    439497(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender)
    440   (let* ((buffer (hemlock-document-buffer self))
    441          (process (if buffer (hi::buffer-process buffer))))
    442     (when (typep process 'cocoa-listener-process)
     498  (let* ((process (hemlock-document-process self)))
     499    (when process
    443500      (let* ((context (listener-backtrace-context process)))
    444501        (when context
     
    447504(objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
    448505  (declare (ignore sender))
    449   (let* ((buffer (hemlock-document-buffer self))
    450          (process (if buffer (hi::buffer-process buffer))))
    451     (when (typep process 'cocoa-listener-process)
     506  (let* ((process (hemlock-document-process self)))
     507    (when process
    452508      (let* ((context (listener-backtrace-context process)))
    453509        (when context
     
    467523  ;; So far, all actions demand that there be an underlying process, so
    468524  ;; check for that first.
    469   (let* ((buffer (hemlock-document-buffer doc))
    470          (process (if buffer (hi::buffer-process buffer))))
    471     (if (typep process 'cocoa-listener-process)
     525  (let* ((process (hemlock-document-process doc)))
     526    (if process
    472527      (let* ((action (#/action item)))
    473528        (cond
     
    508563
    509564(defmethod ui-object-note-package ((app ns:ns-application) package)
    510   (with-autorelease-pool
    511       (process-interrupt *cocoa-event-process*
    512                          #'(lambda (proc name)
    513                              (dolist (buf hi::*buffer-list*)
    514                                (when (eq proc (hi::buffer-process buf))
    515                                  (setf (hi::variable-value 'hemlock::current-package :buffer buf) name))))
    516                          *current-process*
    517                          (shortest-package-name package))))
     565  (let ((proc *current-process*)
     566        (name (shortest-package-name package)))
     567    (execute-in-gui #'(lambda ()
     568                        (dolist (buf hi::*buffer-list*)
     569                          (when (eq proc (buffer-process buf))
     570                            (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))))))
     571
     572
     573(defmethod eval-in-listener-process ((process cocoa-listener-process)
     574                                     string &key path package)
     575  (enqueue-toplevel-form (cocoa-listener-process-input-stream process) string
     576                         :package-name package :pathname path))
    518577
    519578;;; This is basically used to provide INPUT to the listener process, by
    520 ;;; writing to an fd which is conntected to that process's standard
     579;;; writing to an fd which is connected to that process's standard
    521580;;; input.
    522 (defmethod hi::send-string-to-listener-process ((process cocoa-listener-process)
    523                                                 string &key path package)
    524   (let* ((stream (cocoa-listener-process-input-peer-stream process)))
    525     (labels ((out-raw-char (ch)
    526                (write-char ch stream))
    527              (out-ch (ch)
    528                (when (or (eql ch #\^v)
    529                          (eql ch #\^p)
    530                          (eql ch #\newline)
    531                          (eql ch #\^q)
    532                          (eql ch #\^d))
    533                  (out-raw-char #\^q))
    534                (out-raw-char ch))
    535              (out-string (s)
    536                (dotimes (i (length s))
    537                  (out-ch (char s i)))))
    538       (out-raw-char #\^p)
    539       (when package (out-string package))
    540       (out-raw-char #\newline)
    541       (out-raw-char #\^v)
    542       (when path (out-string path))
    543       (out-raw-char #\newline)
    544       (out-string string)
    545       (out-raw-char #\^d)
    546       (force-output stream))))
     581(defun hemlock-ext:send-string-to-listener (listener-buffer string)
     582  (let* ((process (buffer-process listener-buffer)))
     583    (unless process
     584      (error "No listener process found for ~s" listener-buffer))
     585    (enqueue-listener-input (cocoa-listener-process-input-stream process) string)))
     586
    547587
    548588
     
    554594  (declare (ignore selection))
    555595  (#/performSelectorOnMainThread:withObject:waitUntilDone:
    556    (#/delegate *NSApp*) (@selector #/ensureListener:) +null-ptr+ #$YES)
    557   (let* ((top-listener-document (#/topListener hemlock-listener-document)))
    558     (if top-listener-document
    559       (let* ((buffer (hemlock-document-buffer top-listener-document)))
    560         (if buffer
    561           (let* ((proc (hi::buffer-process buffer)))
    562             (if (typep proc 'cocoa-listener-process)
    563               proc)))))))
     596   (#/delegate *NSApp*)
     597   (@selector #/ensureListener:)
     598   +null-ptr+
     599   #$YES)
     600  (hemlock-document-process (#/topListener hemlock-listener-document)))
    564601
    565602(defmethod ui-object-eval-selection ((app ns:ns-application)
     
    567604  (let* ((target-listener (ui-object-choose-listener-for-selection
    568605                           app selection)))
    569     (if (typep target-listener 'cocoa-listener-process)
    570         (destructuring-bind (package path string) selection
    571         (hi::send-string-to-listener-process target-listener string :package package :path path)))))
     606    (when target-listener
     607      (destructuring-bind (package path string) selection
     608        (eval-in-listener-process target-listener string :package package :path path)))))
    572609
    573610(defmethod ui-object-load-buffer ((app ns:ns-application) selection)
    574611  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
    575     (if (typep target-listener 'cocoa-listener-process)
    576         (destructuring-bind (package path) selection
    577           (let ((string (format nil "(load ~S)" path)))
    578             (hi::send-string-to-listener-process target-listener string :package package :path path))))))
     612    (when target-listener
     613      (destructuring-bind (package path) selection
     614        (let ((string (format nil "(load ~S)" path)))
     615          (eval-in-listener-process target-listener string :package package :path path))))))
    579616
    580617(defmethod ui-object-compile-buffer ((app ns:ns-application) selection)
    581618  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
    582     (if (typep target-listener 'cocoa-listener-process)
    583         (destructuring-bind (package path) selection
    584           (let ((string (format nil "(compile-file ~S)" path)))
    585             (hi::send-string-to-listener-process target-listener string :package package :path path))))))
     619    (when target-listener
     620      (destructuring-bind (package path) selection
     621        (let ((string (format nil "(compile-file ~S)" path)))
     622          (eval-in-listener-process target-listener string :package package :path path))))))
    586623
    587624(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection)
    588625  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
    589     (if (typep target-listener 'cocoa-listener-process)
    590         (destructuring-bind (package path) selection
    591           (let ((string (format nil "(progn (compile-file ~S)(load ~S))"
    592                                 path
    593                                 (make-pathname :directory (pathname-directory path)
    594                                                :name (pathname-name path)
    595                                                :type (pathname-type path)))))
    596             (hi::send-string-to-listener-process target-listener string :package package :path path))))))
     626    (when target-listener
     627      (destructuring-bind (package path) selection
     628        (let ((string (format nil "(progn (compile-file ~S)(load ~S))"
     629                              path
     630                              (make-pathname :directory (pathname-directory path)
     631                                             :name (pathname-name path)
     632                                             :type (pathname-type path)))))
     633          (eval-in-listener-process target-listener string :package package :path path))))))
    597634
    598635       
    599   
     636 
  • trunk/source/cocoa-ide/cocoa-utils.lisp

    r8151 r8428  
    102102  (float number ccl::+cgfloat-zero+))
    103103
    104 (defun color-values-to-nscolor (red green blue alpha)
     104(defun color-values-to-nscolor (red green blue &optional alpha)
    105105  (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
    106106                                              (cgfloat red)
    107107                                              (cgfloat green)
    108108                                              (cgfloat blue)
    109                                               (cgfloat alpha)))
     109                                              (cgfloat (or alpha 1.0))))
    110110
    111111(defun windows ()
     
    116116    (nreverse ret)))
    117117
     118
     119;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     120;;
     121
     122(defvar *log-callback-errors* :backtrace)
     123
     124(defun maybe-log-callback-error (condition)
     125  (when *log-callback-errors*
     126    ;; Put these in separate ignore-errors, so at least some of it can get thru
     127    (let ((emsg (ignore-errors (princ-to-string condition))))
     128      (ignore-errors (clear-output *debug-io*))
     129      (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
     130      (when (eq *log-callback-errors* :backtrace)
     131        (let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
     132          (when err
     133            (ignore-errors (format *debug-io* "~&Error printing call history - "))
     134            (ignore-errors (print err *debug-io*))
     135            (ignore-errors (princ err *debug-io*))
     136            (ignore-errors (force-output *debug-io*))))))))
     137
     138(defmacro with-callback-context (description &body body)
     139  (let ((saved-debug-io (gensym)))
     140    `(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
     141       (let ((,saved-debug-io *debug-io*))
     142         (handler-bind ((error #'(lambda (condition)
     143                                   (let ((*debug-io* ,saved-debug-io))
     144                                     (maybe-log-callback-error condition)
     145                                     (abort)))))
     146           ,@body)))))
     147
     148;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     149;;
     150;; utilities for executing in the cocoa event thread
     151
     152(defstatic *cocoa-thread-arg-id-map* (make-id-map))
     153
     154;; This is for debugging, it's preserved across queue-for-gui and bound
     155;; so it can be seen in backtraces.
     156(defvar *invoking-event-context* "unknown")
     157(defvar *invoking-event-process* nil)
     158
     159(defun register-cocoa-thread-function (thunk result-handler context)
     160  (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk
     161                                                     result-handler
     162                                                     (or context *invoking-event-context*)
     163                                                     *current-process*)))
     164
     165(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
     166  (invoke-lisp-function self id))
     167
     168(defmethod invoke-lisp-function ((self ns:ns-application) id)
     169  (destructuring-bind (thunk result-handler context . invoking-process)
     170                      (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id)))
     171    (handle-invoking-lisp-function thunk result-handler context invoking-process)))
     172
     173(defun execute-in-gui (thunk &key context)
     174  "Execute thunk in the main cocoa thread, return whatever values it returns"
     175  (if (typep *current-process* 'appkit-process)
     176    (handle-invoking-lisp-function thunk nil context)
     177    (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
     178      (error "cocoa thread not available")
     179      (let* ((return-values nil)
     180             (result-handler #'(lambda (&rest values) (setq return-values values)))
     181             (arg (make-instance 'ns:ns-number
     182                    :with-long (register-cocoa-thread-function thunk result-handler context))))
     183        (#/performSelectorOnMainThread:withObject:waitUntilDone:
     184         *nsapp*
     185         (@selector #/invokeLispFunction:)
     186         arg
     187         t)
     188        (apply #'values return-values)))))
     189
     190
     191(defconstant $lisp-function-event-subtype 17)
     192
     193(defclass lisp-application (ns:ns-application)
     194    ((termp :foreign-type :<BOOL>))
     195  (:metaclass ns:+ns-object))
     196
     197;;; I'm not sure if there's another way to recognize events whose
     198;;; type is #$NSApplicationDefined.
     199(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
     200  (if (and (eql (#/type e) #$NSApplicationDefined)
     201           (eql (#/subtype e) $lisp-function-event-subtype))
     202    (invoke-lisp-function self (#/data1 e))
     203    (call-next-method e)))
     204
     205;; This queues an event rather than just doing performSelectorOnMainThread, so that the
     206;; action is deferred until the event thread is idle.
     207(defun queue-for-gui (thunk &key result-handler context at-start)
     208  "Queue thunk for execution in main cocoa thread and return immediately."
     209  (execute-in-gui
     210   #'(lambda ()
     211       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
     212                  ns:ns-event
     213                  #$NSApplicationDefined
     214                  (ns:make-ns-point 0 0)
     215                  0
     216                  0.0d0
     217                  0
     218                  +null-ptr+
     219                  $lisp-function-event-subtype
     220                  (register-cocoa-thread-function thunk result-handler context)
     221                  0)))
     222         ;(#/retain e)
     223         (#/postEvent:atStart: *nsapp* e (not (null at-start)))))))
     224
     225(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*))
     226  ;; TODO: the point is to execute result-handler in the original process, but this will do for now.
     227  (let* ((*invoking-event-process* invoking-process)
     228         (*invoking-event-context* context))
     229    (if result-handler
     230      (multiple-value-call result-handler (funcall thunk))
     231      (funcall thunk))))
     232
     233;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     234;;
     235;; debugging
     236
    118237(defun log-debug (format-string &rest args)
    119238  (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args))))
    120239
     240(defun nslog-condition (c)
     241  (let* ((rep (format nil "~a" c)))
     242    (with-cstrs ((str rep))
     243      (with-nsstr (nsstr str (length rep))
     244        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
     245
     246
     247
    121248(defun assume-cocoa-thread ()
    122   #+debug (assert (eq *current-process* *initial-process*)))
     249  (assert (eq *current-process* ccl::*initial-process*)))
    123250
    124251(defmethod assume-not-editing ((whatever t)))
  • trunk/source/cocoa-ide/cocoa-window.lisp

    r8204 r8428  
    5050                 :void))
    5151
    52 (defstatic *appkit-process-interrupt-ids* (make-id-map))
    53 (defun register-appkit-process-interrupt (thunk)
    54   (assign-id-map-id *appkit-process-interrupt-ids* thunk))
    55 (defun appkit-interrupt-function (id)
    56   (id-map-free-object *appkit-process-interrupt-ids* id))
    57 
    5852(defclass appkit-process (process) ())
    59 
    60 (defconstant process-interrupt-event-subtype 17)
    61 
    62 
    63 
    64 
    65 (defclass lisp-application (ns:ns-application)
    66     ((termp :foreign-type :<BOOL>))
    67   (:metaclass ns:+ns-object))
    68 
    69 
    70 (objc:defmethod (#/postEventAtStart: :void) ((self  ns:ns-application) e)
    71   (#/postEvent:atStart: self e t))
    7253
    7354;;; Interrupt the AppKit event process, by enqueing an event (if the
     
    7657;;; case, the application's probably already in the process of
    7758;;; exiting, and isn't that different from the case where asynchronous
    78 ;;; interrupts are used.  An attribute of the event is used to identify
    79 ;;; the thunk which the event handler needs to funcall.
     59;;; interrupts are used.
    8060(defmethod process-interrupt ((process appkit-process) function &rest args)
    8161  (if (eq process *current-process*)
    8262    (apply function args)
    83     (if (or (not *NSApp*) (not (#/isRunning *NSApp*)))
    84       (call-next-method)
    85       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
    86                  ns:ns-event
    87                  #$NSApplicationDefined
    88                  (ns:make-ns-point 0 0)
    89                  0
    90                  0.0d0
    91                  0
    92                  +null-ptr+
    93                  process-interrupt-event-subtype
    94                  (register-appkit-process-interrupt
    95                   #'(lambda () (apply function args))) 0)))
    96         (#/retain e)
    97         (#/performSelectorOnMainThread:withObject:waitUntilDone:
    98          *NSApp* (@selector "postEventAtStart:") e  t)))))
    99 
     63    (if (and *NSApp* (#/isRunning *NSApp*))
     64      (queue-for-gui #'(lambda () (apply function args)) :at-start t)
     65      (call-next-method))))
    10066
    10167(defparameter *debug-in-event-process* t)
     
    10975                (ccl::ns-lisp-exception-condition condition)
    11076                condition)))
    111       (unless (member c *event-process-reported-conditions*)
     77      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
    11278        (push c *event-process-reported-conditions*)
    11379        (catch 'need-a-catch-frame-for-backtrace
     
    147113    (eql 0 (#_SetFrontProcess psn))))
    148114
    149 ;;; I'm not sure if there's another way to recognize events whose
    150 ;;; type is #$NSApplicationDefined.
    151 (objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
    152   (if (and (eql (#/type e) #$NSApplicationDefined)
    153            (eql (#/subtype e)  process-interrupt-event-subtype))
    154     ;;; The thunk to funcall is identified by the value
    155     ;;; of the event's data1 attribute.
    156     (funcall (appkit-interrupt-function (#/data1 e)))
    157     (call-next-method e)))
    158 
    159115#+nil
    160116(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
     
    166122  (#/show (#/sharedPanel typeout-window)))
    167123
    168 (defun nslog-condition (c)
    169   (let* ((rep (format nil "~a" c)))
    170     (with-cstrs ((str rep))
    171       (with-nsstr (nsstr str (length rep))
    172         (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
    173 
    174 
    175124(defmethod ccl::process-exit-application ((process appkit-process) thunk)
    176125  (when (eq process ccl::*initial-process*)
     
    181130  (%set-toplevel nil)
    182131  (change-class *cocoa-event-process* 'appkit-process)
    183   (let* ((app *NSApp*))
     132  (event-loop))
     133
     134(defun stop-event-loop ()
     135  (#/stop: *nsapp* +null-ptr+))
     136
     137(defun event-loop (&optional end-test)
     138  (let ((app *NSApp*))
    184139    (loop
    185         (handler-case (let* ((*event-process-reported-conditions* nil))
    186                         (#/run app))
    187           (error (c) (nslog-condition c)))
    188         (unless (#/isRunning app)
    189           (return)))))
    190 
    191 
     140      (handler-case (let* ((*event-process-reported-conditions* nil))
     141                      (if end-test
     142                        (#/run app)
     143                        #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
     144                                               #&NSDefaultRunLoopMode
     145                                               (#/distantFuture ns:ns-date))|#
     146                        (#/run app)))
     147        (error (c) (nslog-condition c)))
     148      #+GZ (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
     149      (when (or (and end-test (funcall end-test))
     150                (and ccl::*quitting* (not (#/isRunning app))))
     151        (return)))))
    192152
    193153(defun start-cocoa-application (&key
     
    197157  (flet ((cocoa-startup ()
    198158           ;; Start up a thread to run periodic tasks.
    199            (process-run-function "housekeeping"
    200                                  #'(lambda ()
    201                                      (loop
    202                                        (ccl::%nanosleep ccl::*periodic-task-seconds*
    203                                                         ccl::*periodic-task-nanoseconds*)
    204                                        (ccl::housekeeping))))
    205            
     159           (process-run-function "housekeeping" #'ccl::housekeeping-loop)
    206160           (with-autorelease-pool
    207161             (enable-foreground)
  • trunk/source/cocoa-ide/cocoa.lisp

    r7804 r8428  
    11(in-package "CCL")
    22
    3 (defvar *cocoa-application-path* "ccl:temp bundle.app;")
     3(defvar *cocoa-application-path* #+gz "ccl:GZ temp bundle.app;" #-gz "ccl:temp bundle.app;")
    44(defvar *cocoa-application-copy-headers-p* nil)
    55(load "ccl:cocoa-ide;defsystem.lisp")
  • trunk/source/cocoa-ide/compile-hemlock.lisp

    r7804 r8428  
    3232  '("package"
    3333
    34     ;; Lisp implementation specific stuff goes into one of
    35     ;; the next two files.
    36     "lispdep"
    3734    "hemlock-ext"                     
    3835               
     
    4744
    4845    "macros"
     46
     47    "views"
    4948    "line"
    5049    "ring"
     
    6261    "table"
    6362    "modeline"
    64     "linimage"
    6563    "pop-up-stream"
    66     "cursor"
    6764    "font"
    6865    "streams"
     
    7774    "killcoms"
    7875    "searchcoms"
     76    "isearchcoms"
    7977    "filecoms"
    8078    "doccoms"
     
    8583    "comments"
    8684    "icom"
    87     "kbdmac"
    8885    "defsyn"
    8986    "edit-defs"
     
    9289    "symbol-completion"
    9390    "bindings"
    94     "bindings-gb"                       ;Gilbert's bindings
    95     )) 
     91    ))
    9692
    9793(defun compile-hemlock (&optional force)
  • trunk/source/cocoa-ide/defsystem.lisp

    r7804 r8428  
    1616
    1717(require "OBJC-SUPPORT")
    18 
    19 (require "PTY")
    20 
    2118
    2219(defpackage "GUI"
     
    5552   objc-message-send
    5653   open-main-bundle
    57    ;; Symbols perhaps that should be exported by library;pty.lisp but aren't
    58    open-pty-pair
    59    set-tty-raw
    6054   )
    6155  (:export
  • trunk/source/cocoa-ide/hemlock/src/bindings.lisp

    r7595 r8428  
    3737;;; Self insert letters:
    3838;;;
    39 (hemlock-ext:do-alpha-key-events (key-event :both)
    40                                  (bind-key "Self Insert" key-event))
     39(do-alpha-key-events (key-event :both)
     40  (bind-key "Self Insert" key-event))
    4141
    4242(bind-key "Beginning of Line" #k"control-a")
     
    7575(bind-key "Scroll Window Up" #k"meta-v")
    7676(bind-key "Scroll Window Up" #k"pageup")
    77 (bind-key "Scroll Next Window Down" #k"control-meta-v")
    78 (bind-key "Scroll Next Window Up" #k"control-meta-V")
     77;(bind-key "Scroll Next Window Down" #k"control-meta-v")
     78;(bind-key "Scroll Next Window Up" #k"control-meta-V")
    7979
    8080(bind-key "Do Nothing" #k"leftdown")
     81;(bind-key "Do Nothing" #k"leftup")
     82
     83(bind-key "Abort Command" #k"control-g")
     84(bind-key "Abort Command" #k"control-G")
     85(bind-key "Abort Command" #k"control-x control-g")
     86(bind-key "Abort Command" #k"control-x control-G")
    8187
    8288
     
    8692(bind-key "End of Buffer" #k"end")
    8793(bind-key "Undo" #k"control-_")
     94(bind-key "Undo" #k"control-\/")
    8895(bind-key "Describe Key" #k"meta-?")
    8996(bind-key "What Cursor Position" #k"control-x =")
     
    116123(bind-key "Buffer Not Modified" #k"meta-~")
    117124;(bind-key "Check Buffer Modified" #k"control-x ~")
    118 (bind-key "Select Buffer" #k"control-x b")
     125;(bind-key "Select Buffer" #k"control-x b")
    119126;(bind-key "Select Previous Buffer" #k"control-meta-l")
    120127;(bind-key "Circulate Buffers" #k"control-meta-L")
     
    126133;(bind-key "Next Window" #k"control-x o")
    127134;(bind-key "Previous Window" #k"control-x p")
    128 (bind-key "Split Window" #k"control-x 2")
     135;(bind-key "Split Window" #k"control-x 2")
    129136;(bind-key "New Window" #k"control-x control-n")
    130137;(bind-key "Delete Window" #k"control-x d")
     
    134141;(bind-key "Top of Window" #k"meta-,")
    135142;(bind-key "Bottom of Window" #k"meta-.")
    136 
    137 (bind-key "Exit Recursive Edit" #k"control-meta-z")
    138 (bind-key "Abort Recursive Edit" #k"control-]")
    139143
    140144(bind-key "Delete Previous Character" #k"delete")
     
    189193(bind-key "Expand Dynamic Abbreviation" #k"meta-`") ;; MCL binding
    190194
     195(bind-key "Help" #k"control-h")
    191196
    192197
    193198;;;; Argument Digit and Negative Argument.
    194199
    195 (bind-key "Negative Argument" #k"meta-\-")
     200(bind-key "Argument Digit" #k"meta-\-")
    196201(bind-key "Argument Digit" #k"meta-0")
    197202(bind-key "Argument Digit" #k"meta-1")
     
    204209(bind-key "Argument Digit" #k"meta-8")
    205210(bind-key "Argument Digit" #k"meta-9")
    206 (bind-key "Negative Argument" #k"control-\-")
     211(bind-key "Argument Digit" #k"control-\-")
    207212(bind-key "Argument Digit" #k"control-0")
    208213(bind-key "Argument Digit" #k"control-1")
     
    215220(bind-key "Argument Digit" #k"control-8")
    216221(bind-key "Argument Digit" #k"control-9")
    217 (bind-key "Negative Argument" #k"control-meta-\-")
     222(bind-key "Argument Digit" #k"control-meta-\-")
    218223(bind-key "Argument Digit" #k"control-meta-0")
    219224(bind-key "Argument Digit" #k"control-meta-1")
     
    226231(bind-key "Argument Digit" #k"control-meta-8")
    227232(bind-key "Argument Digit" #k"control-meta-9")
     233
     234(bind-key "Digit" #k"\-")
     235(bind-key "Digit" #k"0")
     236(bind-key "Digit" #k"1")
     237(bind-key "Digit" #k"2")
     238(bind-key "Digit" #k"3")
     239(bind-key "Digit" #k"4")
     240(bind-key "Digit" #k"5")
     241(bind-key "Digit" #k"6")
     242(bind-key "Digit" #k"7")
     243(bind-key "Digit" #k"8")
     244(bind-key "Digit" #k"9")
    228245
    229246
     
    247264(bind-key "Self Insert" #k"+")
    248265(bind-key "Self Insert" #k"~")
    249 (bind-key "Self Insert" #k"1")
    250 (bind-key "Self Insert" #k"2")
    251 (bind-key "Self Insert" #k"3")
    252 (bind-key "Self Insert" #k"4")
    253 (bind-key "Self Insert" #k"5")
    254 (bind-key "Self Insert" #k"6")
    255 (bind-key "Self Insert" #k"7")
    256 (bind-key "Self Insert" #k"8")
    257 (bind-key "Self Insert" #k"9")
    258 (bind-key "Self Insert" #k"0")
    259266(bind-key "Self Insert" #k"[")
    260267(bind-key "Self Insert" #k"]")
     
    265272(bind-key "Self Insert" #k"\"")
    266273(bind-key "Self Insert" #k"'")
    267 (bind-key "Self Insert" #k"\-")
    268274(bind-key "Self Insert" #k"=")
    269275(bind-key "Self Insert" #k"`")
     
    354360(bind-key "Editor Describe Symbol" #k"control-meta-S" :mode "Editor")
    355361
    356 
    357 
    358 ;;;; Typescript.
    359 #+typescript
    360 (progn
    361 (bind-key "Confirm Typescript Input" #k"return" :mode "Typescript")
    362 (bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript")
    363 (bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript")
    364 (bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript")
    365 (bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript")
    366 (bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript")
    367 (bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript")
    368 (bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript")
    369 (bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript")
    370 (bind-key "Typescript Slave Status" #k"hyper-s" :mode "Typescript")
    371 (bind-key "Select Slave" #k"control-meta-\c")
    372 (bind-key "Select Background" #k"control-meta-C")
    373 
    374 (bind-key "Abort Operations" #k"hyper-a")
    375 (bind-key "List Operations" #k"hyper-l")
    376 
    377 (bind-key "Next Compiler Error" #k"hyper-n")
    378 (bind-key "Previous Compiler Error" #k"hyper-p")
    379 )
    380362
    381363
     
    521503
    522504
     505#|
    523506;;;; Keyboard macro bindings.
    524507
     
    529512(bind-key "Last Keyboard Macro" #k"control-x e")
    530513(bind-key "Keyboard Macro Query" #k"control-x q")
     514|#
    531515
    532516
     
    562546(do ((i 33 (1+ i)))
    563547    ((= i 126))
    564   (let ((key-event (hemlock-ext:char-key-event (code-char i))))
     548  (let ((key-event (hi:char-key-event (code-char i))))
    565549    (bind-key "Self Overwrite" key-event :mode "Overwrite")))
    566550
     
    625609;;; message about modifying read-only buffers.
    626610;;;
    627 (hemlock-ext:do-alpha-key-events (key-event :both)
    628                                  (bind-key "Illegal" key-event :mode "Headers")
    629                                  (bind-key "Illegal" key-event :mode "Message"))
     611(do-alpha-key-events (key-event :both)
     612  (bind-key "Illegal" key-event :mode "Headers")
     613  (bind-key "Illegal" key-event :mode "Message"))
    630614
    631615;;; Global.
     
    719703;;; message about modifying read-only buffers.
    720704;;;
    721 (hemlock-ext:do-alpha-key-events (key-event :both)
    722                                  (bind-key "Illegal" key-event :mode "News-Headers")
    723                                  (bind-key "Illegal" key-event :mode "News-Message"))
     705(do-alpha-key-events (key-event :both)
     706  (bind-key "Illegal" key-event :mode "News-Headers")
     707  (bind-key "Illegal" key-event :mode "News-Message"))
    724708
    725709
     
    920904(bind-key "Completion Self Insert" #k"linefeed" :mode "Completion")
    921905
    922 (bind-key "Completion Complete Word" #k"end")
    923 (bind-key "Completion Rotate Completions" #k"meta-end")
    924 
    925 
     906(bind-key "Completion Complete Word" #k"end" :mode "Completion")
     907(bind-key "Completion Rotate Completions" #k"meta-end" :mode "Completion")
    926908
    927909
    928910;;;; Caps-Lock mode.
    929911
    930 (hemlock-ext:do-alpha-key-events (key-event :lower)
    931                                  (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK"))
    932 
    933 
     912(do-alpha-key-events (key-event :lower)
     913  (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK"))
     914
     915
     916
     917;;;; I-Search mode.
     918;;;;
     919;;;; Anything that's not explicitly bound here will exit i-search.
     920
     921(dotimes (n hi::hemlock-char-code-limit)
     922  (when (standard-char-p (code-char n))
     923    (let ((key (make-key-event n)))
     924      (bind-key "I-Search Self Insert" key :mode "I-Search"))))
     925
     926(bind-key "I-Search Repeat Forward" #k"control-s" :mode "I-Search")
     927(bind-key "I-Search Repeat Backward" #k"control-r" :mode "I-Search")
     928(bind-key "I-Search Backup" #k"backspace" :mode "I-Search")
     929(bind-key "I-Search Backup" #k"delete" :mode "I-Search")
     930(bind-key "I-Search Abort" #k"control-g" :mode "I-Search")
     931(bind-key "I-Search Abort" #k"control-G" :mode "I-Search")
     932(bind-key "I-Search Exit or Search" #k"escape" :mode "I-Search")
     933(bind-key "I-Search Yank Word" #k"control-w" :mode "I-Search")
     934(bind-key "Quoted Insert" #k"control-q" :mode "I-Search")
     935
     936
     937;;;; Query/Replace mode.
     938;;;;
     939;;;; Anything that's not explicitly bound here will exit i-search.
     940
     941(bind-key "Query/Replace This" #k"y" :mode "Query/Replace")
     942(bind-key "Query/Replace This" #k"space" :mode "Query/Replace")
     943(bind-key "Query/Replace Skip" #k"n" :mode "Query/Replace")
     944(bind-key "Query/Replace Skip" #k"backspace" :mode "Query/Replace")
     945(bind-key "Query/Replace Skip" #k"delete" :mode "Query/Replace")
     946(bind-key "Query/Replace All" #k"!" :mode "Query/Replace")
     947(bind-key "Query/Replace Last" #k"." :mode "Query/Replace")
     948(bind-key "Query/Replace Exit" #k"q" :mode "Query/Replace")
     949(bind-key "Query/Replace Exit" #k"escape" :mode "Query/Replace")
     950(bind-key "Query/Replace Abort" #k"control-g" :mode "Query/Replace")
     951(bind-key "Query/Replace Abort" #k"control-G" :mode "Query/Replace")
     952(bind-key "Query/Replace Help" #k"h" :mode "Query/Replace")
     953(bind-key "Query/Replace Help" #k"?" :mode "Query/Replace")
     954(bind-key "Query/Replace Help" #k"home" :mode "Query/Replace")
     955(bind-key "Query/Replace Help" #k"control-_" :mode "Query/Replace")
    934956
    935957;;;; Logical characters.
    936 
    937 (setf (logical-key-event-p #k"control-s" :forward-search) t)
    938 (setf (logical-key-event-p #k"control-r" :backward-search) t)
    939 (setf (logical-key-event-p #k"control-r" :recursive-edit) t)
    940 (setf (logical-key-event-p #k"delete" :cancel) t)
    941 (setf (logical-key-event-p #k"backspace" :cancel) t)
     958 
    942959(setf (logical-key-event-p #k"control-g" :abort) t)
    943 (setf (logical-key-event-p #k"escape" :exit) t)
    944 (setf (logical-key-event-p #k"leftdown" :mouse-exit) t)
    945960(setf (logical-key-event-p #k"y" :yes) t)
    946961(setf (logical-key-event-p #k"space" :yes) t)
     
    948963(setf (logical-key-event-p #k"backspace" :no) t)
    949964(setf (logical-key-event-p #k"delete" :no) t)
    950 (setf (logical-key-event-p #k"!" :do-all) t)
    951 (setf (logical-key-event-p #k"." :do-once) t)
    952965(setf (logical-key-event-p #k"home" :help) t)
    953966(setf (logical-key-event-p #k"h" :help) t)
     
    957970(setf (logical-key-event-p #k"control-q" :quote) t)
    958971(setf (logical-key-event-p #k"k" :keep) t)
    959 (setf (logical-key-event-p #k"control-w" :extend-search-word) t)
     972(setf (logical-key-event-p #k"y" :y) t)
     973(setf (logical-key-event-p #k"Y" :y) t)
     974(setf (logical-key-event-p #k"n" :n) t)
     975(setf (logical-key-event-p #k"N" :n) t)
     976
  • trunk/source/cocoa-ide/hemlock/src/buffer.lisp

    r7595 r8428  
    4242  "If true make the buffer modified, if NIL unmodified."
    4343  (unless (bufferp buffer) (error "~S is not a buffer." buffer))
    44   (let* ((was-modified (buffer-modified buffer)))
     44  (let* ((was-modified (buffer-modified buffer))
     45         (changed (not (eq was-modified (buffer-modified buffer)))))
    4546    (invoke-hook hemlock::buffer-modified-hook buffer sense)
    4647    (if sense
    4748      (setf (buffer-modified-tick buffer) (tick))
    4849      (setf (buffer-unmodified-tick buffer) (tick)))
    49     (unless (eq was-modified (buffer-modified buffer))
    50       (queue-buffer-change buffer)))
    51   (let* ((document (buffer-document buffer)))
    52     (if document (set-document-modified document sense)))
     50    (when changed
     51      (if sense
     52        (hemlock-ext:note-buffer-unsaved buffer)
     53        (hemlock-ext:note-buffer-saved buffer))
     54      (note-modeline-change buffer)))
    5355  sense)
    5456
     
    9294  (setf (buffer-%pathname buffer) pathname))
    9395
    94 (defun buffer-modeline-fields (window)
     96(defun buffer-modeline-fields (buffer)
    9597  "Return a copy of the buffer's modeline fields list."
    96   (do ((finfos (buffer-%modeline-fields window) (cdr finfos))
     98  (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos))
    9799       (result () (cons (ml-field-info-field (car finfos)) result)))
    98100      ((null finfos) (nreverse result))))
    99101
    100 (defun %set-buffer-modeline-fields (buffer fields)
    101   (check-type fields list)
    102   (check-type buffer buffer "a Hemlock buffer")
    103   (sub-set-buffer-modeline-fields buffer fields)
    104   (dolist (w (buffer-windows buffer))
    105     (update-modeline-fields buffer w)))
    106 
    107 (defun sub-set-buffer-modeline-fields (buffer modeline-fields)
     102(defun set-buffer-modeline-fields (buffer modeline-fields)
    108103  (unless (every #'modeline-field-p modeline-fields)
    109104    (error "Fields must be a list of modeline-field objects."))
     
    131126
    132127
    133 ;;;; Variable binding -- winding and unwinding.
    134 
    135 (eval-when (:compile-toplevel :execute)
    136 
    137 (defmacro unbind-variable-bindings (bindings)
    138   `(do ((binding ,bindings (binding-across binding)))
    139        ((null binding))
    140      (setf (car (binding-cons binding))
    141            (variable-object-down (binding-object binding)))))
    142 
    143 (defmacro bind-variable-bindings (bindings)
    144   `(do ((binding ,bindings (binding-across binding)))
    145        ((null binding))
    146      (let ((cons (binding-cons binding))
    147            (object (binding-object binding)))
    148        (setf (variable-object-down object) (car cons)
    149              (car cons) object))))
    150 
    151 ) ;eval-when
    152 
    153 ;;; UNWIND-BINDINGS  --  Internal
    154 ;;;
    155 ;;;    Unwind buffer variable bindings and all mode bindings up to and
    156 ;;; including mode.  Return a list of the modes unwound in reverse order.
    157 ;;; (buffer-mode-objects *current-buffer*) is clobbered.  If "mode" is NIL
    158 ;;; unwind all bindings.
    159 ;;;
    160 (defun unwind-bindings (mode)
    161   (unbind-variable-bindings (buffer-var-values *current-buffer*))
    162   (do ((curmode (buffer-mode-objects *current-buffer*))
    163        (unwound ()) cw)
    164       (())
    165     (setf cw curmode  curmode (cdr curmode)  (cdr cw) unwound  unwound cw)
    166     (unbind-variable-bindings (mode-object-var-values (car unwound)))
    167     (when (or (null curmode) (eq (car unwound) mode))
    168       (setf (buffer-mode-objects *current-buffer*) curmode)
    169       (return unwound))))
    170 
    171 ;;; WIND-BINDINGS  --  Internal
    172 ;;;
    173 ;;;    Add "modes" to the mode bindings currently in effect.
    174 ;;;
    175 (defun wind-bindings (modes)
    176   (do ((curmode (buffer-mode-objects *current-buffer*)) cw)
    177       ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode))
    178     (bind-variable-bindings (mode-object-var-values (car modes)))
    179     (setf cw modes  modes (cdr modes)  (cdr cw) curmode  curmode cw))
    180   (bind-variable-bindings (buffer-var-values *current-buffer*)))
    181 
    182 
    183 
    184 
    185128;;;; BUFFER-MAJOR-MODE.
    186129
    187 (eval-when (:compile-toplevel :execute)
    188130(defmacro with-mode-and-buffer ((name major-p buffer) &body forms)
    189   `(let ((mode (get-mode-object name)))
     131  `(let ((mode (get-mode-object ,name)))
    190132    (setq ,name (mode-object-name mode))
    191133    (,(if major-p 'unless 'when) (mode-object-major-p mode)
     
    193135    (check-type ,buffer buffer)
    194136    ,@forms))
    195 ) ;eval-when
    196137
    197138;;; BUFFER-MAJOR-MODE  --  Public
    198139;;;
    199 ;;;    The major mode is the first on the list, so just return that.
    200140;;;
    201141(defun buffer-major-mode (buffer)
     
    203143  use Setf."
    204144  (check-type buffer buffer)
    205   (car (buffer-modes buffer)))
     145  (mode-object-name (buffer-major-mode-object buffer)))
    206146
    207147;;; %SET-BUFFER-MAJOR-MODE  --  Public
    208 ;;;
    209 ;;;    Unwind all modes in effect and add the major mode specified.
    210 ;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers
    211 ;;;other than the current buffer, and in the reverse order in the
    212 ;;;current buffer.
    213148;;;
    214149(defun %set-buffer-major-mode (buffer name)
     
    216151  (with-mode-and-buffer (name t buffer)
    217152    (invoke-hook hemlock::buffer-major-mode-hook buffer name)
    218     (cond
    219      ((eq buffer *current-buffer*)
    220       (let ((old-mode (car (last (buffer-mode-objects buffer)))))
    221         (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
    222         (funcall (mode-object-cleanup-function old-mode) buffer)
    223         (swap-char-attributes old-mode)
    224         (wind-bindings (cons mode (cdr (unwind-bindings old-mode))))
    225         (swap-char-attributes mode)))
    226      (t
    227       (let ((old-mode (car (buffer-mode-objects buffer))))
    228         (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
    229         (funcall (mode-object-cleanup-function old-mode) buffer))
    230       (setf (car (buffer-mode-objects buffer)) mode)))
    231     (setf (car (buffer-modes buffer)) name)
     153    (let ((old-mode (buffer-major-mode-object buffer)))
     154      (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
     155      (funcall (mode-object-cleanup-function old-mode) buffer))
     156    (setf (buffer-major-mode-object buffer) mode)
     157    (invalidate-shadow-attributes buffer)
    232158    (funcall (mode-object-setup-function mode) buffer)
    233159    (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
     
    247173  A minor mode can be turned on or off with Setf."
    248174  (with-mode-and-buffer (name nil buffer)
    249     (not (null (member mode (buffer-mode-objects buffer))))))
     175    (not (null (member mode (buffer-minor-mode-objects buffer))))))
    250176   
    251177(declaim (special *mode-names*))
     
    257183;;;
    258184(defun %set-buffer-minor-mode (buffer name new-value)
    259   (let ((objects (buffer-mode-objects buffer)))   
    260     (with-mode-and-buffer (name nil buffer)
    261       (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value)
    262       (cond
    263        ;; Already there or not there, nothing to do.
    264        ((if (member mode (buffer-mode-objects buffer)) new-value (not new-value)))
    265        ;; Adding a new mode.
    266        (new-value
    267         (cond
    268          ((eq buffer *current-buffer*)
    269           ;;
    270           ;; Unwind bindings having higher precedence, cons on the new
    271           ;; mode and then wind them back on again.
    272           (do ((m objects (cdr m))
    273                (prev nil (car m)))
    274               ((or (null (cdr m))
    275                    (< (mode-object-precedence (car m))
    276                       (mode-object-precedence mode)))
    277                (wind-bindings
    278                 (cons mode (if prev
    279                                (unwind-bindings prev)
    280                                (unbind-variable-bindings
    281                                 (buffer-var-values *current-buffer*))))))))
    282          (t
    283           (do ((m (cdr objects) (cdr m))
    284                (prev objects m))
    285               ((or (null m)
    286                    (>= (mode-object-precedence (car m))
    287                        (mode-object-precedence mode)))
    288                (setf (cdr prev) (cons mode m))))))
    289         ;;
    290         ;; Add the mode name.
    291         (let ((bm (buffer-modes buffer)))
    292           (setf (cdr bm)
    293                 (merge 'list (cdr bm) (list name) #'<  :key
    294                        #'(lambda (x)
    295                            (mode-object-precedence (getstring x *mode-names*))))))
    296 
    297         (funcall (mode-object-setup-function mode) buffer)
    298         (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
    299        (t
    300         ;; Removing an active mode.
    301         (invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
    302         (funcall (mode-object-cleanup-function mode) buffer)
    303         ;; In the current buffer, unwind buffer and any mode bindings on top
    304         ;; pop off the mode and wind the rest back on.
    305         (cond ((eq buffer *current-buffer*)
    306                (wind-bindings (cdr (unwind-bindings mode))))
    307               (t
    308                (setf (buffer-mode-objects buffer)
    309                      (delq mode (buffer-mode-objects buffer)))))
    310         ;; We always use the same string, so we can delq it (How Tense!)
    311         (setf (buffer-modes buffer) (delq name (buffer-modes buffer))))))
    312   new-value))
    313 
     185  (with-mode-and-buffer (name nil buffer)
     186    (let ((objects (buffer-minor-mode-objects buffer)))
     187      (unless (if (member mode objects) new-value (not new-value))
     188        (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value)
     189        (cond
     190         ;; Adding a new mode, insert sorted.
     191         (new-value
     192          (do ((m objects (cdr m))
     193               (prev nil m))
     194              ((or (null m)
     195                   (< (mode-object-precedence (car m))
     196                      (mode-object-precedence mode)))
     197               (if prev
     198                 (setf (cdr prev) (cons mode m))
     199                 (setf (buffer-minor-mode-objects buffer) (setq objects (cons mode m))))))
     200          (funcall (mode-object-setup-function mode) buffer)
     201          (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
     202         (t
     203          ;; Removing an active mode.
     204          (invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
     205          (funcall (mode-object-cleanup-function mode) buffer)
     206          (setf (buffer-minor-mode-objects buffer) (delq mode (buffer-minor-mode-objects buffer)))))))
     207    new-value))
     208
     209;;; BUFFER-MODES -- Public
     210;;; List of buffer mode names, in precendence order, major mode first.
     211;;;
     212(defun buffer-modes (buffer)
     213  "Return the list of the names of the modes active in a given buffer."
     214  (cons (buffer-major-mode buffer)
     215        (nreverse (mapcar #'mode-object-name (buffer-minor-mode-objects buffer)))))
    314216
    315217
     
    344246    ;; establish a new (empty) region at point.
    345247    (unless (%buffer-current-region-p b)
    346       (push-buffer-mark (copy-mark point) t))
     248      (push-new-buffer-mark point t))
    347249    point))
    348250
     
    384286      (unless region
    385287        point))))
    386 
    387 ;;; %SET-CURRENT-BUFFER  --  Internal
    388 ;;;
    389 ;;;    Undo previous buffer and mode specific variables and character
    390 ;;;attributes and set up the new ones.  Set *current-buffer*.
    391 ;;;
    392 (defun %set-current-buffer (buffer)
    393   (let ((old-buffer *current-buffer*))
    394     (check-type buffer buffer)
    395     (invoke-hook hemlock::set-buffer-hook buffer)
    396     ;; Undo old bindings.
    397     (setf (buffer-mode-objects *current-buffer*)
    398           (unwind-bindings nil))
    399     (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
    400     (setq *current-buffer* buffer)
    401     (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
    402     ;; Make new bindings.
    403     (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))
    404     (invoke-hook hemlock::after-set-buffer-hook old-buffer))
    405   buffer)
    406 
    407 ;;; USE-BUFFER-SET-UP  --  Internal
    408 ;;;
    409 ;;;    This function is called by the use-buffer macro to wind on the
    410 ;;; new buffer's variable and key bindings and character attributes.
    411 ;;;
    412 (defun use-buffer-set-up (old-buffer)
    413   (unless (eq old-buffer *current-buffer*)
    414     ;; Let new char attributes overlay old ones.
    415     (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
    416     ;; Wind on bindings of new current buffer.
    417     (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))))
    418 
    419 ;;; USE-BUFFER-CLEAN-UP  --  Internal
    420 ;;;
    421 ;;;    This function is called by use-buffer to clean up after it is done.
    422 ;;;
    423 (defun use-buffer-clean-up (old-buffer)
    424   (unless (eq old-buffer *current-buffer*)
    425     ;; When we leave, unwind the bindings,
    426     (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil))
    427     ;; Restore the character attributes,
    428     (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))))
    429 
    430 
    431 
    432 
    433 ;;;; Recursive editing.
    434 
    435 (defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.")
    436 
    437 (declaim (inline in-recursive-edit))
    438 
    439 (defun in-recursive-edit ()
    440   "Returns whether the calling point is dynamically within a recursive edit
    441    context."
    442   *in-a-recursive-edit*)
    443 
    444 ;;; RECURSIVE-EDIT  --  Public
    445 ;;;
    446 ;;;    Call the command interpreter recursively, winding on new state as
    447 ;;; necessary.
    448 ;;;
    449 (defun recursive-edit (&optional (handle-abort t))
    450   "Call the command interpreter recursively.  If Handle-Abort is true
    451   then an abort caused by a control-g or a lisp error does not cause
    452   the recursive edit to be aborted."
    453   (invoke-hook hemlock::enter-recursive-edit-hook)
    454   (multiple-value-bind (flag args)
    455                        (let ((*in-a-recursive-edit* t)
    456                              #+nil (doc (buffer-document *current-buffer*))
    457                              )
    458                          (catch 'leave-recursive-edit
    459                            (unwind-protect
    460                                 (progn
    461                                   #+nil (when doc (document-end-editing doc))
    462                                   (if handle-abort
    463                                     (loop (catch 'editor-top-level-catcher
    464                                             (%command-loop)))
    465                                     (%command-loop)))
    466                              #+nil
    467                              (when doc (document-begin-editing doc)))))
    468                              
    469     (case flag
    470       (:abort (apply #'editor-error args))
    471       (:exit (values-list args))
    472       (t (error "Bad thing ~S thrown out of recursive edit." flag)))))
    473 
    474 ;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context
    475 ;;; of RECURSIVE-EDIT, causing return from that function with values returned
    476 ;;; as multiple values.  When not in a recursive edit, signal an error.
    477 ;;;
    478 (defun exit-recursive-edit (&optional values)
    479   "Exit from a recursive edit.  Values is a list of things which are
    480    to be the return values from Recursive-Edit."
    481   (unless *in-a-recursive-edit*
    482     (error "Not in a recursive edit!"))
    483   (invoke-hook hemlock::exit-recursive-edit-hook values)
    484   (throw 'leave-recursive-edit (values :exit values)))
    485 
    486 ;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context
    487 ;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args.  When not
    488 ;;; in a recursive edit, signal an error.
    489 ;;;
    490 (defun abort-recursive-edit (&rest args)
    491   "Abort a recursive edit, causing an Editor-Error with the args given in
    492    the calling context."
    493   (unless *in-a-recursive-edit*
    494     (error "Not in a recursive edit!"))
    495   (invoke-hook hemlock::abort-recursive-edit-hook args)
    496   (throw 'leave-recursive-edit (values :abort args)))
    497 
    498 
    499288
    500289;;;; WITH-WRITABLE-BUFFER
     
    530319(defun defmode (name &key (setup-function #'identity)
    531320                     (cleanup-function #'identity) major-p transparent-p
    532                      precedence documentation hidden)
     321                     precedence documentation hidden default-command)
    533322  "Define a new mode, specifying whether it is a major mode, and what the
    534323   setup and cleanup functions are.  Precedence, which defaults to 0.0, and is
     
    565354      (setf (getstring name *mode-names*) mode)))
    566355
     356    (when (eq precedence :highest)
     357      (setq precedence most-positive-double-float))
    567358    (if precedence
    568359        (if major-p
     
    571362        (setq precedence 0))
    572363   
     364    (when default-command
     365      (setf (mode-object-default-command mode) default-command))
     366
    573367    (setf (mode-object-major-p mode) major-p
    574368          (mode-object-documentation mode) documentation
     
    603397  "Internal variable which might contain the current buffer." )
    604398
     399(defun all-buffers ()
     400  "List of all buffers"
     401  (remove-if #'echo-buffer-p *buffer-list*))
     402
     403(ccl:defloadvar *echo-area-counter* 0)
     404
     405(defun make-echo-buffer ()
     406  (let* ((name (loop as name = (format nil "Echo Area ~d" (incf *echo-area-counter*))
     407                  until (null (getstring name *buffer-names*))
     408                  finally (return name)))
     409         (buffer (internal-make-echo-buffer
     410                  :%name name
     411                  :major-mode-object (getstring "Echo Area" *mode-names*))))
     412    (initialize-buffer buffer)))
     413
    605414(defun make-buffer (name &key (modes (value hemlock::default-modes))
    606                               (modeline-fields
    607                                (value hemlock::default-modeline-fields))
    608                               delete-hook)
     415                              (modeline-fields (value hemlock::default-modeline-fields))
     416                              delete-hook)
    609417  "Creates and returns a buffer with the given Name if a buffer with Name does
    610418   not already exist, otherwise returns nil.  Modes is a list of mode names,
    611419   and Modeline-fields is a list of modeline field objects.  Delete-hook is a
    612420   list of functions that take a buffer as the argument."
    613   (cond ((getstring name *buffer-names*) nil)
     421  (when (getstring name *buffer-names*)
     422    (cerror "Try to delete" "~s already exists" name)
     423    (let ((buffer (getstring name *buffer-names*)))
     424      (delete-buffer buffer)))
     425  (cond ((getstring name *buffer-names*)
     426         nil)
    614427        (t
    615428         (unless (listp delete-hook)
    616429           (error ":delete-hook is a list of functions -- ~S." delete-hook))
    617          (let* ((region (make-empty-region))
    618                 (object (getstring "Fundamental" *mode-names*))
    619                 (buffer (internal-make-buffer
    620                          :%name name
    621                          :%region region
    622                          :modes (list (mode-object-name object))
    623                          :mode-objects (list object)
    624                          :bindings (make-hash-table)
    625                          :point (copy-mark (region-end region))
    626                          :display-start (copy-mark (region-start region))
    627                          :delete-hook delete-hook
    628                          :variables (make-string-table))))
    629            (sub-set-buffer-modeline-fields buffer modeline-fields)
    630            (setf (line-%buffer (mark-line (region-start region))) buffer)
    631            (push buffer *buffer-list*)
    632            (setf (getstring name *buffer-names*) buffer)
    633            (unless (equalp modes '("Fundamental"))
    634              (setf (buffer-major-mode buffer) (car modes))
    635              (dolist (m (cdr modes))
    636                (setf (buffer-minor-mode buffer m) t)))
    637            (invoke-hook hemlock::make-buffer-hook buffer)
    638            buffer))))
     430         (let* ((buffer (internal-make-buffer
     431                         :%name name
     432                         :major-mode-object (getstring "Fundamental" *mode-names*)
     433                         :delete-hook delete-hook)))
     434           (initialize-buffer buffer :modeline-fields modeline-fields :modes modes)))))
     435
     436(defun initialize-buffer (buffer &key modeline-fields modes)
     437  (setf (buffer-bindings buffer) (make-hash-table))
     438  (setf (buffer-variables buffer) (make-string-table))
     439  (let ((region (make-empty-region)))
     440    (setf (line-%buffer (mark-line (region-start region))) buffer)
     441    (setf (buffer-%region buffer) region)
     442    (setf (buffer-point buffer) (copy-mark (region-end region))))
     443  (setf (getstring (buffer-%name buffer) *buffer-names*) buffer)
     444  (push buffer *buffer-list*)
     445  (set-buffer-modeline-fields buffer modeline-fields)
     446  (when modes
     447    (unless (equalp modes '("Fundamental"))
     448      (setf (buffer-major-mode buffer) (car modes))
     449      (dolist (m (cdr modes))
     450        (setf (buffer-minor-mode buffer m) t))))
     451  (invoke-hook hemlock::make-buffer-hook buffer)
     452  buffer)
    639453
    640454(defun delete-buffer (buffer)
    641   "Deletes a buffer.  If buffer is current, or if it is displayed in any
    642    windows, an error is signaled."
     455  "Deletes a buffer.  If buffer is current, an error is signaled."
    643456  (when (eq buffer *current-buffer*)
    644457    (error "Cannot delete current buffer ~S." buffer))
    645   (when (buffer-windows buffer)
    646     (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
    647            buffer (length (buffer-windows buffer))))
     458  (when (buffer-document buffer)
     459    (error "Cannot delete displayed buffer ~S." buffer))
    648460  (invoke-hook (buffer-delete-hook buffer) buffer)
    649461  (invoke-hook hemlock::delete-buffer-hook buffer)
     
    676488;;; "make-buffer" wants fundamental to be defined when it is called, and we
    677489;;; can't make the real fundamental mode until there is a current buffer
    678 ;;; because "defmode" wants to invoke it's mode definition hook.  Also,
     490;;; because "defmode" wants to invoke its mode definition hook.  Also,
    679491;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet
    680492;;; defined, so we supply this argument to MAKE-BUFFER as nil.  This is
     
    690502  ;; Make it look like there is a make-buffer-hook...
    691503  (setf (get 'hemlock::make-buffer-hook 'hemlock-variable-value)
    692         (make-variable-object "foo" "bar"))
     504        (make-variable-object 'foo))
    693505  (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
    694506                                      :modeline-fields nil))
     
    700512  ;; Bash the real mode object into the buffer.
    701513  (let ((obj (getstring "Fundamental" *mode-names*)))
    702     (setf (car (buffer-mode-objects *current-buffer*)) obj
    703           (car (buffer-modes *current-buffer*)) (mode-object-name obj))))
     514    (setf (buffer-major-mode-object *current-buffer*) obj)))
  • trunk/source/cocoa-ide/hemlock/src/charmacs.lisp

    r6577 r8428  
    3131;;;; Stuff for the Syntax table functions (syntax)
    3232
    33 (defconstant syntax-char-code-limit char-code-limit
     33(defconstant syntax-char-code-limit hemlock-char-code-limit
    3434  "The highest char-code which a character argument to the syntax
    3535  table functions may have.")
  • trunk/source/cocoa-ide/hemlock/src/cocoa-hemlock.lisp

    r7595 r8428  
    77(in-package :hemlock-internals)
    88
    9 (defstruct (frame-event-queue (:include ccl::locked-dll-header))
    10   (signal (ccl::make-semaphore))
    11   (quoted-insert nil))
    12 
    13 (defstruct (buffer-operation (:include ccl::dll-node))
    14   (thunk nil))
    15 
    16 (defstruct (event-queue-node (:include ccl::dll-node)
    17                              (:constructor make-event-queue-node (event)))
    18   event)
    19 
    20 (defun event-queue-insert (q node)
    21   (ccl::locked-dll-header-enqueue node q)
    22   (ccl::signal-semaphore (frame-event-queue-signal q)))
    23 
    24 (defun enqueue-key-event (q event)
    25   (event-queue-insert q (make-event-queue-node event)))
    26 
    27 (defun dequeue-key-event (q)
    28   (unless (listen-editor-input q)
    29     (let* ((document (buffer-document (current-buffer))))
    30       (when document
    31         (document-set-point-position document))))
    32   (ccl::wait-on-semaphore (frame-event-queue-signal q))
    33   (ccl::locked-dll-header-dequeue q))
    34 
    35 
    36 (defun unget-key-event (event q)
    37   (ccl::with-locked-dll-header (q)
    38     (ccl::insert-dll-node-after (make-event-queue-node  event) q))
    39   (ccl::signal-semaphore (frame-event-queue-signal q)))
    40 
    41 (defun timed-wait-for-key-event (q seconds)
    42   (let* ((signal (frame-event-queue-signal q)))
    43     (when (ccl:timed-wait-on-semaphore signal seconds)
    44       (ccl:signal-semaphore signal)
    45       t)))
    46 
    47 (defvar *command-key-event-buffer* nil)
    48 
    49  
    50 
    51 (defun buffer-windows (buffer)
    52   (let* ((doc (buffer-document buffer)))
    53     (when doc
    54       (document-panes doc))))
    55 
    56 (defvar *current-window* ())
    57 
    58 (defvar *window-list* ())
    59 (defun current-window ()
    60   "Return the current window.  The current window is specially treated by
    61   redisplay in several ways, the most important of which is that is does
    62   recentering, ensuring that the Buffer-Point of the current window's
    63   Window-Buffer is always displayed.  This may be set with Setf."
    64   *current-window*)
    65 
    66 (defun %set-current-window (new-window)
    67   #+not-yet
    68   (invoke-hook hemlock::set-window-hook new-window)
    69   (activate-hemlock-view new-window)
    70   (setq *current-window* new-window))
    71 
    72 ;;; This is a public variable.
    73 ;;;
    74 (defvar *last-key-event-typed* ()
    75   "This variable contains the last key-event typed by the user and read as
    76    input.")
    77 
    78 (defvar *input-transcript* ())
    79 
    80 (defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G"))
    81 
    82 (defmacro abort-key-event-p (key-event)
    83   `(member (event-queue-node-event ,key-event) editor-abort-key-events))
    84 
    85 (defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift"))
    86    
    87 (defun get-key-event (q &optional ignore-pending-aborts)
    88   (do* ((e (dequeue-key-event q) (dequeue-key-event q)))
    89        ((typep e 'event-queue-node)
    90         (unless ignore-pending-aborts
    91           (when (abort-key-event-p e)
    92             (beep)
    93             (clear-echo-area)
    94             (throw 'editor-top-level-catcher nil)))
    95         (values (setq *last-key-event-typed* (event-queue-node-event e))
    96                 (prog1 (frame-event-queue-quoted-insert q)
    97                   (setf (frame-event-queue-quoted-insert q) nil))))
    98     (if (typep e 'buffer-operation)
    99       (catch 'command-loop-catcher
    100         (funcall (buffer-operation-thunk e))))))
    101 
    102 (defun recursive-get-key-event (q &optional ignore-pending-aborts)
    103   (let* ((buffer *command-key-event-buffer*)
    104          (doc (when buffer (buffer-document buffer))))
    105     (if (null doc)
    106       (get-key-event q ignore-pending-aborts)
    107       (unwind-protect
    108            (progn
    109              (document-end-editing doc)
    110              (get-key-event q ignore-pending-aborts))
    111         (document-begin-editing doc)))))
    112 
    113 
    114 (defun listen-editor-input (q)
    115   (ccl::with-locked-dll-header (q)
    116     (not (eq (ccl::dll-header-first q) q))))
    117 
    1189(defun add-buffer-font-region (buffer region)
    11910  (when (typep buffer 'buffer)
     
    12314      (setf (font-region-node region) node)
    12415      region)))
    125 
    126 (defun enable-self-insert (q)
    127   (setf (frame-event-queue-quoted-insert q) t))
    128 
    129 (defmethod disable-self-insert ((q frame-event-queue))
    130   (setf (frame-event-queue-quoted-insert q) nil))
    13116
    13217(defun remove-font-region (region)
     
    19075      (format t "~& style ~d ~d [~s]/ ~d [~s] ~a"
    19176              (font-mark-font start)
    192               (ccl::mark-absolute-position start)
     77              (mark-absolute-position start)
    19378              (mark-%kind start)
    194               (ccl::mark-absolute-position end)
     79              (mark-absolute-position end)
    19580              (mark-%kind end)
    19681              (eq r (buffer-active-font-region buffer))))))
     
    20085  (string-to-clipboard (region-to-string region)))
    20186
    202 ;;; Meta-.
    203 (defun hemlock::get-def-info-and-go-to-it (string package)
    204   (multiple-value-bind (fun-name error)
    205       (let* ((*package* package))
    206         (ignore-errors (values (read-from-string string))))
    207     (if error
    208       (editor-error)
    209       (hi::edit-definition fun-name))))
    210 
    211 ;;; Search highlighting
    212 (defun note-selection-set-by-search (&optional (buffer (current-buffer)))
    213   (let* ((doc (buffer-document buffer)))
    214     (when doc (hi::document-note-selection-set-by-search doc))))
  • trunk/source/cocoa-ide/hemlock/src/command.lisp

    r7595 r8428  
    4242  With prefix argument insert the character that many times."
    4343  "Implements ``Self Insert'', calling this function is not meaningful."
    44   (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)))
     44  (let ((char (last-char-typed)))
    4545    (unless char (editor-error "Can't insert that character."))
    4646    (if (and p (> p 1))
     
    5353  "Causes the next character typed to be inserted in the current
    5454   buffer, even if would normally be interpreted as an editor command."
    55   "Reads a key-event from *editor-input* and inserts it at the point."
    5655  (declare (ignore p))
    57   (hi::enable-self-insert hi::*editor-input*))
     56  (setf (hi::hemlock-view-quote-next-p hi::*current-view*) t))
    5857
    5958(defcommand "Forward Character" (p)
     
    182181         (t
    183182          (move-mark
    184            mark (buffer-start-mark (line-buffer (mark-line mark)))))))
     183           mark (buffer-start-mark (mark-buffer mark))))))
    185184      (do ((cnt offset (1- cnt)))
    186185          ((zerop cnt) mark)
     
    234233;;;; Moving around:
    235234
    236 (defvar *target-column* 0)
    237 
    238235(defun set-target-column (mark)
    239236  (if (eq (last-command-type) :line-motion)
    240       *target-column*
    241       (setq *target-column* (mark-column mark))))
     237    (hi::hemlock-target-column hi::*current-view*)
     238    (setf (hi::hemlock-target-column hi::*current-view*) (mark-column mark))))
    242239
    243240(defhvar "Next Line Inserts Newlines"
     
    253250  "Moves the down p lines, collapsing the selection."
    254251  (let* ((point (current-point-collapsing-selection))
    255          (target (set-target-column point)))
    256     (unless (line-offset point (or p 1))
    257       (when (value next-line-inserts-newlines)
    258         (cond ((not p)
    259                (when (same-line-p point (buffer-end-mark (current-buffer)))
    260                  (line-end point))
    261                (insert-character point #\newline))
    262               ((minusp p)
    263                (buffer-start point)
    264                (editor-error "No previous line."))
    265               (t
    266                (buffer-end point)
    267                (when p (editor-error "No next line."))))))
    268     (unless (move-to-column point target) (line-end point))
     252         (target (set-target-column point))
     253         (count (or p 1)))
     254    (unless (line-offset point count)
     255      (cond ((and (not p) (value next-line-inserts-newlines))
     256             (when (same-line-p point (buffer-end-mark (current-buffer)))
     257               (line-end point))
     258             (insert-character point #\newline))
     259            ((minusp count)
     260             (buffer-start point)
     261             (editor-error "No previous line."))
     262            (t
     263             (buffer-end point)
     264             (editor-error "No next line."))))
     265    (unless (move-to-position point target) (line-end point))
    269266    (setf (last-command-type) :line-motion)))
    270267
     
    288285               (buffer-end point)
    289286               (when p (editor-error "No next line."))))))
    290     (unless (move-to-column point target) (line-end point))
     287    (unless (move-to-position point target) (line-end point))
    291288    (setf (last-command-type) :line-motion)))
    292289
     
    310307  "Sets the current region from point to the end of the buffer."
    311308  (declare (ignore p))
    312   (push-buffer-mark (buffer-end (copy-mark (current-point))) t))
     309  (buffer-end (push-new-buffer-mark (current-point) t)))
    313310
    314311(defcommand "Mark to Beginning of Buffer" (p)
     
    316313  "Sets the current region from the beginning of the buffer to point."
    317314  (declare (ignore p))
    318   (push-buffer-mark (buffer-start (copy-mark (current-point))) t))
     315  (buffer-start (push-new-buffer-mark (current-point) t)))
    319316
    320317(defcommand "Beginning of Buffer" (p)
     
    323320  (declare (ignore p))
    324321  (let ((point (current-point-collapsing-selection)))
    325     (push-buffer-mark (copy-mark point))
     322    (push-new-buffer-mark point)
    326323    (buffer-start point)))
    327324
     
    331328  (declare (ignore p))
    332329  (let ((point (current-point-collapsing-selection)))
    333     (push-buffer-mark (copy-mark point))
     330    (push-new-buffer-mark point)
    334331    (buffer-end point)))
    335332
     
    383380  :value nil)
    384381
    385 (defcommand "Scroll Window Down" (p &optional (window (current-window)))
     382(defcommand "Scroll Window Down" (p)
    386383  "Move down one screenfull.
    387384  With prefix argument scroll down that many lines."
     
    389386  window, down one screenfull.  If P is supplied then scroll that
    390387  many lines."
    391   (scroll-window window (or p :page-down)))
    392 
    393 (defcommand "Scroll Window Up" (p &optional (window (current-window)))
     388  (if p
     389    (set-scroll-position :lines-down p)
     390    (set-scroll-position :page-down)))
     391
     392(defcommand "Scroll Window Up" (p)
    394393  "Move up one screenfull.
    395394  With prefix argument scroll up that many lines."
     
    397396  window, up one screenfull.  If P is supplied then scroll that
    398397  many lines."
    399   (scroll-window window (if p (- p) :page-up)))
    400 
    401 (defcommand "Scroll Next Window Down" (p)
    402   "Do a \"Scroll Window Down\" on the next window."
    403   "Do a \"Scroll Window Down\" on the next window."
    404   (let ((win (next-window (current-window))))
    405     (when (eq win (current-window)) (editor-error "Only one window."))
    406     (scroll-window-down-command p win)))
    407 
    408 (defcommand "Scroll Next Window Up" (p)
    409   "Do a \"Scroll Window Up\" on the next window."
    410   "Do a \"Scroll Window Up\" on the next window."
    411   (let ((win (next-window (current-window))))
    412     (when (eq win (current-window)) (editor-error "Only one window."))
    413     (scroll-window-up-command p win)))
    414 
    415 
    416 
     398  (if p
     399    (set-scroll-position :lines-up p)
     400    (set-scroll-position :page-up)))
    417401
    418402;;;; Kind of miscellaneous commands:
    419403
    420 ;;; "Refresh Screen" may not be right with respect to wrapping lines in
    421 ;;; the case where an argument is supplied due the use of
    422 ;;; WINDOW-DISPLAY-START instead of SCROLL-WINDOW, but using the latter
    423 ;;; messed with point and did other hard to predict stuff.
    424 ;;;
    425404(defcommand "Refresh Screen" (p)
    426   "Refreshes everything in the window, centering current line."
    427   "Refreshes everything in the window, centering current line."
    428   (declare (ignore p))
    429   (center-text-pane (current-window)))
    430 
    431 
    432 
    433 ;;;
    434 (defun reset-window-display-recentering (window &optional buffer)
    435   (declare (ignore buffer))
    436   (setf (window-display-recentering window) nil))
    437 ;;;
    438 (add-hook window-buffer-hook #'reset-window-display-recentering)
     405  "Refreshes everything in the window, centering current line.
     406With prefix argument, puts moves current line to top of window"
     407  (if p
     408    (set-scroll-position :line (current-point))
     409    (set-scroll-position :center-selection)))
    439410
    440411
     
    443414  "Prompts for and executes an extended command.  The prefix argument is
    444415  passed to the command."
    445   (let* ((name (prompt-for-keyword (list *command-names*)
     416  (let* ((name (prompt-for-keyword :tables (list *command-names*)
    446417                                   :prompt "Extended Command: "
    447418                                   :help "Name of a Hemlock command"))
     
    453424  :value 4)
    454425
     426(defstruct (prefix-argument-state (:conc-name "PS-"))
     427  sign
     428  multiplier
     429  read-some-digit-p
     430  ;; This is NIL if haven't started and don't have a universal argument, else a number
     431  result
     432  ;; This is cleared by prefix-argument-resetting-state (called at the start of each
     433  ;; command) and can be set by a command to avoid the state being reset at
     434  ;; the end of the command.
     435  set-p)
     436
     437(defun prefix-argument-resetting-state (&optional (ps (current-prefix-argument-state)))
     438  "Fetches the prefix argument and uses it up, i.e. marks it as not being set"
     439  (unless (ps-set-p ps)
     440    (setf (ps-sign ps) 1
     441          (ps-multiplier ps) 1
     442          (ps-read-some-digit-p ps) nil
     443          (ps-result ps) nil))
     444  (setf (ps-set-p ps) nil) ;; mark it for death unless explicitly revived.
     445  (when (ps-result ps)
     446    (* (ps-sign ps)
     447       (if (ps-read-some-digit-p ps)
     448         (ps-result ps)
     449         (expt (value universal-argument-default) (ps-multiplier ps))))))
     450
     451(defun note-prefix-argument-set (ps)
     452  (assert (ps-result ps))
     453  (setf (ps-set-p ps) t)
     454  (message (with-output-to-string (s)
     455             (dotimes (i (ps-multiplier ps))
     456               (write-string "C-U " s))
     457             (cond ((ps-read-some-digit-p ps)
     458                    (format s "~d" (* (ps-sign ps) (ps-result ps))))
     459                   ((< (ps-sign ps) 0)
     460                    (write-string "-" s))))))
     461
    455462(defcommand "Universal Argument" (p)
    456463  "Sets prefix argument for next command.
    457   Typing digits, regardless of any modifier keys, specifies the argument.
    458   Optionally, you may first type a sign (- or +).  While typing digits, if you
    459   type C-U or C-u, the digits following the C-U form a number this command
    460   multiplies by the digits preceding the C-U.  The default value for this
    461   command and any number following a C-U is the value of \"Universal Argument
    462   Default\"."
    463   "You probably don't want to use this as a function."
    464   (declare (ignore p))
    465   (clear-echo-area)
    466   (write-string "C-U " *echo-area-stream*)
    467   (let* ((key-event (get-key-event hi::*editor-input*))
    468          (char (hemlock-ext:key-event-char key-event)))
    469     (if char
    470         (case char
    471           (#\-
    472            (write-char #\- *echo-area-stream*)
    473            (universal-argument-loop (get-key-event hi::*editor-input*) -1))
    474           (#\+
    475            (write-char #\+ *echo-area-stream*)
    476            (universal-argument-loop (get-key-event hi::*editor-input*) -1))
    477           (t
    478            (universal-argument-loop key-event 1)))
    479         (universal-argument-loop key-event 1))))
    480 
    481 (defcommand "Negative Argument" (p)
    482   "This command is equivalent to invoking \"Universal Argument\" and typing
    483    a minus sign (-).  It waits for more digits and a command to which to give
    484    the prefix argument."
    485   "Don't call this as a function."
    486   (when p (editor-error "Must type minus sign first."))
    487   (clear-echo-area)
    488   (write-string "C-U -" *echo-area-stream*)
    489   (universal-argument-loop (get-key-event hi::*editor-input*) -1))
     464   Typing digits, regardless of any modifier keys, specifies the argument.
     465   Optionally, you may first type a sign (- or +).  While typing digits, if you
     466   type C-U or C-u, the digits following the C-U form a number this command
     467   multiplies by the digits preceding the C-U.  The default value for this
     468   command and any number following a C-U is the value of \"Universal Argument
     469   Default\"."
     470  (declare (ignore p)) ;; we operate on underlying state instead
     471  (let ((ps (current-prefix-argument-state)))
     472    (if (ps-result ps)
     473      (incf (ps-multiplier ps))
     474      (setf (ps-result ps) 0))
     475    (note-prefix-argument-set ps)))
    490476
    491477(defcommand "Argument Digit" (p)
    492478  "This command is equivalent to invoking \"Universal Argument\" and typing
    493    the digit used to invoke this command.  It waits for more digits and a
     479   the key used to invoke this command.  It waits for more digits and a
    494480   command to which to give the prefix argument."
    495   "Don't call this as a function."
    496   (declare (ignore p))
    497   (clear-echo-area)
    498   (write-string "C-U " *echo-area-stream*)
    499   (universal-argument-loop *last-key-event-typed* 1))
    500 
    501 (defun universal-argument-loop (key-event sign &optional (multiplier 1))
    502   (flet ((prefix (sign multiplier read-some-digit-p result)
    503            ;; read-some-digit-p and (zerop result) are not
    504            ;; equivalent if the user invokes this and types 0.
    505            (* sign multiplier
    506               (if read-some-digit-p
    507                   result
    508                   (value universal-argument-default)))))
    509     (let* ((stripped-key-event (if key-event (hemlock-ext:make-key-event key-event)))
    510            (char (hemlock-ext:key-event-char stripped-key-event))
    511            (digit (if char (digit-char-p char)))
    512            (result 0)
    513            (read-some-digit-p nil))
    514       (loop
    515         (cond (digit
    516                (setf read-some-digit-p t)
    517                (write-char char *echo-area-stream*)
    518                (setf result (+ digit (* 10 result)))
    519                (setf key-event (get-key-event hi::*editor-input*))
    520                (setf stripped-key-event (if key-event
    521                                             (hemlock-ext:make-key-event key-event)))
    522                (setf char (hemlock-ext:key-event-char stripped-key-event))
    523                (setf digit (if char (digit-char-p char))))
    524               ((or (eq key-event #k"C-u") (eq key-event #k"C-U"))
    525                (write-string " C-U " *echo-area-stream*)
    526                (universal-argument-loop
    527                 (get-key-event hi::*editor-input*) 1
    528                 (prefix sign multiplier read-some-digit-p result))
    529                (return))
    530               (t
    531                (unget-key-event key-event hi::*editor-input*)
    532                (setf (prefix-argument)
    533                      (prefix sign multiplier read-some-digit-p result))
    534                (return))))))
    535   (setf (last-command-type) (last-command-type)))
     481  (declare (ignore p)) ;; we operate on underlying state instead
     482  (let* ((ps (current-prefix-argument-state))
     483         (key-event (last-key-event-typed))
     484         (stripped-key-event (make-key-event key-event))
     485         (char (key-event-char stripped-key-event))
     486         (digit (if char (digit-char-p char))))
     487    (when (null (ps-result ps))
     488      (setf (ps-result ps) 0))
     489    (case char
     490      (#\-
     491       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
     492         (editor-error "Must type minus sign first."))
     493       (setf (ps-sign ps) (- (ps-sign ps))))
     494      (#\+
     495       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
     496         (editor-error "Must type plus sign first.")))
     497      (t
     498       (unless digit
     499         (editor-error "Argument Digit must be bound to a digit!"))
     500       (setf (ps-read-some-digit-p ps) t)
     501       (setf (ps-result ps) (+ digit (* (ps-result ps) 10)))))
     502    (note-prefix-argument-set ps)))
     503
     504(defcommand "Digit" (p)
     505  "With a numeric argument, this command extends the argument.
     506   Otherwise it does self insert"
     507  (if p
     508    (argument-digit-command p)
     509    (self-insert-command p)))
  • trunk/source/cocoa-ide/hemlock/src/completion.lisp

    r7540 r8428  
    191191   Size\" limits the number of completions saved in each list.")
    192192
     193(defvar *completion-modeline-field* (modeline-field :completion))
     194
    193195(defcommand "Completion Mode" (p)
    194196  "Toggles Completion Mode in the current buffer."
    195197  "Toggles Completion Mode in the current buffer."
    196198  (declare (ignore p))
    197   (setf (buffer-minor-mode (current-buffer) "Completion")
    198         (not (buffer-minor-mode (current-buffer) "Completion"))))
     199  (let ((buffer (current-buffer)))
     200    (setf (buffer-minor-mode buffer "Completion")
     201          (not (buffer-minor-mode buffer "Completion")))
     202    (let ((fields (buffer-modeline-fields buffer)))
     203      (if (buffer-minor-mode buffer "Completion")
     204        (unless (member *completion-modeline-field* fields)
     205          (hi::set-buffer-modeline-fields buffer
     206                                          (append fields
     207                                                  (list *completion-modeline-field*))))
     208        (when (member *completion-modeline-field* fields)
     209          (hi::set-buffer-modeline-fields buffer
     210                                          (remove *completion-modeline-field*
     211                                                  fields)))))))
    199212
    200213
     
    223236  "Implements \"Completion Self Insert\". Calling this function is not
    224237   meaningful."
    225   (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)))
     238  (let ((char (last-char-typed)))
    226239    (unless char (editor-error "Can't insert that character."))
    227240    (cond ((completion-char-p char)
     
    494507(defvar *completion-mode-possibility* "")
    495508
    496 (defvar *completion-modeline-field* (modeline-field :completion))
    497 
    498509(defun display-possible-completion (prefix
    499510                                    &optional (prefix-length (length prefix)))
     
    502513          (or (find-completion prefix prefix-length) ""))
    503514    (unless (eq old *completion-mode-possibility*)
    504       (update-modeline-field *echo-area-buffer* *echo-area-window*
    505                              *completion-modeline-field*))))
     515      (hi::note-modeline-change (current-buffer)))))
    506516
    507517(defun clear-completion-display ()
    508518  (unless (= (length (the simple-string *completion-mode-possibility*)) 0)
    509519    (setq *completion-mode-possibility* "")
    510     (update-modeline-field *echo-area-buffer* *echo-area-window*
    511                            *completion-modeline-field*)))
    512 
    513 
     520    (hi::note-modeline-change (current-buffer))))
     521
     522#|
    514523;;; COMPLETION-REDISPLAY-FUN erases any completion displayed in the status line.
    515524;;;
     
    518527  (unless (eq (last-command-type) :completion-self-insert)
    519528    (clear-completion-display)))
    520 ;;;
    521529(add-hook redisplay-hook #'completion-redisplay-fun)
     530|#
  • trunk/source/cocoa-ide/hemlock/src/decls.lisp

    r7595 r8428  
    5555             ,name)))
    5656
    57 (declfun window-buffer (window))
    58 (declfun change-to-buffer (buffer))     ;filecoms.lisp
    59 
    60 (declfun hemlock::to-line-comment (mark start)) ;defined in comments.lisp used in lispbuf.lisp
    61 
    6257;;; Some special variables are forward-referenced, and we don't even
    6358;;; need to invent a new language to advise the compiler of that ...
    64 (declaim (special *mode-names* *current-buffer* *echo-area-buffer*
     59(declaim (special *mode-names* *current-buffer*
    6560                  *the-sentinel*
    6661                  *in-the-editor* *buffer-list* *things-to-do-once*
    67                   *gc-notify-before* *gc-notify-after*))
     62                  *gc-notify-before* *gc-notify-after*
     63                  *key-event-history*))
  • trunk/source/cocoa-ide/hemlock/src/defsyn.lisp

    r6 r8428  
    6565(setf (character-attribute :word-delimiter
    6666                           #+CMU #\formfeed
    67                            #+(or EXCL sbcl CLISP OpenMCL) #\page) 1)
     67                           #+(or EXCL sbcl CLISP Clozure) #\page) 1)
    6868(setf (character-attribute :word-delimiter #\tab) 1)
    6969(setf (character-attribute :word-delimiter #\newline) 1)
  • trunk/source/cocoa-ide/hemlock/src/doccoms.lisp

    r7123 r8428  
    4444    (#\m "Describe a mode."
    4545     (describe-mode-command nil))
    46     (#\p "Describe commands with mouse/pointer bindings."
    47     (describe-pointer-command nil))
     46    ;(#\p "Describe commands with mouse/pointer bindings."
     47    ; (describe-pointer-command nil))
    4848    (#\w "Find out Where a command is bound."
    4949     (where-is-command nil))
     
    5959  (declare (ignore p))
    6060  (multiple-value-bind (nam cmd)
    61                        (prompt-for-keyword (list *command-names*)
     61                       (prompt-for-keyword :tables (list *command-names*)
    6262                                           :prompt "Command: "
    6363                                           :help "Name of command to look for.")
     
    150150  (multiple-value-bind (nam com)
    151151                       (prompt-for-keyword
    152                         (list *command-names*)
     152                        :tables (list *command-names*)
    153153                        :prompt "Describe command: "
    154154                        :help "Name of a command to document.")
     
    176176  which is prompted for."
    177177  (declare (ignore p))
    178   (let ((old-window (current-window)))
    179     (unwind-protect
    180         (progn
    181           (setf (current-window) hi::*echo-area-window*)
    182           (hi::display-prompt-nicely "Describe key: " nil)
    183           (setf (fill-pointer hi::*prompt-key*) 0)
    184           (loop
    185             (let ((key-event (get-key-event hi::*editor-input*)))
    186               (vector-push-extend key-event hi::*prompt-key*)
    187               (let ((res (get-command hi::*prompt-key* :current)))
    188                 (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
    189                 (write-char #\space *echo-area-stream*)
    190                 (cond ((commandp res)
    191                        (with-pop-up-display (s :title "Key documentation")
    192                          (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s)
    193                          (format s " is bound to ~S.~%" (command-name res))
    194                          (format s "Documentation for this command:~%   ~A"
    195                                  (command-documentation res)))
    196                        (return))
    197                       ((not (eq res :prefix))
    198                        (with-pop-up-display (s :height 1)
    199                          (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s)
    200                          (write-string " is not bound to anything." s))
    201                        (return)))))))
    202       (setf (current-window) old-window))))
    203 
    204 
    205 
     178  (multiple-value-bind (key res) (prompt-for-key :prompt "Describe key: "
     179                                                 :must-exist t)
     180    (cond ((commandp res)
     181           (with-pop-up-display (s :title "Key documentation")
     182             (write-string (pretty-key-string key) s)
     183             (format s " is bound to ~S.~%" (command-name res))
     184             (format s "Documentation for this command:~%   ~A"
     185                     (command-documentation res))))
     186          (t
     187           (with-pop-up-display (s :height 1)
     188             (write-string (pretty-key-string key) s)
     189             (write-string " is not bound to anything." s))))))
    206190
    207191;;;; Generic describe variable, command, key, attribute.
     
    222206  (declare (ignore p))
    223207  (multiple-value-bind (ignore kwd)
    224                        (prompt-for-keyword *generic-describe-kinds*
     208                       (prompt-for-keyword :tables *generic-describe-kinds*
    225209                                           :default "Variable"
    226210                                           :help "Kind of thing to describe."
     
    235219       (multiple-value-bind (name attr)
    236220                            (prompt-for-keyword
    237                              (list *character-attribute-names*)
     221                             :tables (list *character-attribute-names*)
    238222                             :help "Name of character attribute to describe."
    239223                             :prompt "Attribute: ")
     
    309293  (declare (ignore p))
    310294  (let ((name (or name
    311                   (prompt-for-keyword (list *mode-names*)
     295                  (prompt-for-keyword :tables (list *mode-names*)
    312296                                      :prompt "Mode: "
    313297                                      :help "Enter mode to describe."
    314298                                      :default
    315                                       (car (buffer-modes (current-buffer)))))))
     299                                      (buffer-major-mode (current-buffer))))))
    316300    (with-pop-up-display (s :title (format nil "~A mode" name))
    317301      (format s "~A mode description:~%" name)
     
    325309                           *describe-mode-ignore*
    326310                           :test #'string-equal)
    327              (let ((str (key-to-string key)))
     311             (let ((str (pretty-key-string key)))
    328312               (cond ((= (length str) 1)
    329313                      (write-string str s)
     
    334318       :mode name))))
    335319                   
    336 (defun key-to-string (key)
    337   (with-output-to-string (s)
    338     (hemlock-ext:print-pretty-key key s)))
    339 
    340 
    341 
    342 
    343320;;;; Printing bindings and last N characters typed.
    344321
     
    352329      (do ((i (1- num) (1- i)))
    353330          ((minusp i))
    354         (hemlock-ext:print-pretty-key-event (ring-ref *key-event-history* i) s)
     331        (write-string (pretty-key-string (ring-ref *key-event-history* i)) s)
    355332        (write-char #\space s)))))
    356333
     
    390367  (do ((key keys (cdr key)))
    391368      ((null (cdr key))
    392        (hemlock-ext:print-pretty-key (car key) stream))
    393     (hemlock-ext:print-pretty-key (car key) stream)
     369       (write-string (pretty-key-string (car key)) stream))
     370    (write-string (pretty-key-string (car key)) stream)
    394371    (write-string ", " stream)))
  • trunk/source/cocoa-ide/hemlock/src/echo.lisp

    r7475 r8428  
    1414;;; Modified by Bill Chiles.
    1515;;;
     16;;; Totally rewritten for Clozure CL.
     17
    1618(in-package :hemlock-internals)
    1719
    18 (defmode "Echo Area" :major-p t)
    19 (defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area"))
    20   "Buffer used to hack text for the echo area.")
    21 (defvar *echo-area-region* (buffer-region *echo-area-buffer*)
    22   "Internal thing that's the *echo-area-buffer*'s region.")
    23 (defvar *echo-area-stream*
    24   (make-hemlock-output-stream (region-end *echo-area-region*) :full)
    25   "Buffered stream that prints into the echo area.")
    26 (defvar *echo-area-window* ()
    27   "Window used to display stuff in the echo area.")
    28 (defvar *parse-starting-mark*
    29   (copy-mark (buffer-point *echo-area-buffer*) :right-inserting)
    30   "Mark that points to the beginning of the text that'll be parsed.")
    31 (defvar *parse-input-region*
    32   (region *parse-starting-mark* (region-end *echo-area-region*))
    33   "Region that contains the text typed in.")
    34 
    35 
    36 
    37 
    38 ;;;; Variables that control parsing:
    39 
    40 (defvar *parse-verification-function* '%not-inside-a-parse
    41   "Function that verifies what's being parsed.")
    42 
    4320(defmacro modifying-echo-buffer (&body body)
    44   `(unwind-protect
    45     (progn
    46       (buffer-document-begin-editing *echo-area-buffer*)
    47       (modifying-buffer *echo-area-buffer* ,@body))
    48     (buffer-document-end-editing *echo-area-buffer*)))
    49 ;;; %Not-Inside-A-Parse  --  Internal
    50 ;;;
    51 ;;;    This function is called if someone does stuff in the echo area when
    52 ;;; we aren't inside a parse.  It tries to put them back in a reasonable place.
    53 ;;;
    54 (defun %not-inside-a-parse (quaz)
    55   "Thing that's called when somehow we get called to confirm a parse that's
    56   not in progress."
    57   (declare (ignore quaz))
    58   (let* ((bufs (remove *echo-area-buffer* *buffer-list*))
    59          (buf (or (find-if #'buffer-windows bufs)
    60                   (car bufs)
    61                   (make-buffer "Main"))))
    62     (setf (current-buffer) buf)
    63     (dolist (w *window-list*)
    64       (when (and (eq (window-buffer w) *echo-area-buffer*)
    65                  (not (eq w *echo-area-window*)))
    66         (setf (window-buffer w) buf)))
    67     (setf (current-window)
    68           (or (car (buffer-windows buf))
    69               (make-window (buffer-start-mark buf)))))
    70   (editor-error "Wham!  We tried to confirm a parse that wasn't in progress?"))
    71 
    72 (defvar *parse-string-tables* ()
    73   "String tables being used in the current parse.")
    74 
    75 (defvar *parse-value-must-exist* ()
    76   "You know.")
    77 
    78 (defvar *parse-default* ()
    79   "When the user attempts to default a parse, we call the verification function
    80   on this string.  This is not the :Default argument to the prompting function,
    81   but rather a string representation of it.")
    82 
    83 (defvar *parse-default-string* ()
    84   "String that we show the user to inform him of the default.  If this
    85   is NIL then we just use *Parse-Default*.")
    86 
    87 (defvar *parse-prompt* ()
    88   "Prompt for the current parse.")
    89 
    90 (defvar *parse-help* ()
    91   "Help string for the current parse.")
    92 
    93 (defvar *parse-type* :string "A hack. :String, :File or :Keyword.")
    94 
    95 
    96 
    97 
    98 ;;;; MESSAGE and CLEAR-ECHO-AREA:
    99 
    100 (defhvar "Message Pause" "The number of seconds to pause after a Message."
    101   :value 0.0s0)
    102 
    103 (defvar *last-message-time* 0
    104   "Internal-Real-Time the last time we displayed a message.")
    105 
    106 (defun maybe-wait ()
    107   (let* ((now (get-internal-real-time))
    108          (delta (/ (float (- now *last-message-time*))
    109                    (float internal-time-units-per-second)))
    110          (pause (value hemlock::message-pause)))
    111     (when (< delta pause)
    112       (sleep (- pause delta)))))
     21  `(modifying-buffer-storage ((hemlock-echo-area-buffer *current-view*))
     22     ,@body))
     23
     24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     25;;;;
     26;;;; Echo area output.
     27
     28(defvar *last-message-time* (get-internal-real-time))
    11329
    11430(defun clear-echo-area ()
    11531  "You guessed it."
    116   ;;(maybe-wait)
    117   (let* ((b (current-buffer)))
    118     (unwind-protect
    119          (progn
    120            (setf (current-buffer) *echo-area-buffer*)
    121            (modifying-echo-buffer
    122             (delete-region *echo-area-region*))
    123            (setf (buffer-modified *echo-area-buffer*) nil))
    124       (setf (current-buffer) b))))
     32  (modifying-echo-buffer
     33   (delete-region (buffer-region *current-buffer*))))
    12534
    12635;;; Message  --  Public
    12736;;;
    128 ;;;    Display the stuff on *echo-area-stream* and then wait.  Editor-Sleep
    129 ;;; will do a redisplay if appropriate.
     37;;;    Display the stuff on *echo-area-stream*
    13038;;;
    13139(defun message (string &rest args)
    13240  "Nicely display a message in the echo-area.
    133   Put the message on a fresh line and wait for \"Message Pause\" seconds
    134   to give the luser a chance to see it.  String and Args are a format
    135   control string and format arguments, respectively."
    136   ;(maybe-wait)
    137   (modifying-echo-buffer
    138    (cond ((eq *current-window* *echo-area-window*)
    139           (let ((point (buffer-point *echo-area-buffer*)))
    140             (with-mark ((m point :left-inserting))
    141               (line-start m)
    142               (with-output-to-mark (s m :full)
    143                 (apply #'format s string args)
    144                 (fresh-line s)))))
    145          (t
    146           (let ((mark (region-end *echo-area-region*)))
    147             (cond ((buffer-modified *echo-area-buffer*)
    148                    (clear-echo-area))
    149                   ((not (zerop (mark-charpos mark)))
    150                    (insert-character mark #\newline)
    151                    (clear-echo-area)))
    152             (write-string (apply #'format nil string args)
    153                           *echo-area-stream*)
    154             ;; keep command loop from clearing the echo area,
    155             ;; by asserting that the echo area buffer's unmodified.
    156             (setf (buffer-modified *echo-area-buffer*) t))))
    157    (force-output *echo-area-stream*)
    158    (setq *last-message-time* (get-internal-real-time)))
    159   nil)
    160 
     41  String and Args are a format control string and format arguments, respectively."
     42  ;; TODO: used to do something cleverish if in the middle of reading prompted input, might
     43  ;; want to address that.
     44  (if *current-view*
     45    (let ((message (apply #'format nil string args)))
     46      (modifying-echo-buffer
     47       (delete-region (buffer-region *current-buffer*))
     48       (insert-string (buffer-point *current-buffer*) message)
     49       (setq *last-message-time* (get-internal-real-time))
     50       ))
     51    ;; For some reason this crashes.  Perhaps something is too aggressive about
     52    ;; catching conditions in events??
     53    #+not-yet(apply #'warn string args)
     54    #-not-yet (apply #'format t string args)))
    16155
    16256;;; LOUD-MESSAGE -- Public.
     
    16862   doing anything else."
    16963  (beep)
    170   (clear-echo-area)
    17164  (apply #'message args))
    17265
    173 
    174 
    175 
    176 
     66;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     67;;
     68;; Echo area input
     69
     70(defmode "Echo Area" :major-p t)
     71
     72
     73(defstruct (echo-parse-state (:conc-name "EPS-"))
     74  (parse-verification-function nil)
     75  (parse-string-tables ())
     76  (parse-value-must-exist ())
     77  ;; When the user attempts to default a parse, we call the verification function
     78  ;; on this string.  This is not the :Default argument to the prompting function,
     79  ;; but rather a string representation of it.
     80  (parse-default ())
     81  ;; String that we show the user to inform him of the default.  If this
     82  ;; is NIL then we just use Parse-Default.
     83  (parse-default-string ())
     84  ;; Prompt for the current parse.
     85  (parse-prompt ())
     86  ;; Help string for the current parse.
     87  (parse-help ())
     88  ;; :String, :File or :Keyword.
     89  (parse-type :string)
     90  ;; input region
     91  parse-starting-mark
     92  parse-input-region
     93  ;; key handler, nil to use the standard one
     94  (parse-key-handler nil)
     95  ;; Store result here
     96  (parse-results ()))
     97
     98(defun current-echo-parse-state (&key (must-exist t))
     99  (or (hemlock-prompted-input-state *current-view*)
     100      (and must-exist (error "Can't do that when not in echo area input"))))
    177101
    178102
     
    180104;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
    181105
    182 (defun display-prompt-nicely (&optional (prompt *parse-prompt*)
    183                                         (default (or *parse-default-string*
    184                                                      *parse-default*)))
    185   (clear-echo-area)
     106(defun display-prompt-nicely (eps &optional (prompt (eps-parse-prompt eps))
     107                                            (default (or (eps-parse-default-string eps)
     108                                                         (eps-parse-default eps))))
    186109  (modifying-echo-buffer
    187    (let ((point (buffer-point *echo-area-buffer*)))
    188      (if (listp prompt)
    189        (apply #'format *echo-area-stream* prompt)
    190        (insert-string point prompt))
     110   (let* ((buffer *current-buffer*)
     111          (point (buffer-point buffer)))
     112     (delete-region (buffer-region buffer))
     113     (insert-string point (if (listp prompt)
     114                            (apply #'format nil prompt)
     115                            prompt))
    191116     (when default
    192117       (insert-character point #\[)
    193118       (insert-string point default)
    194        (insert-string point "] ")))))
    195 
    196 (defun parse-for-something ()
    197   (display-prompt-nicely)
    198   (let ((start-window (current-window)))
    199     (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
    200     (setf (current-window) *echo-area-window*)
    201     (unwind-protect
    202      (use-buffer *echo-area-buffer*
    203        (recursive-edit nil))
    204      
    205      (setf (current-window) start-window))))
    206 
    207 
    208 
     119       (insert-string point "] "))
     120     (move-mark (eps-parse-starting-mark eps) point))))
     121
     122;; This is used to prevent multiple buffers trying to do echo area input
     123;; at the same time - there would be no way to exit the earlier one
     124;; without exiting the later one, because they're both on the same stack.
     125(defvar *recursive-edit-view* nil)
     126
     127(defun parse-for-something (&key verification-function
     128                                 type
     129                                 string-tables
     130                                 value-must-exist
     131                                 default-string
     132                                 default
     133                                 prompt
     134                                 help
     135                                 key-handler)
     136  ;; We can't do a "recursive" edit in more than one view, because if the earlier
     137  ;; one wants to exit first, we'd have to unwind the stack to allow it to exit,
     138  ;; which would force the later one to exit whether it wants to or not.
     139  (when (and *recursive-edit-view* (not (eq *recursive-edit-view* *current-view*)))
     140    (editor-error "~s is already waiting for input"
     141                  (buffer-name (hemlock-view-buffer *recursive-edit-view*))))
     142  (modifying-echo-buffer
     143   (let* ((view *current-view*)
     144          (buffer *current-buffer*)
     145          (old-eps (hemlock-prompted-input-state view))
     146          (parse-mark (copy-mark (buffer-point buffer) :right-inserting))
     147          (end-mark (buffer-end-mark buffer))
     148          (eps (make-echo-parse-state
     149                :parse-starting-mark parse-mark
     150                :parse-input-region (region parse-mark end-mark)
     151                :parse-verification-function verification-function
     152                :parse-type type
     153                :parse-string-tables string-tables
     154                :parse-value-must-exist value-must-exist
     155                :parse-default-string default-string
     156                :parse-default default
     157                :parse-prompt prompt
     158                :parse-help help
     159                :parse-key-handler key-handler)))
     160     ;; TODO: There is really no good reason to disallow recursive edits in the same
     161     ;; buffer, I'm just too lazy.  Should save contents, starting mark, and point,
     162     ;; and restore them at the end.
     163     (when old-eps
     164       (editor-error "Attempt to recursively use echo area"))
     165     (display-prompt-nicely eps)
     166     (modifying-buffer-storage (nil)
     167       (unwind-protect
     168            (let ((*recursive-edit-view* view))
     169              (setf (hemlock-prompted-input-state view) eps)
     170              (unless old-eps
     171                (hemlock-ext:change-active-pane view :echo))
     172              (with-standard-standard-output
     173                  (gui::event-loop #'(lambda () (eps-parse-results eps))))
     174              #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
     175         (unless old-eps
     176           (hemlock-ext:change-active-pane view :text))
     177         (setf (hemlock-prompted-input-state view) old-eps)
     178         (delete-mark parse-mark)))
     179     (let ((results (eps-parse-results eps)))
     180       (if (listp results)
     181         (apply #'values results)
     182         (abort-to-toplevel))))))
     183
     184(defun exit-echo-parse (eps results)
     185  #+gz (log-debug "~&exit echo parse, results = ~s" results)
     186  ;; Must be set to non-nil to indicate parse done.
     187  (setf (eps-parse-results eps) (or results '(nil)))
     188  (gui::stop-event-loop) ;; this just marks it for dead then returns.
     189  ;; this exits current event, and since the event loop is stopped, it
     190  ;; will exit the event loop, which will return to parse-for-something,
     191  ;; which will notice we have the result set and will handle it accordingly.
     192  (exit-event-handler))
    209193
    210194;;;; Buffer prompting.
    211195
    212 (defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t)
    213                                default
    214                                ((:default-string *parse-default-string*))
    215                                ((:prompt *parse-prompt*) "Buffer: ")
    216                                ((:help *parse-help*) "Type a buffer name."))
     196(defun prompt-for-buffer (&key (must-exist t)
     197                                default
     198                                default-string
     199                               (prompt "Buffer: ")
     200                               (help "Type a buffer name."))
    217201  "Prompts for a buffer name and returns the corresponding buffer.  If
    218202   :must-exist is nil, then return the input string.  This refuses to accept
     
    221205   when :must-exist is non-nil, :default-string must be the name of an existing
    222206   buffer."
    223     (let ((*parse-string-tables* (list *buffer-names*))
    224           (*parse-type* :keyword)
    225           (*parse-default* (cond
    226                             (default (buffer-name default))
    227                             (*parse-default-string*
    228                              (when (and *parse-value-must-exist*
    229                                         (not (getstring *parse-default-string*
    230                                                         *buffer-names*)))
    231                                (error "Default-string must name an existing ~
    232                                        buffer when must-exist is non-nil -- ~S."
    233                                       *parse-default-string*))
    234                              *parse-default-string*)
    235                             (t nil)))
    236           (*parse-verification-function* #'buffer-verification-function))
    237       (parse-for-something)))
    238 
    239 (defun buffer-verification-function (string)
     207  (when (and must-exist
     208             (not default)
     209             (not (getstring default-string *buffer-names*)))
     210    (error "Default-string must name an existing buffer when must-exist is non-nil -- ~S."
     211           default-string))
     212  (parse-for-something
     213   :verification-function #'buffer-verification-function
     214   :type :keyword
     215   :string-tables (list *buffer-names*)
     216   :value-must-exist must-exist
     217   :default-string default-string
     218   :default (if default (buffer-name default) default-string)
     219   :prompt prompt
     220   :help help))
     221
     222(defun buffer-verification-function (eps string)
    240223  (declare (simple-string string))
    241224  (modifying-echo-buffer
    242225   (cond ((string= string "") nil)
    243          (*parse-value-must-exist*
     226         ((eps-parse-value-must-exist eps)
    244227          (multiple-value-bind
    245228              (prefix key value field ambig)
    246               (complete-string string *parse-string-tables*)
     229              (complete-string string (eps-parse-string-tables eps))
    247230            (declare (ignore field))
    248231            (ecase key
     
    251234               (list value))
    252235              (:ambiguous
    253                (delete-region *parse-input-region*)
    254                (insert-string (region-start *parse-input-region*) prefix)
    255                (let ((point (current-point)))
    256                  (move-mark point (region-start *parse-input-region*))
    257                  (unless (character-offset point ambig)
    258                    (buffer-end point)))
    259                nil))))
     236               (let ((input-region (eps-parse-input-region eps)))
     237                 (delete-region input-region)
     238                 (insert-string (region-start input-region) prefix)
     239                 (let ((point (current-point)))
     240                   (move-mark point (region-start input-region))
     241                   (unless (character-offset point ambig)
     242                     (buffer-end point)))
     243                 nil)))))
    260244         (t
    261245          (list (or (getstring string *buffer-names*) string))))))
     
    266250;;;; File Prompting.
    267251
    268 (defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t)
     252(defun prompt-for-file (&key (must-exist t)
    269253                             default
    270                              ((:default-string *parse-default-string*))
    271                              ((:prompt *parse-prompt*) "Filename: ")
    272                              ((:help *parse-help*) "Type a file name."))
     254                             default-string
     255                             (prompt "Filename: ")
     256                             (help "Type a file name."))
    273257  "Prompts for a filename."
    274   (let ((*parse-verification-function* #'file-verification-function)
    275         (*parse-default* (if default (namestring default)))
    276         (*parse-type* :file))
    277     (parse-for-something)))
    278 
    279 (defun file-verification-function (string)
    280   (let ((pn (pathname-or-lose string)))
     258  (parse-for-something
     259   :verification-function #'file-verification-function
     260   :type :file
     261   :string-tables nil
     262   :value-must-exist must-exist
     263   :default-string default-string
     264   :default (if default (namestring default))
     265   :prompt prompt
     266   :help help))
     267
     268(defun file-verification-function (eps string)
     269  (let ((pn (pathname-or-lose eps string)))
    281270    (if pn
    282271        (let ((merge
    283                (cond ((not *parse-default*) nil)
    284                      ((directoryp pn)
    285                       (merge-pathnames pn *parse-default*))
     272               (cond ((not (eps-parse-default eps)) nil)
     273                     ((ccl:directory-pathname-p pn)
     274                      (merge-pathnames pn (eps-parse-default eps)))
    286275                     (t
    287276                      (merge-pathnames pn
    288277                                       (or (directory-namestring
    289                                             *parse-default*)
     278                                            (eps-parse-default eps))
    290279                                           ""))))))
    291280          (cond ((probe-file pn) (list pn))
    292281                ((and merge (probe-file merge)) (list merge))
    293                 ((not *parse-value-must-exist*) (list (or merge pn)))
     282                ((not (eps-parse-value-must-exist eps)) (list (or merge pn)))
    294283                (t nil))))))
    295284
     
    299288;;; an editor-error.
    300289;;;
    301 (defun pathname-or-lose (string)
    302   (declare (simple-string string))
     290(defun pathname-or-lose (eps string)
    303291  (multiple-value-bind (pn idx)
    304292                       (parse-namestring string nil *default-pathname-defaults*
     
    306294    (cond (pn)
    307295          (t (modifying-echo-buffer
    308               (delete-characters (region-end *echo-area-region*)
    309                                 (- idx (length string))))
     296              (delete-characters (region-end (eps-parse-input-region eps))
     297                                 (- idx (length string))))
    310298             nil))))
    311299
     
    315303;;;; Keyword and variable prompting.
    316304
    317 (defun prompt-for-keyword (*parse-string-tables*
    318                            &key
    319                            ((:must-exist *parse-value-must-exist*) t)
    320                            ((:default *parse-default*))
    321                            ((:default-string *parse-default-string*))
    322                            ((:prompt *parse-prompt*) "Keyword: ")
    323                            ((:help *parse-help*) "Type a keyword."))
     305(defun prompt-for-keyword (&key
     306                           tables
     307                           (must-exist t)
     308                           default
     309                           default-string
     310                           (prompt "Keyword: ")
     311                           (help "Type a keyword."))
    324312  "Prompts for a keyword using the String Tables."
    325   (let ((*parse-verification-function* #'keyword-verification-function)
    326         (*parse-type* :keyword))
    327     (parse-for-something)))
    328 
    329 (defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t)
    330                                  ((:default *parse-default*))
    331                                  ((:default-string *parse-default-string*))
    332                                  ((:prompt *parse-prompt*) "Variable: ")
    333                                  ((:help *parse-help*)
    334                                   "Type the name of a variable."))
     313  (parse-for-something
     314   :verification-function #'keyword-verification-function
     315   :type :keyword
     316   :string-tables tables
     317   :value-must-exist must-exist
     318   :default-string default-string
     319   :default default
     320   :prompt prompt
     321   :help help))
     322
     323
     324
     325(defun prompt-for-variable (&key (must-exist t)
     326                                 default
     327                                 default-string
     328                                 (prompt "Variable: ")
     329                                 (help "Type the name of a variable."))
    335330  "Prompts for a variable defined in the current scheme of things."