Changeset 7833


Ignore:
Timestamp:
Dec 6, 2007, 7:31:36 PM (13 years ago)
Author:
gz
Message:

checkpoint work in progress

Location:
branches/event-ide/ccl/cocoa-ide
Files:
1 added
1 deleted
38 edited
1 copied

Legend:

Unmodified
Added
Removed
  • branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

    r7701 r7833  
    2626
    2727(def-cocoa-default *use-screen-fonts* :bool t "Use bitmap screen fonts when available")
     28
     29
     30(defgeneric hi:hemlock-view (ns-object))
     31
     32(defmethod hi:hemlock-view ((unknown t)) nil)
     33
     34
    2835
    2936(defmacro nsstring-encoding-to-nsinteger (n)
     
    656663  (with-slots (mirror styles) self
    657664    (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))))
     665      (#_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))
    664666      (ccl::dbg))
    665667    (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr)))
     
    713715      (when textstorage
    714716        (#/endEditing textstorage)
     717        ;; This isn't really right.  It should abort the entire command in progress,
     718        ;; e.g. c-x ..., etc. and should do it before event start... Basically it
     719        ;; should be handled as if it was a regular key event, except for the
     720        ;; extra string argument.
    715721        (for-each-textview-using-storage
    716722         textstorage
    717723         (lambda (tv)
    718724           (hi::disable-self-insert
    719             (hemlock-frame-event-queue (#/window tv)))))
     725            (hi:hemlock-view tv))))
    720726        (#/ensureSelectionVisible textstorage)))))
    721727
     
    777783              (process-kill p)))
    778784          (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*))))))
     785            (setf hi::*current-buffer* nil))
     786          (hi::delete-buffer buffer :force t))))))
    785787
    786788
     
    812814(declaim (special hemlock-textstorage-text-view))
    813815
     816(defmethod hi:hemlock-view ((self hemlock-textstorage-text-view))
     817  ;; Not sure when any of this can fail, but at least try to make sure that if hemlock-view
     818  ;; returns non-nil, then callers don't have to check for any other marginal situations.
     819  (let ((frame (#/window self)))
     820    (unless (%null-ptr-p frame)
     821      (let ((view (hi:hemlock-view frame)))
     822        (when view
     823          (when (eq (hi::hemlock-view-buffer view) (text-view-buffer self))
     824            view))))))
     825
     826
     827(defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view))
     828  ;; Return true if cmd-. is in the queue.  Not sure what to do about c-g:
     829  ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe
     830  ;; c-g will need to be synchronous meaning just end current command,
     831  ;; while cmd-. is the real abort.
     832  #|
     833   (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0)))
     834    (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue:
     835                         target (logior #$whatever) now #&NSDefaultRunLoopMode t)))
     836            (when (%null-ptr-p event) (return)))))
     837  "target" can either be an NSWindow or the global shared application object;
     838  |#
     839  nil)
     840
     841(defvar *buffer-being-edited* nil)
     842
     843(objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event)
     844  #+debug (#_NSLog #@"Key down event = %@" :address event)
     845  (let* ((view (hi:hemlock-view self))
     846         ;; quote-p means handle characters natively
     847         (quote-p (and view (hi::hemlock-view-quote-next-p view))))
     848    #+GZ (log-debug "~&quote-p ~s event ~s" quote-p event)
     849    (if (or (null view)
     850            (#/hasMarkedText self)
     851            (and quote-p (zerop (#/length (#/characters event))))) ;; dead key, e.g. option-E
     852      (call-next-method event)
     853      (unless (eventqueue-abort-pending-p self)
     854        (let ((hemlock-key (nsevent-to-key-event event quote-p)))
     855          (when hemlock-key
     856            #+GZ (log-debug "Handle key ~s" hemlock-key)
     857            (hi::handle-hemlock-event view hemlock-key)))))))
     858
     859(defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event)
     860  (declare (ignore event))
     861  (with-autorelease-pool
     862   (call-next-method)))
     863
     864;;; Translate a keyDown NSEvent to a Hemlock key-event.
     865(defun nsevent-to-key-event (event quote-p)
     866  (let* ((modifiers (#/modifierFlags event)))
     867    (unless (logtest #$NSCommandKeyMask modifiers)
     868      (let* ((chars (if quote-p
     869                      (#/characters event)
     870                      (#/charactersIgnoringModifiers event)))
     871             (n (if (%null-ptr-p chars)
     872                  0
     873                  (#/length chars)))
     874             (c (and (eql n 1)
     875                     (#/characterAtIndex: chars 0))))
     876        (when c
     877          (let* ((bits 0)
     878                 (useful-modifiers (logandc2 modifiers
     879                                             (logior
     880                                              ;#$NSShiftKeyMask
     881                                              #$NSAlphaShiftKeyMask))))
     882            (unless quote-p
     883              (dolist (map hemlock-ext::*modifier-translations*)
     884                (when (logtest useful-modifiers (car map))
     885                  (setq bits (logior bits
     886                                     (hemlock-ext:key-event-modifier-mask (cdr map)))))))
     887            (let* ((char (code-char c)))
     888              (when (and char (standard-char-p char))
     889                (setq bits (logandc2 bits hi::+shift-event-mask+))))
     890            (hemlock-ext:make-key-event c bits)))))))
     891
     892;; For now, this is only used to abort i-search.  All actual mouse handling is done
     893;; by Cocoa.   In the future might want to allow users to extend via hemlock, e.g.
     894;; to implement mouse-copy.
     895;; Also -- shouldn't this happen on mouse up?
     896(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event)
     897  ;; If no modifier keys are pressed, send hemlock a no-op.
     898  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
     899    (let* ((view (hi:hemlock-view self)))
     900      (when view
     901        (unless (eventqueue-abort-pending-p self)
     902          (hi::handle-hemlock-event view #k"leftdown")))))
     903  (call-next-method event))
     904
     905#+GZ
     906(objc:defmethod  (#/mouseUp: :void) ((self hemlock-textstorage-text-view) event)
     907  (log-debug "~&MOUSE UP!!")
     908  (call-next-method event))
    814909
    815910(defmethod assume-not-editing ((tv hemlock-textstorage-text-view))
     
    11571252
    11581253
    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))
     1254(defun append-output (view string)
     1255  (assume-cocoa-thread)
     1256  ;; Arrange to do the append in command context
     1257  (when view
     1258    (hi::handle-hemlock-event view #'(lambda ()
     1259                                       (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string)))))
     1260
    12311261
    12321262;;; Update the underlying buffer's point (and "active region", if appropriate.
     
    16851715(objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document)))
    16861716
    1687 (objc:defmethod (#/keyDown: :void) ((self echo-area-view) event)
    1688   (or (handle-key-down self event)
    1689       (call-next-method event)))
    1690 
    1691 
    16921717(defloadvar *hemlock-frame-count* 0)
    16931718
     
    17131738              (progn
    17141739                ;; 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))
     1740                (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer))
    17161741                (make-textstorage-for-hemlock-buffer buffer)))
    17171742             (doc (make-instance 'echo-area-document))
     
    17641789    ((echo-area-view :foreign-type :id)
    17651790     (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)
     1791     (hemlock-view :initform nil :reader hemlock-frame-hemlock-view)
    17691792     (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer)
    17701793     (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream))
    17711794  (:metaclass ns:+ns-object))
    17721795(declaim (special hemlock-frame))
     1796
     1797(defmethod hi:hemlock-view ((self hemlock-frame))
     1798  (hemlock-frame-hemlock-view self))
     1799
    17731800
    17741801(defun double-%-in (string)
     
    18251852                                    :count 2))
    18261853             #|(*debug-io* *typeout-stream*)|#)
    1827         (stream-clear-output *debug-io*)
    1828         (ignore-errors (print-call-history :detailed-p t))
    18291854        (#/performSelectorOnMainThread:withObject:waitUntilDone:
    18301855         frame (@selector #/runErrorSheet:) params t)
    1831         (wait-on-semaphore semaphore)))))
     1856        (unless (eq *current-process* *initial-process*)
     1857          (wait-on-semaphore semaphore))))))
    18321858
    18331859(defun hi::report-hemlock-error (condition)
     
    18361862      (report-condition-in-hemlock-frame condition (#/window pane)))))
    18371863                       
    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 
    18811864(objc:defmethod (#/close :void) ((self hemlock-frame))
    18821865  (let* ((content-view (#/contentView self))
     
    18851868         ((< i 0))
    18861869      (#/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)))
    18911870  (let* ((buf (hemlock-frame-echo-area-buffer self))
    18921871         (echo-doc (if buf (hi::buffer-document buf))))
     
    19291908    (nsstring-to-buffer nsstring buffer)))
    19301909
    1931 (defun %nsstring-to-mark (nsstring mark)
     1910(defun %nsstring-to-hemlock-string (nsstring)
    19321911  "returns line-termination of string"
    19331912  (let* ((string (lisp-string-from-nsstring nsstring))
     
    19361915         (line-termination (if crpos
    19371916                             (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  
     1917                               :crlf
     1918                               :cr)
     1919                             :lf))
     1920         (hemlock-string (case line-termination
     1921                           (:crlf (remove #\return string))
     1922                           (:cr (nsubstitute #\linefeed #\return string))
     1923                           (t string))))
     1924    (values hemlock-string line-termination)))
     1925
     1926;: TODO: I think this is jumping through hoops because it want to be invokable outside the main
     1927;; cocoa thread.
    19481928(defun nsstring-to-buffer (nsstring buffer)
    19491929  (let* ((document (hi::buffer-document buffer))
    19501930         (hi::*current-buffer* buffer)
    19511931         (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 
     1932    (multiple-value-bind (hemlock-string line-termination)
     1933                         (%nsstring-to-hemlock-string nsstring)
     1934      (setf (hi::buffer-line-termination buffer) line-termination)
     1935
     1936      (setf (hi::buffer-document buffer) nil) ;; What's this about??
     1937      (unwind-protect
     1938          (let ((point (hi::buffer-point buffer)))
     1939            (hi::delete-region region)
     1940            (hi::insert-string point hemlock-string)
     1941            (setf (hi::buffer-modified buffer) nil)
     1942            (hi::buffer-start point)
     1943            ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping.
     1944            (hi::renumber-region region)
     1945            buffer)
     1946        (setf (hi::buffer-document buffer) document)))))
    19661947
    19671948
     
    19841965      (setq peer tv))
    19851966    (hi::activate-hemlock-view pane)
     1967    (setf (slot-value frame 'hemlock-view)
     1968          (make-instance 'hi:hemlock-view
     1969            :buffer buffer
     1970            :pane pane
     1971            :echo-area-buffer (hemlock-frame-echo-area-buffer frame)
     1972            :echo-area-pane echo-area))
    19861973    (setf (slot-value frame 'echo-area-view) echo-area
    19871974          (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)))))
    19981975    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 
    20081976
    20091977
     
    20141982  (release-lock (hi::buffer-lock b)))
    20151983
    2016 (defun hi::document-begin-editing (document)
    2017   (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2018    (slot-value document 'textstorage)
    2019    (@selector #/beginEditing)
    2020    +null-ptr+
    2021    t))
     1984(defun invoke-modifying-buffer-storage (buffer thunk)
     1985  (assume-cocoa-thread)
     1986  (when buffer ;; nil means just get rid of any prior buffer
     1987    (setq buffer (require-type buffer 'hi::buffer)))
     1988  (let ((old *buffer-being-edited*))
     1989    (if (eq buffer old)
     1990      (funcall thunk)
     1991      (unwind-protect
     1992          (progn
     1993            (buffer-document-end-editing old)
     1994            (buffer-document-begin-editing buffer)
     1995            (funcall thunk))
     1996        (buffer-document-end-editing buffer)
     1997        (buffer-document-begin-editing old)))))
     1998
     1999(defun buffer-document-end-editing (buffer)
     2000  (when buffer
     2001    (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer))))
     2002      (when document
     2003        (setq *buffer-being-edited* nil)
     2004        (let ((ts (slot-value document 'textstorage)))
     2005          (#/endEditing ts)
     2006          ;; TODO: no reason for this to be an objC function!!
     2007          (#/updateHemlockSelection ts))))))
     2008
     2009(defun buffer-document-begin-editing (buffer)
     2010  (when buffer
     2011    (let* ((document (hi::buffer-document buffer)))
     2012      (when document
     2013        (setq *buffer-being-edited* buffer)
     2014        (#/beginEditing (slot-value document 'textstorage))))))
    20222015
    20232016(defun document-edit-level (document)
     
    20252018  (slot-value (slot-value document 'textstorage) 'edit-count))
    20262019
    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 
     2020#|
    20342021(defun hi::document-set-point-position (document)
    20352022  (declare (ignorable document))
     
    20392026    (#/performSelectorOnMainThread:withObject:waitUntilDone:
    20402027     textstorage (@selector #/updateHemlockSelection) +null-ptr+ t)))
    2041 
    2042 
     2028|#
    20432029
    20442030(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
     
    21942180  (:metaclass ns:+ns-object))
    21952181
     2182(defmethod hi:hemlock-view ((self hemlock-editor-window-controller))
     2183  (let ((frame (#/window self)))
     2184    (unless (%null-ptr-p frame)
     2185      (hi:hemlock-view frame))))
    21962186
    21972187;;; Map *default-file-character-encoding* to an :<NSS>tring<E>ncoding
     
    22832273(defvar *encoding-name-hash* (make-hash-table))
    22842274
    2285 (defmethod hi::document-encoding-name ((doc hemlock-editor-document))
     2275(defmethod document-encoding-name ((doc hemlock-editor-document))
    22862276  (with-slots (encoding) doc
    22872277    (if (eql encoding 0)
     
    22912281                (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding)))))))
    22922282
    2293 
     2283(defun hi::buffer-encoding-name (buffer)
     2284  (let ((doc (hi::buffer-document buffer)))
     2285    (and doc (document-encoding-name doc))))
     2286
     2287;; TODO: make each buffer have a slot, and this is just the default value.
    22942288(defmethod textview-background-color ((doc hemlock-editor-document))
    22952289  *editor-background-color*)
     
    23442338    (hi::queue-buffer-change buffer)
    23452339    t))
    2346          
    2347            
    2348  
     2340
     2341
    23492342(objc:defmethod #/init ((self hemlock-editor-document))
    23502343  (let* ((doc (call-next-method)))
     
    23582351
    23592352 
     2353(defun make-buffer-for-document (ns-document pathname)
     2354  (let* ((buffer-name (hi::pathname-to-buffer-name pathname))
     2355         (buffer (make-hemlock-buffer buffer-name)))
     2356    (setf (slot-value ns-document 'textstorage)
     2357          (make-textstorage-for-hemlock-buffer buffer))
     2358    (setf (hi::buffer-pathname buffer) pathname)
     2359    buffer))
     2360
    23602361(objc:defmethod (#/readFromURL:ofType:error: :<BOOL>)
    23612362    ((self hemlock-editor-document) url type (perror (:* :id)))
     
    23672368               (#/path url)
    23682369               (#/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)))
     2370           (buffer (or (hemlock-document-buffer self)
     2371                       (make-buffer-for-document self pathname)))
    23772372           (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
    23782373           (string
     
    23972392      (unless (%null-ptr-p string)
    23982393        (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 
    24032394        (let* ((textstorage (slot-value self 'textstorage))
    24042395               (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
     2396
     2397          (hi::queue-buffer-change buffer)
     2398          (#/beginEditing textstorage)
     2399
     2400          (nsstring-to-buffer string buffer)
    24052401
    24062402          (reset-buffer-cache display)
     
    24132409           textstorage
    24142410           0
    2415            (hemlock-buffer-length buffer)))
    2416 
    2417         (hi::document-end-editing self)
     2411           (hemlock-buffer-length buffer))
     2412
     2413          (#/endEditing textstorage))
    24182414
    24192415        (setf (hi::buffer-modified buffer) nil)
    24202416        (hi::process-file-options buffer pathname)
    24212417        t))))
    2422 
    2423 
    24242418
    24252419
     
    24642458        (when cache (buffer-cache-buffer cache))))))
    24652459
    2466 (defmethod hi:window-buffer ((frame hemlock-frame))
     2460(defmethod hi::window-buffer ((frame hemlock-frame))
    24672461  (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
    24682462         (doc (#/documentForWindow: dc frame)))
     
    24732467      (hemlock-document-buffer doc))))
    24742468
    2475 (defmethod hi:window-buffer ((pane text-pane))
    2476   (hi:window-buffer (#/window pane)))
     2469(defmethod hi::window-buffer ((pane text-pane))
     2470  (hi::window-buffer (#/window pane)))
    24772471
    24782472(defun ordered-hemlock-windows ()
    24792473  (delete-if-not #'(lambda (win)
    24802474                     (and (typep win 'hemlock-frame)
    2481                           (hi:window-buffer win)))
     2475                          (hi::window-buffer win)))
    24822476                   (windows)))
    24832477
     
    25242518           (buffer (hemlock-document-buffer self)))
    25252519      (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)))))
     2520        (:crlf (unless (typep string 'ns:ns-mutable-string)
     2521                (setq string (make-instance 'ns:ns-mutable-string :with string string))
     2522                (#/replaceOccurrencesOfString:withString:options:range:
     2523                  string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
     2524        (:cr (setq string (if (typep string 'ns:ns-mutable-string)
     2525                            string
     2526                            (make-instance 'ns:ns-mutable-string :with string string)))
     2527             (#/replaceOccurrencesOfString:withString:options:range:
     2528              string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string)))))
    25352529      (when (#/writeToURL:atomically:encoding:error:
    25362530             string url t encoding error)
     
    30223016          ((or (typep arg 'string)
    30233017               (typep arg 'pathname))
    3024            (unless (probe-file arg)
    3025              (ccl::touch arg))
     3018           #+no (unless (probe-file arg)
     3019                  (ccl::touch arg))
    30263020           (with-autorelease-pool
    30273021             (let* ((url (pathname-to-url arg))
  • branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp

    r7698 r7833  
    163163    (let* ((data (#/objectForKey: (#/userInfo notification)
    164164                                  #&NSFileHandleNotificationDataItem))
    165            (document (#/document self))
    166165           (encoding (load-time-value (get-character-encoding :utf-8)))
    167166           (data-length (#/length data))
    168            (buffer (hemlock-document-buffer document))
    169167           (n nextra)
    170168           (cursize bufsize)
     
    200198                      (%get-unsigned-byte xlate (+ noctets-used i)))))
    201199            (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))))
     200            (let ((view (hi::hemlock-view self)))
     201              (queue-for-cocoa-thread #'(lambda () (append-output view string))))
    210202            (#/readInBackgroundAndNotify fh)))))))
    211203             
     
    239231  (declare (ignore buffer)))
    240232
    241 (defmethod hi::document-encoding-name ((doc hemlock-listener-document))
     233(defmethod document-encoding-name ((doc hemlock-listener-document))
    242234  "UTF-8")
    243235
     
    398390  (let* ((buffer (hemlock-document-buffer self))
    399391         (process (if buffer (hi::buffer-process buffer))))
     392    (log-debug  "~&exitBreak buffer ~s process ~s" buffer process)
    400393    (when (typep process 'cocoa-listener-process)
    401394      (process-interrupt process #'abort-break))))
     
    471464    (if (typep process 'cocoa-listener-process)
    472465      (let* ((action (#/action item)))
     466        #+GZ (log-debug "Validate menu item buffer: ~s process: ~s action: ~s context ~s" buffer process
     467                        (cond ((eql action (@selector #/revertDocumentToSaved:))
     468                               "revertDocumentToSaved:")
     469                              ((eql action (@selector #/saveDocument:))
     470                               "saveDocument:")
     471                              ((eql action (@selector #/saveDocumentAs:))
     472                               "saveDocumentAs:")
     473                              ((eql action (@selector #/interrupt:))
     474                               "interrupt")
     475                              ((eql action (@selector #/continue:))
     476                               "continue")
     477                              ((eql action (@selector #/backtrace:))
     478                               "backtrace")
     479                              ((eql action (@selector #/exitBreak:))
     480                               "exitBreak:")
     481                              ((eql action (@selector #/restarts:))
     482                               "restarts:")
     483                              (t action))
     484                        (cocoa-listener-process-backtrace-contexts process))
    473485        (cond
    474486          ((or (eql action (@selector #/revertDocumentToSaved:))
  • branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp

    r7698 r7833  
    115115    (nreverse ret)))
    116116
     117
     118;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     119;;
     120;; utilities for executing in the cocoa event thread
     121
     122(defstatic *cocoa-thread-arg-id-map* (make-id-map))
     123
     124;; This is for debugging, it's preserved across queue-for-cocoa-thread and bound
     125;; so it can be seen in backtraces.
     126(defvar *invoking-event-context* "unknown")
     127(defvar *invoking-event-process* nil)
     128
     129(defun register-cocoa-thread-function (thunk result-handler context)
     130  (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk
     131                                                     result-handler
     132                                                     (or context *invoking-event-context*)
     133                                                     *current-process*)))
     134
     135(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
     136  (invoke-lisp-function self id))
     137
     138(defmethod invoke-lisp-function ((self ns:ns-application) id)
     139  (destructuring-bind (thunk result-handler context . invoking-process)
     140                      (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id)))
     141    (handle-invoking-lisp-function thunk result-handler context invoking-process)))
     142
     143;; This immediately executes the thunk in the cocoa thread, via performSelectorOnMainThread.
     144;; It should only be used for relatively quick and safe stuff.
     145(defun execute-in-cocoa-thread (thunk &key result-handler context)
     146  "Execute thunk in the main cocoa thread, waiting for it to return."
     147  (if (eq *current-process* ccl::*initial-process*)
     148    (handle-invoking-lisp-function thunk result-handler context)
     149    (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
     150      (error "cocoa thread not available")
     151      (let ((arg (make-instance 'ns:ns-number
     152                   :with-long (register-cocoa-thread-function thunk result-handler context))))
     153        (#/performSelectorOnMainThread:withObject:waitUntilDone:
     154         *nsapp*
     155         (@selector #/invokeLispFunction:)
     156         arg
     157         t)))))
     158
     159(defconstant $lisp-function-event-subtype 17)
     160
     161(defclass lisp-application (ns:ns-application)
     162    ((termp :foreign-type :<BOOL>))
     163  (:metaclass ns:+ns-object))
     164
     165;;; I'm not sure if there's another way to recognize events whose
     166;;; type is #$NSApplicationDefined.
     167(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
     168  (if (and (eql (#/type e) #$NSApplicationDefined)
     169           (eql (#/subtype e) $lisp-function-event-subtype))
     170    (invoke-lisp-function self (#/data1 e))
     171    (call-next-method e)))
     172
     173;; This queues an event rather than just doing performSelectorOnMainThread.
     174(defun queue-for-cocoa-thread (thunk &key result-handler context at-start)
     175  "Queue thunk for execution in main cocoa thread and return immediately."
     176  (execute-in-cocoa-thread
     177   #'(lambda ()
     178       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
     179                  ns:ns-event
     180                  #$NSApplicationDefined
     181                  (ns:make-ns-point 0 0)
     182                  0
     183                  0.0d0
     184                  0
     185                  +null-ptr+
     186                  $lisp-function-event-subtype
     187                  (register-cocoa-thread-function thunk result-handler context)
     188                  0)))
     189         ;(#/retain e)
     190         (#/postEvent:atStart: *nsapp* e (not (null at-start)))))))
     191
     192(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*))
     193  ;; TODO: the point is to execute result-handler in the original process, but this will do for now.
     194  (let* ((*invoking-event-process* invoking-process)
     195         (*invoking-event-context* context))
     196    (if result-handler
     197      (multiple-value-call result-handler (funcall thunk))
     198      (funcall thunk))))
     199
     200;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     201;;
     202;; debugging
     203
    117204(defun log-debug (format-string &rest args)
    118205  (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args))))
    119206
     207(defun nslog-condition (c)
     208  (let* ((rep (format nil "~a" c)))
     209    (with-cstrs ((str rep))
     210      (with-nsstr (nsstr str (length rep))
     211        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
     212
     213
     214
    120215(defun assume-cocoa-thread ()
    121216  #+debug (assert (eq *current-process* *initial-process*)))
  • branches/event-ide/ccl/cocoa-ide/cocoa-window.lisp

    r7698 r7833  
    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-cocoa-thread #'(lambda () (apply function args))
     65                              :at-start t)
     66      (call-next-method))))
    10067
    10168(defparameter *debug-in-event-process* t)
     
    147114    (eql 0 (#_SetFrontProcess psn))))
    148115
    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 
    159116#+nil
    160117(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
     
    166123  (#/show (#/sharedPanel typeout-window)))
    167124
    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 
    175125(defmethod ccl::process-exit-application ((process appkit-process) thunk)
    176126  (when (eq process ccl::*initial-process*)
     
    181131  (%set-toplevel nil)
    182132  (change-class *cocoa-event-process* 'appkit-process)
    183   (let* ((app *NSApp*))
     133  (event-loop))
     134
     135(defun stop-event-loop ()
     136  (#/stop: *nsapp* +null-ptr+))
     137
     138(defun event-loop (&optional end-test)
     139  (let ((app *NSApp*))
    184140    (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 
     141      (handler-case (let* ((*event-process-reported-conditions* nil))
     142                      (if end-test
     143                        (#/run app)
     144                        #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
     145                                               #&NSDefaultRunLoopMode
     146                                               (#/distantFuture ns:ns-date))|#
     147                        (#/run app)))
     148        (error (c) (nslog-condition c)))
     149      #+GZ (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
     150      (when (or (and end-test (funcall end-test))
     151                (and ccl::*quitting* (not (#/isRunning app))))
     152        (return)))))
    192153
    193154(defun start-cocoa-application (&key
  • branches/event-ide/ccl/cocoa-ide/cocoa.lisp

    r7698 r7833  
    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")
  • branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp

    r7698 r7833  
    4747
    4848    "macros"
     49
     50    "views"
    4951    "line"
    5052    "ring"
     
    7779    "killcoms"
    7880    "searchcoms"
     81    "isearchcoms"
    7982    "filecoms"
    8083    "doccoms"
     
    8588    "comments"
    8689    "icom"
    87     "kbdmac"
    8890    "defsyn"
    8991    "edit-defs"
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

    r7595 r7833  
    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 
     81;(bind-key "Do Nothing" #k"leftup")
     82
     83(bind-key "Abort Command" #k"control-g")
     84(bind-key "Abort Command" #k"control-G")
    8285
    8386(bind-key "Process File Options" #k"control-x m" :global)
     
    116119(bind-key "Buffer Not Modified" #k"meta-~")
    117120;(bind-key "Check Buffer Modified" #k"control-x ~")
    118 (bind-key "Select Buffer" #k"control-x b")
     121;(bind-key "Select Buffer" #k"control-x b")
    119122;(bind-key "Select Previous Buffer" #k"control-meta-l")
    120123;(bind-key "Circulate Buffers" #k"control-meta-L")
     
    134137;(bind-key "Top of Window" #k"meta-,")
    135138;(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-]")
    139139
    140140(bind-key "Delete Previous Character" #k"delete")
     
    193193;;;; Argument Digit and Negative Argument.
    194194
    195 (bind-key "Negative Argument" #k"meta-\-")
     195(bind-key "Argument Digit" #k"meta-\-")
    196196(bind-key "Argument Digit" #k"meta-0")
    197197(bind-key "Argument Digit" #k"meta-1")
     
    204204(bind-key "Argument Digit" #k"meta-8")
    205205(bind-key "Argument Digit" #k"meta-9")
    206 (bind-key "Negative Argument" #k"control-\-")
     206(bind-key "Argument Digit" #k"control-\-")
    207207(bind-key "Argument Digit" #k"control-0")
    208208(bind-key "Argument Digit" #k"control-1")
     
    215215(bind-key "Argument Digit" #k"control-8")
    216216(bind-key "Argument Digit" #k"control-9")
    217 (bind-key "Negative Argument" #k"control-meta-\-")
     217(bind-key "Argument Digit" #k"control-meta-\-")
    218218(bind-key "Argument Digit" #k"control-meta-0")
    219219(bind-key "Argument Digit" #k"control-meta-1")
     
    226226(bind-key "Argument Digit" #k"control-meta-8")
    227227(bind-key "Argument Digit" #k"control-meta-9")
     228
     229(bind-key "Digit" #k"\-")
     230(bind-key "Digit" #k"0")
     231(bind-key "Digit" #k"1")
     232(bind-key "Digit" #k"2")
     233(bind-key "Digit" #k"3")
     234(bind-key "Digit" #k"4")
     235(bind-key "Digit" #k"5")
     236(bind-key "Digit" #k"6")
     237(bind-key "Digit" #k"7")
     238(bind-key "Digit" #k"8")
     239(bind-key "Digit" #k"9")
    228240
    229241
     
    247259(bind-key "Self Insert" #k"+")
    248260(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")
    259261(bind-key "Self Insert" #k"[")
    260262(bind-key "Self Insert" #k"]")
     
    265267(bind-key "Self Insert" #k"\"")
    266268(bind-key "Self Insert" #k"'")
    267 (bind-key "Self Insert" #k"\-")
    268269(bind-key "Self Insert" #k"=")
    269270(bind-key "Self Insert" #k"`")
     
    521522
    522523
     524#|
    523525;;;; Keyboard macro bindings.
    524526
     
    529531(bind-key "Last Keyboard Macro" #k"control-x e")
    530532(bind-key "Keyboard Macro Query" #k"control-x q")
     533|#
    531534
    532535
     
    933936
    934937
     938;;;; I-Search mode.
     939;;;;
     940;;;; Anything that's not explicitly bound here will exit i-search.
     941
     942(dotimes (n hemlock::char-code-limit)
     943  (when (standard-char-p (code-char n))
     944    (let ((key (hemlock-ext:make-key-event n)))
     945      (bind-key "I-Search Self Insert" key :mode "I-Search"))))
     946
     947(bind-key "I-Search Repeat Forward" #k"control-s" :mode "I-Search")
     948(bind-key "I-Search Repeat Backward" #k"control-r" :mode "I-Search")
     949(bind-key "I-Search Backup" #k"backspace" :mode "I-Search")
     950(bind-key "I-Search Backup" #k"delete" :mode "I-Search")
     951(bind-key "I-Search Abort" #k"control-g" :mode "I-Search")
     952(bind-key "I-Search Abort" #k"control-G" :mode "I-Search")
     953(bind-key "I-Search Exit or Search" #k"escape" :mode "I-Search")
     954(bind-key "I-Search Yank Word" #k"control-w" :mode "I-Search")
     955(bind-key "Quoted Insert" #k"control-q" :mode "I-Search")
     956
     957
    935958;;;; 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)
     959 
    942960(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)
    945961(setf (logical-key-event-p #k"y" :yes) t)
    946962(setf (logical-key-event-p #k"space" :yes) t)
     
    957973(setf (logical-key-event-p #k"control-q" :quote) t)
    958974(setf (logical-key-event-p #k"k" :keep) t)
    959 (setf (logical-key-event-p #k"control-w" :extend-search-word) t)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp

    r7595 r7833  
    133133;;;; Variable binding -- winding and unwinding.
    134134
    135 (eval-when (:compile-toplevel :execute)
    136 
    137135(defmacro unbind-variable-bindings (bindings)
    138136  `(do ((binding ,bindings (binding-across binding)))
     
    149147             (car cons) object))))
    150148
    151 ) ;eval-when
    152 
    153149;;; UNWIND-BINDINGS  --  Internal
    154150;;;
     
    158154;;; unwind all bindings.
    159155;;;
    160 (defun unwind-bindings (mode)
    161   (unbind-variable-bindings (buffer-var-values *current-buffer*))
    162   (do ((curmode (buffer-mode-objects *current-buffer*))
     156(defun unwind-bindings (buffer mode)
     157  #+gz (assert (buffer-bindings-wound-p buffer))
     158  (setf (buffer-bindings-wound-p buffer) nil)
     159  (unbind-variable-bindings (buffer-var-values buffer))
     160  (do ((curmode (buffer-mode-objects buffer))
    163161       (unwound ()) cw)
    164162      (())
     
    166164    (unbind-variable-bindings (mode-object-var-values (car unwound)))
    167165    (when (or (null curmode) (eq (car unwound) mode))
    168       (setf (buffer-mode-objects *current-buffer*) curmode)
     166      (setf (buffer-mode-objects buffer) curmode)
    169167      (return unwound))))
    170168
     
    173171;;;    Add "modes" to the mode bindings currently in effect.
    174172;;;
    175 (defun wind-bindings (modes)
    176   (do ((curmode (buffer-mode-objects *current-buffer*)) cw)
    177       ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode))
     173(defun wind-bindings (buffer modes)
     174  #+gz (assert (not (buffer-bindings-wound-p buffer)))
     175  (setf (buffer-bindings-wound-p buffer) t)
     176  (do ((curmode (buffer-mode-objects buffer)) cw)
     177      ((null modes) (setf (buffer-mode-objects buffer) curmode))
    178178    (bind-variable-bindings (mode-object-var-values (car modes)))
    179179    (setf cw modes  modes (cdr modes)  (cdr cw) curmode  curmode cw))
    180   (bind-variable-bindings (buffer-var-values *current-buffer*)))
    181 
    182 
     180  (bind-variable-bindings (buffer-var-values buffer)))
     181
     182
     183
     184(defun setup-buffer-bindings (buffer)
     185  (wind-bindings buffer (shiftf (buffer-mode-objects buffer) nil)))
     186
     187(defun revert-buffer-bindings (buffer)
     188  (setf (buffer-mode-objects buffer) (unwind-bindings buffer nil)))
    183189
    184190
    185191;;;; BUFFER-MAJOR-MODE.
    186192
    187 (eval-when (:compile-toplevel :execute)
    188193(defmacro with-mode-and-buffer ((name major-p buffer) &body forms)
    189194  `(let ((mode (get-mode-object name)))
     
    193198    (check-type ,buffer buffer)
    194199    ,@forms))
    195 ) ;eval-when
    196200
    197201;;; BUFFER-MAJOR-MODE  --  Public
     
    217221    (invoke-hook hemlock::buffer-major-mode-hook buffer name)
    218222    (cond
    219      ((eq buffer *current-buffer*)
     223     ((buffer-bindings-wound-p buffer)
    220224      (let ((old-mode (car (last (buffer-mode-objects buffer)))))
    221225        (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
    222226        (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)))
     227        (wind-bindings buffer (cons mode (cdr (unwind-bindings buffer old-mode))))))
    226228     (t
    227229      (let ((old-mode (car (buffer-mode-objects buffer))))
     
    229231        (funcall (mode-object-cleanup-function old-mode) buffer))
    230232      (setf (car (buffer-mode-objects buffer)) mode)))
     233    (invalidate-shadow-attributes buffer)
    231234    (setf (car (buffer-modes buffer)) name)
    232235    (funcall (mode-object-setup-function mode) buffer)
     
    265268       ;; Adding a new mode.
    266269       (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
     270        (let ((wound-p (buffer-bindings-wound-p buffer)))
     271          (when wound-p
     272            (revert-buffer-bindings buffer))
    283273          (do ((m (cdr objects) (cdr m))
    284274               (prev objects m))
     
    286276                   (>= (mode-object-precedence (car m))
    287277                       (mode-object-precedence mode)))
    288                (setf (cdr prev) (cons mode m))))))
     278               (setf (cdr prev) (cons mode m))))
     279          (when wound-p
     280            (setup-buffer-bindings buffer)))
    289281        ;;
    290282        ;; Add the mode name.
     
    303295        ;; In the current buffer, unwind buffer and any mode bindings on top
    304296        ;; pop off the mode and wind the rest back on.
    305         (cond ((eq buffer *current-buffer*)
    306                (wind-bindings (cdr (unwind-bindings mode))))
     297        (cond ((buffer-bindings-wound-p buffer)
     298               (wind-bindings buffer (cdr (unwind-bindings buffer mode))))
    307299              (t
    308300               (setf (buffer-mode-objects buffer)
     
    384376      (unless region
    385377        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 
    499378
    500379;;;; WITH-WRITABLE-BUFFER
     
    530409(defun defmode (name &key (setup-function #'identity)
    531410                     (cleanup-function #'identity) major-p transparent-p
    532                      precedence documentation hidden)
     411                     precedence documentation hidden default-command)
    533412  "Define a new mode, specifying whether it is a major mode, and what the
    534413   setup and cleanup functions are.  Precedence, which defaults to 0.0, and is
     
    565444      (setf (getstring name *mode-names*) mode)))
    566445
     446    (when (eq precedence :highest)
     447      (setq precedence most-positive-double-float))
    567448    (if precedence
    568449        (if major-p
     
    571452        (setq precedence 0))
    572453   
     454    (when default-command
     455      (setf (mode-object-default-command mode) default-command))
     456
    573457    (setf (mode-object-major-p mode) major-p
    574458          (mode-object-documentation mode) documentation
     
    611495   and Modeline-fields is a list of modeline field objects.  Delete-hook is a
    612496   list of functions that take a buffer as the argument."
    613   (cond ((getstring name *buffer-names*) nil)
     497  #+GZ
     498  (when (getstring name *buffer-names*)
     499    (warn "~s already exists, trying to delete" name *buffer-names*)
     500    (let ((buffer (getstring name *buffer-names*)))
     501      (when (buffer-windows buffer)
     502        (delete-buffer buffer))))
     503  (cond ((getstring name *buffer-names*)
     504         nil)
    614505        (t
    615506         (unless (listp delete-hook)
     
    638529           buffer))))
    639530
    640 (defun delete-buffer (buffer)
     531(defun delete-buffer (buffer &key force)
    641532  "Deletes a buffer.  If buffer is current, or if it is displayed in any
    642533   windows, an error is signaled."
    643534  (when (eq buffer *current-buffer*)
    644535    (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))))
     536  (unless force
     537    (when (buffer-windows buffer)
     538      (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
     539             buffer (length (buffer-windows buffer)))))
    648540  (invoke-hook (buffer-delete-hook buffer) buffer)
    649541  (invoke-hook hemlock::delete-buffer-hook buffer)
     
    693585  (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
    694586                                      :modeline-fields nil))
     587  (wind-bindings *current-buffer* nil)
     588
    695589  ;; Make the bogus variable go away...
    696590  (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp

    r7595 r7833  
    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 
    519(defun buffer-windows (buffer)
    5210  (let* ((doc (buffer-document buffer)))
     
    5412      (document-panes doc))))
    5513
    56 (defvar *current-window* ())
     14(defvar *window-list* ())
    5715
    58 (defvar *window-list* ())
    5916(defun current-window ()
    6017  "Return the current window.  The current window is specially treated by
     
    6219  recentering, ensuring that the Buffer-Point of the current window's
    6320  Window-Buffer is always displayed.  This may be set with Setf."
    64   *current-window*)
     21  (hemlock-view-pane *current-view*))
    6522
    6623(defun %set-current-window (new-window)
     
    6825  (invoke-hook hemlock::set-window-hook new-window)
    6926  (activate-hemlock-view new-window)
    70   (setq *current-window* new-window))
     27  (setf (hemlock-view-pane *current-view*) new-window))
    7128
    7229;;; This is a public variable.
    7330;;;
    74 (defvar *last-key-event-typed* ()
    75   "This variable contains the last key-event typed by the user and read as
    76    input.")
    7731
    78 (defvar *input-transcript* ())
     32(defun last-key-event-typed ()
     33  "This function returns the last key-event typed by the user and read as input."
     34  (hemlock-last-key-event-typed *current-view*))
     35
     36(defun %set-last-key-event-typed (key)
     37  (setf (hemlock-last-key-event-typed *current-view*) key))
     38
     39(defun hemlock::last-char-typed ()
     40  (let ((key (hemlock-last-key-event-typed *current-view*)))
     41    (when key (hemlock-ext:key-event-char key))))
     42
    7943
    8044(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G"))
    8145
    82 (defmacro abort-key-event-p (key-event)
    83   `(member (event-queue-node-event ,key-event) editor-abort-key-events))
    84 
    8546(defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift"))
    8647   
    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 
    11448(defun listen-editor-input (q)
    11549  (ccl::with-locked-dll-header (q)
     
    12357      (setf (font-region-node region) node)
    12458      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))
    13159
    13260(defun remove-font-region (region)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

    r7595 r7833  
    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"
     
    430427
    431428
    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)
    439 
    440 
    441429(defcommand "Extended Command" (p)
    442430  "Prompts for and executes an extended command."
    443431  "Prompts for and executes an extended command.  The prefix argument is
    444432  passed to the command."
    445   (let* ((name (prompt-for-keyword (list *command-names*)
     433  (let* ((name (prompt-for-keyword :tables (list *command-names*)
    446434                                   :prompt "Extended Command: "
    447435                                   :help "Name of a Hemlock command"))
     
    453441  :value 4)
    454442
     443(defstruct (prefix-argument-state (:conc-name "PS-"))
     444  sign
     445  multiplier
     446  read-some-digit-p
     447  ;; This is NIL if haven't started and don't have a universal argument, else a number
     448  result
     449  ;; This is cleared by prefix-argument-resetting-state (called at the start of each
     450  ;; command) and can be set by a command to avoid the state being reset at
     451  ;; the end of the command.
     452  set-p)
     453
     454(defun prefix-argument-resetting-state (&optional (ps (current-prefix-argument-state)))
     455  "Fetches the prefix argument and uses it up, i.e. marks it as not being set"
     456  (unless (ps-set-p ps)
     457    (setf (ps-sign ps) 1
     458          (ps-multiplier ps) 1
     459          (ps-read-some-digit-p ps) nil
     460          (ps-result ps) nil))
     461  (setf (ps-set-p ps) nil) ;; mark it for death unless explicitly revived.
     462  (when (ps-result ps)
     463    (* (ps-sign ps)
     464       (expt (value universal-argument-default) (ps-multiplier ps))
     465       (if (ps-read-some-digit-p ps)
     466         (ps-result ps)
     467         1))))
     468
     469(defun note-prefix-argument-set (ps)
     470  (assert (ps-result ps))
     471  (setf (ps-set-p ps) t)
     472  #+GZ (gui::log-debug "Note prefix argument set: ~s" ps)
     473  (message (with-output-to-string (s)
     474             (dotimes (i (ps-multiplier ps))
     475               (write-string "C-U " s))
     476             (cond ((ps-read-some-digit-p ps)
     477                    (format s "~d" (* (ps-sign ps) (ps-result ps))))
     478                   ((< (ps-sign ps) 0)
     479                    (write-string "-" s))))))
     480
    455481(defcommand "Universal Argument" (p)
    456482  "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))
     483   Typing digits, regardless of any modifier keys, specifies the argument.
     484   Optionally, you may first type a sign (- or +).  While typing digits, if you
     485   type C-U or C-u, the digits following the C-U form a number this command
     486   multiplies by the digits preceding the C-U.  The default value for this
     487   command and any number following a C-U is the value of \"Universal Argument
     488   Default\"."
     489  (declare (ignore p)) ;; we operate on underlying state instead
     490  (let ((ps (current-prefix-argument-state)))
     491    (if (ps-result ps)
     492      (incf (ps-multiplier ps))
     493      (setf (ps-result ps) 0))
     494    (note-prefix-argument-set ps)))
    490495
    491496(defcommand "Argument Digit" (p)
    492497  "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
     498   the key used to invoke this command.  It waits for more digits and a
    494499   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)))
     500  (declare (ignore p)) ;; we operate on underlying state instead
     501  (let* ((ps (current-prefix-argument-state))
     502         (key-event (last-key-event-typed))
     503         (stripped-key-event (hemlock-ext:make-key-event key-event))
     504         (char (hemlock-ext:key-event-char stripped-key-event))
     505         (digit (if char (digit-char-p char))))
     506    (when (null (ps-result ps))
     507      (setf (ps-result ps) 0))
     508    (case char
     509      (#\-
     510       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
     511         (editor-error "Must type minus sign first."))
     512       (setf (ps-sign ps) (- (ps-sign ps))))
     513      (#\+
     514       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
     515         (editor-error "Must type plus sign first.")))
     516      (t
     517       (unless digit
     518         (editor-error "Argument Digit must be bound to a digit!"))
     519       (setf (ps-read-some-digit-p ps) t)
     520       (setf (ps-result ps) (+ digit (* (ps-result ps) 10)))))
     521    (note-prefix-argument-set ps)))
     522
     523(defcommand "Digit" (p)
     524  "With a numeric argument, this command extends the argument.
     525   Otherwise it does self insert"
     526  (if p
     527    (argument-digit-command p)
     528    (self-insert-command p)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp

    r7540 r7833  
    223223  "Implements \"Completion Self Insert\". Calling this function is not
    224224   meaningful."
    225   (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)))
     225  (let ((char (last-char-typed)))
    226226    (unless char (editor-error "Can't insert that character."))
    227227    (cond ((completion-char-p char)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp

    r7595 r7833  
    6262;;; Some special variables are forward-referenced, and we don't even
    6363;;; need to invent a new language to advise the compiler of that ...
    64 (declaim (special *mode-names* *current-buffer* *echo-area-buffer*
     64(declaim (special *mode-names* *current-buffer*
    6565                  *the-sentinel*
    6666                  *in-the-editor* *buffer-list* *things-to-do-once*
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp

    r7123 r7833  
    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-command-key)
     179    (cond ((commandp res)
     180           (with-pop-up-display (s :title "Key documentation")
     181             (hemlock-ext:print-pretty-key key s)
     182             (format s " is bound to ~S.~%" (command-name res))
     183             (format s "Documentation for this command:~%   ~A"
     184                     (command-documentation res))))
     185          (t
     186           (with-pop-up-display (s :height 1)
     187             (hemlock-ext:print-pretty-key key s)
     188             (write-string " is not bound to anything." s))))))
    206189
    207190;;;; Generic describe variable, command, key, attribute.
     
    222205  (declare (ignore p))
    223206  (multiple-value-bind (ignore kwd)
    224                        (prompt-for-keyword *generic-describe-kinds*
     207                       (prompt-for-keyword :tables *generic-describe-kinds*
    225208                                           :default "Variable"
    226209                                           :help "Kind of thing to describe."
     
    235218       (multiple-value-bind (name attr)
    236219                            (prompt-for-keyword
    237                              (list *character-attribute-names*)
     220                             :tables (list *character-attribute-names*)
    238221                             :help "Name of character attribute to describe."
    239222                             :prompt "Attribute: ")
     
    309292  (declare (ignore p))
    310293  (let ((name (or name
    311                   (prompt-for-keyword (list *mode-names*)
     294                  (prompt-for-keyword :tables (list *mode-names*)
    312295                                      :prompt "Mode: "
    313296                                      :help "Enter mode to describe."
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

    r7475 r7833  
    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
     
    13140(defun message (string &rest args)
    13241  "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 
     42  String and Args are a format control string and format arguments, respectively."
     43  ;; TODO: used to do something cleverish if in the middle of reading prompted input, might
     44  ;; want to address that.
     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     )))
    16151
    16252;;; LOUD-MESSAGE -- Public.
     
    16858   doing anything else."
    16959  (beep)
    170   (clear-echo-area)
    17160  (apply #'message args))
    17261
    173 
    174 
    175 
    176 
     62;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     63;;
     64;; Echo area input
     65
     66(defmode "Echo Area" :major-p t)
     67
     68
     69(defstruct (echo-parse-state (:conc-name "EPS-"))
     70  (parse-verification-function nil)
     71  (parse-string-tables ())
     72  (parse-value-must-exist ())
     73  ;; When the user attempts to default a parse, we call the verification function
     74  ;; on this string.  This is not the :Default argument to the prompting function,
     75  ;; but rather a string representation of it.
     76  (parse-default ())
     77  ;; String that we show the user to inform him of the default.  If this
     78  ;; is NIL then we just use Parse-Default.
     79  (parse-default-string ())
     80  ;; Prompt for the current parse.
     81  (parse-prompt ())
     82  ;; Help string for the current parse.
     83  (parse-help ())
     84  ;; A hack. :String, :File or :Keyword.
     85  (parse-type :string)
     86  ;; input region
     87  parse-starting-mark
     88  parse-input-region
     89  ;; Store result here
     90  (parse-results ()))
     91
     92(defun current-echo-parse-state (&key (must-exist t))
     93  (or (hemlock-prompted-input-state *current-view*)
     94      (and must-exist (error "Can't do that when not in echo area input"))))
    17795
    17896
     
    18098;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
    18199
    182 (defun display-prompt-nicely (&optional (prompt *parse-prompt*)
    183                                         (default (or *parse-default-string*
    184                                                      *parse-default*)))
    185   (clear-echo-area)
     100(defun display-prompt-nicely (eps &optional (prompt (eps-parse-prompt eps))
     101                                            (default (or (eps-parse-default-string eps)
     102                                                         (eps-parse-default eps))))
    186103  (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))
     104   (let* ((buffer *current-buffer*)
     105          (point (buffer-point buffer)))
     106     (delete-region (buffer-region buffer))
     107     (insert-string point (if (listp prompt)
     108                            (apply #'format nil prompt)
     109                            prompt))
    191110     (when default
    192111       (insert-character point #\[)
    193112       (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 
     113       (insert-string point "] "))
     114     (move-mark (eps-parse-starting-mark eps) point))))
     115
     116;; This is used to prevent multiple buffers trying to do echo area input
     117;; at the same time - there would be no way to exit the earlier one
     118;; without exiting the later one, because they're both on the same stack.
     119(defvar *recursive-edit-view* nil)
     120
     121(defun parse-for-something (&key verification-function
     122                                 type
     123                                 string-tables
     124                                 value-must-exist
     125                                 default-string
     126                                 default
     127                                 prompt
     128                                 help)
     129  ;; We can't do a "recursive" edit in more than one view, because if the earlier
     130  ;; one wants to exit first, we'd have to unwind the stack to allow it to exit,
     131  ;; which would force the later one to exit whether it wants to or not.
     132  (when (and *recursive-edit-view* (not (eq *recursive-edit-view* *current-view*)))
     133    (editor-error "~s is already waiting for input"
     134                  (buffer-name (hemlock-view-buffer *recursive-edit-view*))))
     135  (modifying-echo-buffer
     136   (let* ((old-eps (hemlock-prompted-input-state *current-view*))
     137          (parse-mark (copy-mark (buffer-point *current-buffer*) :right-inserting))
     138          (end-mark (buffer-end-mark *current-buffer*))
     139          (eps (make-echo-parse-state
     140                :parse-starting-mark parse-mark
     141                :parse-input-region (region parse-mark end-mark)
     142                :parse-verification-function verification-function
     143                :parse-type type
     144                :parse-string-tables string-tables
     145                :parse-value-must-exist value-must-exist
     146                :parse-default-string default-string
     147                :parse-default default
     148                :parse-prompt prompt
     149                :parse-help help)))
     150     ;; TODO: There is really no good reason to disallow recursive edits in the same
     151     ;; buffer, I'm just too lazy.  Should save contents, starting mark, and point,
     152     ;; and restore them at the end.
     153     (when old-eps
     154       (editor-error "Attempt to recursively use echo area"))
     155     (unwind-protect
     156         (let ((*recursive-edit-view* *current-view*))
     157           (setf (hemlock-prompted-input-state *current-view*) eps)
     158           (display-prompt-nicely eps)
     159           (modifying-buffer-storage (nil)
     160             (gui::event-loop #'(lambda () (eps-parse-results eps))))
     161           #+gz (gui::log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
     162       (setf (hemlock-prompted-input-state *current-view*) old-eps)
     163       (delete-mark parse-mark))
     164     (let ((results (eps-parse-results eps)))
     165       (if (listp results)
     166         (apply #'values results)
     167         (abort-to-toplevel))))))
     168
     169(defun exit-echo-parse (eps results)
     170  #+gz (gui::log-debug "~&exit echo parse, results = ~s" results)
     171  ;; Must be set to non-nil to indicate parse done.
     172  (setf (eps-parse-results eps) (or results '(nil)))
     173  (gui::stop-event-loop) ;; this just marks it for dead then returns.
     174  ;; this exits current event, and since the event loop is stopped, it
     175  ;; will exit the event loop, which will return to parse-for-something,
     176  ;; which will notice we have the result set and will handle it accordingly.
     177  (exit-event-handler))
    209178
    210179;;;; Buffer prompting.
    211180
    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."))
     181(defun prompt-for-buffer (&key (must-exist t)
     182                                default
     183                                default-string
     184                               (prompt "Buffer: ")
     185                               (help "Type a buffer name."))
    217186  "Prompts for a buffer name and returns the corresponding buffer.  If
    218187   :must-exist is nil, then return the input string.  This refuses to accept
     
    221190   when :must-exist is non-nil, :default-string must be the name of an existing
    222191   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)
     192  (when (and must-exist
     193             (not default)
     194             (not (getstring default-string *buffer-names*)))
     195    (error "Default-string must name an existing buffer when must-exist is non-nil -- ~S."
     196           default-string))
     197  (parse-for-something
     198   :verification-function #'buffer-verification-function
     199   :type :keyword
     200   :string-tables (list *buffer-names*)
     201   :value-must-exist must-exist
     202   :default-string default-string
     203   :default (if default (buffer-name default) default-string)
     204   :prompt prompt
     205   :help help))
     206
     207(defun buffer-verification-function (eps string)
    240208  (declare (simple-string string))
    241209  (modifying-echo-buffer
    242210   (cond ((string= string "") nil)
    243          (*parse-value-must-exist*
     211         ((eps-parse-value-must-exist eps)
    244212          (multiple-value-bind
    245213              (prefix key value field ambig)
    246               (complete-string string *parse-string-tables*)
     214              (complete-string string (eps-parse-string-tables eps))
    247215            (declare (ignore field))
    248216            (ecase key
     
    251219               (list value))
    252220              (: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))))
     221               (let ((input-region (eps-parse-input-region eps)))
     222                 (delete-region input-region)
     223                 (insert-string (region-start input-region) prefix)
     224                 (let ((point (current-point)))
     225                   (move-mark point (region-start input-region))
     226                   (unless (character-offset point ambig)
     227                     (buffer-end point)))
     228                 nil)))))
    260229         (t
    261230          (list (or (getstring string *buffer-names*) string))))))
     
    266235;;;; File Prompting.
    267236
    268 (defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t)
     237(defun prompt-for-file (&key (must-exist t)
    269238                             default
    270                              ((:default-string *parse-default-string*))
    271                              ((:prompt *parse-prompt*) "Filename: ")
    272                              ((:help *parse-help*) "Type a file name."))
     239                             default-string
     240                             (prompt "Filename: ")
     241                             (help "Type a file name."))
    273242  "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)))
     243  (parse-for-something
     244   :verification-function #'file-verification-function
     245   :type :file
     246   :string-tables nil
     247   :value-must-exist must-exist
     248   :default-string default-string
     249   :default (if default (namestring default))
     250   :prompt prompt
     251   :help help))
     252
     253(defun file-verification-function (eps string)
     254  (let ((pn (pathname-or-lose eps string)))
    281255    (if pn
    282256        (let ((merge
    283                (cond ((not *parse-default*) nil)
     257               (cond ((not (eps-parse-default eps)) nil)
    284258                     ((directoryp pn)
    285                       (merge-pathnames pn *parse-default*))
     259                      (merge-pathnames pn (eps-parse-default eps)))
    286260                     (t
    287261                      (merge-pathnames pn
    288262                                       (or (directory-namestring
    289                                             *parse-default*)
     263                                            (eps-parse-default eps))
    290264                                           ""))))))
    291265          (cond ((probe-file pn) (list pn))
    292266                ((and merge (probe-file merge)) (list merge))
    293                 ((not *parse-value-must-exist*) (list (or merge pn)))
     267                ((not (eps-parse-value-must-exist eps)) (list (or merge pn)))
    294268                (t nil))))))
    295269
     
    299273;;; an editor-error.
    300274;;;
    301 (defun pathname-or-lose (string)
    302   (declare (simple-string string))
     275(defun pathname-or-lose (eps string)
    303276  (multiple-value-bind (pn idx)
    304277                       (parse-namestring string nil *default-pathname-defaults*
     
    306279    (cond (pn)
    307280          (t (modifying-echo-buffer
    308               (delete-characters (region-end *echo-area-region*)
    309                                 (- idx (length string))))
     281              (delete-characters (region-end (eps-input-region eps))
     282                                 (- idx (length string))))
    310283             nil))))
    311284
     
    315288;;;; Keyword and variable prompting.
    316289
    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."))
     290(defun prompt-for-keyword (&key
     291                           tables
     292                           (must-exist t)
     293                           default
     294                           default-string
     295                           (prompt "Keyword: ")
     296                           (help "Type a keyword."))
    324297  "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."))
     298  (parse-for-something
     299   :verification-function #'keyword-verification-function
     300   :type :keyword
     301   :string-tables tables
     302   :value-must-exist must-exist
     303   :default-string default-string
     304   :default default
     305   :prompt prompt
     306   :help help))
     307
     308
     309
     310(defun prompt-for-variable (&key (must-exist t)
     311                                 default
     312                                 default-string
     313                                 (prompt "Variable: ")
     314                                 (help "Type the name of a variable."))
    335315  "Prompts for a variable defined in the current scheme of things."
    336   (let ((*parse-string-tables* (current-variable-tables))
    337         (*parse-verification-function* #'keyword-verification-function)
    338         (*parse-type* :keyword))
    339     (parse-for-something)))
     316  (parse-for-something
     317   :verification-function  #'keyword-verification-function
     318   :type :keyword
     319   :string-tables (current-variable-tables)
     320   :value-must-exist must-exist
     321   :default-string default-string
     322   :default default
     323   :prompt prompt
     324   :help help))
    340325
    341326(defun current-variable-tables ()
     
    348333      ((null mode) tables)))
    349334
    350 (defun keyword-verification-function (string)
     335(defun keyword-verification-function (eps string)
    351336  (declare (simple-string string))
    352337  (multiple-value-bind
    353338      (prefix key value field ambig)
    354       (complete-string string *parse-string-tables*)
     339      (complete-string string (eps-parse-string-tables eps))
    355340    (declare (ignore field))
    356341    (modifying-echo-buffer
    357      (cond (*parse-value-must-exist*
     342     (cond ((eps-parse-value-must-exist eps)
    358343            (ecase key
    359344              (:none nil)
     
    361346               (list prefix value))
    362347              (:ambiguous
    363                (delete-region *parse-input-region*)
    364                (insert-string (region-start *parse-input-region*) prefix)
    365                (let ((point (current-point)))
    366                  (move-mark point (region-start *parse-input-region*))
    367                  (unless (character-offset point ambig)
    368                    (buffer-end point)))
    369                nil)))
     348               (let ((input-region (eps-parse-input-region eps)))
     349                 (delete-region input-region)
     350                 (insert-string (region-start input-region) prefix)
     351                 (let ((point (current-point)))
     352                   (move-mark point (region-start input-region))
     353                   (unless (character-offset point ambig)
     354                     (buffer-end point)))
     355                 nil))))
    370356           (t
    371357            ;; HACK: If it doesn't have to exist, and the completion does not
     
    379365;;;; Integer, expression, and string prompting.
    380366
    381 (defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t)
     367(defun prompt-for-integer (&key (must-exist t)
    382368                                default
    383                                 ((:default-string *parse-default-string*))
    384                                 ((:prompt *parse-prompt*) "Integer: ")
    385                                 ((:help *parse-help*) "Type an integer."))
     369                                default-string
     370                                (prompt "Integer: ")
     371                                (help "Type an integer."))
    386372  "Prompt for an integer.  If :must-exist is Nil, then we return as a string
    387373  whatever was input if it is not a valid integer."
    388   (let ((*parse-verification-function*
    389          #'(lambda (string)
    390              (let ((number (parse-integer string  :junk-allowed t)))
    391                (if *parse-value-must-exist*
    392                    (if number (list number))
    393                    (list (or number string))))))
    394         (*parse-default* (if default (write-to-string default :base 10))))
    395     (parse-for-something)))
     374
     375  (parse-for-something
     376   :verification-function #'(lambda (eps string)
     377                              (let ((number (parse-integer string  :junk-allowed t)))
     378                                (if (eps-parse-value-must-exist eps)
     379                                  (if number (list number))
     380                                  (list (or number string)))))
     381   :type :string
     382   :string-tables nil
     383   :value-must-exist must-exist
     384   :default-string default-string
     385   :default (if default (write-to-string default :base 10))
     386   :prompt prompt
     387   :help help))
    396388
    397389
     
    399391  "An object that won't be EQ to anything read.")
    400392
    401 (defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t)
     393(defun prompt-for-expression (&key (must-exist t)
    402394                                   (default nil defaultp)
    403                                    ((:default-string *parse-default-string*))
    404                                    ((:prompt *parse-prompt*) "Expression: ")
    405                                    ((:help *parse-help*)
    406                                     "Type a Lisp expression."))
     395                                   default-string
     396                                   (prompt "Expression: ")
     397                                   (help "Type a Lisp expression."))
    407398  "Prompts for a Lisp expression."
    408   (let ((*parse-verification-function*
    409          #'(lambda (string)
    410              (let ((expr (with-input-from-region (stream *parse-input-region*)
    411                            (handler-case (read stream nil hemlock-eof)
    412                              (error () hemlock-eof)))))
    413                (if *parse-value-must-exist*
    414                    (if (not (eq expr hemlock-eof)) (values (list expr) t))
    415                    (if (eq expr hemlock-eof)
    416                        (list string) (values (list expr) t))))))
    417         (*parse-default* (if defaultp (prin1-to-string default))))
    418       (parse-for-something)))
    419 
    420 
    421 (defun prompt-for-string (&key ((:default *parse-default*))
    422                                ((:default-string *parse-default-string*))
     399  (parse-for-something
     400   :verification-function #'(lambda (eps string)
     401                              (let* ((input-region (eps-parse-input-region eps))
     402                                     (expr (with-input-from-region (stream input-region)
     403                                             (handler-case (read stream nil hemlock-eof)
     404                                               (error () hemlock-eof)))))
     405                                (if (eq expr hemlock-eof)
     406                                  (unless (eps-parse-value-must-exist eps) (list string))
     407                                  (values (list expr) t))))
     408   :type :string
     409   :string-tables nil
     410   :value-must-exist must-exist
     411   :default-string default-string
     412   :default (if defaultp (prin1-to-string default))
     413   :prompt prompt
     414   :help help))
     415
     416
     417(defun prompt-for-string (&key default
     418                               default-string
    423419                               (trim ())
    424                                ((:prompt *parse-prompt*) "String: ")
    425                                ((:help *parse-help*) "Type a string."))
     420                               (prompt "String: ")
     421                               (help "Type a string."))
    426422  "Prompts for a string.  If :trim is t, then leading and trailing whitespace
    427423   is removed from input, otherwise it is interpreted as a Char-Bag argument
    428424   to String-Trim."
    429   (let ((*parse-verification-function*
    430          #'(lambda (string)
    431              (list (string-trim (if (eq trim t) '(#\space #\tab) trim)
    432                                 string)))))
    433     (parse-for-something)))
    434 
     425  (when (eq trim t) (setq trim '(#\space #\tab)))
     426  (parse-for-something
     427   :verification-function #'(lambda (eps string)
     428                              (declare (ignore eps))
     429                              (list (string-trim trim string)))
     430   :type :string
     431   :string-tables nil
     432   :value-must-exist nil
     433   :default-string default-string
     434   :default default
     435   :prompt prompt
     436   :help help))
    435437
    436438
     
    447449
    448450#||
    449 (defun prompt-for-package (&key ((:must-exist *parse-value-must-exist*) t)
    450                                   (default nil defaultp)
    451                                   ((:default-string *parse-default-string*))
    452                                   ((:prompt *parse-prompt*) "Package Name:")
    453                                   ((:help *parse-help*) "Type a package name."))
     451(defun prompt-for-package (&key (must-exist t)
     452                                (default nil defaultp)
     453                                default-string
     454                                (prompt "Package Name:")
     455                                (help "Type a package name."))
     456)
    454457||#
    455458
     
    461464  (make-string-table :initial-contents '(("Yes" . t) ("No" . nil))))
    462465
    463 (defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t)
     466(defun prompt-for-yes-or-no (&key (must-exist t)
    464467                                  (default nil defaultp)
    465                                   ((:default-string *parse-default-string*))
    466                                   ((:prompt *parse-prompt*) "Yes or No? ")
    467                                   ((:help *parse-help*) "Type Yes or No."))
     468                                  default-string
     469                                  (prompt "Yes or No? ")
     470                                  (help "Type Yes or No."))
    468471  "Prompts for Yes or No."
    469   (let* ((*parse-string-tables* (list *yes-or-no-string-table*))
    470          (*parse-default* (if defaultp (if default "Yes" "No")))
    471          (*parse-verification-function*
    472           #'(lambda (string)
    473               (multiple-value-bind
    474                   (prefix key value field ambig)
    475                   (complete-string string *parse-string-tables*)
    476                 (declare (ignore prefix field ambig))
    477                 (let ((won (or (eq key :complete) (eq key :unique))))
    478                   (if *parse-value-must-exist*
    479                       (if won (values (list value) t))
    480                       (list (if won (values value t) string)))))))
    481          (*parse-type* :keyword))
    482     (parse-for-something)))
     472  (parse-for-something
     473   :verification-function #'(lambda (eps string)
     474                              (multiple-value-bind
     475                                  (prefix key value field ambig)
     476                                  (complete-string string (eps-parse-string-tables eps))
     477                                (declare (ignore prefix field ambig))
     478                                (let ((won (or (eq key :complete) (eq key :unique))))
     479                                  (if (eps-parse-value-must-exist eps)
     480                                    (if won (values (list value) t))
     481                                    (list (if won (values value t) string))))))
     482   :type :keyword
     483   :string-tables (list *yes-or-no-string-table*)
     484   :value-must-exist must-exist
     485   :default-string default-string
     486   :default (if defaultp (if default "Yes" "No"))
     487   :prompt prompt
     488   :help help))
    483489
    484490(defun prompt-for-y-or-n (&key ((:must-exist must-exist) t)
     
    532538      (when change-window (setf (current-window) old-window)))))
    533539
    534 (defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
    535540(defun prompt-for-key (&key ((:must-exist must-exist) t)
    536541                            default default-string
     
    547552          (setf (current-window) *echo-area-window*)
    548553          (display-prompt-nicely prompt string)
    549           (setf (fill-pointer *prompt-key*) 0)
    550           (prog ((key *prompt-key*) key-event)
     554          (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event)
    551555                (declare (vector key))
    552556                TOP
     
    587591      (setf (current-window) old-window))))
    588592
     593(defun prompt-for-command-key ()
     594  (let ((old-window (current-window)))
     595    (unwind-protect
     596        (let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0)))
     597          (setf (current-window) hi::*echo-area-window*)
     598          (hi::display-prompt-nicely "Describe key: " nil)
     599          (loop
     600            (let ((key-event (get-key-event hi::*editor-input*)))
     601              (vector-push-extend key-event prompt-key)
     602              (let ((res (get-command prompt-key :current)))
     603                (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*)
     604                (write-char #\space *echo-area-stream*)
     605                (unless (eq res :prefix)
     606                  (return (values (copy-seq prompt-key) res)))))))
     607      (setf (current-window) old-window))))
     608
    589609
    590610
     
    693713(define-logical-key-event "Backward Search"
    694714  "This key-event is used to indicate that a backward search should be made.")
    695 (define-logical-key-event "Recursive Edit"
    696   "This key-event indicates that a recursive edit should be entered.")
    697715(define-logical-key-event "Cancel"
    698716  "This key-event is used  to cancel a previous key-event of input.")
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp

    r6790 r7833  
    2323  "File types to ignore when trying to complete a filename."
    2424  :value
    25   (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err"
     25  (list "fasl" "cfsl" "dfsl" "cfasl"
     26        "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err"
    2627        "x86f" "lbytef" "core" "trace"      ; Lisp
    2728        "BAK" "CKP"                         ; Backups & Checkpoints
     
    5657      ((null table) res)))
    5758
     59(defun get-parse-input-string (eps)
     60  (region-to-string (eps-parse-input-region eps)))
     61
     62(defun replace-parse-input-string (eps string)
     63  (delete-region (eps-parse-input-region eps))
     64  (insert-string (eps-parse-starting-mark eps) string))
     65
    5866(defcommand "Help on Parse" (p)
    5967  "Display help for parse in progress.
     
    6270  input."
    6371  (declare (ignore p))
    64   (let ((help (typecase *parse-help*
    65                 (list (unless *parse-help* (error "There is no parse help."))
    66                       (apply #'format nil *parse-help*))
    67                 (string *parse-help*)
    68                 (t (error "Parse help is not a string or list: ~S" *parse-help*))))
    69         (input (region-to-string *parse-input-region*)))
     72  (let* ((eps (current-echo-parse-state))
     73         (raw-help (eps-parse-help eps))
     74         (help (typecase raw-help
     75                 (null (error "There is no parse help."))
     76                 (list (apply #'format nil raw-help))
     77                 (string raw-help)
     78                 (t (error "Parse help is not a string or list: ~S" raw-help))))
     79         (input (get-parse-input-string eps)))
    7080    (cond
    71      ((eq *parse-type* :keyword)
    72       (let ((strings (find-all-completions input *parse-string-tables*)))
     81     ((eq (eps-parse-type eps) :keyword)
     82      (let ((strings (find-all-completions input (eps-parse-string-tables eps))))
    7383        (with-pop-up-display (s :title "input help" :height (+ (length strings) 2))
    7484          (write-line help s)
     
    7888                   (write-line string s)))
    7989                (t
    80                  (write-line
    81  "There are no possible completions of what you have typed." s))))))
    82      ((and (eq *parse-type* :file) (not (zerop (length input))))
    83       (let ((pns (ambiguous-files (region-to-string *parse-input-region*)
    84                                   *parse-default*)))
     90                 (write-line "There are no possible completions of what you have typed." s))))))
     91     ((and (eq (eps-parse-type eps) :file) (not (zerop (length input))))
     92      (let ((pns (ambiguous-files input (eps-parse-default eps))))
    8593        (declare (list pns))
    8694        (with-pop-up-display(s :title "Completion help" :height (+ (length pns) 2))
     
    103111                               (file-namestring pn) dir)))))
    104112                (t
    105                  (write-line
    106  "There are no possible completions of what you have typed." s))))))
     113                 (write-line  "There are no possible completions of what you have typed." s))))))
    107114     (t
    108       (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting))
    109         (insert-string m help)
    110         (insert-character m #\newline))))))
    111 
    112 (defun file-completion-action (typein)
     115      (with-pop-up-display (s :title "input help" :height 2)
     116        (write-line help s))))))
     117
     118(defun file-completion-action (eps typein)
    113119  (declare (simple-string typein))
    114120  (when (zerop (length typein)) (editor-error))
     
    116122      (result win)
    117123      (hemlock-ext:complete-file typein
    118                                  :defaults (directory-namestring *parse-default*)
     124                                 :defaults (directory-namestring (eps-parse-default eps))
    119125                                 :ignore-types (value ignore-file-types))
    120126    (when result
    121       (delete-region *parse-input-region*)
    122       (insert-string (region-start *parse-input-region*)
    123                      (namestring result)))
     127      (replace-parse-input-string eps (namestring result)))
    124128    (when (and (not win) (value beep-on-ambiguity))
    125129      (editor-error))))
     
    131135  If it is ambiguous and ``Beep On Ambiguity'' true beep."
    132136  (declare (ignore p))
    133   (let ((typein (region-to-string *parse-input-region*)))
     137  (let* ((eps (current-echo-parse-state))
     138         (typein (get-parse-input-string eps)))
    134139    (declare (simple-string typein))
    135     (case *parse-type*
     140    (case (eps-parse-type eps)
    136141      (:keyword
    137        (multiple-value-bind
    138            (prefix key value field ambig)
    139            (complete-string typein *parse-string-tables*)
     142       (multiple-value-bind (prefix key value field ambig)
     143                            (complete-string typein (eps-parse-string-tables eps))
    140144         (declare (ignore value field))
    141145         (when prefix
    142            (delete-region *parse-input-region*)
    143            (insert-string (region-start *parse-input-region*) prefix)
     146           (replace-parse-input-string eps prefix)
    144147           (when (eq key :ambiguous)
    145148             (let ((point (current-point)))
    146                (move-mark point (region-start *parse-input-region*))
     149               (move-mark point (eps-parse-starting-mark eps))
    147150               (unless (character-offset point ambig)
    148151                 (buffer-end point)))))
     
    151154           (editor-error))))
    152155      (:file
    153        (file-completion-action typein))
     156       (file-completion-action eps typein))
    154157      (t
    155158       (editor-error "Cannot complete input for this prompt.")))))
     
    166169  separated by characters having a non-zero :parse-field-separator attribute,
    167170  and this command should only be bound to characters having that attribute."
    168   (let ((typein (region-to-string *parse-input-region*)))
     171  (let* ((eps (current-echo-parse-state))
     172         (typein (get-parse-input-string eps)))
    169173    (declare (simple-string typein))
    170     (case *parse-type*
     174    (case (eps-parse-type eps)
    171175      (:string
    172176       (self-insert-command p))
    173177      (:file
    174        (file-completion-action typein))
     178       (file-completion-action eps typein))
    175179      (:keyword
    176180       (let ((point (current-point)))
    177181         (unless (blank-after-p point)
    178            (insert-character point
    179                              (hemlock-ext:key-event-char *last-key-event-typed*))))
     182           (insert-character point (last-char-typed))))
    180183       (multiple-value-bind
    181184           (prefix key value field ambig)
    182            (complete-string typein *parse-string-tables*)
     185           (complete-string typein (eps-parse-string-tables eps))
    183186         (declare (ignore value ambig))
    184187         (when (eq key :none) (editor-error "No possible completion."))
    185          (delete-region *parse-input-region*)
    186188         (let ((new-typein (if (and (eq key :unique) (null field))
    187189                               (subseq prefix 0 field)
    188190                               (concatenate 'string
    189191                                            (subseq prefix 0 field)
    190                                             (string
    191                                              (hemlock-ext:key-event-char
    192                                               *last-key-event-typed*))))))
    193            (insert-string (region-start *parse-input-region*) new-typein))))
     192                                            (string (last-char-typed))))))
     193           (replace-parse-input-string eps new-typein))))
    194194      (t
    195195       (editor-error "Cannot complete input for this prompt.")))))
     
    197197
    198198
     199;;; *** TODO: this needs to be view-local
    199200(defvar *echo-area-history* (make-ring 10)
    200201  "This ring-buffer contains strings which were previously input in the
     
    203204(defvar *echo-history-pointer* 0
    204205  "This is our current position to the ring during a historical exploration.")
     206
    205207
    206208(defcommand "Confirm Parse" (p)
     
    210212  otherwise calls the verification function."
    211213  (declare (ignore p))
    212   (let* ((string (region-to-string *parse-input-region*))
     214  (let* ((eps (current-echo-parse-state))
     215         (string (get-parse-input-string eps))
    213216         (empty (zerop (length string))))
    214217    (declare (simple-string string))
    215218    (if empty
    216         (when *parse-default* (setq string *parse-default*))
     219        (when (eps-parse-default eps) (setq string (eps-parse-default eps)))
    217220        (when (or (zerop (ring-length *echo-area-history*))
    218221                  (string/= string (ring-ref *echo-area-history* 0)))
    219222          (ring-push string *echo-area-history*)))
    220223    (multiple-value-bind (res flag)
    221                          (funcall *parse-verification-function* string)
     224                         (funcall (eps-parse-verification-function eps) eps string)
    222225      (unless (or res flag) (editor-error))
    223       (exit-recursive-edit res))))
     226      (exit-echo-parse eps res))))
    224227
    225228(defcommand "Previous Parse" (p)
     
    228231  of the ring then push it on the ring before inserting the new input."
    229232  "Pop the *echo-area-history* ring buffer."
    230   (let ((length (ring-length *echo-area-history*))
    231         (p (or p 1)))
     233  (let* ((eps (current-echo-parse-state))
     234         (length (ring-length *echo-area-history*))
     235         (p (or p 1)))
    232236    (when (zerop length) (editor-error))
    233237    (cond
    234238     ((eq (last-command-type) :echo-history)
    235239      (let ((base (mod (+ *echo-history-pointer* p) length)))
    236         (delete-region *parse-input-region*)
    237         (insert-string (region-end *parse-input-region*)
    238                        (ring-ref *echo-area-history* base))
     240        (replace-parse-input-string eps (ring-ref *echo-area-history* base))
    239241        (setq *echo-history-pointer* base)))
    240242     (t
    241       (let ((current (region-to-string *parse-input-region*))
     243      (let ((current (get-parse-input-string eps))
    242244            (base (mod (if (minusp p) p (1- p)) length)))
    243         (delete-region *parse-input-region*)
    244         (insert-string (region-end *parse-input-region*)
    245                        (ring-ref *echo-area-history* base))     
     245        (replace-parse-input-string eps (ring-ref *echo-area-history* base))
    246246        (when (and (plusp (length current))
    247247                   (string/= (ring-ref *echo-area-history* 0) current))
     
    266266  (editor-error))
    267267
    268 (add-hook window-buffer-hook
    269           #'(lambda (window new-buff)
    270               (when (and (eq window *echo-area-window*)
    271                          (not (eq new-buff *echo-area-buffer*)))
    272                 (editor-error "Can't change echo area window."))))
    273 
    274268(defcommand "Beginning Of Parse" (p)
    275269  "Moves to immediately after the prompt when in the echo area."
    276270  "Move the point of the echo area buffer to *parse-starting-mark*."
    277271  (declare (ignore p))
    278   (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*))
     272  (let* ((eps (current-echo-parse-state))
     273         (start (eps-parse-starting-mark eps)))
     274    (move-mark (current-point) start)))
    279275
    280276(defcommand "Echo Area Delete Previous Character" (p)
    281   "Delete the previous character.
    282   Don't let the luser rub out the prompt."
    283   "Signal an editor-error if we would nuke the prompt,
    284   otherwise do a normal delete."
    285   (with-mark ((tem (buffer-point *echo-area-buffer*)))
    286     (unless (character-offset tem (- (or p 1))) (editor-error))
    287     (when (mark< tem *parse-starting-mark*) (editor-error))
    288     (delete-previous-character-command p)))
     277  "Delete the previous character, up to the prompt."
     278  (let* ((eps (current-echo-parse-state))
     279         (start (eps-parse-starting-mark eps)))
     280    (with-mark ((tem (current-point)))
     281      (unless (character-offset tem (- (or p 1))) (editor-error))
     282      (when (mark< tem start) (editor-error))
     283      (delete-previous-character-command p))))
    289284
    290285(defcommand "Echo Area Kill Previous Word" (p)
    291   "Kill the previous word.
    292   Don't let the luser rub out the prompt."
    293   "Signal an editor-error if we would mangle the prompt, otherwise
    294   do a normal kill-previous-word."
    295   (with-mark ((tem (buffer-point *echo-area-buffer*)))
    296     (unless (word-offset tem (- (or p 1))) (editor-error))
    297     (when (mark< tem *parse-starting-mark*) (editor-error))
    298     (kill-previous-word-command p)))
     286  "Kill the previous word, up to the prompt."
     287  (let* ((eps (current-echo-parse-state))
     288         (start (eps-parse-starting-mark eps)))
     289    (with-mark ((tem (current-point)))
     290      (unless (word-offset tem (- (or p 1))) (editor-error))
     291      (when (mark< tem start) (editor-error))
     292      (kill-previous-word-command p))))
    299293
    300294(declaim (special *kill-ring*))
     
    304298  "Kills *parse-input-region*."
    305299  (declare (ignore p))
    306   (if (end-line-p (current-point))
    307       (kill-region *parse-input-region* :kill-backward)
    308       (ring-push (delete-and-save-region *parse-input-region*)
    309                  *kill-ring*)))
     300  (let* ((eps (current-echo-parse-state)))
     301    (if (end-line-p (current-point))
     302      (kill-region (eps-parse-input-region eps) :kill-backward)
     303      (ring-push (delete-and-save-region (eps-parse-input-region eps))
     304                 *kill-ring*))))
    310305
    311306(defcommand "Insert Parse Default" (p)
    312307  "Inserts the default for the parse in progress.
    313308  The text is inserted at the point."
    314   "Inserts *parse-default* at the point of the *echo-area-buffer*.
    315   If there is no default an editor-error is signalled."
    316   (declare (ignore p))
    317   (unless *parse-default* (editor-error))
    318   (insert-string (buffer-point *echo-area-buffer*) *parse-default*))
     309  (declare (ignore p))
     310  (let* ((eps (current-echo-parse-state))
     311         (default (eps-parse-default eps)))
     312    (unless default (editor-error))
     313    (insert-string (current-point) default)))
    319314
    320315(defcommand "Echo Area Backward Character" (p)
    321316  "Go back one character.
    322   Don't let the luser move into the prompt."
     317   Don't let the luser move into the prompt."
    323318  "Signal an editor-error if we try to go into the prompt, otherwise
    324   do a backward-character command."
    325   (backward-character-command p)
    326   (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
    327     (beginning-of-parse-command ())
    328     (editor-error)))
     319   do a backward-character command."
     320  (let* ((eps (current-echo-parse-state))
     321         (start (eps-parse-starting-mark eps))
     322         (point (current-point)))
     323    (when (mark<= point start)
     324      (editor-error))
     325    (backward-character-command p)
     326    (when (mark< point start)
     327      (beginning-of-parse-command nil))))
    329328
    330329(defcommand "Echo Area Backward Word" (p)
     
    333332  "Signal an editor-error if we try to go into the prompt, otherwise
    334333  do a backward-word command."
    335   (backward-word-command p)
    336   (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*)
    337     (beginning-of-parse-command ())
    338     (editor-error)))
     334  (let* ((eps (current-echo-parse-state))
     335         (start (eps-parse-starting-mark eps))
     336         (point (current-point)))
     337    (when (mark<= point start)
     338      (editor-error))
     339    (backward-word-command p)
     340    (when (mark< point start)
     341      (beginning-of-parse-command nil))))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp

    r7541 r7833  
    106106            (declare (ignore key))
    107107            (values (command-name cmd) cmd))
    108           (prompt-for-keyword (list *command-names*)
     108          (prompt-for-keyword :tables (list *command-names*)
    109109                              :prompt "Command to edit: "))
    110110    (go-to-definition (fun-defined-from-pathname (command-function command))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp

    r7595 r7833  
    379379;;;; Find file.
    380380
    381 
    382 (defcommand "Old Find File" (p &optional pathname)
    383   "Visit a file in its own buffer.
    384    If the file is already in some buffer, select that buffer,
    385    otherwise make a new buffer with the same name as the file and
    386    read the file into it."
    387   "Make a buffer containing the file Pathname current, creating a buffer
    388    if necessary.  The buffer is returned."
    389   (declare (ignore p))
    390   (let* ((pn (or pathname
    391                  (prompt-for-file
    392                   :prompt "Find File: "
    393                   :must-exist nil
    394                   :help "Name of file to read into its own buffer."
    395                   :default (buffer-default-pathname (current-buffer)))))
    396          (buffer (find-file-buffer pn)))
    397     (change-to-buffer buffer)
    398     buffer))
    399381
    400382(defcommand "Find File" (p &optional pathname)
     
    633615  "Writes the contents of the current buffer to the associated file."
    634616  (declare (ignore p))
    635   (let* ((document (hi::buffer-document buffer)))
    636     (when document
    637       (when (buffer-modified buffer)
     617  (when (buffer-modified buffer)
     618    (let* ((document (hi::buffer-document buffer)))
     619      (when document
    638620        (hi::save-hemlock-document document)))))
    639621
     
    668650        (message "Saved ~S file~:P." saved-count))))
    669651
    670 (defcommand "Save All Files and Exit" (p)
    671   "Save all modified buffers in their associated files and exit;
    672   a combination of \"Save All Files\" and \"Exit Hemlock\"."
    673   "Do a save-all-files-command and then an exit-hemlock."
    674   (declare (ignore p))
    675   (save-all-files-command ())
    676   (exit-hemlock))
    677 
    678652(defcommand "Backup File" (p)
    679653  "Write the buffer to a file without changing the associated name."
     
    693667;;;; Buffer hacking commands:
    694668
    695 (defvar *buffer-history* ()
    696   "A list of buffers, in order from most recently to least recently selected.")
    697 
    698 (defun previous-buffer ()
    699   "Returns some previously selected buffer that is not the current buffer.
    700    Returns nil if no such buffer exists."
    701   (let ((b (car *buffer-history*)))
    702     (or (if (eq b (current-buffer)) (cadr *buffer-history*) b)
    703         (find-if-not #'(lambda (x)
    704                          (or (eq x (current-buffer))
    705                              (eq x *echo-area-buffer*)))
    706                      (the list *buffer-list*)))))
    707 
    708 ;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by
    709 ;;; "Circulate Buffers" even if it has never been before.
    710 ;;;
    711 (defun add-buffer-history-hook (buffer)
    712   (let ((ele (last *buffer-history*))
    713         (new-stuff (list buffer)))
    714     (if ele
    715         (setf (cdr ele) new-stuff)
    716         (setf *buffer-history* new-stuff))))
    717 ;;;
    718 (add-hook make-buffer-hook 'add-buffer-history-hook)
    719 
    720 ;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer.
    721 ;;;
    722 (defun delete-buffer-history-hook (buffer)
    723   (setq *buffer-history* (delq buffer *buffer-history*)))
    724 ;;;
    725 (add-hook delete-buffer-hook 'delete-buffer-history-hook)
    726  
    727 (defun change-to-buffer (buffer)
    728   "Switches to buffer in the current window maintaining *buffer-history*."
    729   (setq *buffer-history*
    730         (cons (current-buffer) (delq (current-buffer) *buffer-history*)))
    731   (setf (current-buffer) buffer)
    732   (setf (window-buffer (current-window)) buffer))
    733 
    734 (defun delete-buffer-if-possible (buffer)
    735   "Deletes a buffer if at all possible.  If buffer is the only buffer, other
    736    than the echo area, signals an error.  Otherwise, find some recently current
    737    buffer, and make all of buffer's windows display this recent buffer.  If
    738    buffer is current, set the current buffer to be this recently current
    739    buffer."
    740   (let ((new-buf (flet ((frob (b)
    741                           (or (eq b buffer) (eq b *echo-area-buffer*))))
    742                    (or (find-if-not #'frob (the list *buffer-history*))
    743                        (find-if-not #'frob (the list *buffer-list*))))))
    744     (unless new-buf
    745       (error "Cannot delete only buffer ~S." buffer))
    746     (dolist (w (buffer-windows buffer))
    747       (setf (window-buffer w) new-buf))
    748     (when (eq buffer (current-buffer))
    749       (setf (current-buffer) new-buf)))
    750   (delete-buffer buffer))
    751 
    752 
    753 (defvar *create-buffer-count* 0)
    754 
    755 (defcommand "Create Buffer" (p &optional buffer-name)
    756   "Create a new buffer.  If a buffer with the specified name already exists,
    757    then go to it."
    758   "Create or go to the buffer with the specifed name."
    759   (declare (ignore p))
    760   (let ((name (or buffer-name
    761                   (prompt-for-buffer :prompt "Create Buffer: "
    762                                      :default-string
    763                                      (format nil "Buffer ~D"
    764                                              (incf *create-buffer-count*))
    765                                      :must-exist nil))))
    766     (if (bufferp name)
    767         (change-to-buffer name)
    768         (change-to-buffer (or (getstring name *buffer-names*)
    769                               (make-buffer name))))))
    770 
    771 (defcommand "Select Buffer" (p)
    772   "Select a different buffer.
    773    The buffer to go to is prompted for."
    774   "Select a different buffer.
    775    The buffer to go to is prompted for."
    776   (declare (ignore p))
    777   (let ((buf (prompt-for-buffer :prompt "Select Buffer: "
    778                                 :default (previous-buffer))))
    779     (when (eq buf *echo-area-buffer*)
    780       (editor-error "Cannot select Echo Area buffer."))
    781     (change-to-buffer buf)))
    782 
    783 
    784 (defvar *buffer-history-ptr* ()
    785   "The successively previous buffer to the current buffer.")
    786 
    787 (defcommand "Select Previous Buffer" (p)
    788   "Select the buffer selected before this one.  If called repeatedly
    789    with an argument, select the successively previous buffer to the
    790    current one leaving the buffer history as it is."
    791   "Select the buffer selected before this one."
    792   (if p
    793       (circulate-buffers-command nil)
    794       (let ((b (previous-buffer)))
    795         (unless b (editor-error "No previous buffer."))
    796         (change-to-buffer b)
    797         ;;
    798         ;; If the pointer goes to nil, then "Circulate Buffers" will keep doing
    799         ;; "Select Previous Buffer".
    800         (setf *buffer-history-ptr* (cddr *buffer-history*))
    801         (setf (last-command-type) :previous-buffer))))
    802 
    803 (defcommand "Circulate Buffers" (p)
    804   "Advance through buffer history, selecting successively previous buffer."
    805   "Advance through buffer history, selecting successively previous buffer."
    806   (declare (ignore p))
    807   (if (and (eq (last-command-type) :previous-buffer)
    808            *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER.
    809       (let ((b (pop *buffer-history-ptr*)))
    810         (when (eq b (current-buffer))
    811           (setf b (pop *buffer-history-ptr*)))
    812         (unless b
    813           (setf *buffer-history-ptr*
    814                 (or (cdr *buffer-history*) *buffer-history*))
    815           (setf b (car *buffer-history*)))
    816         (setf (current-buffer) b)
    817         (setf (window-buffer (current-window)) b)
    818         (setf (last-command-type) :previous-buffer))
    819       (select-previous-buffer-command nil)))
    820  
    821669
    822670(defcommand "Buffer Not Modified" (p)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/files.lisp

    r6579 r7833  
    3333           (buffer (line-%buffer first-line)))
    3434      (modifying-buffer buffer)
    35       (cocoa-read-file pathname mark buffer))))
    36      
    37 
     35      (with-open-file (input pathname :direction :input :element-type 'character)
     36        (do ((line (read-line input nil :eof) (read-line input nil :eof)))
     37            ((eql line :eof))
     38          (insert-string mark line)
     39          (insert-character mark #\newline))))))
    3840
    3941
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp

    r6600 r7833  
    665665      (return i))))
    666666
     667#-clozure
    667668(defun delq (item list)
    668669  (delete item list :test #'eq))
    669670
     671#-clozure
    670672(defun memq (item list)
    671673  (member item list :test #'eq))
    672674
     675#-clozure
    673676(defun assq (item alist)
    674677  (assoc item alist :test #'eq))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp

    r7595 r7833  
    114114(defvar *cache-modification-tick* -1
    115115  "The counter for the fixnums we stick in the chars of the cached line.")
     116
     117(defun next-cache-modification-tick ()
     118  (ccl::atomic-decf *cache-modification-tick*))
    116119
    117120(defun open-line (line mark)
     
    171174    (unless (and (= (mark-charpos ,mark) (current-left-open-pos)) (current-open-line-p ,line))
    172175      (open-line ,line ,mark))
    173     (setf (line-chars (current-open-line)) (decf *cache-modification-tick*))))
     176    (setf (line-chars (current-open-line)) (next-cache-modification-tick))))
    174177
    175178;;; Now-Tick tells us when now is and isn't.
     
    182185
    183186 
    184 (defun buffer-document-begin-editing (buffer)
    185   (when (bufferp buffer)
    186     (let* ((document (buffer-document buffer)))
    187       (when document
    188         (lock-buffer buffer)
    189         (document-begin-editing document)))))
    190 
    191 (defun buffer-document-end-editing (buffer)
    192   (when (bufferp buffer)
    193     (let* ((document (buffer-document buffer)))
    194       (when document
    195         (unlock-buffer buffer)
    196         (document-end-editing document)))))
    197 
    198 
    199 
    200187;;; Yeah, the following is kind of obscure, but at least it doesn't
    201188;;; call Bufferp twice.  The without-interrupts is just to prevent
     
    422409           (error "~S is an invalid mark type." kind)))))
    423410
     411(defun mark-buffer (mark)
     412  (line-buffer (mark-line mark)))
     413
    424414(defun copy-mark (mark &optional (kind (mark-%kind mark)))
    425415  "Returns a new mark pointing to the same position as Mark.  The kind
     
    469459  "``Buffer'' given to lines in regions not in any buffer.")
    470460
     461(defun next-disembodied-buffer-counter ()
     462  (ccl::atomic-incf *disembodied-buffer-counter*))
     463
    471464(defun make-empty-region ()
    472465  "Returns a region with start and end marks pointing to the start of one empty
    473466  line.  The start mark is right-inserting and the end mark is left-inserting."
    474467  (let* ((line (make-line :chars ""  :number 0
    475                           :%buffer (incf *disembodied-buffer-counter*)))
     468                          :%buffer (next-disembodied-buffer-counter)))
    476469         (start (mark line 0 :right-inserting))
    477470         (end (mark line 0 :left-inserting)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/htext2.lisp

    r7595 r7833  
    6767    (declare (simple-string string))
    6868    (do* ((index 0)
    69           (buffer (incf *disembodied-buffer-counter*))
     69          (buffer (next-disembodied-buffer-counter))
    7070          (previous-line)
    7171          (line (make-line :%buffer buffer))
     
    243243  mark)
    244244
    245 (defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark))))
     245(defun buffer-start (mark &optional (buffer (mark-buffer mark)))
    246246  "Change Mark to point to the beginning of Buffer, which defaults to
    247247  the buffer Mark is currently in."
     
    249249  (move-mark mark (buffer-start-mark buffer)))
    250250
    251 (defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark))))
     251(defun buffer-end (mark &optional (buffer (mark-buffer mark)))
    252252  "Change Mark to point to the end of Buffer, which defaults to
    253253  the buffer Mark is currently in."
     
    392392
    393393(defun %print-before-mark (mark stream)
    394   (let* ((hi::*current-buffer* (line-buffer (mark-line mark))))
     394  (let* ((hi::*current-buffer* (mark-buffer mark)))
    395395    (if (mark-line mark)
    396396        (let* ((line (mark-line mark))
     
    415415
    416416(defun %print-after-mark (mark stream)
    417   (let* ((hi::*current-buffer* (line-buffer (mark-line mark))))
     417  (let* ((hi::*current-buffer* (mark-buffer mark)))
    418418    (if (mark-line mark)
    419419        (let* ((line (mark-line mark))
     
    446446(defun %print-hmark (structure stream d)
    447447  (declare (ignore d))
    448   (let ((hi::*current-buffer* (line-buffer (mark-line structure))))
     448  (let ((hi::*current-buffer* (mark-buffer structure)))
    449449    (write-string "#<Hemlock Mark \"" stream)
    450450    (%print-before-mark structure stream)
     
    461461  (let* ((start (region-start region))
    462462         (end (region-end region))
    463          (hi::*current-buffer* (line-buffer (mark-line start)))
     463         (hi::*current-buffer* (mark-buffer start))
    464464         (first-line (mark-line start))
    465465         (last-line (mark-line end)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/htext3.lisp

    r7595 r7833  
    5656                                                       0 (current-left-open-pos)))
    5757                                    (new-line (make-line :%buffer buffer
    58                                                          :chars (decf *cache-modification-tick*)
     58                                                         :chars (next-cache-modification-tick)
    5959                                                         :previous line
    6060                                                         :next next)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/htext4.lisp

    r7595 r7833  
    128128                 ;;line-%buffer:
    129129                 (do* ((line (line-next first-line) (line-next line))
    130                        (count (incf *disembodied-buffer-counter*)))
     130                       (count (next-disembodied-buffer-counter)))
    131131                      ((eq line last-line)
    132132                       (setf (line-%buffer last-line) count))
     
    181181                          (new-line (make-line
    182182                                     :chars new-chars  :number 0
    183                                      :%buffer (incf *disembodied-buffer-counter*))))
     183                                     :%buffer (next-disembodied-buffer-counter))))
    184184                     (declare (simple-string new-chars))
    185185                     (%sp-byte-blt (current-open-chars) (current-right-open-pos) new-chars 0 num)
     
    205205                          (saved-first-chars (make-string saved-first-length))
    206206                          (saved-last-chars (make-string last-charpos))
    207                           (count (incf *disembodied-buffer-counter*))
     207                          (count (next-disembodied-buffer-counter))
    208208                          (saved-line (make-line :chars saved-first-chars
    209209                                                 :%buffer count)))
     
    275275         (first-charpos (mark-charpos start))
    276276         (last-charpos (mark-charpos end))
    277          (count (incf *disembodied-buffer-counter*)))
     277         (count (next-disembodied-buffer-counter)))
    278278    (cond
    279279     ((eq first-line last-line)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp

    r7595 r7833  
    4040;;; our purposes it is presently used to look up commands and key-translations.
    4141;;;
    42 (defun get-table-entry (table key)
     42(defun get-table-entry (table key &key (end (length key)))
    4343  (let ((foo nil))
    44     (dotimes (i (length key) foo)
     44    (dotimes (i end foo)
    4545      (let ((key-event (aref key i)))
    4646        (setf foo (gethash key-event table))
     
    7474
    7575(defvar *key-translations* (make-hash-table))
    76 (defvar *translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t))
    77 
    7876
    7977;;; TRANSLATE-KEY  --  Internal
     
    8785(defun translate-key (key &optional (result (make-array (length key)
    8886                                                        :fill-pointer 0
    89                                                         :adjustable t)))
     87                                                        :adjustable t))
     88                                    (temp (make-array 10 :fill-pointer 0 :adjustable t)))
    9089  (let ((key-len (length key))
    91         (temp *translate-key-temp*)
    9290        (start 0)
    9391        (try-pos 0)
     
    10098        (vector-push-extend
    10199         (hemlock-ext:make-key-event key-event (logior (hemlock-ext:key-event-bits key-event)
    102                                                prefix))
     100                                                       prefix))
    103101         temp)
    104102        (setf prefix 0))
     
    222220                              "~&Error while trying to bind key ~A: ~A~%"
    223221                              key condition)
    224                       (return-from bind-key nil))))
     222                      (message (format nil "~a" condition))
     223                      #-GZ (return-from bind-key nil)
     224                      )))
    225225                (let ((cmd (getstring name *command-names*))
    226226                      (table (get-right-table kind where))
     
    262262                   (nreverse t-bindings)))
    263263        (declare (list t-bindings))
    264         (let ((res (get-table-entry (mode-object-bindings (car mode)) key)))
     264        (let* ((res (or (get-table-entry (mode-object-bindings (car mode)) key)
     265                        (let ((default (mode-object-default-command (car mode))))
     266                          (and default (getstring default *command-names*))))))
    265267          (when res
    266             (if (mode-object-transparent-p (car mode))
     268            (if (or (mode-object-transparent-p (car mode))
     269                    (and (commandp res) (command-transparent-p res)))
    267270                (push res t-bindings)
    268271                (return (values res (nreverse t-bindings)))))))))))
     
    308311;;; otherwise, make a new command object and enter it into the *command-names*.
    309312;;;
    310 (defun make-command (name documentation function)
     313(defun make-command (name documentation function &key transparent-p)
    311314  "Create a new Hemlock command with Name and Documentation which is
    312315   implemented by calling the function-value of the symbol Function"
     
    316319      (setf (command-name entry) name)
    317320      (setf (command-documentation entry) documentation)
    318       (setf (command-function entry) function))
     321      (setf (command-function entry) function)
     322      (setf (command-transparent-p entry) transparent-p))
    319323     (t
    320324      (setf (getstring name *command-names*)
    321             (internal-make-command name documentation function))))))
     325            (internal-make-command name documentation function transparent-p))))))
    322326
    323327
     
    366370
    367371
    368 (defvar *last-command-type* ()
    369   "The command-type of the last command invoked.")
    370 (defvar *command-type-set* ()
    371   "True if the last command set the command-type.")
    372 
    373372;;; LAST-COMMAND-TYPE  --  Public
    374373;;;
     
    378377  If no command-type has been set then return NIL.  Setting this with
    379378  Setf sets the value for the next command."
    380   *last-command-type*)
     379  *last-last-command-type*)
    381380
    382381;;; %SET-LAST-COMMAND-TYPE  --  Internal
    383382;;;
    384 ;;;    Set the flag so we know not to clear the command-type.
    385 ;;;
    386383(defun %set-last-command-type (type)
    387   (setq *last-command-type* type *command-type-set* t))
    388 
    389 
    390 (defvar *prefix-argument* nil "The prefix argument or NIL.")
    391 (defvar *prefix-argument-supplied* nil
    392   "Should be set by functions which supply a prefix argument.")
     384  (setf (hemlock-last-command-type *current-view*) type))
     385
    393386
    394387;;; PREFIX-ARGUMENT  --  Public
     
    396389;;;
    397390(defun prefix-argument ()
    398   "Return the current value of prefix argument.  This can be set with SETF."
    399   *prefix-argument*)
    400 
    401 ;;; %SET-PREFIX-ARGUMENT  --  Internal
    402 ;;;
    403 (defun %set-prefix-argument (argument)
    404   "Set the prefix argument for the next command to Argument."
    405   (unless (or (null argument) (integerp argument))
    406     (error "Prefix argument ~S is neither an integer nor Nil." argument))
    407   (setq *prefix-argument* argument  *prefix-argument-supplied* t))
    408 
    409 
    410 ;;;; The Command Loop:
    411 
    412 ;;; Buffers we use to read and translate keys.
    413 ;;;
    414 (defvar *current-command* (make-array 10 :fill-pointer 0 :adjustable t))
    415 (defvar *current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
    416 
     391  "Return the current value of prefix argument."
     392  *last-prefix-argument*)
     393
     394;;;
    417395(defvar *invoke-hook* #'(lambda (command p)
    418396                          (funcall (command-function command) p))
     
    422400
    423401
    424 
    425 (defvar *self-insert-command* nil)
    426 
    427 (defun self-insert-command ()
    428   (or *self-insert-command*
    429       (setq *self-insert-command* (getstring "Self Insert" *command-names*))))
    430 
    431    
    432 ;;; %COMMAND-LOOP  --  Internal
    433 ;;;
    434 ;;;    Read commands from the terminal and execute them, forever.
    435 ;;;
    436 (defun %command-loop ()
    437   (let  ((cmd *current-command*)
    438          (trans *current-translation*)
    439          (*last-command-type* nil)
    440          (*command-type-set* nil)
    441          (*prefix-argument* nil)
    442          (*prefix-argument-supplied* nil))
    443     (declare (special *last-command-type* *command-type-set*
    444                       *prefix-argument* *prefix-argument-supplied*))
    445     (setf (fill-pointer cmd) 0)
    446     (handler-bind
    447         ;; Bind this outside the invocation loop to save consing.
    448         ((editor-error #'(lambda (condx)
    449                            (beep)
    450                            (let ((string (editor-error-format-string condx)))
    451                              (when string
    452                                (apply #'message string
    453                                       (editor-error-format-arguments condx)))
    454                              (throw 'command-loop-catcher nil)))))
    455       (loop
    456         (let* ((temporary-object-pool (allocate-temporary-object-pool)))
    457           (unwind-protect
    458                (progn
    459                  (unless (eq *current-buffer* *echo-area-buffer*)
    460                    (unless (or (zerop (length cmd))
    461                                (not (value hemlock::key-echo-delay)))
    462                      (editor-sleep (value hemlock::key-echo-delay))
    463                      (unless (listen-editor-input *editor-input*)
    464                        (clear-echo-area)
    465                        (dotimes (i (length cmd))
    466                          (hemlock-ext:print-pretty-key (aref cmd i) *echo-area-stream*)
    467                          (write-char #\space *echo-area-stream*)))))
    468                  (multiple-value-bind (key self-insert)
    469                      (get-key-event *editor-input*)
    470                    (unless (eq *current-buffer* *echo-area-buffer*)
    471                      (when (buffer-modified *echo-area-buffer*)
    472                        (clear-echo-area)))
    473                    (vector-push-extend key cmd)
    474                    (multiple-value-bind (trans-result prefix-p)
    475                        (unless self-insert (translate-key cmd trans))
    476                      (multiple-value-bind (res t-bindings)
    477                          (if self-insert
    478                            (self-insert-command)
    479                            (get-current-binding trans-result))
    480                        (etypecase res
    481                          (command
    482                           (let ((punt t))
    483                             (catch 'command-loop-catcher
    484                               (let* ((buffer *current-buffer*)
    485                                      (*command-key-event-buffer* buffer)
    486                                      (doc (buffer-document buffer)))
    487                                 (unwind-protect
    488                                      (progn
    489                                        (when doc
    490                                          (hi::document-begin-editing doc))
    491                                        (dolist (c t-bindings)
    492                                          (funcall *invoke-hook* c *prefix-argument*))
    493                                        (funcall *invoke-hook* res *prefix-argument*)
    494                                        (setf punt nil))
    495                                   (when doc
    496                                     (hi::document-end-editing doc)))))
    497                             (when punt (invoke-hook hemlock::command-abort-hook)))
    498                           (if *command-type-set*
    499                             (setq *command-type-set* nil)
    500                             (setq *last-command-type* nil))
    501                           (if *prefix-argument-supplied*
    502                             (setq *prefix-argument-supplied* nil)
    503                             (setq *prefix-argument* nil))
    504                           (setf (fill-pointer cmd) 0))
    505                          (null
    506                           (unless prefix-p
    507                             (beep)
    508                             (setq *prefix-argument* nil)
    509                             (setf (fill-pointer cmd) 0)))
    510                          (hash-table)))))
    511                  (free-temporary-objects temporary-object-pool))))))))
    512 
    513 
    514 
    515 
    516    
    517 
    518 
    519 
    520 ;;; EXIT-HEMLOCK  --  Public
    521 ;;;
    522 
     402(defun get-self-insert-command ()
     403  ;; Get the command used to implement normal character insertion in current buffer.
     404  (getstring (value hemlock::self-insert-command-name) *command-names*))
     405
     406(defun get-default-command ()
     407  ;; Get the command used when no binding is present in current buffer.
     408  (getstring (value hemlock::default-command-name) *command-names*))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp

    r7322 r7833  
    128128
    129129(defun %buffer-push-buffer-mark (b mark activate-region)
    130   (cond ((eq (line-buffer (mark-line mark)) b)
     130  (cond ((eq (mark-buffer mark) b)
    131131         (setf (mark-kind mark) :right-inserting)
    132132         (let* ((old-mark (hi::buffer-%mark b)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp

    r7698 r7833  
    554554   ignored."
    555555  (declare (ignore p))
    556   (clear-echo-area)
    557   (write-string "Evaluating buffer in the editor ..." *echo-area-stream*)
    558   (finish-output *echo-area-stream*)
     556  (message "Evaluating buffer in the editor ...")
    559557  (with-input-from-region (stream (buffer-region (current-buffer)))
    560558    (let ((*standard-output* *echo-area-stream*))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

    r7698 r7833  
    7171         ,@unsets))))
    7272
    73 
     73;; WITH-BUFFER-BINDINGS
     74;;
     75;; Execute body with buffer's bindings in effect.  Also binds *current-buffer*,
     76;; (unless buffer _is_ *current-buffer*) because anything that looks at bindings
     77;; probably looks at *current-buffer* as well.
     78
     79(defmacro with-buffer-bindings ((buffer) &body body)
     80  (let ((buffer-var (gensym)))
     81    `(let ((,buffer-var ,buffer)
     82           ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var))))
     83       (unwind-protect
     84           (progn
     85             (setup-buffer-bindings ,buffer-var)
     86             ,@body)
     87         (revert-buffer-bindings ,buffer-var)))))
     88
     89
     90;; MODIFYING-BUFFER-STORAGE
     91;;
     92;; This is kinda Cocoa-specific, but we'll pretend it's not. It gets wrapped around
     93;; possible multiple modifications of the buffer's text, so that the OS can defer
     94;; layout and redisplay until the end.
     95;; Buffer can be NIL to temporarily turn off the grouping.
     96
     97(defmacro modifying-buffer-storage ((buffer) &body body)
     98  (if (eq buffer '*current-buffer*)
     99    `(gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))
     100    `(let ((*current-buffer* ,buffer))
     101       (gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)))))
    74102
    75103
     
    186214  (when (atom lambda-list)
    187215    (error "Command argument list is not a list: ~S." lambda-list))
    188   (let (command-name function-name)
     216  (let (command-name function-name extra-args)
    189217    (cond ((listp name)
    190            (setq command-name (car name)  function-name (cadr name))
     218           (setq command-name (car name) function-name (cadr name))
    191219           (unless (symbolp function-name)
    192              (error "Function name is not a symbol: ~S" function-name)))
     220             (error "Function name is not a symbol: ~S" function-name))
     221           (if (keywordp function-name)
     222             (setq function-name nil extra-args (cdr name))
     223             (setq extra-args (cddr name))))
    193224          (t
    194            (setq command-name name
    195                  function-name (bash-string-to-symbol name '-command))))
     225           (setq command-name name)))
     226    (when (null function-name)
     227      (setq function-name (bash-string-to-symbol command-name '-command)))
    196228    (unless (stringp command-name)
    197229      (error "Command name is not a string: ~S." name))
     
    199231       (defun ,function-name ,lambda-list ,function-doc
    200232              ,@forms)
    201        (make-command ',name ,command-doc ',function-name)
     233       (make-command ,command-name ,command-doc ',function-name ,@extra-args)
    202234       ',function-name)))
    203235
     
    319351
    320352
    321 (defmacro use-buffer (buffer &body forms)
    322   "Use-Buffer Buffer {Form}*
    323   Has The effect of making Buffer the current buffer during the evaluation
    324   of the Forms.  For restrictions see the manual."
    325   (let ((gensym (gensym)))
    326     `(let ((,gensym *current-buffer*)
    327            (*current-buffer* ,buffer))
    328       (unwind-protect
    329            (progn
    330              (use-buffer-set-up ,gensym)
    331              ,@forms)
    332         (use-buffer-clean-up ,gensym)))))
    333 
    334 
    335 
    336 
    337 
    338353;;;; EDITOR-ERROR.
    339 
    340 (defun print-editor-error (condx s)
    341     (apply #'format s (editor-error-format-string condx)
    342             (editor-error-format-arguments condx)))
    343 
    344 (define-condition editor-error (error)
    345   ((format-string :initform "" :initarg :format-string
    346                   :reader editor-error-format-string)
    347    (format-arguments :initform '() :initarg :format-arguments
    348                      :reader editor-error-format-arguments))
    349   (:report print-editor-error))
    350 ;;;
    351 (setf (documentation 'editor-error-format-string 'function)
    352       "Returns the FORMAT control string of the given editor-error condition.")
    353 (setf (documentation 'editor-error-format-arguments 'function)
    354       "Returns the FORMAT arguments for the given editor-error condition.")
    355354
    356355(defun editor-error (&rest args)
    357356  "This function is called to signal minor errors within Hemlock;
    358357   these are errors that a normal user could encounter in the course of editing
    359    such as a search failing or an attempt to delete past the end of the buffer.
    360    This function SIGNAL's an editor-error condition formed from args.  Hemlock
    361    invokes commands in a dynamic context with an editor-error condition handler
    362    bound.  This default handler beeps or flashes (or both) the display.  If
    363    args were supplied, it also invokes MESSAGE on them.  The command in
    364    progress is always aborted, and this function never returns."
    365   (let ((condx (make-condition 'editor-error
    366                                :format-string (car args)
    367                                :format-arguments (cdr args))))
    368     (signal condx)
    369     (error "Unhandled editor-error was signaled -- ~A." condx)))
    370 
    371    
     358   such as a search failing or an attempt to delete past the end of the buffer."
     359  (let ((message (and args (apply #'format nil args))))
     360    (abort-current-command message)))
    372361
    373362
     
    447436                      `(progn
    448437                         (setf ,',bind
    449                                (prompt-for-key-event* ,',n-prompt ,',n-change))
     438                               (prompt-for-key-event :prompt ,',n-prompt :change-window ,',n-change))
    450439                         (setf ,',bind-char (hemlock-ext:key-event-char ,',bind))
    451440                         (go ,',again))))
     
    453442             (let* ((,n-prompt ,prompt)
    454443                    (,n-change ,change-window)
    455                     (,bind (prompt-for-key-event* ,n-prompt ,n-change))
     444                    (,bind (prompt-for-key-event :prompt ,n-prompt :change-window ,n-change))
    456445                    (,bind-char (hemlock-ext:key-event-char ,bind)))
    457446               (declare (ignorable ,n-prompt ,n-change ,bind ,bind-char))
     
    577566
    578567
    579 
    580 
    581568;;;; Error handling stuff.
    582 
    583 (declaim (special *echo-area-stream*))
    584 
    585 ;;; LISP-ERROR-ERROR-HANDLER is in Macros.Lisp instead of Rompsite.Lisp because
    586 ;;; it uses WITH-POP-UP-DISPLAY, and Macros is compiled after Rompsite.  It
    587 ;;; binds an error condition handler to get us out of here on a recursive error
    588 ;;; (we are already handling one if we are here).  Since COMMAND-CASE uses
    589 ;;; EDITOR-ERROR for logical :abort characters, and this is a subtype of ERROR,
    590 ;;; we bind an editor-error condition handler just inside of the error handler.
    591 ;;; This keeps us from being thrown out into the debugger with supposedly
    592 ;;; recursive errors occuring.  What we really want in this case is to simply
    593 ;;; get back to the command loop and forget about the error we are currently
    594 ;;; handling.
    595 ;;;
    596 
    597 (defun lisp-error-error-handler (condition &optional internalp)
    598   (declare (ignore internalp))
    599   (report-hemlock-error condition)
    600   (throw 'editor-top-level-catcher nil))
    601569
    602570(defmacro handle-lisp-errors (&body body)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp

    r7607 r7833  
    135135  (defhvar "Delete Buffer Hook"
    136136    "This hook is called with the buffer whenever a buffer is deleted.")
    137   (defhvar "Enter Recursive Edit Hook"
    138     "This hook is called with the new buffer when a recursive edit is
    139      entered.")
    140   (defhvar "Exit Recursive Edit Hook"
    141     "This hook is called with the value returned when a recursive edit
    142      is exited.")
    143   (defhvar "Abort Recursive Edit Hook"
    144     "This hook is called with the editor-error args when a recursive
    145      edit is aborted.")
    146137  (defhvar "Buffer Major Mode Hook"
    147138    "This hook is called with the buffer and the new mode when a buffer's
     
    166157  (defhvar "Buffer Package Hook"
    167158      "This hook is called with the new package name whenever a (Lisp) buffer's package changes")
    168   (defhvar "Set Buffer Hook"
    169     "This hook is called with the new buffer when the current buffer is set.")
    170   (defhvar "After Set Buffer Hook"
    171     "This hook is invoked with the old buffer after the current buffer has
    172      been changed.")
    173159  (defhvar "Set Window Hook"
    174160    "This hook is called with the new window when the current window
     
    236222     the pathname fits.  \"...\" indicates a truncated pathname."
    237223    :value nil
    238     :hooks (list 'maximum-modeline-pathname-length-hook)))
     224    :hooks (list 'maximum-modeline-pathname-length-hook))
     225  (defhvar "Self Insert Command Name"
     226    "The name of the command to invoke to handle quoted input (i.e. after c-q).
     227     By default, this is \"Self Insert\"."
     228    :value "Self Insert")
     229  (defhvar "Default Command Name"
     230    "The name of the command to invoke to handle keys that have no binding
     231     defined.  By default, this is \"Illegal\"."
     232    :value "Illegal")
     233  )
    239234
    240235
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp

    r6790 r7833  
    108108               (let* ((line-termination-string
    109109                       (case (buffer-line-termination buffer)
    110                          ((:unix nil))
    111                          (:macos "CR")
    112                          (:cp/m "CRLF")))
    113                       (doc (buffer-document buffer))
    114                       (encoding-name (if doc
    115                                        (document-encoding-name doc)
    116                                        "Default")))
     110                         ((:lf nil))
     111                         ((:cr) "CR")
     112                         ((:crlf) "CRLF")))
     113                      (encoding-name (or (buffer-encoding-name buffer)
     114                                         "Default")))
    117115                 (format nil "[~a~@[ ~a~]] "
    118116                         encoding-name line-termination-string))))
     
    253251  ;; it only wants to do so if the buffer's modified state changes.
    254252;  (add-hook hemlock::buffer-modified-hook 'queue-buffer-change)
    255   (add-hook hemlock::window-buffer-hook 'queue-window-change)
    256253)
    257254
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp

    r7595 r7833  
    3939  (declare (ignore p)))
    4040
     41
     42(defcommand "Abort Command" (p)
     43  "Abort reading a command in current view"
     44  "Aborts c-q, multi-key commands (e.g. c-x), prefix translation (e.g.
     45ESC as Meta-), prefix arguments (e.g. c-u), ephemeral modes such as
     46i-search, and prompted input (e.g. m-x)"
     47  (declare (ignore p))
     48  (abort-to-toplevel))
    4149
    4250;;;; Casing commands...
     
    175183(defun prompt-for-place (prompt help)
    176184  (multiple-value-bind (word val)
    177                        (prompt-for-keyword *scope-table* :prompt prompt
     185                       (prompt-for-keyword :tables *scope-table*
     186                                           :prompt prompt
    178187                                           :help help :default "Global")
    179188    (declare (ignore word))
     
    184193      (:mode
    185194       (values :mode (prompt-for-keyword
    186                       (list *mode-names*)
     195                      :tables (list *mode-names*)
    187196                      :prompt "Mode: "
    188197                      :help "Mode to be local to."
     
    197206  (multiple-value-call #'bind-key
    198207    (values (prompt-for-keyword
    199              (list *command-names*)
     208             :tables (list *command-names*)
    200209             :prompt "Command to bind: "
    201210             :help "Name of command to bind to a key."))
     
    259268          (defhvar name doc :value val :hooks hooks)
    260269          (defhvar name doc kind where :value val :hooks hooks)))))
    261 
    262 
    263 
    264 
    265 
    266 ;;; This is used by the :edit-level modeline field which is defined in Main.Lisp.
    267 ;;;
    268 (defvar *recursive-edit-count* 0)
    269 
    270 (defun do-recursive-edit ()
    271   "Does a recursive edit, wrapping []'s around the modeline of the current
    272   window during its execution.  The current window and buffer are saved
    273   beforehand and restored afterward.  If they have been deleted by the
    274   time the edit is done then an editor-error is signalled."
    275   (let* ((win (current-window))
    276          (buf (current-buffer)))
    277     (unwind-protect
    278         (let ((*recursive-edit-count* (1+ *recursive-edit-count*)))
    279           (update-modeline-field *echo-area-buffer* *echo-area-window*
    280                                  (modeline-field :edit-level))
    281           (recursive-edit))
    282       (update-modeline-field *echo-area-buffer* *echo-area-window*
    283                              (modeline-field :edit-level))
    284       (unless (and (member win *window-list*) (memq buf *buffer-list*))
    285         (editor-error "Old window or buffer has been deleted."))
    286       (setf (current-window) win)
    287       (unless (eq (window-buffer win) buf)
    288         (setf (window-buffer win) buf))
    289       (setf (current-buffer) buf))))
    290 
    291 (defcommand "Exit Recursive Edit" (p)
    292   "Exit a level of recursive edit.  Signals an error when not in a
    293    recursive edit."
    294   "Exit a level of recursive edit.  Signals an error when not in a
    295    recursive edit."
    296   (declare (ignore p))
    297   (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
    298   (exit-recursive-edit ()))
    299 
    300 (defcommand "Abort Recursive Edit" (p)
    301   "Abort the current recursive edit.  Signals an error when not in a
    302    recursive edit."
    303   "Abort the current recursive edit.  Signals an error when not in a
    304    recursive edit."
    305   (declare (ignore p))
    306   (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
    307   (abort-recursive-edit "Recursive edit aborted."))
    308270
    309271
     
    416378
    417379
    418 
    419 
    420 
    421 
    422 
    423 ;;;; Mouse Commands.
    424 
    425 (defcommand "Do Nothing" (p)
    426   "Do nothing.
    427   With prefix argument, do it that many times."
    428   "Do nothing p times."
    429   (dotimes (i (or p 1)))
    430   (setf (last-command-type) (last-command-type)))
    431 
    432 (defun do-nothing (&rest args)
    433   (declare (ignore args))
    434   nil)
    435 
    436 (defun maybe-change-window (window)
    437   (unless (eq window (current-window))
    438     (when (or (eq window *echo-area-window*)
    439               (eq (current-window) *echo-area-window*)
    440               (member window *random-typeout-buffers*
    441                       :key #'(lambda (cons)
    442                                (hi::random-typeout-stream-window (cdr cons)))))
    443       (supply-generic-pointer-up-function #'do-nothing)
    444       (editor-error "I'm afraid I can't let you do that Dave."))
    445     (setf (current-window) window)
    446     (let ((buffer (window-buffer window)))
    447       (unless (eq (current-buffer) buffer)
    448         (setf (current-buffer) buffer)))))
    449 
    450 (defcommand "Top Line to Here" (p)
    451   "Move the top line to the line the mouse is on.
    452   If in the first two columns then scroll continuously until the button is
    453   released."
    454   "Move the top line to the line the mouse is on."
    455   (declare (ignore p))
    456   (multiple-value-bind (x y window)
    457                        (last-key-event-cursorpos)
    458     (unless y (editor-error))
    459     (cond ((< x 2)
    460            (loop
    461              (when (listen-editor-input hi::*editor-input*) (return))
    462              (scroll-window window -1)
    463              (redisplay)
    464              (editor-finish-output window)))
    465           (t
    466            (scroll-window window (- y))))))
    467 
    468 (defcommand "Here to Top of Window" (p)
    469   "Move the line the mouse is on to the top of the window.
    470   If in the first two columns then scroll continuously until the button is
    471   released."
    472   "Move the line the mouse is on to the top of the window."
    473   (declare (ignore p))
    474   (multiple-value-bind (x y window)
    475                        (last-key-event-cursorpos)
    476     (unless y (editor-error))
    477     (cond ((< x 2)
    478            (loop
    479              (when (listen-editor-input hi::*editor-input*) (return))
    480              (scroll-window window 1)
    481              (redisplay)
    482              (editor-finish-output window)))
    483           (t
    484            (scroll-window window y)))))
    485 
    486 
    487 (defvar *generic-pointer-up-fun* nil
    488   "This is the function for the \"Generic Pointer Up\" command that defines
    489    its action.  Other commands set this in preparation for this command's
    490    invocation.")
    491 ;;;
    492 (defun supply-generic-pointer-up-function (fun)
    493   "This provides the action \"Generic Pointer Up\" command performs."
    494   (check-type fun function)
    495   (setf *generic-pointer-up-fun* fun))
    496 
    497 (defcommand "Generic Pointer Up" (p)
    498   "Other commands determine this command's action by supplying functions that
    499    this command invokes.  The following built-in commands supply the following
    500    generic up actions:
    501       \"Point to Here\"
    502          When the position of the pointer is different than the current
    503          point, the action pushes a buffer mark at point and moves point
    504          to the pointer's position.
    505       \"Bufed Goto and Quit\"
    506          The action is a no-op."
    507   "Invoke whatever is on *generic-pointer-up-fun*."
    508   (declare (ignore p))
    509   (unless *generic-pointer-up-fun*
    510     (editor-error "No commands have supplied a \"Generic Pointer Up\" action."))
    511   (funcall *generic-pointer-up-fun*))
    512 
    513 
    514 (defcommand "Point to Here" (p)
    515   "Move the point to the position of the mouse.
    516    If in the modeline, move to the absolute position in the file indicated by
    517    the position within the modeline, pushing the old position on the mark
    518    stack.  This supplies a function \"Generic Pointer Up\" invokes if it runs
    519    without any intervening generic pointer up predecessors running.  If the
    520    position of the pointer is different than the current point when the user
    521    invokes \"Generic Pointer Up\", then this function pushes a buffer mark at
    522    point and moves point to the pointer's position.  This allows the user to
    523    mark off a region with the mouse."
    524   "Move the point to the position of the mouse."
    525   (declare (ignore p))
    526   (multiple-value-bind (x y window)
    527                        (last-key-event-cursorpos)
    528     (unless x (editor-error))
    529     (maybe-change-window window)
    530     (if y
    531         (let ((m (cursorpos-to-mark x y window)))
    532           (unless m (editor-error))
    533           (move-mark (current-point) m))
    534         (let* ((buffer (window-buffer window))
    535                (region (buffer-region buffer))
    536                (point (buffer-point buffer)))
    537           (push-buffer-mark (copy-mark point))
    538           (move-mark point (region-start region))
    539           (line-offset point (round (* (1- (count-lines region)) x)
    540                                     (1- (window-width window)))))))
    541   (supply-generic-pointer-up-function #'point-to-here-up-action))
    542 
    543 (defun point-to-here-up-action ()
    544   (multiple-value-bind (x y window)
    545                        (last-key-event-cursorpos)
    546     (unless x (editor-error))
    547     (when y
    548       (maybe-change-window window)
    549       (let ((m (cursorpos-to-mark x y window)))
    550         (unless m (editor-error))
    551         (when (eq (line-buffer (mark-line (current-point)))
    552                   (line-buffer (mark-line m)))
    553           (unless (mark= m (current-point))
    554             (push-buffer-mark (copy-mark (current-point)) t)))
    555         (move-mark (current-point) m)))))
    556 
    557 
    558 (defcommand "Insert Kill Buffer" (p)
    559   "Move current point to the mouse location and insert the kill buffer."
    560   "Move current point to the mouse location and insert the kill buffer."
    561   (declare (ignore p))
    562   (multiple-value-bind (x y window)
    563                        (last-key-event-cursorpos)
    564     (unless x (editor-error))
    565     (maybe-change-window window)
    566     (if y
    567         (let ((m (cursorpos-to-mark x y window)))
    568           (unless m (editor-error))
    569           (move-mark (current-point) m)
    570           (un-kill-command nil))
    571         (editor-error "Can't insert kill buffer in modeline."))))
    572 
    573 
    574 
    575 
    576380;;;; Page commands & stuff.
    577381
     
    595399                  (name (prompt-for-string :prompt "Substring of page title: "
    596400                                           :default (if againp
    597                                                         *goto-page-last-string*
    598                                                         *parse-default*)))
     401                                                        *goto-page-last-string*)))
    599402                  (dir (page-directory (current-buffer)))
    600403                  (i 1))
     
    720523   If the last character was an alphabetic character, then insert its
    721524   capital form."
    722   (let ((char (char-upcase (hemlock-ext:key-event-char *last-key-event-typed*))))
     525  (let ((char (char-upcase (last-char-typed))))
    723526    (if (and p (> p 1))
    724527        (insert-string (current-point) (make-string p :initial-element char))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

    r7595 r7833  
    3030   #:mark-charpos
    3131   #:mark-kind
     32   #:mark-buffer
    3233   #:previous-character
    3334   #:next-character
     
    6970   #:push-buffer-mark
    7071   #:change-to-buffer
    71    #:previous-buffer
    7272   #:make-buffer
    7373   #:bufferp
     
    8989   #:buffer-package
    9090   #:delete-buffer
    91    #:delete-buffer-if-possible
    9291   #:make-modeline-field
    9392   #:modeline-field-p
     
    185184   #:reverse-find-not-attribute
    186185   #:character-attribute-hooks
    187    #:current-window
    188186   #:make-window
    189187   #:windowp
    190188   #:delete-window
    191    #:window-buffer
    192189   #:window-display-start
    193190   #:window-display-end
     
    238235   #:find-file-buffer
    239236   ;;   #:ed
    240    #:exit-hemlock
    241237   #:pause-hemlock
    242    #:get-key-event
    243    #:unget-key-event
    244    #:recursive-get-key-event
    245238   #:clear-editor-input
    246239   #:listen-editor-input
     
    330323  (:import-from :ext #:complete-file)
    331324  (:shadow #:char-code-limit)
     325  #+clozure
     326  (:import-from :ccl #:memq #:assq #:delq)
    332327  ;;
    333328  (:export
     
    390385   #+sbcl  :sb-gray
    391386   #+scl   :ext
    392    #+openmcl :gray
     387   #+clozure :gray
    393388   ;;
    394389   ;; Note the pacth i received from DTC mentions character-output and
     
    417412   
    418413   ;; rompsite.lisp
    419    #:show-mark #:editor-sleep #:*input-transcript* #:fun-defined-from-pathname
     414   #:show-mark #:editor-sleep #:fun-defined-from-pathname
    420415   #:editor-describe-function #:pause-hemlock #:store-cut-string
    421416   #:fetch-cut-string #:schedule-event #:remove-scheduled-event
     
    438433
    439434   ;; from input.lisp
    440    #:get-key-event #:unget-key-event #:clear-editor-input #:listen-editor-input
    441    #:*last-key-event-typed* #:*key-event-history*
     435   #:clear-editor-input #:listen-editor-input
     436   #:last-key-event-typed #:*key-event-history*
    442437   #:input-waiting #:last-key-event-cursorpos
    443438
     
    448443   #:command-case #:reprompt #:with-output-to-mark #:with-input-from-region
    449444   #:handle-lisp-errors #:with-pop-up-display #:*random-typeout-buffers*
     445
     446   ;; from views.lisp
     447   #:hemlock-view #:current-prefix-argument-state
     448   #:abort-to-toplevel #:abort-current-command
    450449
    451450   ;; from line.lisp
     
    489488
    490489   ;; echo.lisp
    491    #:*echo-area-buffer* #:*echo-area-stream* #:*echo-area-window*
    492    #:*parse-starting-mark* #:*parse-input-region*
    493    #:*parse-verification-function* #:*parse-string-tables*
    494    #:*parse-value-must-exist* #:*parse-default* #:*parse-default-string*
    495    #:*parse-prompt* #:*parse-help* #:clear-echo-area #:message #:loud-message
     490   #:*echo-area-stream*
     491   #:clear-echo-area #:message #:loud-message
     492   #:current-echo-parse-state #:exit-echo-parse
     493   #:eps-parse-type #:eps-parse-starting-mark #:eps-parse-input-region
     494   #:eps-parse-verification-function #:eps-parse-string-tables
     495   #:eps-parse-default #:eps-parse-help
    496496   #:prompt-for-buffer #:prompt-for-file #:prompt-for-integer
    497497   #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string
    498498   #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n
    499    #:prompt-for-key-event #:prompt-for-key #:*logical-key-event-names*
     499   #:prompt-for-key-event #:prompt-for-key #:prompt-for-command-key
     500   #:*logical-key-event-names*
    500501   #:logical-key-event-p #:logical-key-event-documentation
    501502   #:logical-key-event-name #:logical-key-event-key-events
    502    #:define-logical-key-event #:*parse-type* #:current-variable-tables
    503 
     503   #:define-logical-key-event #:current-variable-tables
     504
     505
     506   ;; commands
     507   #:make-prefix-argument-state #:prefix-argument-resetting-state
     508
     509 
    504510   ;; files.lisp
    505511   #:read-file #:write-file
     
    540546   #:bind-key #:delete-key-binding #:get-command #:map-bindings
    541547   #:make-command #:command-name #:command-bindings #:last-command-type
    542    #:prefix-argument #:exit-hemlock #:*invoke-hook* #:key-translation
     548   #:prefix-argument #:*invoke-hook* #:key-translation
    543549
    544550
     
    546552   #:*global-variable-names* #:*mode-names* #:*buffer-names*
    547553   #:*character-attribute-names* #:*command-names* #:*buffer-list*
    548    #:*window-list* #:*last-key-event-typed* #:after-editor-initializations
     554   #:*window-list* #:last-key-event-typed #:after-editor-initializations
    549555
    550556   ;; screen.lisp
     
    575581
    576582   ;; window.lisp
    577    #:current-window #:window-buffer #:modeline-field-width
     583   #:modeline-field-width
    578584   #:modeline-field-function #:make-modeline-field #:update-modeline-fields
    579585   #:update-modeline-field #:modeline-field-name #:modeline-field
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp

    r6 r7833  
    7575  (do-registers (name value)
    7676    (etypecase value
    77       (mark (when (eq (line-buffer (mark-line value)) buffer)
     77      (mark (when (eq (mark-buffer value) buffer)
    7878              (free-register name)))
    7979      (cons (free-register-value value buffer)))))
     
    9090  (etypecase value
    9191    (mark
    92      (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer))
     92     (when (or (not buffer) (eq (mark-buffer value) buffer))
    9393       (delete-mark value)))
    9494    (cons
     
    121121    (unless (markp val)
    122122      (editor-error "Register ~A does not hold a location." reg-name))
    123     (change-to-buffer (line-buffer (mark-line val)))
     123    (change-to-buffer (mark-buffer val))
    124124    (move-mark (current-point) val)))
    125125
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

    r7595 r7833  
    8787             (editor-error)))
    8888    (clear-echo-area)))
    89 
    90 
    91 
    92 
    93 ;;;; Incremental searching.
    94 
    95 (defun i-search-pattern (string direction)
    96   (setq *last-search-pattern*
    97         (new-search-pattern (if (value string-search-ignore-case)
    98                                 :string-insensitive
    99                                 :string-sensitive)
    100                             direction string *last-search-pattern*)))
    101 
    102 ;;;      %I-SEARCH-ECHO-REFRESH refreshes the echo buffer for incremental
    103 ;;; search.
    104 ;;;
    105 (defun %i-search-echo-refresh (string direction failure)
    106   (when (interactive)
    107     (clear-echo-area)
    108     (format *echo-area-stream*
    109             "~:[~;Failing ~]~:[~;Overwrapped ~]~:[Reverse I-Search~;I-Search~]: ~A"
    110             failure *search-wrapped-p* (eq direction :forward) string)))
    111 
    112 (defcommand "Incremental Search" (p)
    113   "Searches for input string as characters are provided.
    114   These are the default I-Search command characters:  ^Q quotes the
    115   next character typed.  Backspace cancels the last character typed.  ^S
    116   repeats forward, and ^R repeats backward.  ^R or ^S with empty string
    117   either changes the direction or yanks the previous search string.
    118   Escape exits the search unless the string is empty.  Escape with
    119   an empty search string calls the non-incremental search command. 
    120   Other control characters cause exit and execution of the appropriate
    121   command.  If the search fails at some point, ^G and backspace may be
    122   used to backup to a non-failing point; also, ^S and ^R may be used to
    123   look the other way.  ^W extends the search string to include the the word
    124   after the point. ^G during a successful search aborts and returns
    125   point to where it started."
    126   "Search for input string as characters are typed in.
    127   It sets up for the recursive searching and checks return values."
    128   (declare (ignore p))
    129   (setf (last-command-type) nil)
    130   (%i-search-echo-refresh "" :forward nil)
    131   (let* ((*search-wrapped-p* nil)
    132          (point (current-point))
    133          (save-start (copy-mark point :temporary)))
    134     (with-mark ((here point))
    135       (when (eq (catch 'exit-i-search
    136                   (%i-search "" point here :forward nil))
    137                 :control-g)
    138         (move-mark point save-start)
    139         (invoke-hook abort-hook)
    140         (editor-error))
    141       (if (region-active-p)
    142           (delete-mark save-start)
    143           (push-buffer-mark save-start)))))
    144 
    145 
    146 (defcommand "Reverse Incremental Search" (p)
    147   "Searches for input string as characters are provided.
    148   These are the default I-Search command characters:  ^Q quotes the
    149   next character typed.  Backspace cancels the last character typed.  ^S
    150   repeats forward, and ^R repeats backward.  ^R or ^S with empty string
    151   either changes the direction or yanks the previous search string.
    152   Altmode exits the search unless the string is empty.  Altmode with
    153   an empty search string calls the non-incremental search command. 
    154   Other control characters cause exit and execution of the appropriate
    155   command.  If the search fails at some point, ^G and backspace may be
    156   used to backup to a non-failing point; also, ^S and ^R may be used to
    157   look the other way.  ^G during a successful search aborts and returns
    158   point to where it started."
    159   "Search for input string as characters are typed in.
    160   It sets up for the recursive searching and checks return values."
    161   (declare (ignore p))
    162   (setf (last-command-type) nil)
    163   (%i-search-echo-refresh "" :backward nil)
    164   (let* ((*search-wrapped-p* nil)
    165          (point (current-point))
    166          (save-start (copy-mark point :temporary)))
    167     (with-mark ((here point))
    168       (when (eq (catch 'exit-i-search
    169                   (%i-search "" point here :backward nil))
    170                 :control-g)
    171         (move-mark point save-start)
    172         (invoke-hook abort-hook)
    173         (editor-error))
    174       (if (region-active-p)
    175           (delete-mark save-start)
    176           (push-buffer-mark save-start)))))
    177 
    178 ;;;      %I-SEARCH recursively (with support functions) searches to provide
    179 ;;; incremental searching.  There is a loop in case the recursion is ever
    180 ;;; unwound to some call.  curr-point must be saved since point is clobbered
    181 ;;; with each recursive call, and the point must be moved back before a
    182 ;;; different letter may be typed at a given call.  In the CASE at :cancel
    183 ;;; and :control-g, if the string is not null, an accurate pattern for this
    184 ;;; call must be provided when %I-SEARCH-CHAR-EVAL is called a second time
    185 ;;; since it is possible for ^S or ^R to be typed.
    186 ;;;
    187 (defun %i-search (string point trailer direction failure)
    188   (do* ((curr-point (copy-mark point :temporary))
    189         (curr-trailer (copy-mark trailer :temporary)))
    190        (nil)
    191     (let* ((next-key-event (recursive-get-key-event hi::*editor-input* t))
    192            (val (%i-search-char-eval next-key-event string point trailer
    193                                  direction failure))
    194            (empty-string-p (zerop (length string))))
    195       (case val
    196         (:mouse-exit
    197          (clear-echo-area)
    198          (throw 'exit-i-search nil))
    199         (:cancel
    200          (%i-search-echo-refresh string direction failure)
    201          (unless empty-string-p
    202            (i-search-pattern string direction))) ;sets *last-search-pattern*
    203         (:return-cancel ;backspace was typed
    204          (if empty-string-p
    205              (beep)
    206              (return :cancel)))
    207         (:control-g
    208          (when failure (return :control-g))
    209          (%i-search-echo-refresh string direction nil)
    210          (unless empty-string-p
    211            (i-search-pattern string direction)))) ;*last-search-pattern*
    212       (move-mark point curr-point)
    213       (move-mark trailer curr-trailer))))
    214 
    215 ;;;      %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes
    216 ;;; necessary actions.
    217 ;;;
    218 (defun %i-search-char-eval (key-event string point trailer direction failure)
    219   (declare (simple-string string))
    220   (cond ((let ((character (key-event-char key-event)))
    221            (and character (standard-char-p character)))
    222          (%i-search-printed-char key-event string point trailer
    223                                  direction failure))
    224         ((or (logical-key-event-p key-event :forward-search)
    225              (logical-key-event-p key-event :backward-search))
    226          (%i-search-control-s-or-r key-event string point trailer
    227                                    direction failure))
    228         ((logical-key-event-p key-event :cancel) :return-cancel)
    229         ((logical-key-event-p key-event :extend-search-word)
    230          (with-mark ((end point))
    231            (word-offset end 1)
    232            (let ((extension (region-to-string (region point end))))
    233              (%i-search-extend-string string extension point trailer direction failure))))           
    234         ((logical-key-event-p key-event :abort)
    235          (unless failure
    236            (clear-echo-area)
    237            (message "Search aborted.")
    238            (throw 'exit-i-search :control-g))
    239          :control-g)
    240         ((logical-key-event-p key-event :quote)
    241          (%i-search-printed-char (get-key-event hi::*editor-input* t)
    242                                  string point trailer direction failure))
    243         ((and (zerop (length string)) (logical-key-event-p key-event :exit))
    244          (if (eq direction :forward)
    245              (forward-search-command nil)
    246              (reverse-search-command nil))
    247          (throw 'exit-i-search nil))
    248         (t
    249          (unless (logical-key-event-p key-event :exit)
    250            (unget-key-event key-event hi::*editor-input*))
    251          (unless (zerop (length string))
    252            (setf *last-search-string* string))
    253          (throw 'exit-i-search nil))))
    254 
    255 ;;;      %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search.  Note
    256 ;;; that there cannot be failure in the last COND branch: since the direction
    257 ;;; has just been changed, there cannot be a failure before trying a new
    258 ;;; direction.
    259 ;;;
    260 (defun %i-search-control-s-or-r (key-event string point trailer
    261                                            direction failure)
    262   (let ((forward-direction-p (eq direction :forward))
    263         (forward-character-p (logical-key-event-p key-event :forward-search)))
    264     (cond ((zerop (length string))
    265            (%i-search-empty-string point trailer direction forward-direction-p
    266                                    forward-character-p))
    267           ((eq forward-direction-p forward-character-p) ;keep searching in the same direction
    268            (cond ((eq failure :first-failure)
    269                   (cond (forward-direction-p
    270                          (buffer-start point)
    271                          (buffer-start trailer)
    272                          (character-offset trailer (length string)))
    273                         (t
    274                          (buffer-end point)
    275                          (buffer-end trailer)))
    276                   (push-buffer-mark (copy-mark point))
    277                   (let ((*search-wrapped-p* t))
    278                     (%i-search-echo-refresh string direction nil)
    279                     (%i-search-find-pattern string point trailer direction)))
    280                   (failure
    281                    (%i-search string point trailer direction t))
    282                   (t
    283                    (%i-search-find-pattern string point (move-mark trailer point)
    284                                            direction))))
    285           (t
    286            (let ((new-direction (if forward-character-p :forward :backward)))
    287              (%i-search-echo-refresh string new-direction nil)
    288              (i-search-pattern string new-direction) ;sets *last-search-pattern*
    289              (%i-search-find-pattern string point (move-mark trailer point)
    290                                      new-direction))))))
    291 
    292 
    293 ;;;      %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S
    294 ;;; or ^R is typed.  If the direction and character typed do not agree,
    295 ;;; then merely switch directions.  If there was a previous string, search
    296 ;;; for it, else flash at the guy.
    297 ;;;
    298 (defun %i-search-empty-string (point trailer direction forward-direction-p
    299                                      forward-character-p)
    300   (cond ((eq forward-direction-p (not forward-character-p))
    301          (let ((direction (if forward-character-p :forward :backward)))
    302            (%i-search-echo-refresh "" direction nil)
    303            (%i-search "" point trailer direction nil)))
    304         (*last-search-string*
    305          (%i-search-echo-refresh *last-search-string* direction nil)
    306          (i-search-pattern *last-search-string* direction) ;sets *last-search-pattern*
    307          (%i-search-find-pattern *last-search-string* point trailer direction))
    308         (t (beep))))
    309 
    310 
    311 ;;;      %I-SEARCH-PRINTED-CHAR handles the case of standard character input.
    312 ;;; If the direction is backwards, we have to be careful not to MARK-AFTER
    313 ;;; the end of the buffer or to include the next character at the beginning
    314 ;;; of the search.
    315 ;;;
    316 (defun %i-search-printed-char (key-event string point trailer direction failure)
    317   (let ((tchar (hemlock-ext:key-event-char key-event)))
    318     (unless tchar (editor-error "Not a text character -- ~S" (key-event-char
    319                                                               key-event)))
    320     (when (interactive)
    321       (insert-character (buffer-point *echo-area-buffer*) tchar)
    322       (force-output *echo-area-stream*))
    323     (let ((new-string (concatenate 'simple-string string (string tchar))))
    324       (i-search-pattern new-string direction) ;sets *last-search-pattern*
    325       (cond (failure (%i-search new-string point trailer direction failure))
    326             ((and (eq direction :backward) (next-character trailer))
    327              (%i-search-find-pattern new-string point (mark-after trailer)
    328                                      direction))
    329             (t
    330              (%i-search-find-pattern new-string point trailer direction))))))
    331 
    332 (defun %i-search-extend-string (string extension point trailer direction failure)
    333   (when (interactive)
    334     (insert-string (buffer-point *echo-area-buffer*) extension)
    335     (force-output *echo-area-stream*))
    336   (let ((new-string (concatenate 'simple-string string extension)))
    337     (i-search-pattern new-string direction) ;sets *last-search-pattern*
    338     (cond (failure (%i-search new-string point trailer direction failure))
    339           ((and (eq direction :backward) (next-character trailer))
    340            (%i-search-find-pattern new-string point (mark-after trailer)
    341                                    direction))
    342           (t
    343            (%i-search-find-pattern new-string point trailer direction)))))
    344 
    345 
    346 ;;;      %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction
    347 ;;; and finds it, updating necessary pointers for the next call to %I-SEARCH.
    348 ;;; If the search failed, tell the user and do not move any pointers.
    349 ;;;
    350 (defun %i-search-find-pattern (string point trailer direction)
    351   (let ((found-offset (find-pattern trailer *last-search-pattern*)))
    352     (cond (found-offset
    353             (cond ((eq direction :forward)
    354                    (character-offset (move-mark point trailer) found-offset))
    355                   (t
    356                    (move-mark point trailer)
    357                    (character-offset trailer found-offset)))
    358             (push-buffer-mark (copy-mark trailer) t)
    359             (hi::note-selection-set-by-search)
    360             (%i-search string point trailer direction nil))
    361           (t
    362            (%i-search-echo-refresh string direction t)
    363            (if (interactive)
    364                (beep)
    365                (editor-error "I-Search failed."))
    366            (%i-search string point trailer direction :first-failure)))))
    36789
    36890
     
    545267                                              dumb)
    546268                           (return nil))
    547                  (:recursive-edit
    548                   "Go into a recursive edit at the current position."
    549                   (do-recursive-edit)
    550                   (get-search-pattern target :forward))
    551269                 (:exit "Exit immediately."
    552270                        (return nil))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/streams.lisp

    r6692 r7833  
    7676  stream)
    7777
    78 (defmacro with-left-inserting-mark ((var form) &body forms)
    79   (let ((change (gensym)))
    80     `(let* ((,var ,form)
    81             (,change (eq (mark-kind ,var) :right-inserting)))
    82        (unwind-protect
    83            (progn
    84              (when ,change
    85                (setf (mark-kind ,var) :left-inserting))
    86              ,@forms)
    87          (when ,change
    88            (setf (mark-kind ,var) :right-inserting))))))
    89 
    9078(defun hemlock-output-unbuffered-out (stream character)
    91   (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    92     (let* ((buffer (line-%buffer (mark-line mark))))
    93       (buffer-document-begin-editing buffer)
    94       (unwind-protect
    95            (insert-character mark character)
    96         (buffer-document-end-editing buffer)))))
     79  (let ((mark (hemlock-output-stream-mark stream)))
     80    (modifying-buffer-storage ((mark-buffer mark))
     81      (insert-character mark character)
     82      (unless (eq (mark-kind mark) :left-inserting)
     83        (character-offset mark 1)))))
    9784
    9885(defun hemlock-output-unbuffered-sout (stream string start end)
    99   (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    100     (unless (and (eql start 0)
    101                  (eql end (length string)))
    102       (setq string (subseq string start end)))
    103     (let* ((buffer (line-%buffer (mark-line mark))))
    104       (buffer-document-begin-editing buffer)
    105       (unwind-protect
    106            (insert-string mark string)
    107         (buffer-document-end-editing buffer)))))
     86  (unless (and (eql start 0)
     87               (eql end (length string)))
     88    (setq string (subseq string start end)))
     89  (let ((mark (hemlock-output-stream-mark stream)))
     90    (modifying-buffer-storage ((mark-buffer mark))
     91      (insert-string mark string)
     92      (unless (eq (mark-kind mark) :left-inserting)
     93        (character-offset mark (- end start))))))
    10894
    10995(defun hemlock-output-buffered-out (stream character)
     
    242228  (let ((index (kbdmac-stream-index stream)))
    243229    (setf (kbdmac-stream-index stream) (1+ index))
    244     (setq *last-key-event-typed*
    245           (svref (kbdmac-stream-buffer stream) index))))
     230    (setf (last-key-event-typed) (svref (kbdmac-stream-buffer stream) index))))
    246231
    247232(defun kbdmac-unget (ignore stream)
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp

    r7595 r7833  
    9393  mode-objects                ; list of buffer's mode objects
    9494  bindings                    ; buffer's command table
     95  bindings-wound-p            ; true if all the mode bindings have been wound.
     96  (shadow-syntax nil)         ; buffer's changes to syntax attributes.
    9597  point                       ; current position in buffer
    9698  %mark                       ; a saved buffer position
     
    109111  %modeline-fields            ; List of modeline-field-info's.
    110112  (delete-hook nil)           ; List of functions to call upon deletion.
    111   (line-termination :unix) ; Line-termination, for the time being
     113  (line-termination :lf)      ; Line-termination, for the time being
    112114  process                     ; Maybe a listener
    113115  (gap-context )              ; The value of *buffer-gap-context*
     
    172174  cleanup-function       ; Cleanup function for this mode
    173175  bindings               ; The mode's command table.
     176  default-command        ; If non-nil, default command
    174177  transparent-p          ; Are key-bindings transparent?
    175178  hook-name              ; The name of the mode hook.
     
    318321  keyword
    319322  documentation
    320   vector
     323  (vector #() :type (simple-array * (*)))
    321324  hooks
    322325  end-value)
     
    328331
    329332(defstruct (command (:constructor internal-make-command
    330                                   (%name documentation function))
     333                                  (%name documentation function transparent-p))
    331334                    (:copier nil)
    332335                    (:predicate commandp)
     
    335338  documentation                    ;Command documentation string or function
    336339  function                         ;The function which implements the command
     340  transparent-p                    ;If true, this command is transparent
    337341  %bindings)                       ;Places where command is bound
    338342
     
    384388          (ignore-errors
    385389            (buffer-name
    386              (line-buffer (mark-line (random-typeout-stream-mark object)))))))
     390             (mark-buffer (random-typeout-stream-mark object))))))
    387391
    388392
     
    531535  (format stream "#<Hemlock Window Group>"))
    532536
    533 ;;; Device-hunks are used to claim a piece of the screen and for ordering
    534 ;;; pieces of the screen.  Window motion primitives and splitting/merging
    535 ;;; primitives use hunks.  Hunks are somewhat of an interface between the
    536 ;;; portable and non-portable parts of screen management, between what the
    537 ;;; user sees on the screen and how Hemlock internals deal with window
    538 ;;; sequencing and creation.  Note: the echo area hunk is not hooked into
    539 ;;; the ring of other hunks via the next and previous fields.
    540 ;;;
    541 (defstruct (device-hunk (:print-function %print-device-hunk))
    542   "This structure is used internally by Hemlock's screen management system."
    543   window                ; Window displayed in this hunk.
    544   position              ; Bottom Y position of hunk.
    545   height                ; Height of hunk in pixels or lines.
    546   next                  ; Next and previous hunks.
    547   previous
    548   device)               ; Display device hunk is on.
    549 
    550 (defun %print-device-hunk (object stream depth)
    551   (declare (ignore depth))
    552   (format stream "#<Hemlock Device-Hunk ~D+~D~@[, ~S~]>"
    553           (device-hunk-position object)
    554           (device-hunk-height object)
    555           (let* ((window (device-hunk-window object))
    556                  (buffer (if window (window-buffer window))))
    557             (if buffer (buffer-name buffer)))))
    558 
    559 
    560 ;;; Bitmap hunks.
    561 ;;;
    562 ;;; The lock field is no longer used.  If events could be handled while we
    563 ;;; were in the middle of something with the hunk, then this could be set
    564 ;;; for exclusion purposes.
    565 ;;;
    566 (defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|#
    567                         (:include device-hunk))
    568   width                       ; Pixel width.
    569   char-height                 ; Height of text body in characters.
    570   char-width                  ; Width in characters.
    571   xwindow                     ; X window for this hunk.
    572   gcontext                    ; X gcontext for xwindow.
    573   start                       ; Head of dis-line list (no dummy).
    574   end                         ; Exclusive end, i.e. nil if nil-terminated.
    575   modeline-dis-line           ; Dis-line for modeline, or NIL if none.
    576   modeline-pos                ; Position of modeline in pixels.
    577   (lock t)                    ; Something going on, set trashed if we're changed.
    578   trashed                     ; Something bad happened, recompute image.
    579   font-family                 ; Font-family used in this window.
    580   input-handler               ; Gets hunk, char, x, y when char read.
    581   changed-handler             ; Gets hunk when size changed.
    582   (thumb-bar-p nil)           ; True if we draw a thumb bar in the top border.
    583   window-group)               ; The window-group to which this hunk belongs.
    584 
    585 
    586 ;;; Terminal hunks.
    587 ;;;
    588 (defstruct (tty-hunk #|(:print-function %print-device-hunk)|#
    589                      (:include device-hunk))
    590   text-position         ; Bottom Y position of text in hunk.
    591   text-height)          ; Number of lines of text.
    592 
    593 
    594 
    595537
    596538;;;; Some defsetfs:
     
    647589(defsetf ring-ref %set-ring-ref "Set an element in a ring.")
    648590(defsetf current-window %set-current-window "Set the current window.")
    649 (defsetf current-buffer %set-current-buffer
    650   "Set the current buffer, doing necessary stuff.")
    651591(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.")
    652592(defsetf buffer-region %set-buffer-region "Set a buffer's region.")
     
    657597(defsetf last-command-type %set-last-command-type
    658598  "Set the Last-Command-Type for use by the next command.")
    659 (defsetf prefix-argument %set-prefix-argument
    660   "Set the prefix argument for the next command.")
     599(defsetf last-key-event-typed %set-last-key-event-typed
     600  "Set the last key event typed")
    661601(defsetf logical-key-event-p %set-logical-key-event-p
    662602  "Change what Logical-Char= returns for the specified arguments.")
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp

    r7595 r7833  
    3434  attribute-vector/mask pairs for find-attribute and reverse-find-attribute.")
    3535
    36 (eval-when (:compile-toplevel :execute :load-toplevel)
    3736(defconstant character-attribute-cache-size 13
    3837  "The number of buckets in the *character-attribute-cache*.")
     
    4039  "The number of bits to use in each bucket of the
    4140  *character-attribute-cache*.")
    42 ); eval-when (:compile-toplevel :execute :load-toplevel)
    43 
    44 ;;;    In addition, since a common pattern in code which uses find-attribute
    45 ;;; is to repeatedly call it with the same function and attribute, we
    46 ;;; remember the last attribute/test-function pair that was used, and check
    47 ;;; if it is the same pair beforehand, thus often avoiding the hastable lookup.
    48 ;;;
    49 (defvar *last-find-attribute-attribute* ()
    50   "The attribute which we last did a find-attribute on.")
    51 (defvar *last-find-attribute-function* ()
    52   "The last test-function used for find-attribute.")
    53 (defvar *last-find-attribute-vector* ()
    54   "The %SP-Find-Character-With-Attribute vector corresponding to the last
    55   attribute/function pair used for find-attribute.")
    56 (defvar *last-find-attribute-mask* ()
    57   "The the mask to use with *last-find-attribute-vector* to do a search
    58   for the last attribute/test-function pair.")
    59 (defvar *last-find-attribute-end-wins* ()
    60   "The the value of End-Wins for the last attribute/test-function pair.")
    61 
     41
     42
     43(defconstant character-attribute-cache-size 13
     44  "The number of buckets in the character-attribute-cache.")
     45(defconstant character-attribute-bucket-size 3
     46  "The number of bits to use in each bucket of the character-attribute-cache.")
     47
     48(defstruct (shadow-syntax (:conc-name "SS-"))
     49  ;;;    In addition, since a common pattern in code which uses find-attribute
     50  ;;; is to repeatedly call it with the same function and attribute, we
     51  ;;; remember the last attribute/test-function pair that was used, and check
     52  ;;; if it is the same pair beforehand, thus often avoiding the hastable lookup.
     53  ;; TODO: another common pattern is to use the same attribute but
     54  ;;       different functions (toggling between zerop and not-zerop), so
     55  ;;       should use a scheme that handles that - this doesn't.
     56  ;; The attribute which we last did a find-attribute on
     57  (last-find-attribute-attribute ())
     58  ;; The last test-function used for find-attribute.
     59  (last-find-attribute-function ())
     60  ;; The %SP-Find-Character-With-Attribute vector corresponding to the last
     61  ;; attribute/function pair used for find-attribute.
     62  (last-find-attribute-vector ())
     63  ;; The the mask to use with *last-find-attribute-vector* to do a search
     64  ;; for the last attribute/test-function pair.
     65  (last-find-attribute-mask ())
     66  ;; The the value of End-Wins for the last attribute/test-function pair.
     67  (last-find-attribute-end-wins ())
     68
     69  ;; The last character attribute which was asked for
     70  (last-character-attribute-requested nil)
     71  ;; The value of the most recent character attribute
     72  (value-of-last-character-attribute-requested #() :type (simple-array * (*)))
     73
     74  ;; list of shadowed bits.
     75  (shadow-bit-descriptors ())
     76  ;; List of shadowed attribute vectors
     77  (shadow-attributes ())
     78  ;; Syntax tick count at the time shadow info was computed.
     79  (global-syntax-tick -1))
     80
     81(defvar *global-syntax-tick* 0 "Tick count noting changes in global syntax settings")
     82
     83(declaim (special *current-buffer*))
     84
     85
     86(declaim (inline current-buffer-shadow-syntax))
     87(defun current-buffer-shadow-syntax ()
     88  (let ((buffer *current-buffer*))
     89    (when buffer
     90      (let ((ss (buffer-shadow-syntax buffer)))
     91        (if (and ss (eql (ss-global-syntax-tick ss) *global-syntax-tick*))
     92          ss
     93          (progn
     94            (%init-shadow-attributes buffer)
     95            (buffer-shadow-syntax buffer)))))))
    6296
    6397(defvar *character-attributes* (make-hash-table :test #'eq)
    6498  "A hash table which translates character attributes to their values.")
    65 (defvar *last-character-attribute-requested* nil
    66   "The last character attribute which was asked for, Do Not Bind.")
    67 (defvar *value-of-last-character-attribute-requested* nil
    68   "The value of the most recent character attribute, Do Not Bind.")
    6999
    70100(declaim (special *character-attribute-names*))
     
    91121
    92122
    93 (eval-when (:compile-toplevel :execute)
     123
    94124(defmacro allocate-bit (vec bit-num)
    95125  `(progn
     
    99129                :vector ,vec
    100130                :mask (ash 1 (prog1 ,bit-num (incf ,bit-num))))
    101                *all-bit-descriptors*)))))
     131               *all-bit-descriptors*))))
    102132;;;   
    103133(defun %init-syntax-table ()
     
    113143
    114144
    115 (eval-when (:compile-toplevel :execute)
    116145#+NIL
    117146(defmacro hash-it (attribute function)
     
    133162;;;
    134163(defmacro cached-attribute-lookup (attribute function vector mask end-wins)
    135   `(if (and (eq ,function *last-find-attribute-function*)
    136             (eq ,attribute *last-find-attribute-attribute*))
    137        (setq ,vector *last-find-attribute-vector*
    138              ,mask *last-find-attribute-mask*
    139              ,end-wins *last-find-attribute-end-wins*)
    140        (let ((bit (svref *character-attribute-cache*
    141                          (hash-it ,attribute ,function))))
    142          ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins)
    143                        (new-cache-attribute ,attribute ,function))
    144                     `(let ((b (car bit)))
    145                        (cond
    146                         ((and (eq (bit-descriptor-function b)
    147                                   ,function)
    148                               (eq (bit-descriptor-attribute b)
    149                                   ,attribute))
    150                          (setq ,vector (bit-descriptor-vector b)
    151                                ,mask (bit-descriptor-mask b)
    152                                ,end-wins (bit-descriptor-end-wins b)))
    153                         (t
    154                          (setq bit (cdr bit)) ,res))))
    155                (count 0 (1+ count)))
    156               ((= count character-attribute-bucket-size) res))
    157          (setq *last-find-attribute-attribute* ,attribute
    158                *last-find-attribute-function* ,function
    159                *last-find-attribute-vector* ,vector
    160                *last-find-attribute-mask* ,mask
    161                *last-find-attribute-end-wins* ,end-wins))))
    162 ); eval-when (:compile-toplevel :execute)
     164  `(let ((ss (current-buffer-shadow-syntax)))
     165     (if (and (eq ,function (ss-last-find-attribute-function ss))
     166              (eq ,attribute (ss-last-find-attribute-attribute ss)))
     167       (setq ,vector (ss-last-find-attribute-vector ss)
     168             ,mask (ss-last-find-attribute-mask ss)
     169             ,end-wins (ss-last-find-attribute-end-wins ss))
     170       (let ((b (or (loop for b in (ss-shadow-bit-descriptors ss)
     171                      when (and (eq (bit-descriptor-attribute b) ,attribute)
     172                                (eq (bit-descriptor-function b) ,function))
     173                      return b)
     174                    (loop for b in (svref *character-attribute-cache*
     175                                          (hash-it ,attribute ,function))
     176                      when (and (eq (bit-descriptor-attribute b) ,attribute)
     177                                (eq (bit-descriptor-function b) ,function))
     178                      return b))))
     179         (cond (b
     180                (setq ,vector (bit-descriptor-vector b)
     181                      ,mask (bit-descriptor-mask b)
     182                      ,end-wins (bit-descriptor-end-wins b)))
     183               (t
     184                (multiple-value-setq (,vector ,mask ,end-wins)
     185                  (new-cache-attribute ,attribute ,function))))
     186         (setf (ss-last-find-attribute-attribute ss) ,attribute
     187               (ss-last-find-attribute-function ss) ,function
     188               (ss-last-find-attribute-vector ss) ,vector
     189               (ss-last-find-attribute-mask ss) ,mask
     190               (ss-last-find-attribute-end-wins ss) ,end-wins)))))
    163191
    164192;;; NEW-CACHE-ATTRIBUTE  --  Internal
     
    182210          (bit-descriptor-function bit) function
    183211          (bit-descriptor-end-wins bit) end-wins)
     212    (incf *global-syntax-tick*)
    184213    (setq values (attribute-descriptor-vector values))
    185214    (do ((mask (bit-descriptor-mask bit))
     
    190219      (declare (type (simple-array (mod 256)) vec))
    191220      (if (funcall fun (aref (the simple-array values) i))
    192           (setf (aref vec i) (logior (aref vec i) mask))
    193           (setf (aref vec i) (logandc2 (aref vec i) mask))))))
     221        (setf (aref vec i) (logior (aref vec i) mask))
     222        (setf (aref vec i) (logandc2 (aref vec i) mask))))))
    194223
    195224
     
    222251    (setf (getstring name *character-attribute-names*) attribute)
    223252    (setf (gethash attribute *character-attributes*) new))
     253    (incf *global-syntax-tick*)
    224254  name)
    225255
     
    229259;;; giving error if it is not a defined attribute.
    230260;;;
    231 (eval-when (:compile-toplevel :execute)
    232 (defmacro with-attribute (symbol &body forms)
    233   `(let ((obj (gethash ,symbol *character-attributes*)))
    234      (unless obj
     261(defmacro with-attribute ((obj symbol) &body forms)
     262  `(let ((,obj (gethash ,symbol *character-attributes*)))
     263     (unless ,obj
    235264       (error "~S is not a defined character attribute." ,symbol))
    236265     ,@forms))
    237 ); eval-when (:compile-toplevel :execute)
    238266
    239267(defun character-attribute-name (attribute)
    240268  "Return the string-name of the character-attribute Attribute."
    241   (with-attribute attribute
     269  (with-attribute (obj attribute)
    242270    (attribute-descriptor-name obj)))
    243271
    244272(defun character-attribute-documentation (attribute)
    245273  "Return the documentation for the character-attribute Attribute."
    246   (with-attribute attribute
     274  (with-attribute (obj attribute)
    247275    (attribute-descriptor-documentation obj)))
    248276
     
    250278  "Return the hook-list for the character-attribute Attribute.  This can
    251279  be set with Setf."
    252   (with-attribute attribute
     280  (with-attribute (obj attribute)
    253281    (attribute-descriptor-hooks obj)))
    254282
    255283(defun %set-character-attribute-hooks (attribute new-value)
    256   (with-attribute attribute
     284  (with-attribute (obj attribute)
    257285    (setf (attribute-descriptor-hooks obj) new-value)))
    258286
    259 (declaim (special *last-character-attribute-requested*
    260                     *value-of-last-character-attribute-requested*))
    261 
    262287;;; CHARACTER-ATTRIBUTE  --  Public
    263288;;;
    264289;;;    Return the value of a character attribute for some character.
    265290;;;
    266 (declaim (inline character-attribute))
    267291(defun character-attribute (attribute character)
    268292  "Return the value of the the character-attribute Attribute for Character.
    269293  If Character is Nil then return the end-value."
    270   (if (and (eq attribute *last-character-attribute-requested*) character)
    271       (aref (the simple-array *value-of-last-character-attribute-requested*)
    272             (syntax-char-code character))
    273       (sub-character-attribute attribute character)))
     294  (let ((ss (current-buffer-shadow-syntax)))
     295    (if (and character ss (eq attribute (ss-last-character-attribute-requested ss)))
     296      (aref (ss-value-of-last-character-attribute-requested ss) (syntax-char-code character))
     297      (sub-character-attribute attribute character))))
    274298;;;
    275299(defun sub-character-attribute (attribute character)
    276   (with-attribute attribute
    277     (setq *last-character-attribute-requested* attribute)
    278     (setq *value-of-last-character-attribute-requested*
    279           (attribute-descriptor-vector obj))
    280     (if character
    281         (aref (the simple-array *value-of-last-character-attribute-requested*)
    282               (syntax-char-code character))
    283         (attribute-descriptor-end-value obj))))
     300  (with-attribute (obj attribute)
     301    (let* ((ss (current-buffer-shadow-syntax))
     302           (cell (and ss (cdr (assoc obj (ss-shadow-attributes ss) :test #'eq)))))
     303      (if character
     304        (let ((vec (if cell (car cell) (attribute-descriptor-vector obj))))
     305          (when ss
     306            (setf (ss-last-character-attribute-requested ss) attribute)
     307            (setf (ss-value-of-last-character-attribute-requested ss) vec))
     308          (aref (the simple-array vec) (syntax-char-code character)))
     309        (if cell (cdr cell) (attribute-descriptor-end-value obj))))))
    284310
    285311;;; CHARACTER-ATTRIBUTE-P
     
    296322;;; %SET-CHARACTER-ATTRIBUTE  --  Internal
    297323;;;
    298 ;;;    Set the value of a character attribute.
     324;;;    Set the global value of a character attribute.
    299325;;;
    300326(defun %set-character-attribute (attribute character new-value)
    301   (with-attribute attribute
     327  (with-attribute (obj attribute)
    302328    (invoke-hook hemlock::character-attribute-hook attribute character new-value)
    303329    (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value)
     
    325351        (when (eq (bit-descriptor-attribute bit) attribute)
    326352          (setf (bit-descriptor-end-wins bit)
    327                 (funcall (bit-descriptor-function bit) new-value))))
    328       new-value))))
    329 
    330 
    331 (eval-when (:compile-toplevel :execute)
    332 ;;; swap-one-attribute  --  Internal
    333 ;;;
    334 ;;;    Install the mode-local values described by Vals for Attribute, whose
    335 ;;; representation vector is Value.
    336 ;;;
    337  (defmacro swap-one-attribute (attribute value vals hooks)
    338   `(progn
    339     ;; Fix up any cached attribute vectors.
    340     (dolist (bit *all-bit-descriptors*)
    341       (when (eq ,attribute (bit-descriptor-attribute bit))
    342         (let ((fun (bit-descriptor-function bit))
    343               (vec (bit-descriptor-vector bit))
    344               (mask (bit-descriptor-mask bit)))
    345           (declare (type (simple-array (mod 256)) vec)
    346                    (fixnum mask))
    347           (dolist (char ,vals)
    348             (setf (aref vec (car char))
    349                   (if (funcall fun (cdr char))
    350                       (logior mask (aref vec (car char)))
    351                       (logandc1 mask (aref vec (car char)))))))))
    352     ;; Invoke the attribute-hook.
    353     (dolist (hook ,hooks)
    354       (dolist (char ,vals)
    355         (funcall hook ,attribute (code-char (car char)) (cdr char))))
    356     ;; Fix up the value vector.
    357     (dolist (char ,vals)
    358       (rotatef (aref ,value (car char)) (cdr char)))))
    359 ); eval-when (:compile-toplevel :execute)
    360 
    361 
    362 ;;; SWAP-CHAR-ATTRIBUTES  --  Internal
    363 ;;;
    364 ;;;    Swap the current values of character attributes and the ones
    365 ;;;specified by "mode".  This is used in Set-Major-Mode.
    366 ;;;
    367 (defun swap-char-attributes (mode)
    368   (dolist (attribute (mode-object-character-attributes mode))
    369     (let* ((obj (car attribute))
    370            (sym (attribute-descriptor-keyword obj))
    371            (value (attribute-descriptor-vector obj))
    372            (hooks (attribute-descriptor-hooks obj)))
    373       (declare (simple-array value))
    374       (swap-one-attribute sym value (cdr attribute) hooks))))
    375 
    376 
    377 
    378 
    379 (declaim (special *mode-names* *current-buffer*))
     353                (funcall (bit-descriptor-function bit) new-value))))))
     354    (incf *global-syntax-tick*)
     355    new-value))
     356
     357
     358;; This is called when change buffer mode.  It used to invoke attribute-descriptor-hooks on
     359;; all the shadowed attributes.  We don't do that any more, should update doc if any.
     360(defun invalidate-shadow-attributes (buffer)
     361  (let ((ss (buffer-shadow-syntax buffer)))
     362    (when ss (setf (ss-global-syntax-tick ss) -1))))
     363
     364(defun %init-one-shadow-attribute (ss desc vals)
     365  ;; Shadow all bits for this attribute
     366  (loop with key = (attribute-descriptor-keyword desc)
     367    for bit in *all-bit-descriptors*
     368    when (eq key (bit-descriptor-attribute bit))
     369    do (let* ((fun (bit-descriptor-function bit))
     370              (b (or (find-if #'(lambda (b)
     371                                  (and (eq (bit-descriptor-function b) fun)
     372                                       (eq (bit-descriptor-attribute b) key)))
     373                              (ss-shadow-bit-descriptors ss))
     374                     (let ((new (make-bit-descriptor
     375                                 :attribute key
     376                                 :function fun
     377                                 :vector (copy-seq (bit-descriptor-vector bit))
     378                                 :mask (bit-descriptor-mask bit))))
     379                       (push new (ss-shadow-bit-descriptors ss))
     380                       new)))
     381              (vec (bit-descriptor-vector b)))
     382         (loop for (code . value) in vals
     383           ;; Since we don't share the shadow vecs, no need to preserve other bits.
     384           do (setf (aref vec code) (if (funcall fun value) #xFF #x00)))))
     385  ;; Shadow the attribute values
     386  (let ((vec (cadr (or (assoc desc (ss-shadow-attributes ss) :test #'eq)
     387                       (let ((new (list* desc
     388                                         (copy-seq (attribute-descriptor-vector desc))