Index: /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7833) @@ -26,4 +26,11 @@ (def-cocoa-default *use-screen-fonts* :bool t "Use bitmap screen fonts when available") + + +(defgeneric hi:hemlock-view (ns-object)) + +(defmethod hi:hemlock-view ((unknown t)) nil) + + (defmacro nsstring-encoding-to-nsinteger (n) @@ -656,10 +663,5 @@ (with-slots (mirror styles) self (when (>= index (#/length mirror)) - (#_NSLog #@"Attributes at index: %lu edit-count: %d mirror: %@ layout: %@" :nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0)) - (for-each-textview-using-storage self - (lambda (tv) - (let* ((w (#/window tv)) - (proc (slot-value w 'command-thread))) - (process-interrupt proc #'ccl::dbg)))) + (#_NSLog #@"Bounds error - Attributes at index: %lu edit-count: %d mirror: %@ layout: %@" :nteger index ::unsigned (slot-value self 'edit-count) :id mirror :id (#/objectAtIndex: (#/layoutManagers self) 0)) (ccl::dbg)) (let* ((attrs (#/attributesAtIndex:effectiveRange: mirror index rangeptr))) @@ -713,9 +715,13 @@ (when textstorage (#/endEditing textstorage) + ;; This isn't really right. It should abort the entire command in progress, + ;; e.g. c-x ..., etc. and should do it before event start... Basically it + ;; should be handled as if it was a regular key event, except for the + ;; extra string argument. (for-each-textview-using-storage textstorage (lambda (tv) (hi::disable-self-insert - (hemlock-frame-event-queue (#/window tv))))) + (hi:hemlock-view tv)))) (#/ensureSelectionVisible textstorage))))) @@ -777,10 +783,6 @@ (process-kill p))) (when (eq buffer hi::*current-buffer*) - (setf (hi::current-buffer) - (car (last hi::*buffer-list*)))) - (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer) - (hi::invoke-hook hemlock::delete-buffer-hook buffer) - (setq hi::*buffer-list* (delq buffer hi::*buffer-list*)) - (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*)))))) + (setf hi::*current-buffer* nil)) + (hi::delete-buffer buffer :force t)))))) @@ -812,4 +814,97 @@ (declaim (special hemlock-textstorage-text-view)) +(defmethod hi:hemlock-view ((self hemlock-textstorage-text-view)) + ;; Not sure when any of this can fail, but at least try to make sure that if hemlock-view + ;; returns non-nil, then callers don't have to check for any other marginal situations. + (let ((frame (#/window self))) + (unless (%null-ptr-p frame) + (let ((view (hi:hemlock-view frame))) + (when view + (when (eq (hi::hemlock-view-buffer view) (text-view-buffer self)) + view)))))) + + +(defmethod eventqueue-abort-pending-p ((self hemlock-textstorage-text-view)) + ;; Return true if cmd-. is in the queue. Not sure what to do about c-g: + ;; would have to distinguish c-g from c-q c-g or c-q c-q c-g etc.... Maybe + ;; c-g will need to be synchronous meaning just end current command, + ;; while cmd-. is the real abort. + #| + (let* ((now (#/dateWithTimeIntervalSinceNow: ns:ns-date 0.0d0))) + (loop (let* ((event (#/nextEventMatchingMask:untilDate:inMode:dequeue: + target (logior #$whatever) now #&NSDefaultRunLoopMode t))) + (when (%null-ptr-p event) (return))))) + "target" can either be an NSWindow or the global shared application object; + |# + nil) + +(defvar *buffer-being-edited* nil) + +(objc:defmethod (#/keyDown: :void) ((self hemlock-textstorage-text-view) event) + #+debug (#_NSLog #@"Key down event = %@" :address event) + (let* ((view (hi:hemlock-view self)) + ;; quote-p means handle characters natively + (quote-p (and view (hi::hemlock-view-quote-next-p view)))) + #+GZ (log-debug "~"e-p ~s event ~s" quote-p event) + (if (or (null view) + (#/hasMarkedText self) + (and quote-p (zerop (#/length (#/characters event))))) ;; dead key, e.g. option-E + (call-next-method event) + (unless (eventqueue-abort-pending-p self) + (let ((hemlock-key (nsevent-to-key-event event quote-p))) + (when hemlock-key + #+GZ (log-debug "Handle key ~s" hemlock-key) + (hi::handle-hemlock-event view hemlock-key))))))) + +(defmethod hi::handle-hemlock-event :around ((view hi:hemlock-view) event) + (declare (ignore event)) + (with-autorelease-pool + (call-next-method))) + +;;; Translate a keyDown NSEvent to a Hemlock key-event. +(defun nsevent-to-key-event (event quote-p) + (let* ((modifiers (#/modifierFlags event))) + (unless (logtest #$NSCommandKeyMask modifiers) + (let* ((chars (if quote-p + (#/characters event) + (#/charactersIgnoringModifiers event))) + (n (if (%null-ptr-p chars) + 0 + (#/length chars))) + (c (and (eql n 1) + (#/characterAtIndex: chars 0)))) + (when c + (let* ((bits 0) + (useful-modifiers (logandc2 modifiers + (logior + ;#$NSShiftKeyMask + #$NSAlphaShiftKeyMask)))) + (unless quote-p + (dolist (map hemlock-ext::*modifier-translations*) + (when (logtest useful-modifiers (car map)) + (setq bits (logior bits + (hemlock-ext:key-event-modifier-mask (cdr map))))))) + (let* ((char (code-char c))) + (when (and char (standard-char-p char)) + (setq bits (logandc2 bits hi::+shift-event-mask+)))) + (hemlock-ext:make-key-event c bits))))))) + +;; For now, this is only used to abort i-search. All actual mouse handling is done +;; by Cocoa. In the future might want to allow users to extend via hemlock, e.g. +;; to implement mouse-copy. +;; Also -- shouldn't this happen on mouse up? +(objc:defmethod (#/mouseDown: :void) ((self hemlock-textstorage-text-view) event) + ;; If no modifier keys are pressed, send hemlock a no-op. + (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event)) + (let* ((view (hi:hemlock-view self))) + (when view + (unless (eventqueue-abort-pending-p self) + (hi::handle-hemlock-event view #k"leftdown"))))) + (call-next-method event)) + +#+GZ +(objc:defmethod (#/mouseUp: :void) ((self hemlock-textstorage-text-view) event) + (log-debug "~&MOUSE UP!!") + (call-next-method event)) (defmethod assume-not-editing ((tv hemlock-textstorage-text-view)) @@ -1157,76 +1252,11 @@ - - - -;;; Translate a keyDown NSEvent to a Hemlock key-event. -(defun nsevent-to-key-event (nsevent &optional quoted) - (let* ((modifiers (#/modifierFlags nsevent))) - (unless (logtest #$NSCommandKeyMask modifiers) - (let* ((chars (if quoted - (#/characters nsevent) - (#/charactersIgnoringModifiers nsevent))) - (n (if (%null-ptr-p chars) - 0 - (#/length chars))) - (c (if (eql n 1) - (#/characterAtIndex: chars 0)))) - (when c - (let* ((bits 0) - (useful-modifiers (logandc2 modifiers - (logior ;#$NSShiftKeyMask - #$NSAlphaShiftKeyMask)))) - (unless quoted - (dolist (map hemlock-ext::*modifier-translations*) - (when (logtest useful-modifiers (car map)) - (setq bits (logior bits (hemlock-ext::key-event-modifier-mask - (cdr map))))))) - (let* ((char (code-char c))) - (when (and char (standard-char-p char)) - (setq bits (logandc2 bits hi::+shift-event-mask+)))) - (hemlock-ext::make-key-event c bits))))))) - -(defun pass-key-down-event-to-hemlock (self event q) - #+debug - (#_NSLog #@"Key down event = %@" :address event) - (let* ((buffer (text-view-buffer self))) - (when buffer - (let* ((hemlock-event (nsevent-to-key-event event (hi::frame-event-queue-quoted-insert q )))) - (when hemlock-event - (hi::enqueue-key-event q hemlock-event)))))) - -(defun hi::enqueue-buffer-operation (buffer thunk) - (dolist (w (hi::buffer-windows buffer)) - (let* ((q (hemlock-frame-event-queue (#/window w))) - (op (hi::make-buffer-operation :thunk thunk))) - (hi::event-queue-insert q op)))) - - - -;;; Process a key-down NSEvent in a Hemlock text view by translating it -;;; into a Hemlock key event and passing it into the Hemlock command -;;; interpreter. - -(defun handle-key-down (self event) - (let* ((q (hemlock-frame-event-queue (#/window self)))) - (if (or (and (zerop (#/length (#/characters event))) - (hi::frame-event-queue-quoted-insert q)) - (#/hasMarkedText self)) - nil - (progn - (pass-key-down-event-to-hemlock self event q) - t)))) - - -(objc:defmethod (#/keyDown: :void) ((self hemlock-text-view) event) - (or (handle-key-down self event) - (call-next-method event))) - -(objc:defmethod (#/mouseDown: :void) ((self hemlock-text-view) event) - ;; If no modifier keys are pressed, send hemlock a no-op. - (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event)) - (let* ((q (hemlock-frame-event-queue (#/window self)))) - (hi::enqueue-key-event q #k"leftdown"))) - (call-next-method event)) +(defun append-output (view string) + (assume-cocoa-thread) + ;; Arrange to do the append in command context + (when view + (hi::handle-hemlock-event view #'(lambda () + (hemlock::append-buffer-output (hi::hemlock-view-buffer view) string))))) + ;;; Update the underlying buffer's point (and "active region", if appropriate. @@ -1685,9 +1715,4 @@ (objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document))) -(objc:defmethod (#/keyDown: :void) ((self echo-area-view) event) - (or (handle-key-down self event) - (call-next-method event))) - - (defloadvar *hemlock-frame-count* 0) @@ -1713,5 +1738,5 @@ (progn ;; What's the reason for sharing this? Is it just the lock? - (setf (hi::buffer-gap-context buffer) (hi::buffer-gap-context main-buffer)) + (setf (hi::buffer-gap-context buffer) (hi::ensure-buffer-gap-context main-buffer)) (make-textstorage-for-hemlock-buffer buffer))) (doc (make-instance 'echo-area-document)) @@ -1764,11 +1789,13 @@ ((echo-area-view :foreign-type :id) (pane :foreign-type :id) - (event-queue :initform (ccl::init-dll-header (hi::make-frame-event-queue)) - :reader hemlock-frame-event-queue) - (command-thread :initform nil) + (hemlock-view :initform nil :reader hemlock-frame-hemlock-view) (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer) (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream)) (:metaclass ns:+ns-object)) (declaim (special hemlock-frame)) + +(defmethod hi:hemlock-view ((self hemlock-frame)) + (hemlock-frame-hemlock-view self)) + (defun double-%-in (string) @@ -1825,9 +1852,8 @@ :count 2)) #|(*debug-io* *typeout-stream*)|#) - (stream-clear-output *debug-io*) - (ignore-errors (print-call-history :detailed-p t)) (#/performSelectorOnMainThread:withObject:waitUntilDone: frame (@selector #/runErrorSheet:) params t) - (wait-on-semaphore semaphore))))) + (unless (eq *current-process* *initial-process*) + (wait-on-semaphore semaphore)))))) (defun hi::report-hemlock-error (condition) @@ -1836,47 +1862,4 @@ (report-condition-in-hemlock-frame condition (#/window pane))))) - -(defun hemlock-thread-function (q buffer pane echo-buffer echo-window) - (let* ((hi::*real-editor-input* q) - (hi::*editor-input* q) - (hi::*current-buffer* hi::*current-buffer*) - (hi::*current-window* pane) - (hi::*echo-area-window* echo-window) - (hi::*echo-area-buffer* echo-buffer) - (region (hi::buffer-region echo-buffer)) - (hi::*echo-area-region* region) - (hi::*echo-area-stream* (hi::make-hemlock-output-stream - (hi::region-end region) :full)) - (hi::*parse-starting-mark* - (hi::copy-mark (hi::buffer-point hi::*echo-area-buffer*) - :right-inserting)) - (hi::*parse-input-region* - (hi::region hi::*parse-starting-mark* - (hi::region-end region))) - (hi::*cache-modification-tick* -1) - (hi::*disembodied-buffer-counter* 0) - (hi::*in-a-recursive-edit* nil) - (hi::*last-key-event-typed* nil) - (hi::*input-transcript* nil) - (hemlock::*target-column* 0) - (hemlock::*last-comment-start* " ") - (hi::*translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t)) - (hi::*current-command* (make-array 10 :fill-pointer 0 :adjustable t)) - (hi::*current-translation* (make-array 10 :fill-pointer 0 :adjustable t)) - (hi::*prompt-key* (make-array 10 :adjustable t :fill-pointer 0)) - (hi::*command-key-event-buffer* buffer)) - - (setf (hi::current-buffer) buffer) - (unwind-protect - (loop - (catch 'hi::editor-top-level-catcher - (handler-bind ((error #'(lambda (condition) - (hi::lisp-error-error-handler condition - :internal)))) - (hi::invoke-hook hemlock::abort-hook) - (hi::%command-loop)))) - (hi::invoke-hook hemlock::exit-hook)))) - - (objc:defmethod (#/close :void) ((self hemlock-frame)) (let* ((content-view (#/contentView self)) @@ -1885,8 +1868,4 @@ ((< i 0)) (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i)))) - (let* ((proc (slot-value self 'command-thread))) - (when proc - (setf (slot-value self 'command-thread) nil) - (process-kill proc))) (let* ((buf (hemlock-frame-echo-area-buffer self)) (echo-doc (if buf (hi::buffer-document buf)))) @@ -1929,5 +1908,5 @@ (nsstring-to-buffer nsstring buffer))) -(defun %nsstring-to-mark (nsstring mark) +(defun %nsstring-to-hemlock-string (nsstring) "returns line-termination of string" (let* ((string (lisp-string-from-nsstring nsstring)) @@ -1936,32 +1915,34 @@ (line-termination (if crpos (if (eql lfpos (1+ crpos)) - :cp/m - :macos) - :unix))) - (hi::insert-string mark - (case line-termination - (:cp/m (remove #\return string)) - (:macos (nsubstitute #\linefeed #\return string)) - (t string))) - line-termination)) - + :crlf + :cr) + :lf)) + (hemlock-string (case line-termination + (:crlf (remove #\return string)) + (:cr (nsubstitute #\linefeed #\return string)) + (t string)))) + (values hemlock-string line-termination))) + +;: TODO: I think this is jumping through hoops because it want to be invokable outside the main +;; cocoa thread. (defun nsstring-to-buffer (nsstring buffer) (let* ((document (hi::buffer-document buffer)) (hi::*current-buffer* buffer) (region (hi::buffer-region buffer))) - (setf (hi::buffer-document buffer) nil) - (unwind-protect - (progn - (hi::delete-region region) - (hi::modifying-buffer buffer - (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting)) - (setf (hi::buffer-line-termination buffer) - (%nsstring-to-mark nsstring mark))) - (setf (hi::buffer-modified buffer) nil) - (hi::buffer-start (hi::buffer-point buffer)) - (hi::renumber-region region) - buffer)) - (setf (hi::buffer-document buffer) document)))) - + (multiple-value-bind (hemlock-string line-termination) + (%nsstring-to-hemlock-string nsstring) + (setf (hi::buffer-line-termination buffer) line-termination) + + (setf (hi::buffer-document buffer) nil) ;; What's this about?? + (unwind-protect + (let ((point (hi::buffer-point buffer))) + (hi::delete-region region) + (hi::insert-string point hemlock-string) + (setf (hi::buffer-modified buffer) nil) + (hi::buffer-start point) + ;; TODO: why would this be needed? insert-string should take care of any internal bookkeeping. + (hi::renumber-region region) + buffer) + (setf (hi::buffer-document buffer) document))))) @@ -1984,26 +1965,13 @@ (setq peer tv)) (hi::activate-hemlock-view pane) + (setf (slot-value frame 'hemlock-view) + (make-instance 'hi:hemlock-view + :buffer buffer + :pane pane + :echo-area-buffer (hemlock-frame-echo-area-buffer frame) + :echo-area-pane echo-area)) (setf (slot-value frame 'echo-area-view) echo-area (slot-value frame 'pane) pane) - (setf (slot-value frame 'command-thread) - (process-run-function (format nil "Hemlock window thread for ~s" - (hi::buffer-name buffer)) - #'(lambda () - (hemlock-thread-function - (hemlock-frame-event-queue frame) - buffer - pane - (hemlock-frame-echo-area-buffer frame) - (slot-value frame 'echo-area-view))))) frame)) - - - - -(defun hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style) - (process-interrupt *cocoa-event-process* - #'%hemlock-frame-for-textstorage - class ts ncols nrows container-tracks-text-view-width color style)) - @@ -2014,10 +1982,35 @@ (release-lock (hi::buffer-lock b))) -(defun hi::document-begin-editing (document) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (slot-value document 'textstorage) - (@selector #/beginEditing) - +null-ptr+ - t)) +(defun invoke-modifying-buffer-storage (buffer thunk) + (assume-cocoa-thread) + (when buffer ;; nil means just get rid of any prior buffer + (setq buffer (require-type buffer 'hi::buffer))) + (let ((old *buffer-being-edited*)) + (if (eq buffer old) + (funcall thunk) + (unwind-protect + (progn + (buffer-document-end-editing old) + (buffer-document-begin-editing buffer) + (funcall thunk)) + (buffer-document-end-editing buffer) + (buffer-document-begin-editing old))))) + +(defun buffer-document-end-editing (buffer) + (when buffer + (let* ((document (hi::buffer-document (require-type buffer 'hi::buffer)))) + (when document + (setq *buffer-being-edited* nil) + (let ((ts (slot-value document 'textstorage))) + (#/endEditing ts) + ;; TODO: no reason for this to be an objC function!! + (#/updateHemlockSelection ts)))))) + +(defun buffer-document-begin-editing (buffer) + (when buffer + (let* ((document (hi::buffer-document buffer))) + (when document + (setq *buffer-being-edited* buffer) + (#/beginEditing (slot-value document 'textstorage)))))) (defun document-edit-level (document) @@ -2025,11 +2018,5 @@ (slot-value (slot-value document 'textstorage) 'edit-count)) -(defun hi::document-end-editing (document) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (slot-value document 'textstorage) - (@selector #/endEditing) - +null-ptr+ - t)) - +#| (defun hi::document-set-point-position (document) (declare (ignorable document)) @@ -2039,6 +2026,5 @@ (#/performSelectorOnMainThread:withObject:waitUntilDone: textstorage (@selector #/updateHemlockSelection) +null-ptr+ t))) - - +|# (defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0)) @@ -2194,4 +2180,8 @@ (:metaclass ns:+ns-object)) +(defmethod hi:hemlock-view ((self hemlock-editor-window-controller)) + (let ((frame (#/window self))) + (unless (%null-ptr-p frame) + (hi:hemlock-view frame)))) ;;; Map *default-file-character-encoding* to an :tringncoding @@ -2283,5 +2273,5 @@ (defvar *encoding-name-hash* (make-hash-table)) -(defmethod hi::document-encoding-name ((doc hemlock-editor-document)) +(defmethod document-encoding-name ((doc hemlock-editor-document)) (with-slots (encoding) doc (if (eql encoding 0) @@ -2291,5 +2281,9 @@ (lisp-string-from-nsstring (nsstring-for-nsstring-encoding encoding))))))) - +(defun hi::buffer-encoding-name (buffer) + (let ((doc (hi::buffer-document buffer))) + (and doc (document-encoding-name doc)))) + +;; TODO: make each buffer have a slot, and this is just the default value. (defmethod textview-background-color ((doc hemlock-editor-document)) *editor-background-color*) @@ -2344,7 +2338,6 @@ (hi::queue-buffer-change buffer) t)) - - - + + (objc:defmethod #/init ((self hemlock-editor-document)) (let* ((doc (call-next-method))) @@ -2358,4 +2351,12 @@ +(defun make-buffer-for-document (ns-document pathname) + (let* ((buffer-name (hi::pathname-to-buffer-name pathname)) + (buffer (make-hemlock-buffer buffer-name))) + (setf (slot-value ns-document 'textstorage) + (make-textstorage-for-hemlock-buffer buffer)) + (setf (hi::buffer-pathname buffer) pathname) + buffer)) + (objc:defmethod (#/readFromURL:ofType:error: :) ((self hemlock-editor-document) url type (perror (:* :id))) @@ -2367,12 +2368,6 @@ (#/path url) (#/absoluteString url)))) - (buffer-name (hi::pathname-to-buffer-name pathname)) - (buffer (or - (hemlock-document-buffer self) - (let* ((b (make-hemlock-buffer buffer-name))) - (setf (hi::buffer-pathname b) pathname) - (setf (slot-value self 'textstorage) - (make-textstorage-for-hemlock-buffer b)) - b))) + (buffer (or (hemlock-document-buffer self) + (make-buffer-for-document self pathname))) (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding)) (string @@ -2397,10 +2392,11 @@ (unless (%null-ptr-p string) (with-slots (encoding) self (setq encoding selected-encoding)) - (hi::queue-buffer-change buffer) - (hi::document-begin-editing self) - (nsstring-to-buffer string buffer) - (let* ((textstorage (slot-value self 'textstorage)) (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))) + + (hi::queue-buffer-change buffer) + (#/beginEditing textstorage) + + (nsstring-to-buffer string buffer) (reset-buffer-cache display) @@ -2413,13 +2409,11 @@ textstorage 0 - (hemlock-buffer-length buffer))) - - (hi::document-end-editing self) + (hemlock-buffer-length buffer)) + + (#/endEditing textstorage)) (setf (hi::buffer-modified buffer) nil) (hi::process-file-options buffer pathname) t)))) - - @@ -2464,5 +2458,5 @@ (when cache (buffer-cache-buffer cache)))))) -(defmethod hi:window-buffer ((frame hemlock-frame)) +(defmethod hi::window-buffer ((frame hemlock-frame)) (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) (doc (#/documentForWindow: dc frame))) @@ -2473,11 +2467,11 @@ (hemlock-document-buffer doc)))) -(defmethod hi:window-buffer ((pane text-pane)) - (hi:window-buffer (#/window pane))) +(defmethod hi::window-buffer ((pane text-pane)) + (hi::window-buffer (#/window pane))) (defun ordered-hemlock-windows () (delete-if-not #'(lambda (win) (and (typep win 'hemlock-frame) - (hi:window-buffer win))) + (hi::window-buffer win))) (windows))) @@ -2524,13 +2518,13 @@ (buffer (hemlock-document-buffer self))) (case (when buffer (hi::buffer-line-termination buffer)) - (:cp/m (unless (typep string 'ns:ns-mutable-string) - (setq string (make-instance 'ns:ns-mutable-string :with string string)) - (#/replaceOccurrencesOfString:withString:options:range: - string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) - (:macos (setq string (if (typep string 'ns:ns-mutable-string) - string - (make-instance 'ns:ns-mutable-string :with string string))) - (#/replaceOccurrencesOfString:withString:options:range: - string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) + (:crlf (unless (typep string 'ns:ns-mutable-string) + (setq string (make-instance 'ns:ns-mutable-string :with string string)) + (#/replaceOccurrencesOfString:withString:options:range: + string *ns-lf-string* *ns-crlf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) + (:cr (setq string (if (typep string 'ns:ns-mutable-string) + string + (make-instance 'ns:ns-mutable-string :with string string))) + (#/replaceOccurrencesOfString:withString:options:range: + string *ns-lf-string* *ns-cr-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))) (when (#/writeToURL:atomically:encoding:error: string url t encoding error) @@ -3022,6 +3016,6 @@ ((or (typep arg 'string) (typep arg 'pathname)) - (unless (probe-file arg) - (ccl::touch arg)) + #+no (unless (probe-file arg) + (ccl::touch arg)) (with-autorelease-pool (let* ((url (pathname-to-url arg)) Index: /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp (revision 7833) @@ -163,8 +163,6 @@ (let* ((data (#/objectForKey: (#/userInfo notification) #&NSFileHandleNotificationDataItem)) - (document (#/document self)) (encoding (load-time-value (get-character-encoding :utf-8))) (data-length (#/length data)) - (buffer (hemlock-document-buffer document)) (n nextra) (cursize bufsize) @@ -200,12 +198,6 @@ (%get-unsigned-byte xlate (+ noctets-used i))))) (setq nextra n) - (hi::enqueue-buffer-operation - buffer - #'(lambda () - (unwind-protect - (progn - (hi::buffer-document-begin-editing buffer) - (hemlock::append-buffer-output buffer string)) - (hi::buffer-document-end-editing buffer)))) + (let ((view (hi::hemlock-view self))) + (queue-for-cocoa-thread #'(lambda () (append-output view string)))) (#/readInBackgroundAndNotify fh))))))) @@ -239,5 +231,5 @@ (declare (ignore buffer))) -(defmethod hi::document-encoding-name ((doc hemlock-listener-document)) +(defmethod document-encoding-name ((doc hemlock-listener-document)) "UTF-8") @@ -398,4 +390,5 @@ (let* ((buffer (hemlock-document-buffer self)) (process (if buffer (hi::buffer-process buffer)))) + (log-debug "~&exitBreak buffer ~s process ~s" buffer process) (when (typep process 'cocoa-listener-process) (process-interrupt process #'abort-break)))) @@ -471,4 +464,23 @@ (if (typep process 'cocoa-listener-process) (let* ((action (#/action item))) + #+GZ (log-debug "Validate menu item buffer: ~s process: ~s action: ~s context ~s" buffer process + (cond ((eql action (@selector #/revertDocumentToSaved:)) + "revertDocumentToSaved:") + ((eql action (@selector #/saveDocument:)) + "saveDocument:") + ((eql action (@selector #/saveDocumentAs:)) + "saveDocumentAs:") + ((eql action (@selector #/interrupt:)) + "interrupt") + ((eql action (@selector #/continue:)) + "continue") + ((eql action (@selector #/backtrace:)) + "backtrace") + ((eql action (@selector #/exitBreak:)) + "exitBreak:") + ((eql action (@selector #/restarts:)) + "restarts:") + (t action)) + (cocoa-listener-process-backtrace-contexts process)) (cond ((or (eql action (@selector #/revertDocumentToSaved:)) Index: /branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp (revision 7833) @@ -115,7 +115,102 @@ (nreverse ret))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; utilities for executing in the cocoa event thread + +(defstatic *cocoa-thread-arg-id-map* (make-id-map)) + +;; This is for debugging, it's preserved across queue-for-cocoa-thread and bound +;; so it can be seen in backtraces. +(defvar *invoking-event-context* "unknown") +(defvar *invoking-event-process* nil) + +(defun register-cocoa-thread-function (thunk result-handler context) + (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk + result-handler + (or context *invoking-event-context*) + *current-process*))) + +(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id) + (invoke-lisp-function self id)) + +(defmethod invoke-lisp-function ((self ns:ns-application) id) + (destructuring-bind (thunk result-handler context . invoking-process) + (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id))) + (handle-invoking-lisp-function thunk result-handler context invoking-process))) + +;; This immediately executes the thunk in the cocoa thread, via performSelectorOnMainThread. +;; It should only be used for relatively quick and safe stuff. +(defun execute-in-cocoa-thread (thunk &key result-handler context) + "Execute thunk in the main cocoa thread, waiting for it to return." + (if (eq *current-process* ccl::*initial-process*) + (handle-invoking-lisp-function thunk result-handler context) + (if (or (not *nsapp*) (not (#/isRunning *nsapp*))) + (error "cocoa thread not available") + (let ((arg (make-instance 'ns:ns-number + :with-long (register-cocoa-thread-function thunk result-handler context)))) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + *nsapp* + (@selector #/invokeLispFunction:) + arg + t))))) + +(defconstant $lisp-function-event-subtype 17) + +(defclass lisp-application (ns:ns-application) + ((termp :foreign-type :)) + (:metaclass ns:+ns-object)) + +;;; I'm not sure if there's another way to recognize events whose +;;; type is #$NSApplicationDefined. +(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e) + (if (and (eql (#/type e) #$NSApplicationDefined) + (eql (#/subtype e) $lisp-function-event-subtype)) + (invoke-lisp-function self (#/data1 e)) + (call-next-method e))) + +;; This queues an event rather than just doing performSelectorOnMainThread. +(defun queue-for-cocoa-thread (thunk &key result-handler context at-start) + "Queue thunk for execution in main cocoa thread and return immediately." + (execute-in-cocoa-thread + #'(lambda () + (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2: + ns:ns-event + #$NSApplicationDefined + (ns:make-ns-point 0 0) + 0 + 0.0d0 + 0 + +null-ptr+ + $lisp-function-event-subtype + (register-cocoa-thread-function thunk result-handler context) + 0))) + ;(#/retain e) + (#/postEvent:atStart: *nsapp* e (not (null at-start))))))) + +(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*)) + ;; TODO: the point is to execute result-handler in the original process, but this will do for now. + (let* ((*invoking-event-process* invoking-process) + (*invoking-event-context* context)) + (if result-handler + (multiple-value-call result-handler (funcall thunk)) + (funcall thunk)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; debugging + (defun log-debug (format-string &rest args) (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args)))) +(defun nslog-condition (c) + (let* ((rep (format nil "~a" c))) + (with-cstrs ((str rep)) + (with-nsstr (nsstr str (length rep)) + (#_NSLog #@"Error in event loop: %@" :address nsstr))))) + + + (defun assume-cocoa-thread () #+debug (assert (eq *current-process* *initial-process*))) Index: /branches/event-ide/ccl/cocoa-ide/cocoa-window.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-window.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-window.lisp (revision 7833) @@ -50,24 +50,5 @@ :void)) -(defstatic *appkit-process-interrupt-ids* (make-id-map)) -(defun register-appkit-process-interrupt (thunk) - (assign-id-map-id *appkit-process-interrupt-ids* thunk)) -(defun appkit-interrupt-function (id) - (id-map-free-object *appkit-process-interrupt-ids* id)) - (defclass appkit-process (process) ()) - -(defconstant process-interrupt-event-subtype 17) - - - - -(defclass lisp-application (ns:ns-application) - ((termp :foreign-type :)) - (:metaclass ns:+ns-object)) - - -(objc:defmethod (#/postEventAtStart: :void) ((self ns:ns-application) e) - (#/postEvent:atStart: self e t)) ;;; Interrupt the AppKit event process, by enqueing an event (if the @@ -76,26 +57,12 @@ ;;; case, the application's probably already in the process of ;;; exiting, and isn't that different from the case where asynchronous -;;; interrupts are used. An attribute of the event is used to identify -;;; the thunk which the event handler needs to funcall. +;;; interrupts are used. (defmethod process-interrupt ((process appkit-process) function &rest args) (if (eq process *current-process*) (apply function args) - (if (or (not *NSApp*) (not (#/isRunning *NSApp*))) - (call-next-method) - (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2: - ns:ns-event - #$NSApplicationDefined - (ns:make-ns-point 0 0) - 0 - 0.0d0 - 0 - +null-ptr+ - process-interrupt-event-subtype - (register-appkit-process-interrupt - #'(lambda () (apply function args))) 0))) - (#/retain e) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - *NSApp* (@selector "postEventAtStart:") e t))))) - + (if (and *NSApp* (#/isRunning *NSApp*)) + (queue-for-cocoa-thread #'(lambda () (apply function args)) + :at-start t) + (call-next-method)))) (defparameter *debug-in-event-process* t) @@ -147,14 +114,4 @@ (eql 0 (#_SetFrontProcess psn)))) -;;; I'm not sure if there's another way to recognize events whose -;;; type is #$NSApplicationDefined. -(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e) - (if (and (eql (#/type e) #$NSApplicationDefined) - (eql (#/subtype e) process-interrupt-event-subtype)) - ;;; The thunk to funcall is identified by the value - ;;; of the event's data1 attribute. - (funcall (appkit-interrupt-function (#/data1 e))) - (call-next-method e))) - #+nil (objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender) @@ -166,11 +123,4 @@ (#/show (#/sharedPanel typeout-window))) -(defun nslog-condition (c) - (let* ((rep (format nil "~a" c))) - (with-cstrs ((str rep)) - (with-nsstr (nsstr str (length rep)) - (#_NSLog #@"Error in event loop: %@" :address nsstr))))) - - (defmethod ccl::process-exit-application ((process appkit-process) thunk) (when (eq process ccl::*initial-process*) @@ -181,13 +131,24 @@ (%set-toplevel nil) (change-class *cocoa-event-process* 'appkit-process) - (let* ((app *NSApp*)) + (event-loop)) + +(defun stop-event-loop () + (#/stop: *nsapp* +null-ptr+)) + +(defun event-loop (&optional end-test) + (let ((app *NSApp*)) (loop - (handler-case (let* ((*event-process-reported-conditions* nil)) - (#/run app)) - (error (c) (nslog-condition c))) - (unless (#/isRunning app) - (return))))) - - + (handler-case (let* ((*event-process-reported-conditions* nil)) + (if end-test + (#/run app) + #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop) + #&NSDefaultRunLoopMode + (#/distantFuture ns:ns-date))|# + (#/run app))) + (error (c) (nslog-condition c))) + #+GZ (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*) + (when (or (and end-test (funcall end-test)) + (and ccl::*quitting* (not (#/isRunning app)))) + (return))))) (defun start-cocoa-application (&key Index: /branches/event-ide/ccl/cocoa-ide/cocoa.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/cocoa.lisp (revision 7833) @@ -1,5 +1,5 @@ (in-package "CCL") -(defvar *cocoa-application-path* "ccl:temp bundle.app;") +(defvar *cocoa-application-path* #+gz "ccl:GZ temp bundle.app;" #-gz "ccl:temp bundle.app;") (defvar *cocoa-application-copy-headers-p* nil) (load "ccl:cocoa-ide;defsystem.lisp") Index: /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/compile-hemlock.lisp (revision 7833) @@ -47,4 +47,6 @@ "macros" + + "views" "line" "ring" @@ -77,4 +79,5 @@ "killcoms" "searchcoms" + "isearchcoms" "filecoms" "doccoms" @@ -85,5 +88,4 @@ "comments" "icom" - "kbdmac" "defsyn" "edit-defs" Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp (revision 7833) @@ -75,9 +75,12 @@ (bind-key "Scroll Window Up" #k"meta-v") (bind-key "Scroll Window Up" #k"pageup") -(bind-key "Scroll Next Window Down" #k"control-meta-v") -(bind-key "Scroll Next Window Up" #k"control-meta-V") +;(bind-key "Scroll Next Window Down" #k"control-meta-v") +;(bind-key "Scroll Next Window Up" #k"control-meta-V") (bind-key "Do Nothing" #k"leftdown") - +;(bind-key "Do Nothing" #k"leftup") + +(bind-key "Abort Command" #k"control-g") +(bind-key "Abort Command" #k"control-G") (bind-key "Process File Options" #k"control-x m" :global) @@ -116,5 +119,5 @@ (bind-key "Buffer Not Modified" #k"meta-~") ;(bind-key "Check Buffer Modified" #k"control-x ~") -(bind-key "Select Buffer" #k"control-x b") +;(bind-key "Select Buffer" #k"control-x b") ;(bind-key "Select Previous Buffer" #k"control-meta-l") ;(bind-key "Circulate Buffers" #k"control-meta-L") @@ -134,7 +137,4 @@ ;(bind-key "Top of Window" #k"meta-,") ;(bind-key "Bottom of Window" #k"meta-.") - -(bind-key "Exit Recursive Edit" #k"control-meta-z") -(bind-key "Abort Recursive Edit" #k"control-]") (bind-key "Delete Previous Character" #k"delete") @@ -193,5 +193,5 @@ ;;;; Argument Digit and Negative Argument. -(bind-key "Negative Argument" #k"meta-\-") +(bind-key "Argument Digit" #k"meta-\-") (bind-key "Argument Digit" #k"meta-0") (bind-key "Argument Digit" #k"meta-1") @@ -204,5 +204,5 @@ (bind-key "Argument Digit" #k"meta-8") (bind-key "Argument Digit" #k"meta-9") -(bind-key "Negative Argument" #k"control-\-") +(bind-key "Argument Digit" #k"control-\-") (bind-key "Argument Digit" #k"control-0") (bind-key "Argument Digit" #k"control-1") @@ -215,5 +215,5 @@ (bind-key "Argument Digit" #k"control-8") (bind-key "Argument Digit" #k"control-9") -(bind-key "Negative Argument" #k"control-meta-\-") +(bind-key "Argument Digit" #k"control-meta-\-") (bind-key "Argument Digit" #k"control-meta-0") (bind-key "Argument Digit" #k"control-meta-1") @@ -226,4 +226,16 @@ (bind-key "Argument Digit" #k"control-meta-8") (bind-key "Argument Digit" #k"control-meta-9") + +(bind-key "Digit" #k"\-") +(bind-key "Digit" #k"0") +(bind-key "Digit" #k"1") +(bind-key "Digit" #k"2") +(bind-key "Digit" #k"3") +(bind-key "Digit" #k"4") +(bind-key "Digit" #k"5") +(bind-key "Digit" #k"6") +(bind-key "Digit" #k"7") +(bind-key "Digit" #k"8") +(bind-key "Digit" #k"9") @@ -247,14 +259,4 @@ (bind-key "Self Insert" #k"+") (bind-key "Self Insert" #k"~") -(bind-key "Self Insert" #k"1") -(bind-key "Self Insert" #k"2") -(bind-key "Self Insert" #k"3") -(bind-key "Self Insert" #k"4") -(bind-key "Self Insert" #k"5") -(bind-key "Self Insert" #k"6") -(bind-key "Self Insert" #k"7") -(bind-key "Self Insert" #k"8") -(bind-key "Self Insert" #k"9") -(bind-key "Self Insert" #k"0") (bind-key "Self Insert" #k"[") (bind-key "Self Insert" #k"]") @@ -265,5 +267,4 @@ (bind-key "Self Insert" #k"\"") (bind-key "Self Insert" #k"'") -(bind-key "Self Insert" #k"\-") (bind-key "Self Insert" #k"=") (bind-key "Self Insert" #k"`") @@ -521,4 +522,5 @@ +#| ;;;; Keyboard macro bindings. @@ -529,4 +531,5 @@ (bind-key "Last Keyboard Macro" #k"control-x e") (bind-key "Keyboard Macro Query" #k"control-x q") +|# @@ -933,14 +936,27 @@ +;;;; I-Search mode. +;;;; +;;;; Anything that's not explicitly bound here will exit i-search. + +(dotimes (n hemlock::char-code-limit) + (when (standard-char-p (code-char n)) + (let ((key (hemlock-ext:make-key-event n))) + (bind-key "I-Search Self Insert" key :mode "I-Search")))) + +(bind-key "I-Search Repeat Forward" #k"control-s" :mode "I-Search") +(bind-key "I-Search Repeat Backward" #k"control-r" :mode "I-Search") +(bind-key "I-Search Backup" #k"backspace" :mode "I-Search") +(bind-key "I-Search Backup" #k"delete" :mode "I-Search") +(bind-key "I-Search Abort" #k"control-g" :mode "I-Search") +(bind-key "I-Search Abort" #k"control-G" :mode "I-Search") +(bind-key "I-Search Exit or Search" #k"escape" :mode "I-Search") +(bind-key "I-Search Yank Word" #k"control-w" :mode "I-Search") +(bind-key "Quoted Insert" #k"control-q" :mode "I-Search") + + ;;;; Logical characters. - -(setf (logical-key-event-p #k"control-s" :forward-search) t) -(setf (logical-key-event-p #k"control-r" :backward-search) t) -(setf (logical-key-event-p #k"control-r" :recursive-edit) t) -(setf (logical-key-event-p #k"delete" :cancel) t) -(setf (logical-key-event-p #k"backspace" :cancel) t) + (setf (logical-key-event-p #k"control-g" :abort) t) -(setf (logical-key-event-p #k"escape" :exit) t) -(setf (logical-key-event-p #k"leftdown" :mouse-exit) t) (setf (logical-key-event-p #k"y" :yes) t) (setf (logical-key-event-p #k"space" :yes) t) @@ -957,3 +973,2 @@ (setf (logical-key-event-p #k"control-q" :quote) t) (setf (logical-key-event-p #k"k" :keep) t) -(setf (logical-key-event-p #k"control-w" :extend-search-word) t) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp (revision 7833) @@ -133,6 +133,4 @@ ;;;; Variable binding -- winding and unwinding. -(eval-when (:compile-toplevel :execute) - (defmacro unbind-variable-bindings (bindings) `(do ((binding ,bindings (binding-across binding))) @@ -149,6 +147,4 @@ (car cons) object)))) -) ;eval-when - ;;; UNWIND-BINDINGS -- Internal ;;; @@ -158,7 +154,9 @@ ;;; unwind all bindings. ;;; -(defun unwind-bindings (mode) - (unbind-variable-bindings (buffer-var-values *current-buffer*)) - (do ((curmode (buffer-mode-objects *current-buffer*)) +(defun unwind-bindings (buffer mode) + #+gz (assert (buffer-bindings-wound-p buffer)) + (setf (buffer-bindings-wound-p buffer) nil) + (unbind-variable-bindings (buffer-var-values buffer)) + (do ((curmode (buffer-mode-objects buffer)) (unwound ()) cw) (()) @@ -166,5 +164,5 @@ (unbind-variable-bindings (mode-object-var-values (car unwound))) (when (or (null curmode) (eq (car unwound) mode)) - (setf (buffer-mode-objects *current-buffer*) curmode) + (setf (buffer-mode-objects buffer) curmode) (return unwound)))) @@ -173,17 +171,24 @@ ;;; Add "modes" to the mode bindings currently in effect. ;;; -(defun wind-bindings (modes) - (do ((curmode (buffer-mode-objects *current-buffer*)) cw) - ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode)) +(defun wind-bindings (buffer modes) + #+gz (assert (not (buffer-bindings-wound-p buffer))) + (setf (buffer-bindings-wound-p buffer) t) + (do ((curmode (buffer-mode-objects buffer)) cw) + ((null modes) (setf (buffer-mode-objects buffer) curmode)) (bind-variable-bindings (mode-object-var-values (car modes))) (setf cw modes modes (cdr modes) (cdr cw) curmode curmode cw)) - (bind-variable-bindings (buffer-var-values *current-buffer*))) - - + (bind-variable-bindings (buffer-var-values buffer))) + + + +(defun setup-buffer-bindings (buffer) + (wind-bindings buffer (shiftf (buffer-mode-objects buffer) nil))) + +(defun revert-buffer-bindings (buffer) + (setf (buffer-mode-objects buffer) (unwind-bindings buffer nil))) ;;;; BUFFER-MAJOR-MODE. -(eval-when (:compile-toplevel :execute) (defmacro with-mode-and-buffer ((name major-p buffer) &body forms) `(let ((mode (get-mode-object name))) @@ -193,5 +198,4 @@ (check-type ,buffer buffer) ,@forms)) -) ;eval-when ;;; BUFFER-MAJOR-MODE -- Public @@ -217,11 +221,9 @@ (invoke-hook hemlock::buffer-major-mode-hook buffer name) (cond - ((eq buffer *current-buffer*) + ((buffer-bindings-wound-p buffer) (let ((old-mode (car (last (buffer-mode-objects buffer))))) (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) (funcall (mode-object-cleanup-function old-mode) buffer) - (swap-char-attributes old-mode) - (wind-bindings (cons mode (cdr (unwind-bindings old-mode)))) - (swap-char-attributes mode))) + (wind-bindings buffer (cons mode (cdr (unwind-bindings buffer old-mode)))))) (t (let ((old-mode (car (buffer-mode-objects buffer)))) @@ -229,4 +231,5 @@ (funcall (mode-object-cleanup-function old-mode) buffer)) (setf (car (buffer-mode-objects buffer)) mode))) + (invalidate-shadow-attributes buffer) (setf (car (buffer-modes buffer)) name) (funcall (mode-object-setup-function mode) buffer) @@ -265,20 +268,7 @@ ;; Adding a new mode. (new-value - (cond - ((eq buffer *current-buffer*) - ;; - ;; Unwind bindings having higher precedence, cons on the new - ;; mode and then wind them back on again. - (do ((m objects (cdr m)) - (prev nil (car m))) - ((or (null (cdr m)) - (< (mode-object-precedence (car m)) - (mode-object-precedence mode))) - (wind-bindings - (cons mode (if prev - (unwind-bindings prev) - (unbind-variable-bindings - (buffer-var-values *current-buffer*)))))))) - (t + (let ((wound-p (buffer-bindings-wound-p buffer))) + (when wound-p + (revert-buffer-bindings buffer)) (do ((m (cdr objects) (cdr m)) (prev objects m)) @@ -286,5 +276,7 @@ (>= (mode-object-precedence (car m)) (mode-object-precedence mode))) - (setf (cdr prev) (cons mode m)))))) + (setf (cdr prev) (cons mode m)))) + (when wound-p + (setup-buffer-bindings buffer))) ;; ;; Add the mode name. @@ -303,6 +295,6 @@ ;; In the current buffer, unwind buffer and any mode bindings on top ;; pop off the mode and wind the rest back on. - (cond ((eq buffer *current-buffer*) - (wind-bindings (cdr (unwind-bindings mode)))) + (cond ((buffer-bindings-wound-p buffer) + (wind-bindings buffer (cdr (unwind-bindings buffer mode)))) (t (setf (buffer-mode-objects buffer) @@ -384,117 +376,4 @@ (unless region point)))) - -;;; %SET-CURRENT-BUFFER -- Internal -;;; -;;; Undo previous buffer and mode specific variables and character -;;;attributes and set up the new ones. Set *current-buffer*. -;;; -(defun %set-current-buffer (buffer) - (let ((old-buffer *current-buffer*)) - (check-type buffer buffer) - (invoke-hook hemlock::set-buffer-hook buffer) - ;; Undo old bindings. - (setf (buffer-mode-objects *current-buffer*) - (unwind-bindings nil)) - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) - (setq *current-buffer* buffer) - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) - ;; Make new bindings. - (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil)) - (invoke-hook hemlock::after-set-buffer-hook old-buffer)) - buffer) - -;;; USE-BUFFER-SET-UP -- Internal -;;; -;;; This function is called by the use-buffer macro to wind on the -;;; new buffer's variable and key bindings and character attributes. -;;; -(defun use-buffer-set-up (old-buffer) - (unless (eq old-buffer *current-buffer*) - ;; Let new char attributes overlay old ones. - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))) - ;; Wind on bindings of new current buffer. - (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil)))) - -;;; USE-BUFFER-CLEAN-UP -- Internal -;;; -;;; This function is called by use-buffer to clean up after it is done. -;;; -(defun use-buffer-clean-up (old-buffer) - (unless (eq old-buffer *current-buffer*) - ;; When we leave, unwind the bindings, - (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil)) - ;; Restore the character attributes, - (swap-char-attributes (car (buffer-mode-objects *current-buffer*))))) - - - - -;;;; Recursive editing. - -(defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.") - -(declaim (inline in-recursive-edit)) - -(defun in-recursive-edit () - "Returns whether the calling point is dynamically within a recursive edit - context." - *in-a-recursive-edit*) - -;;; RECURSIVE-EDIT -- Public -;;; -;;; Call the command interpreter recursively, winding on new state as -;;; necessary. -;;; -(defun recursive-edit (&optional (handle-abort t)) - "Call the command interpreter recursively. If Handle-Abort is true - then an abort caused by a control-g or a lisp error does not cause - the recursive edit to be aborted." - (invoke-hook hemlock::enter-recursive-edit-hook) - (multiple-value-bind (flag args) - (let ((*in-a-recursive-edit* t) - #+nil (doc (buffer-document *current-buffer*)) - ) - (catch 'leave-recursive-edit - (unwind-protect - (progn - #+nil (when doc (document-end-editing doc)) - (if handle-abort - (loop (catch 'editor-top-level-catcher - (%command-loop))) - (%command-loop))) - #+nil - (when doc (document-begin-editing doc))))) - - (case flag - (:abort (apply #'editor-error args)) - (:exit (values-list args)) - (t (error "Bad thing ~S thrown out of recursive edit." flag))))) - -;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context -;;; of RECURSIVE-EDIT, causing return from that function with values returned -;;; as multiple values. When not in a recursive edit, signal an error. -;;; -(defun exit-recursive-edit (&optional values) - "Exit from a recursive edit. Values is a list of things which are - to be the return values from Recursive-Edit." - (unless *in-a-recursive-edit* - (error "Not in a recursive edit!")) - (invoke-hook hemlock::exit-recursive-edit-hook values) - (throw 'leave-recursive-edit (values :exit values))) - -;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context -;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args. When not -;;; in a recursive edit, signal an error. -;;; -(defun abort-recursive-edit (&rest args) - "Abort a recursive edit, causing an Editor-Error with the args given in - the calling context." - (unless *in-a-recursive-edit* - (error "Not in a recursive edit!")) - (invoke-hook hemlock::abort-recursive-edit-hook args) - (throw 'leave-recursive-edit (values :abort args))) - - ;;;; WITH-WRITABLE-BUFFER @@ -530,5 +409,5 @@ (defun defmode (name &key (setup-function #'identity) (cleanup-function #'identity) major-p transparent-p - precedence documentation hidden) + precedence documentation hidden default-command) "Define a new mode, specifying whether it is a major mode, and what the setup and cleanup functions are. Precedence, which defaults to 0.0, and is @@ -565,4 +444,6 @@ (setf (getstring name *mode-names*) mode))) + (when (eq precedence :highest) + (setq precedence most-positive-double-float)) (if precedence (if major-p @@ -571,4 +452,7 @@ (setq precedence 0)) + (when default-command + (setf (mode-object-default-command mode) default-command)) + (setf (mode-object-major-p mode) major-p (mode-object-documentation mode) documentation @@ -611,5 +495,12 @@ and Modeline-fields is a list of modeline field objects. Delete-hook is a list of functions that take a buffer as the argument." - (cond ((getstring name *buffer-names*) nil) + #+GZ + (when (getstring name *buffer-names*) + (warn "~s already exists, trying to delete" name *buffer-names*) + (let ((buffer (getstring name *buffer-names*))) + (when (buffer-windows buffer) + (delete-buffer buffer)))) + (cond ((getstring name *buffer-names*) + nil) (t (unless (listp delete-hook) @@ -638,12 +529,13 @@ buffer)))) -(defun delete-buffer (buffer) +(defun delete-buffer (buffer &key force) "Deletes a buffer. If buffer is current, or if it is displayed in any windows, an error is signaled." (when (eq buffer *current-buffer*) (error "Cannot delete current buffer ~S." buffer)) - (when (buffer-windows buffer) - (error "Cannot delete buffer ~S, which is displayed in ~R window~:P." - buffer (length (buffer-windows buffer)))) + (unless force + (when (buffer-windows buffer) + (error "Cannot delete buffer ~S, which is displayed in ~R window~:P." + buffer (length (buffer-windows buffer))))) (invoke-hook (buffer-delete-hook buffer) buffer) (invoke-hook hemlock::delete-buffer-hook buffer) @@ -693,4 +585,6 @@ (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental") :modeline-fields nil)) + (wind-bindings *current-buffer* nil) + ;; Make the bogus variable go away... (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/cocoa-hemlock.lisp (revision 7833) @@ -7,46 +7,4 @@ (in-package :hemlock-internals) -(defstruct (frame-event-queue (:include ccl::locked-dll-header)) - (signal (ccl::make-semaphore)) - (quoted-insert nil)) - -(defstruct (buffer-operation (:include ccl::dll-node)) - (thunk nil)) - -(defstruct (event-queue-node (:include ccl::dll-node) - (:constructor make-event-queue-node (event))) - event) - -(defun event-queue-insert (q node) - (ccl::locked-dll-header-enqueue node q) - (ccl::signal-semaphore (frame-event-queue-signal q))) - -(defun enqueue-key-event (q event) - (event-queue-insert q (make-event-queue-node event))) - -(defun dequeue-key-event (q) - (unless (listen-editor-input q) - (let* ((document (buffer-document (current-buffer)))) - (when document - (document-set-point-position document)))) - (ccl::wait-on-semaphore (frame-event-queue-signal q)) - (ccl::locked-dll-header-dequeue q)) - - -(defun unget-key-event (event q) - (ccl::with-locked-dll-header (q) - (ccl::insert-dll-node-after (make-event-queue-node event) q)) - (ccl::signal-semaphore (frame-event-queue-signal q))) - -(defun timed-wait-for-key-event (q seconds) - (let* ((signal (frame-event-queue-signal q))) - (when (ccl:timed-wait-on-semaphore signal seconds) - (ccl:signal-semaphore signal) - t))) - -(defvar *command-key-event-buffer* nil) - - - (defun buffer-windows (buffer) (let* ((doc (buffer-document buffer))) @@ -54,7 +12,6 @@ (document-panes doc)))) -(defvar *current-window* ()) +(defvar *window-list* ()) -(defvar *window-list* ()) (defun current-window () "Return the current window. The current window is specially treated by @@ -62,5 +19,5 @@ recentering, ensuring that the Buffer-Point of the current window's Window-Buffer is always displayed. This may be set with Setf." - *current-window*) + (hemlock-view-pane *current-view*)) (defun %set-current-window (new-window) @@ -68,48 +25,25 @@ (invoke-hook hemlock::set-window-hook new-window) (activate-hemlock-view new-window) - (setq *current-window* new-window)) + (setf (hemlock-view-pane *current-view*) new-window)) ;;; This is a public variable. ;;; -(defvar *last-key-event-typed* () - "This variable contains the last key-event typed by the user and read as - input.") -(defvar *input-transcript* ()) +(defun last-key-event-typed () + "This function returns the last key-event typed by the user and read as input." + (hemlock-last-key-event-typed *current-view*)) + +(defun %set-last-key-event-typed (key) + (setf (hemlock-last-key-event-typed *current-view*) key)) + +(defun hemlock::last-char-typed () + (let ((key (hemlock-last-key-event-typed *current-view*))) + (when key (hemlock-ext:key-event-char key)))) + (defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G")) -(defmacro abort-key-event-p (key-event) - `(member (event-queue-node-event ,key-event) editor-abort-key-events)) - (defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift")) -(defun get-key-event (q &optional ignore-pending-aborts) - (do* ((e (dequeue-key-event q) (dequeue-key-event q))) - ((typep e 'event-queue-node) - (unless ignore-pending-aborts - (when (abort-key-event-p e) - (beep) - (clear-echo-area) - (throw 'editor-top-level-catcher nil))) - (values (setq *last-key-event-typed* (event-queue-node-event e)) - (prog1 (frame-event-queue-quoted-insert q) - (setf (frame-event-queue-quoted-insert q) nil)))) - (if (typep e 'buffer-operation) - (catch 'command-loop-catcher - (funcall (buffer-operation-thunk e)))))) - -(defun recursive-get-key-event (q &optional ignore-pending-aborts) - (let* ((buffer *command-key-event-buffer*) - (doc (when buffer (buffer-document buffer)))) - (if (null doc) - (get-key-event q ignore-pending-aborts) - (unwind-protect - (progn - (document-end-editing doc) - (get-key-event q ignore-pending-aborts)) - (document-begin-editing doc))))) - - (defun listen-editor-input (q) (ccl::with-locked-dll-header (q) @@ -123,10 +57,4 @@ (setf (font-region-node region) node) region))) - -(defun enable-self-insert (q) - (setf (frame-event-queue-quoted-insert q) t)) - -(defmethod disable-self-insert ((q frame-event-queue)) - (setf (frame-event-queue-quoted-insert q) nil)) (defun remove-font-region (region) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7833) @@ -42,5 +42,5 @@ With prefix argument insert the character that many times." "Implements ``Self Insert'', calling this function is not meaningful." - (let ((char (hemlock-ext:key-event-char *last-key-event-typed*))) + (let ((char (last-char-typed))) (unless char (editor-error "Can't insert that character.")) (if (and p (> p 1)) @@ -53,7 +53,6 @@ "Causes the next character typed to be inserted in the current buffer, even if would normally be interpreted as an editor command." - "Reads a key-event from *editor-input* and inserts it at the point." (declare (ignore p)) - (hi::enable-self-insert hi::*editor-input*)) + (setf (hi::hemlock-view-quote-next-p hi::*current-view*) t)) (defcommand "Forward Character" (p) @@ -182,5 +181,5 @@ (t (move-mark - mark (buffer-start-mark (line-buffer (mark-line mark))))))) + mark (buffer-start-mark (mark-buffer mark)))))) (do ((cnt offset (1- cnt))) ((zerop cnt) mark) @@ -234,10 +233,8 @@ ;;;; Moving around: -(defvar *target-column* 0) - (defun set-target-column (mark) (if (eq (last-command-type) :line-motion) - *target-column* - (setq *target-column* (mark-column mark)))) + (hi::hemlock-target-column hi::*current-view*) + (setf (hi::hemlock-target-column hi::*current-view*) (mark-column mark)))) (defhvar "Next Line Inserts Newlines" @@ -430,18 +427,9 @@ - -;;; -(defun reset-window-display-recentering (window &optional buffer) - (declare (ignore buffer)) - (setf (window-display-recentering window) nil)) -;;; -(add-hook window-buffer-hook #'reset-window-display-recentering) - - (defcommand "Extended Command" (p) "Prompts for and executes an extended command." "Prompts for and executes an extended command. The prefix argument is passed to the command." - (let* ((name (prompt-for-keyword (list *command-names*) + (let* ((name (prompt-for-keyword :tables (list *command-names*) :prompt "Extended Command: " :help "Name of a Hemlock command")) @@ -453,83 +441,88 @@ :value 4) +(defstruct (prefix-argument-state (:conc-name "PS-")) + sign + multiplier + read-some-digit-p + ;; This is NIL if haven't started and don't have a universal argument, else a number + result + ;; This is cleared by prefix-argument-resetting-state (called at the start of each + ;; command) and can be set by a command to avoid the state being reset at + ;; the end of the command. + set-p) + +(defun prefix-argument-resetting-state (&optional (ps (current-prefix-argument-state))) + "Fetches the prefix argument and uses it up, i.e. marks it as not being set" + (unless (ps-set-p ps) + (setf (ps-sign ps) 1 + (ps-multiplier ps) 1 + (ps-read-some-digit-p ps) nil + (ps-result ps) nil)) + (setf (ps-set-p ps) nil) ;; mark it for death unless explicitly revived. + (when (ps-result ps) + (* (ps-sign ps) + (expt (value universal-argument-default) (ps-multiplier ps)) + (if (ps-read-some-digit-p ps) + (ps-result ps) + 1)))) + +(defun note-prefix-argument-set (ps) + (assert (ps-result ps)) + (setf (ps-set-p ps) t) + #+GZ (gui::log-debug "Note prefix argument set: ~s" ps) + (message (with-output-to-string (s) + (dotimes (i (ps-multiplier ps)) + (write-string "C-U " s)) + (cond ((ps-read-some-digit-p ps) + (format s "~d" (* (ps-sign ps) (ps-result ps)))) + ((< (ps-sign ps) 0) + (write-string "-" s)))))) + (defcommand "Universal Argument" (p) "Sets prefix argument for next command. - Typing digits, regardless of any modifier keys, specifies the argument. - Optionally, you may first type a sign (- or +). While typing digits, if you - type C-U or C-u, the digits following the C-U form a number this command - multiplies by the digits preceding the C-U. The default value for this - command and any number following a C-U is the value of \"Universal Argument - Default\"." - "You probably don't want to use this as a function." - (declare (ignore p)) - (clear-echo-area) - (write-string "C-U " *echo-area-stream*) - (let* ((key-event (get-key-event hi::*editor-input*)) - (char (hemlock-ext:key-event-char key-event))) - (if char - (case char - (#\- - (write-char #\- *echo-area-stream*) - (universal-argument-loop (get-key-event hi::*editor-input*) -1)) - (#\+ - (write-char #\+ *echo-area-stream*) - (universal-argument-loop (get-key-event hi::*editor-input*) -1)) - (t - (universal-argument-loop key-event 1))) - (universal-argument-loop key-event 1)))) - -(defcommand "Negative Argument" (p) - "This command is equivalent to invoking \"Universal Argument\" and typing - a minus sign (-). It waits for more digits and a command to which to give - the prefix argument." - "Don't call this as a function." - (when p (editor-error "Must type minus sign first.")) - (clear-echo-area) - (write-string "C-U -" *echo-area-stream*) - (universal-argument-loop (get-key-event hi::*editor-input*) -1)) + Typing digits, regardless of any modifier keys, specifies the argument. + Optionally, you may first type a sign (- or +). While typing digits, if you + type C-U or C-u, the digits following the C-U form a number this command + multiplies by the digits preceding the C-U. The default value for this + command and any number following a C-U is the value of \"Universal Argument + Default\"." + (declare (ignore p)) ;; we operate on underlying state instead + (let ((ps (current-prefix-argument-state))) + (if (ps-result ps) + (incf (ps-multiplier ps)) + (setf (ps-result ps) 0)) + (note-prefix-argument-set ps))) (defcommand "Argument Digit" (p) "This command is equivalent to invoking \"Universal Argument\" and typing - the digit used to invoke this command. It waits for more digits and a + the key used to invoke this command. It waits for more digits and a command to which to give the prefix argument." - "Don't call this as a function." - (declare (ignore p)) - (clear-echo-area) - (write-string "C-U " *echo-area-stream*) - (universal-argument-loop *last-key-event-typed* 1)) - -(defun universal-argument-loop (key-event sign &optional (multiplier 1)) - (flet ((prefix (sign multiplier read-some-digit-p result) - ;; read-some-digit-p and (zerop result) are not - ;; equivalent if the user invokes this and types 0. - (* sign multiplier - (if read-some-digit-p - result - (value universal-argument-default))))) - (let* ((stripped-key-event (if key-event (hemlock-ext:make-key-event key-event))) - (char (hemlock-ext:key-event-char stripped-key-event)) - (digit (if char (digit-char-p char))) - (result 0) - (read-some-digit-p nil)) - (loop - (cond (digit - (setf read-some-digit-p t) - (write-char char *echo-area-stream*) - (setf result (+ digit (* 10 result))) - (setf key-event (get-key-event hi::*editor-input*)) - (setf stripped-key-event (if key-event - (hemlock-ext:make-key-event key-event))) - (setf char (hemlock-ext:key-event-char stripped-key-event)) - (setf digit (if char (digit-char-p char)))) - ((or (eq key-event #k"C-u") (eq key-event #k"C-U")) - (write-string " C-U " *echo-area-stream*) - (universal-argument-loop - (get-key-event hi::*editor-input*) 1 - (prefix sign multiplier read-some-digit-p result)) - (return)) - (t - (unget-key-event key-event hi::*editor-input*) - (setf (prefix-argument) - (prefix sign multiplier read-some-digit-p result)) - (return)))))) - (setf (last-command-type) (last-command-type))) + (declare (ignore p)) ;; we operate on underlying state instead + (let* ((ps (current-prefix-argument-state)) + (key-event (last-key-event-typed)) + (stripped-key-event (hemlock-ext:make-key-event key-event)) + (char (hemlock-ext:key-event-char stripped-key-event)) + (digit (if char (digit-char-p char)))) + (when (null (ps-result ps)) + (setf (ps-result ps) 0)) + (case char + (#\- + (when (ps-read-some-digit-p ps) ;; could just insert it up front... + (editor-error "Must type minus sign first.")) + (setf (ps-sign ps) (- (ps-sign ps)))) + (#\+ + (when (ps-read-some-digit-p ps) ;; could just insert it up front... + (editor-error "Must type plus sign first."))) + (t + (unless digit + (editor-error "Argument Digit must be bound to a digit!")) + (setf (ps-read-some-digit-p ps) t) + (setf (ps-result ps) (+ digit (* (ps-result ps) 10))))) + (note-prefix-argument-set ps))) + +(defcommand "Digit" (p) + "With a numeric argument, this command extends the argument. + Otherwise it does self insert" + (if p + (argument-digit-command p) + (self-insert-command p))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp (revision 7833) @@ -223,5 +223,5 @@ "Implements \"Completion Self Insert\". Calling this function is not meaningful." - (let ((char (hemlock-ext:key-event-char *last-key-event-typed*))) + (let ((char (last-char-typed))) (unless char (editor-error "Can't insert that character.")) (cond ((completion-char-p char) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/decls.lisp (revision 7833) @@ -62,5 +62,5 @@ ;;; Some special variables are forward-referenced, and we don't even ;;; need to invent a new language to advise the compiler of that ... -(declaim (special *mode-names* *current-buffer* *echo-area-buffer* +(declaim (special *mode-names* *current-buffer* *the-sentinel* *in-the-editor* *buffer-list* *things-to-do-once* Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp (revision 7833) @@ -59,5 +59,5 @@ (declare (ignore p)) (multiple-value-bind (nam cmd) - (prompt-for-keyword (list *command-names*) + (prompt-for-keyword :tables (list *command-names*) :prompt "Command: " :help "Name of command to look for.") @@ -150,5 +150,5 @@ (multiple-value-bind (nam com) (prompt-for-keyword - (list *command-names*) + :tables (list *command-names*) :prompt "Describe command: " :help "Name of a command to document.") @@ -176,32 +176,15 @@ which is prompted for." (declare (ignore p)) - (let ((old-window (current-window))) - (unwind-protect - (progn - (setf (current-window) hi::*echo-area-window*) - (hi::display-prompt-nicely "Describe key: " nil) - (setf (fill-pointer hi::*prompt-key*) 0) - (loop - (let ((key-event (get-key-event hi::*editor-input*))) - (vector-push-extend key-event hi::*prompt-key*) - (let ((res (get-command hi::*prompt-key* :current))) - (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*) - (write-char #\space *echo-area-stream*) - (cond ((commandp res) - (with-pop-up-display (s :title "Key documentation") - (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s) - (format s " is bound to ~S.~%" (command-name res)) - (format s "Documentation for this command:~% ~A" - (command-documentation res))) - (return)) - ((not (eq res :prefix)) - (with-pop-up-display (s :height 1) - (hemlock-ext:print-pretty-key (copy-seq hi::*prompt-key*) s) - (write-string " is not bound to anything." s)) - (return))))))) - (setf (current-window) old-window)))) - - - + (multiple-value-bind (key res) (prompt-for-command-key) + (cond ((commandp res) + (with-pop-up-display (s :title "Key documentation") + (hemlock-ext:print-pretty-key key s) + (format s " is bound to ~S.~%" (command-name res)) + (format s "Documentation for this command:~% ~A" + (command-documentation res)))) + (t + (with-pop-up-display (s :height 1) + (hemlock-ext:print-pretty-key key s) + (write-string " is not bound to anything." s)))))) ;;;; Generic describe variable, command, key, attribute. @@ -222,5 +205,5 @@ (declare (ignore p)) (multiple-value-bind (ignore kwd) - (prompt-for-keyword *generic-describe-kinds* + (prompt-for-keyword :tables *generic-describe-kinds* :default "Variable" :help "Kind of thing to describe." @@ -235,5 +218,5 @@ (multiple-value-bind (name attr) (prompt-for-keyword - (list *character-attribute-names*) + :tables (list *character-attribute-names*) :help "Name of character attribute to describe." :prompt "Attribute: ") @@ -309,5 +292,5 @@ (declare (ignore p)) (let ((name (or name - (prompt-for-keyword (list *mode-names*) + (prompt-for-keyword :tables (list *mode-names*) :prompt "Mode: " :help "Enter mode to describe." Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 7833) @@ -14,113 +14,22 @@ ;;; Modified by Bill Chiles. ;;; +;;; Totally rewritten for Clozure CL. + (in-package :hemlock-internals) -(defmode "Echo Area" :major-p t) -(defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area")) - "Buffer used to hack text for the echo area.") -(defvar *echo-area-region* (buffer-region *echo-area-buffer*) - "Internal thing that's the *echo-area-buffer*'s region.") -(defvar *echo-area-stream* - (make-hemlock-output-stream (region-end *echo-area-region*) :full) - "Buffered stream that prints into the echo area.") -(defvar *echo-area-window* () - "Window used to display stuff in the echo area.") -(defvar *parse-starting-mark* - (copy-mark (buffer-point *echo-area-buffer*) :right-inserting) - "Mark that points to the beginning of the text that'll be parsed.") -(defvar *parse-input-region* - (region *parse-starting-mark* (region-end *echo-area-region*)) - "Region that contains the text typed in.") - - - - -;;;; Variables that control parsing: - -(defvar *parse-verification-function* '%not-inside-a-parse - "Function that verifies what's being parsed.") - (defmacro modifying-echo-buffer (&body body) - `(unwind-protect - (progn - (buffer-document-begin-editing *echo-area-buffer*) - (modifying-buffer *echo-area-buffer* ,@body)) - (buffer-document-end-editing *echo-area-buffer*))) -;;; %Not-Inside-A-Parse -- Internal -;;; -;;; This function is called if someone does stuff in the echo area when -;;; we aren't inside a parse. It tries to put them back in a reasonable place. -;;; -(defun %not-inside-a-parse (quaz) - "Thing that's called when somehow we get called to confirm a parse that's - not in progress." - (declare (ignore quaz)) - (let* ((bufs (remove *echo-area-buffer* *buffer-list*)) - (buf (or (find-if #'buffer-windows bufs) - (car bufs) - (make-buffer "Main")))) - (setf (current-buffer) buf) - (dolist (w *window-list*) - (when (and (eq (window-buffer w) *echo-area-buffer*) - (not (eq w *echo-area-window*))) - (setf (window-buffer w) buf))) - (setf (current-window) - (or (car (buffer-windows buf)) - (make-window (buffer-start-mark buf))))) - (editor-error "Wham! We tried to confirm a parse that wasn't in progress?")) - -(defvar *parse-string-tables* () - "String tables being used in the current parse.") - -(defvar *parse-value-must-exist* () - "You know.") - -(defvar *parse-default* () - "When the user attempts to default a parse, we call the verification function - on this string. This is not the :Default argument to the prompting function, - but rather a string representation of it.") - -(defvar *parse-default-string* () - "String that we show the user to inform him of the default. If this - is NIL then we just use *Parse-Default*.") - -(defvar *parse-prompt* () - "Prompt for the current parse.") - -(defvar *parse-help* () - "Help string for the current parse.") - -(defvar *parse-type* :string "A hack. :String, :File or :Keyword.") - - - - -;;;; MESSAGE and CLEAR-ECHO-AREA: - -(defhvar "Message Pause" "The number of seconds to pause after a Message." - :value 0.0s0) - -(defvar *last-message-time* 0 - "Internal-Real-Time the last time we displayed a message.") - -(defun maybe-wait () - (let* ((now (get-internal-real-time)) - (delta (/ (float (- now *last-message-time*)) - (float internal-time-units-per-second))) - (pause (value hemlock::message-pause))) - (when (< delta pause) - (sleep (- pause delta))))) + `(modifying-buffer-storage ((hemlock-echo-area-buffer *current-view*)) + ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Echo area output. + +(defvar *last-message-time* (get-internal-real-time)) (defun clear-echo-area () "You guessed it." - ;;(maybe-wait) - (let* ((b (current-buffer))) - (unwind-protect - (progn - (setf (current-buffer) *echo-area-buffer*) - (modifying-echo-buffer - (delete-region *echo-area-region*)) - (setf (buffer-modified *echo-area-buffer*) nil)) - (setf (current-buffer) b)))) + (modifying-echo-buffer + (delete-region (buffer-region *current-buffer*)))) ;;; Message -- Public @@ -131,32 +40,13 @@ (defun message (string &rest args) "Nicely display a message in the echo-area. - Put the message on a fresh line and wait for \"Message Pause\" seconds - to give the luser a chance to see it. String and Args are a format - control string and format arguments, respectively." - ;(maybe-wait) - (modifying-echo-buffer - (cond ((eq *current-window* *echo-area-window*) - (let ((point (buffer-point *echo-area-buffer*))) - (with-mark ((m point :left-inserting)) - (line-start m) - (with-output-to-mark (s m :full) - (apply #'format s string args) - (fresh-line s))))) - (t - (let ((mark (region-end *echo-area-region*))) - (cond ((buffer-modified *echo-area-buffer*) - (clear-echo-area)) - ((not (zerop (mark-charpos mark))) - (insert-character mark #\newline) - (clear-echo-area))) - (write-string (apply #'format nil string args) - *echo-area-stream*) - ;; keep command loop from clearing the echo area, - ;; by asserting that the echo area buffer's unmodified. - (setf (buffer-modified *echo-area-buffer*) t)))) - (force-output *echo-area-stream*) - (setq *last-message-time* (get-internal-real-time))) - nil) - + String and Args are a format control string and format arguments, respectively." + ;; TODO: used to do something cleverish if in the middle of reading prompted input, might + ;; want to address that. + (let ((message (apply #'format nil string args))) + (modifying-echo-buffer + (delete-region (buffer-region *current-buffer*)) + (insert-string (buffer-point *current-buffer*) message) + (setq *last-message-time* (get-internal-real-time)) + ))) ;;; LOUD-MESSAGE -- Public. @@ -168,11 +58,39 @@ doing anything else." (beep) - (clear-echo-area) (apply #'message args)) - - - - +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Echo area input + +(defmode "Echo Area" :major-p t) + + +(defstruct (echo-parse-state (:conc-name "EPS-")) + (parse-verification-function nil) + (parse-string-tables ()) + (parse-value-must-exist ()) + ;; When the user attempts to default a parse, we call the verification function + ;; on this string. This is not the :Default argument to the prompting function, + ;; but rather a string representation of it. + (parse-default ()) + ;; String that we show the user to inform him of the default. If this + ;; is NIL then we just use Parse-Default. + (parse-default-string ()) + ;; Prompt for the current parse. + (parse-prompt ()) + ;; Help string for the current parse. + (parse-help ()) + ;; A hack. :String, :File or :Keyword. + (parse-type :string) + ;; input region + parse-starting-mark + parse-input-region + ;; Store result here + (parse-results ())) + +(defun current-echo-parse-state (&key (must-exist t)) + (or (hemlock-prompted-input-state *current-view*) + (and must-exist (error "Can't do that when not in echo area input")))) @@ -180,39 +98,90 @@ ;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING. -(defun display-prompt-nicely (&optional (prompt *parse-prompt*) - (default (or *parse-default-string* - *parse-default*))) - (clear-echo-area) +(defun display-prompt-nicely (eps &optional (prompt (eps-parse-prompt eps)) + (default (or (eps-parse-default-string eps) + (eps-parse-default eps)))) (modifying-echo-buffer - (let ((point (buffer-point *echo-area-buffer*))) - (if (listp prompt) - (apply #'format *echo-area-stream* prompt) - (insert-string point prompt)) + (let* ((buffer *current-buffer*) + (point (buffer-point buffer))) + (delete-region (buffer-region buffer)) + (insert-string point (if (listp prompt) + (apply #'format nil prompt) + prompt)) (when default (insert-character point #\[) (insert-string point default) - (insert-string point "] "))))) - -(defun parse-for-something () - (display-prompt-nicely) - (let ((start-window (current-window))) - (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*)) - (setf (current-window) *echo-area-window*) - (unwind-protect - (use-buffer *echo-area-buffer* - (recursive-edit nil)) - - (setf (current-window) start-window)))) - - - + (insert-string point "] ")) + (move-mark (eps-parse-starting-mark eps) point)))) + +;; This is used to prevent multiple buffers trying to do echo area input +;; at the same time - there would be no way to exit the earlier one +;; without exiting the later one, because they're both on the same stack. +(defvar *recursive-edit-view* nil) + +(defun parse-for-something (&key verification-function + type + string-tables + value-must-exist + default-string + default + prompt + help) + ;; We can't do a "recursive" edit in more than one view, because if the earlier + ;; one wants to exit first, we'd have to unwind the stack to allow it to exit, + ;; which would force the later one to exit whether it wants to or not. + (when (and *recursive-edit-view* (not (eq *recursive-edit-view* *current-view*))) + (editor-error "~s is already waiting for input" + (buffer-name (hemlock-view-buffer *recursive-edit-view*)))) + (modifying-echo-buffer + (let* ((old-eps (hemlock-prompted-input-state *current-view*)) + (parse-mark (copy-mark (buffer-point *current-buffer*) :right-inserting)) + (end-mark (buffer-end-mark *current-buffer*)) + (eps (make-echo-parse-state + :parse-starting-mark parse-mark + :parse-input-region (region parse-mark end-mark) + :parse-verification-function verification-function + :parse-type type + :parse-string-tables string-tables + :parse-value-must-exist value-must-exist + :parse-default-string default-string + :parse-default default + :parse-prompt prompt + :parse-help help))) + ;; TODO: There is really no good reason to disallow recursive edits in the same + ;; buffer, I'm just too lazy. Should save contents, starting mark, and point, + ;; and restore them at the end. + (when old-eps + (editor-error "Attempt to recursively use echo area")) + (unwind-protect + (let ((*recursive-edit-view* *current-view*)) + (setf (hemlock-prompted-input-state *current-view*) eps) + (display-prompt-nicely eps) + (modifying-buffer-storage (nil) + (gui::event-loop #'(lambda () (eps-parse-results eps)))) + #+gz (gui::log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps))) + (setf (hemlock-prompted-input-state *current-view*) old-eps) + (delete-mark parse-mark)) + (let ((results (eps-parse-results eps))) + (if (listp results) + (apply #'values results) + (abort-to-toplevel)))))) + +(defun exit-echo-parse (eps results) + #+gz (gui::log-debug "~&exit echo parse, results = ~s" results) + ;; Must be set to non-nil to indicate parse done. + (setf (eps-parse-results eps) (or results '(nil))) + (gui::stop-event-loop) ;; this just marks it for dead then returns. + ;; this exits current event, and since the event loop is stopped, it + ;; will exit the event loop, which will return to parse-for-something, + ;; which will notice we have the result set and will handle it accordingly. + (exit-event-handler)) ;;;; Buffer prompting. -(defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t) - default - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Buffer: ") - ((:help *parse-help*) "Type a buffer name.")) +(defun prompt-for-buffer (&key (must-exist t) + default + default-string + (prompt "Buffer: ") + (help "Type a buffer name.")) "Prompts for a buffer name and returns the corresponding buffer. If :must-exist is nil, then return the input string. This refuses to accept @@ -221,28 +190,27 @@ when :must-exist is non-nil, :default-string must be the name of an existing buffer." - (let ((*parse-string-tables* (list *buffer-names*)) - (*parse-type* :keyword) - (*parse-default* (cond - (default (buffer-name default)) - (*parse-default-string* - (when (and *parse-value-must-exist* - (not (getstring *parse-default-string* - *buffer-names*))) - (error "Default-string must name an existing ~ - buffer when must-exist is non-nil -- ~S." - *parse-default-string*)) - *parse-default-string*) - (t nil))) - (*parse-verification-function* #'buffer-verification-function)) - (parse-for-something))) - -(defun buffer-verification-function (string) + (when (and must-exist + (not default) + (not (getstring default-string *buffer-names*))) + (error "Default-string must name an existing buffer when must-exist is non-nil -- ~S." + default-string)) + (parse-for-something + :verification-function #'buffer-verification-function + :type :keyword + :string-tables (list *buffer-names*) + :value-must-exist must-exist + :default-string default-string + :default (if default (buffer-name default) default-string) + :prompt prompt + :help help)) + +(defun buffer-verification-function (eps string) (declare (simple-string string)) (modifying-echo-buffer (cond ((string= string "") nil) - (*parse-value-must-exist* + ((eps-parse-value-must-exist eps) (multiple-value-bind (prefix key value field ambig) - (complete-string string *parse-string-tables*) + (complete-string string (eps-parse-string-tables eps)) (declare (ignore field)) (ecase key @@ -251,11 +219,12 @@ (list value)) (:ambiguous - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) prefix) - (let ((point (current-point))) - (move-mark point (region-start *parse-input-region*)) - (unless (character-offset point ambig) - (buffer-end point))) - nil)))) + (let ((input-region (eps-parse-input-region eps))) + (delete-region input-region) + (insert-string (region-start input-region) prefix) + (let ((point (current-point))) + (move-mark point (region-start input-region)) + (unless (character-offset point ambig) + (buffer-end point))) + nil))))) (t (list (or (getstring string *buffer-names*) string)))))) @@ -266,30 +235,35 @@ ;;;; File Prompting. -(defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t) +(defun prompt-for-file (&key (must-exist t) default - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Filename: ") - ((:help *parse-help*) "Type a file name.")) + default-string + (prompt "Filename: ") + (help "Type a file name.")) "Prompts for a filename." - (let ((*parse-verification-function* #'file-verification-function) - (*parse-default* (if default (namestring default))) - (*parse-type* :file)) - (parse-for-something))) - -(defun file-verification-function (string) - (let ((pn (pathname-or-lose string))) + (parse-for-something + :verification-function #'file-verification-function + :type :file + :string-tables nil + :value-must-exist must-exist + :default-string default-string + :default (if default (namestring default)) + :prompt prompt + :help help)) + +(defun file-verification-function (eps string) + (let ((pn (pathname-or-lose eps string))) (if pn (let ((merge - (cond ((not *parse-default*) nil) + (cond ((not (eps-parse-default eps)) nil) ((directoryp pn) - (merge-pathnames pn *parse-default*)) + (merge-pathnames pn (eps-parse-default eps))) (t (merge-pathnames pn (or (directory-namestring - *parse-default*) + (eps-parse-default eps)) "")))))) (cond ((probe-file pn) (list pn)) ((and merge (probe-file merge)) (list merge)) - ((not *parse-value-must-exist*) (list (or merge pn))) + ((not (eps-parse-value-must-exist eps)) (list (or merge pn))) (t nil)))))) @@ -299,6 +273,5 @@ ;;; an editor-error. ;;; -(defun pathname-or-lose (string) - (declare (simple-string string)) +(defun pathname-or-lose (eps string) (multiple-value-bind (pn idx) (parse-namestring string nil *default-pathname-defaults* @@ -306,6 +279,6 @@ (cond (pn) (t (modifying-echo-buffer - (delete-characters (region-end *echo-area-region*) - (- idx (length string)))) + (delete-characters (region-end (eps-input-region eps)) + (- idx (length string)))) nil)))) @@ -315,27 +288,39 @@ ;;;; Keyword and variable prompting. -(defun prompt-for-keyword (*parse-string-tables* - &key - ((:must-exist *parse-value-must-exist*) t) - ((:default *parse-default*)) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Keyword: ") - ((:help *parse-help*) "Type a keyword.")) +(defun prompt-for-keyword (&key + tables + (must-exist t) + default + default-string + (prompt "Keyword: ") + (help "Type a keyword.")) "Prompts for a keyword using the String Tables." - (let ((*parse-verification-function* #'keyword-verification-function) - (*parse-type* :keyword)) - (parse-for-something))) - -(defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t) - ((:default *parse-default*)) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Variable: ") - ((:help *parse-help*) - "Type the name of a variable.")) + (parse-for-something + :verification-function #'keyword-verification-function + :type :keyword + :string-tables tables + :value-must-exist must-exist + :default-string default-string + :default default + :prompt prompt + :help help)) + + + +(defun prompt-for-variable (&key (must-exist t) + default + default-string + (prompt "Variable: ") + (help "Type the name of a variable.")) "Prompts for a variable defined in the current scheme of things." - (let ((*parse-string-tables* (current-variable-tables)) - (*parse-verification-function* #'keyword-verification-function) - (*parse-type* :keyword)) - (parse-for-something))) + (parse-for-something + :verification-function #'keyword-verification-function + :type :keyword + :string-tables (current-variable-tables) + :value-must-exist must-exist + :default-string default-string + :default default + :prompt prompt + :help help)) (defun current-variable-tables () @@ -348,12 +333,12 @@ ((null mode) tables))) -(defun keyword-verification-function (string) +(defun keyword-verification-function (eps string) (declare (simple-string string)) (multiple-value-bind (prefix key value field ambig) - (complete-string string *parse-string-tables*) + (complete-string string (eps-parse-string-tables eps)) (declare (ignore field)) (modifying-echo-buffer - (cond (*parse-value-must-exist* + (cond ((eps-parse-value-must-exist eps) (ecase key (:none nil) @@ -361,11 +346,12 @@ (list prefix value)) (:ambiguous - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) prefix) - (let ((point (current-point))) - (move-mark point (region-start *parse-input-region*)) - (unless (character-offset point ambig) - (buffer-end point))) - nil))) + (let ((input-region (eps-parse-input-region eps))) + (delete-region input-region) + (insert-string (region-start input-region) prefix) + (let ((point (current-point))) + (move-mark point (region-start input-region)) + (unless (character-offset point ambig) + (buffer-end point))) + nil)))) (t ;; HACK: If it doesn't have to exist, and the completion does not @@ -379,19 +365,25 @@ ;;;; Integer, expression, and string prompting. -(defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t) +(defun prompt-for-integer (&key (must-exist t) default - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Integer: ") - ((:help *parse-help*) "Type an integer.")) + default-string + (prompt "Integer: ") + (help "Type an integer.")) "Prompt for an integer. If :must-exist is Nil, then we return as a string whatever was input if it is not a valid integer." - (let ((*parse-verification-function* - #'(lambda (string) - (let ((number (parse-integer string :junk-allowed t))) - (if *parse-value-must-exist* - (if number (list number)) - (list (or number string)))))) - (*parse-default* (if default (write-to-string default :base 10)))) - (parse-for-something))) + + (parse-for-something + :verification-function #'(lambda (eps string) + (let ((number (parse-integer string :junk-allowed t))) + (if (eps-parse-value-must-exist eps) + (if number (list number)) + (list (or number string))))) + :type :string + :string-tables nil + :value-must-exist must-exist + :default-string default-string + :default (if default (write-to-string default :base 10)) + :prompt prompt + :help help)) @@ -399,38 +391,48 @@ "An object that won't be EQ to anything read.") -(defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t) +(defun prompt-for-expression (&key (must-exist t) (default nil defaultp) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Expression: ") - ((:help *parse-help*) - "Type a Lisp expression.")) + default-string + (prompt "Expression: ") + (help "Type a Lisp expression.")) "Prompts for a Lisp expression." - (let ((*parse-verification-function* - #'(lambda (string) - (let ((expr (with-input-from-region (stream *parse-input-region*) - (handler-case (read stream nil hemlock-eof) - (error () hemlock-eof))))) - (if *parse-value-must-exist* - (if (not (eq expr hemlock-eof)) (values (list expr) t)) - (if (eq expr hemlock-eof) - (list string) (values (list expr) t)))))) - (*parse-default* (if defaultp (prin1-to-string default)))) - (parse-for-something))) - - -(defun prompt-for-string (&key ((:default *parse-default*)) - ((:default-string *parse-default-string*)) + (parse-for-something + :verification-function #'(lambda (eps string) + (let* ((input-region (eps-parse-input-region eps)) + (expr (with-input-from-region (stream input-region) + (handler-case (read stream nil hemlock-eof) + (error () hemlock-eof))))) + (if (eq expr hemlock-eof) + (unless (eps-parse-value-must-exist eps) (list string)) + (values (list expr) t)))) + :type :string + :string-tables nil + :value-must-exist must-exist + :default-string default-string + :default (if defaultp (prin1-to-string default)) + :prompt prompt + :help help)) + + +(defun prompt-for-string (&key default + default-string (trim ()) - ((:prompt *parse-prompt*) "String: ") - ((:help *parse-help*) "Type a string.")) + (prompt "String: ") + (help "Type a string.")) "Prompts for a string. If :trim is t, then leading and trailing whitespace is removed from input, otherwise it is interpreted as a Char-Bag argument to String-Trim." - (let ((*parse-verification-function* - #'(lambda (string) - (list (string-trim (if (eq trim t) '(#\space #\tab) trim) - string))))) - (parse-for-something))) - + (when (eq trim t) (setq trim '(#\space #\tab))) + (parse-for-something + :verification-function #'(lambda (eps string) + (declare (ignore eps)) + (list (string-trim trim string))) + :type :string + :string-tables nil + :value-must-exist nil + :default-string default-string + :default default + :prompt prompt + :help help)) @@ -447,9 +449,10 @@ #|| -(defun prompt-for-package (&key ((:must-exist *parse-value-must-exist*) t) - (default nil defaultp) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Package Name:") - ((:help *parse-help*) "Type a package name.")) +(defun prompt-for-package (&key (must-exist t) + (default nil defaultp) + default-string + (prompt "Package Name:") + (help "Type a package name.")) +) ||# @@ -461,24 +464,27 @@ (make-string-table :initial-contents '(("Yes" . t) ("No" . nil)))) -(defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t) +(defun prompt-for-yes-or-no (&key (must-exist t) (default nil defaultp) - ((:default-string *parse-default-string*)) - ((:prompt *parse-prompt*) "Yes or No? ") - ((:help *parse-help*) "Type Yes or No.")) + default-string + (prompt "Yes or No? ") + (help "Type Yes or No.")) "Prompts for Yes or No." - (let* ((*parse-string-tables* (list *yes-or-no-string-table*)) - (*parse-default* (if defaultp (if default "Yes" "No"))) - (*parse-verification-function* - #'(lambda (string) - (multiple-value-bind - (prefix key value field ambig) - (complete-string string *parse-string-tables*) - (declare (ignore prefix field ambig)) - (let ((won (or (eq key :complete) (eq key :unique)))) - (if *parse-value-must-exist* - (if won (values (list value) t)) - (list (if won (values value t) string))))))) - (*parse-type* :keyword)) - (parse-for-something))) + (parse-for-something + :verification-function #'(lambda (eps string) + (multiple-value-bind + (prefix key value field ambig) + (complete-string string (eps-parse-string-tables eps)) + (declare (ignore prefix field ambig)) + (let ((won (or (eq key :complete) (eq key :unique)))) + (if (eps-parse-value-must-exist eps) + (if won (values (list value) t)) + (list (if won (values value t) string)))))) + :type :keyword + :string-tables (list *yes-or-no-string-table*) + :value-must-exist must-exist + :default-string default-string + :default (if defaultp (if default "Yes" "No")) + :prompt prompt + :help help)) (defun prompt-for-y-or-n (&key ((:must-exist must-exist) t) @@ -532,5 +538,4 @@ (when change-window (setf (current-window) old-window))))) -(defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0)) (defun prompt-for-key (&key ((:must-exist must-exist) t) default default-string @@ -547,6 +552,5 @@ (setf (current-window) *echo-area-window*) (display-prompt-nicely prompt string) - (setf (fill-pointer *prompt-key*) 0) - (prog ((key *prompt-key*) key-event) + (prog ((key (make-array 10 :adjustable t :fill-pointer 0)) key-event) (declare (vector key)) TOP @@ -587,4 +591,20 @@ (setf (current-window) old-window)))) +(defun prompt-for-command-key () + (let ((old-window (current-window))) + (unwind-protect + (let ((prompt-key (make-array 10 :adjustable t :fill-pointer 0))) + (setf (current-window) hi::*echo-area-window*) + (hi::display-prompt-nicely "Describe key: " nil) + (loop + (let ((key-event (get-key-event hi::*editor-input*))) + (vector-push-extend key-event prompt-key) + (let ((res (get-command prompt-key :current))) + (hemlock-ext:print-pretty-key-event key-event *echo-area-stream*) + (write-char #\space *echo-area-stream*) + (unless (eq res :prefix) + (return (values (copy-seq prompt-key) res))))))) + (setf (current-window) old-window)))) + @@ -693,6 +713,4 @@ (define-logical-key-event "Backward Search" "This key-event is used to indicate that a backward search should be made.") -(define-logical-key-event "Recursive Edit" - "This key-event indicates that a recursive edit should be entered.") (define-logical-key-event "Cancel" "This key-event is used to cancel a previous key-event of input.") Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp (revision 7833) @@ -23,5 +23,6 @@ "File types to ignore when trying to complete a filename." :value - (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err" + (list "fasl" "cfsl" "dfsl" "cfasl" + "pmaxf" "sparcf" "rtf" "hpf" "axpf" "sgif" "err" "x86f" "lbytef" "core" "trace" ; Lisp "BAK" "CKP" ; Backups & Checkpoints @@ -56,4 +57,11 @@ ((null table) res))) +(defun get-parse-input-string (eps) + (region-to-string (eps-parse-input-region eps))) + +(defun replace-parse-input-string (eps string) + (delete-region (eps-parse-input-region eps)) + (insert-string (eps-parse-starting-mark eps) string)) + (defcommand "Help on Parse" (p) "Display help for parse in progress. @@ -62,13 +70,15 @@ input." (declare (ignore p)) - (let ((help (typecase *parse-help* - (list (unless *parse-help* (error "There is no parse help.")) - (apply #'format nil *parse-help*)) - (string *parse-help*) - (t (error "Parse help is not a string or list: ~S" *parse-help*)))) - (input (region-to-string *parse-input-region*))) + (let* ((eps (current-echo-parse-state)) + (raw-help (eps-parse-help eps)) + (help (typecase raw-help + (null (error "There is no parse help.")) + (list (apply #'format nil raw-help)) + (string raw-help) + (t (error "Parse help is not a string or list: ~S" raw-help)))) + (input (get-parse-input-string eps))) (cond - ((eq *parse-type* :keyword) - (let ((strings (find-all-completions input *parse-string-tables*))) + ((eq (eps-parse-type eps) :keyword) + (let ((strings (find-all-completions input (eps-parse-string-tables eps)))) (with-pop-up-display (s :title "input help" :height (+ (length strings) 2)) (write-line help s) @@ -78,9 +88,7 @@ (write-line string s))) (t - (write-line - "There are no possible completions of what you have typed." s)))))) - ((and (eq *parse-type* :file) (not (zerop (length input)))) - (let ((pns (ambiguous-files (region-to-string *parse-input-region*) - *parse-default*))) + (write-line "There are no possible completions of what you have typed." s)))))) + ((and (eq (eps-parse-type eps) :file) (not (zerop (length input)))) + (let ((pns (ambiguous-files input (eps-parse-default eps)))) (declare (list pns)) (with-pop-up-display(s :title "Completion help" :height (+ (length pns) 2)) @@ -103,12 +111,10 @@ (file-namestring pn) dir))))) (t - (write-line - "There are no possible completions of what you have typed." s)))))) + (write-line "There are no possible completions of what you have typed." s)))))) (t - (with-mark ((m (buffer-start-mark *echo-area-buffer*) :left-inserting)) - (insert-string m help) - (insert-character m #\newline)))))) - -(defun file-completion-action (typein) + (with-pop-up-display (s :title "input help" :height 2) + (write-line help s)))))) + +(defun file-completion-action (eps typein) (declare (simple-string typein)) (when (zerop (length typein)) (editor-error)) @@ -116,10 +122,8 @@ (result win) (hemlock-ext:complete-file typein - :defaults (directory-namestring *parse-default*) + :defaults (directory-namestring (eps-parse-default eps)) :ignore-types (value ignore-file-types)) (when result - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) - (namestring result))) + (replace-parse-input-string eps (namestring result))) (when (and (not win) (value beep-on-ambiguity)) (editor-error)))) @@ -131,18 +135,17 @@ If it is ambiguous and ``Beep On Ambiguity'' true beep." (declare (ignore p)) - (let ((typein (region-to-string *parse-input-region*))) + (let* ((eps (current-echo-parse-state)) + (typein (get-parse-input-string eps))) (declare (simple-string typein)) - (case *parse-type* + (case (eps-parse-type eps) (:keyword - (multiple-value-bind - (prefix key value field ambig) - (complete-string typein *parse-string-tables*) + (multiple-value-bind (prefix key value field ambig) + (complete-string typein (eps-parse-string-tables eps)) (declare (ignore value field)) (when prefix - (delete-region *parse-input-region*) - (insert-string (region-start *parse-input-region*) prefix) + (replace-parse-input-string eps prefix) (when (eq key :ambiguous) (let ((point (current-point))) - (move-mark point (region-start *parse-input-region*)) + (move-mark point (eps-parse-starting-mark eps)) (unless (character-offset point ambig) (buffer-end point))))) @@ -151,5 +154,5 @@ (editor-error)))) (:file - (file-completion-action typein)) + (file-completion-action eps typein)) (t (editor-error "Cannot complete input for this prompt."))))) @@ -166,30 +169,27 @@ separated by characters having a non-zero :parse-field-separator attribute, and this command should only be bound to characters having that attribute." - (let ((typein (region-to-string *parse-input-region*))) + (let* ((eps (current-echo-parse-state)) + (typein (get-parse-input-string eps))) (declare (simple-string typein)) - (case *parse-type* + (case (eps-parse-type eps) (:string (self-insert-command p)) (:file - (file-completion-action typein)) + (file-completion-action eps typein)) (:keyword (let ((point (current-point))) (unless (blank-after-p point) - (insert-character point - (hemlock-ext:key-event-char *last-key-event-typed*)))) + (insert-character point (last-char-typed)))) (multiple-value-bind (prefix key value field ambig) - (complete-string typein *parse-string-tables*) + (complete-string typein (eps-parse-string-tables eps)) (declare (ignore value ambig)) (when (eq key :none) (editor-error "No possible completion.")) - (delete-region *parse-input-region*) (let ((new-typein (if (and (eq key :unique) (null field)) (subseq prefix 0 field) (concatenate 'string (subseq prefix 0 field) - (string - (hemlock-ext:key-event-char - *last-key-event-typed*)))))) - (insert-string (region-start *parse-input-region*) new-typein)))) + (string (last-char-typed)))))) + (replace-parse-input-string eps new-typein)))) (t (editor-error "Cannot complete input for this prompt."))))) @@ -197,4 +197,5 @@ +;;; *** TODO: this needs to be view-local (defvar *echo-area-history* (make-ring 10) "This ring-buffer contains strings which were previously input in the @@ -203,4 +204,5 @@ (defvar *echo-history-pointer* 0 "This is our current position to the ring during a historical exploration.") + (defcommand "Confirm Parse" (p) @@ -210,16 +212,17 @@ otherwise calls the verification function." (declare (ignore p)) - (let* ((string (region-to-string *parse-input-region*)) + (let* ((eps (current-echo-parse-state)) + (string (get-parse-input-string eps)) (empty (zerop (length string)))) (declare (simple-string string)) (if empty - (when *parse-default* (setq string *parse-default*)) + (when (eps-parse-default eps) (setq string (eps-parse-default eps))) (when (or (zerop (ring-length *echo-area-history*)) (string/= string (ring-ref *echo-area-history* 0))) (ring-push string *echo-area-history*))) (multiple-value-bind (res flag) - (funcall *parse-verification-function* string) + (funcall (eps-parse-verification-function eps) eps string) (unless (or res flag) (editor-error)) - (exit-recursive-edit res)))) + (exit-echo-parse eps res)))) (defcommand "Previous Parse" (p) @@ -228,20 +231,17 @@ of the ring then push it on the ring before inserting the new input." "Pop the *echo-area-history* ring buffer." - (let ((length (ring-length *echo-area-history*)) - (p (or p 1))) + (let* ((eps (current-echo-parse-state)) + (length (ring-length *echo-area-history*)) + (p (or p 1))) (when (zerop length) (editor-error)) (cond ((eq (last-command-type) :echo-history) (let ((base (mod (+ *echo-history-pointer* p) length))) - (delete-region *parse-input-region*) - (insert-string (region-end *parse-input-region*) - (ring-ref *echo-area-history* base)) + (replace-parse-input-string eps (ring-ref *echo-area-history* base)) (setq *echo-history-pointer* base))) (t - (let ((current (region-to-string *parse-input-region*)) + (let ((current (get-parse-input-string eps)) (base (mod (if (minusp p) p (1- p)) length))) - (delete-region *parse-input-region*) - (insert-string (region-end *parse-input-region*) - (ring-ref *echo-area-history* base)) + (replace-parse-input-string eps (ring-ref *echo-area-history* base)) (when (and (plusp (length current)) (string/= (ring-ref *echo-area-history* 0) current)) @@ -266,35 +266,29 @@ (editor-error)) -(add-hook window-buffer-hook - #'(lambda (window new-buff) - (when (and (eq window *echo-area-window*) - (not (eq new-buff *echo-area-buffer*))) - (editor-error "Can't change echo area window.")))) - (defcommand "Beginning Of Parse" (p) "Moves to immediately after the prompt when in the echo area." "Move the point of the echo area buffer to *parse-starting-mark*." (declare (ignore p)) - (move-mark (buffer-point *echo-area-buffer*) *parse-starting-mark*)) + (let* ((eps (current-echo-parse-state)) + (start (eps-parse-starting-mark eps))) + (move-mark (current-point) start))) (defcommand "Echo Area Delete Previous Character" (p) - "Delete the previous character. - Don't let the luser rub out the prompt." - "Signal an editor-error if we would nuke the prompt, - otherwise do a normal delete." - (with-mark ((tem (buffer-point *echo-area-buffer*))) - (unless (character-offset tem (- (or p 1))) (editor-error)) - (when (mark< tem *parse-starting-mark*) (editor-error)) - (delete-previous-character-command p))) + "Delete the previous character, up to the prompt." + (let* ((eps (current-echo-parse-state)) + (start (eps-parse-starting-mark eps))) + (with-mark ((tem (current-point))) + (unless (character-offset tem (- (or p 1))) (editor-error)) + (when (mark< tem start) (editor-error)) + (delete-previous-character-command p)))) (defcommand "Echo Area Kill Previous Word" (p) - "Kill the previous word. - Don't let the luser rub out the prompt." - "Signal an editor-error if we would mangle the prompt, otherwise - do a normal kill-previous-word." - (with-mark ((tem (buffer-point *echo-area-buffer*))) - (unless (word-offset tem (- (or p 1))) (editor-error)) - (when (mark< tem *parse-starting-mark*) (editor-error)) - (kill-previous-word-command p))) + "Kill the previous word, up to the prompt." + (let* ((eps (current-echo-parse-state)) + (start (eps-parse-starting-mark eps))) + (with-mark ((tem (current-point))) + (unless (word-offset tem (- (or p 1))) (editor-error)) + (when (mark< tem start) (editor-error)) + (kill-previous-word-command p)))) (declaim (special *kill-ring*)) @@ -304,27 +298,32 @@ "Kills *parse-input-region*." (declare (ignore p)) - (if (end-line-p (current-point)) - (kill-region *parse-input-region* :kill-backward) - (ring-push (delete-and-save-region *parse-input-region*) - *kill-ring*))) + (let* ((eps (current-echo-parse-state))) + (if (end-line-p (current-point)) + (kill-region (eps-parse-input-region eps) :kill-backward) + (ring-push (delete-and-save-region (eps-parse-input-region eps)) + *kill-ring*)))) (defcommand "Insert Parse Default" (p) "Inserts the default for the parse in progress. The text is inserted at the point." - "Inserts *parse-default* at the point of the *echo-area-buffer*. - If there is no default an editor-error is signalled." - (declare (ignore p)) - (unless *parse-default* (editor-error)) - (insert-string (buffer-point *echo-area-buffer*) *parse-default*)) + (declare (ignore p)) + (let* ((eps (current-echo-parse-state)) + (default (eps-parse-default eps))) + (unless default (editor-error)) + (insert-string (current-point) default))) (defcommand "Echo Area Backward Character" (p) "Go back one character. - Don't let the luser move into the prompt." + Don't let the luser move into the prompt." "Signal an editor-error if we try to go into the prompt, otherwise - do a backward-character command." - (backward-character-command p) - (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) - (beginning-of-parse-command ()) - (editor-error))) + do a backward-character command." + (let* ((eps (current-echo-parse-state)) + (start (eps-parse-starting-mark eps)) + (point (current-point))) + (when (mark<= point start) + (editor-error)) + (backward-character-command p) + (when (mark< point start) + (beginning-of-parse-command nil)))) (defcommand "Echo Area Backward Word" (p) @@ -333,6 +332,10 @@ "Signal an editor-error if we try to go into the prompt, otherwise do a backward-word command." - (backward-word-command p) - (when (mark< (buffer-point *echo-area-buffer*) *parse-starting-mark*) - (beginning-of-parse-command ()) - (editor-error))) + (let* ((eps (current-echo-parse-state)) + (start (eps-parse-starting-mark eps)) + (point (current-point))) + (when (mark<= point start) + (editor-error)) + (backward-word-command p) + (when (mark< point start) + (beginning-of-parse-command nil)))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/edit-defs.lisp (revision 7833) @@ -106,5 +106,5 @@ (declare (ignore key)) (values (command-name cmd) cmd)) - (prompt-for-keyword (list *command-names*) + (prompt-for-keyword :tables (list *command-names*) :prompt "Command to edit: ")) (go-to-definition (fun-defined-from-pathname (command-function command)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/filecoms.lisp (revision 7833) @@ -379,22 +379,4 @@ ;;;; Find file. - -(defcommand "Old Find File" (p &optional pathname) - "Visit a file in its own buffer. - If the file is already in some buffer, select that buffer, - otherwise make a new buffer with the same name as the file and - read the file into it." - "Make a buffer containing the file Pathname current, creating a buffer - if necessary. The buffer is returned." - (declare (ignore p)) - (let* ((pn (or pathname - (prompt-for-file - :prompt "Find File: " - :must-exist nil - :help "Name of file to read into its own buffer." - :default (buffer-default-pathname (current-buffer))))) - (buffer (find-file-buffer pn))) - (change-to-buffer buffer) - buffer)) (defcommand "Find File" (p &optional pathname) @@ -633,7 +615,7 @@ "Writes the contents of the current buffer to the associated file." (declare (ignore p)) - (let* ((document (hi::buffer-document buffer))) - (when document - (when (buffer-modified buffer) + (when (buffer-modified buffer) + (let* ((document (hi::buffer-document buffer))) + (when document (hi::save-hemlock-document document))))) @@ -668,12 +650,4 @@ (message "Saved ~S file~:P." saved-count)))) -(defcommand "Save All Files and Exit" (p) - "Save all modified buffers in their associated files and exit; - a combination of \"Save All Files\" and \"Exit Hemlock\"." - "Do a save-all-files-command and then an exit-hemlock." - (declare (ignore p)) - (save-all-files-command ()) - (exit-hemlock)) - (defcommand "Backup File" (p) "Write the buffer to a file without changing the associated name." @@ -693,130 +667,4 @@ ;;;; Buffer hacking commands: -(defvar *buffer-history* () - "A list of buffers, in order from most recently to least recently selected.") - -(defun previous-buffer () - "Returns some previously selected buffer that is not the current buffer. - Returns nil if no such buffer exists." - (let ((b (car *buffer-history*))) - (or (if (eq b (current-buffer)) (cadr *buffer-history*) b) - (find-if-not #'(lambda (x) - (or (eq x (current-buffer)) - (eq x *echo-area-buffer*))) - (the list *buffer-list*))))) - -;;; ADD-BUFFER-HISTORY-HOOK makes sure every buffer will be visited by -;;; "Circulate Buffers" even if it has never been before. -;;; -(defun add-buffer-history-hook (buffer) - (let ((ele (last *buffer-history*)) - (new-stuff (list buffer))) - (if ele - (setf (cdr ele) new-stuff) - (setf *buffer-history* new-stuff)))) -;;; -(add-hook make-buffer-hook 'add-buffer-history-hook) - -;;; DELETE-BUFFER-HISTORY-HOOK makes sure we never end up in a dead buffer. -;;; -(defun delete-buffer-history-hook (buffer) - (setq *buffer-history* (delq buffer *buffer-history*))) -;;; -(add-hook delete-buffer-hook 'delete-buffer-history-hook) - -(defun change-to-buffer (buffer) - "Switches to buffer in the current window maintaining *buffer-history*." - (setq *buffer-history* - (cons (current-buffer) (delq (current-buffer) *buffer-history*))) - (setf (current-buffer) buffer) - (setf (window-buffer (current-window)) buffer)) - -(defun delete-buffer-if-possible (buffer) - "Deletes a buffer if at all possible. If buffer is the only buffer, other - than the echo area, signals an error. Otherwise, find some recently current - buffer, and make all of buffer's windows display this recent buffer. If - buffer is current, set the current buffer to be this recently current - buffer." - (let ((new-buf (flet ((frob (b) - (or (eq b buffer) (eq b *echo-area-buffer*)))) - (or (find-if-not #'frob (the list *buffer-history*)) - (find-if-not #'frob (the list *buffer-list*)))))) - (unless new-buf - (error "Cannot delete only buffer ~S." buffer)) - (dolist (w (buffer-windows buffer)) - (setf (window-buffer w) new-buf)) - (when (eq buffer (current-buffer)) - (setf (current-buffer) new-buf))) - (delete-buffer buffer)) - - -(defvar *create-buffer-count* 0) - -(defcommand "Create Buffer" (p &optional buffer-name) - "Create a new buffer. If a buffer with the specified name already exists, - then go to it." - "Create or go to the buffer with the specifed name." - (declare (ignore p)) - (let ((name (or buffer-name - (prompt-for-buffer :prompt "Create Buffer: " - :default-string - (format nil "Buffer ~D" - (incf *create-buffer-count*)) - :must-exist nil)))) - (if (bufferp name) - (change-to-buffer name) - (change-to-buffer (or (getstring name *buffer-names*) - (make-buffer name)))))) - -(defcommand "Select Buffer" (p) - "Select a different buffer. - The buffer to go to is prompted for." - "Select a different buffer. - The buffer to go to is prompted for." - (declare (ignore p)) - (let ((buf (prompt-for-buffer :prompt "Select Buffer: " - :default (previous-buffer)))) - (when (eq buf *echo-area-buffer*) - (editor-error "Cannot select Echo Area buffer.")) - (change-to-buffer buf))) - - -(defvar *buffer-history-ptr* () - "The successively previous buffer to the current buffer.") - -(defcommand "Select Previous Buffer" (p) - "Select the buffer selected before this one. If called repeatedly - with an argument, select the successively previous buffer to the - current one leaving the buffer history as it is." - "Select the buffer selected before this one." - (if p - (circulate-buffers-command nil) - (let ((b (previous-buffer))) - (unless b (editor-error "No previous buffer.")) - (change-to-buffer b) - ;; - ;; If the pointer goes to nil, then "Circulate Buffers" will keep doing - ;; "Select Previous Buffer". - (setf *buffer-history-ptr* (cddr *buffer-history*)) - (setf (last-command-type) :previous-buffer)))) - -(defcommand "Circulate Buffers" (p) - "Advance through buffer history, selecting successively previous buffer." - "Advance through buffer history, selecting successively previous buffer." - (declare (ignore p)) - (if (and (eq (last-command-type) :previous-buffer) - *buffer-history-ptr*) ;Possibly nil if never CHANGE-TO-BUFFER. - (let ((b (pop *buffer-history-ptr*))) - (when (eq b (current-buffer)) - (setf b (pop *buffer-history-ptr*))) - (unless b - (setf *buffer-history-ptr* - (or (cdr *buffer-history*) *buffer-history*)) - (setf b (car *buffer-history*))) - (setf (current-buffer) b) - (setf (window-buffer (current-window)) b) - (setf (last-command-type) :previous-buffer)) - (select-previous-buffer-command nil))) - (defcommand "Buffer Not Modified" (p) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/files.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/files.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/files.lisp (revision 7833) @@ -33,7 +33,9 @@ (buffer (line-%buffer first-line))) (modifying-buffer buffer) - (cocoa-read-file pathname mark buffer)))) - - + (with-open-file (input pathname :direction :input :element-type 'character) + (do ((line (read-line input nil :eof) (read-line input nil :eof))) + ((eql line :eof)) + (insert-string mark line) + (insert-character mark #\newline)))))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/hemlock-ext.lisp (revision 7833) @@ -665,10 +665,13 @@ (return i)))) +#-clozure (defun delq (item list) (delete item list :test #'eq)) +#-clozure (defun memq (item list) (member item list :test #'eq)) +#-clozure (defun assq (item alist) (assoc item alist :test #'eq)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext1.lisp (revision 7833) @@ -114,4 +114,7 @@ (defvar *cache-modification-tick* -1 "The counter for the fixnums we stick in the chars of the cached line.") + +(defun next-cache-modification-tick () + (ccl::atomic-decf *cache-modification-tick*)) (defun open-line (line mark) @@ -171,5 +174,5 @@ (unless (and (= (mark-charpos ,mark) (current-left-open-pos)) (current-open-line-p ,line)) (open-line ,line ,mark)) - (setf (line-chars (current-open-line)) (decf *cache-modification-tick*)))) + (setf (line-chars (current-open-line)) (next-cache-modification-tick)))) ;;; Now-Tick tells us when now is and isn't. @@ -182,20 +185,4 @@ -(defun buffer-document-begin-editing (buffer) - (when (bufferp buffer) - (let* ((document (buffer-document buffer))) - (when document - (lock-buffer buffer) - (document-begin-editing document))))) - -(defun buffer-document-end-editing (buffer) - (when (bufferp buffer) - (let* ((document (buffer-document buffer))) - (when document - (unlock-buffer buffer) - (document-end-editing document))))) - - - ;;; Yeah, the following is kind of obscure, but at least it doesn't ;;; call Bufferp twice. The without-interrupts is just to prevent @@ -422,4 +409,7 @@ (error "~S is an invalid mark type." kind))))) +(defun mark-buffer (mark) + (line-buffer (mark-line mark))) + (defun copy-mark (mark &optional (kind (mark-%kind mark))) "Returns a new mark pointing to the same position as Mark. The kind @@ -469,9 +459,12 @@ "``Buffer'' given to lines in regions not in any buffer.") +(defun next-disembodied-buffer-counter () + (ccl::atomic-incf *disembodied-buffer-counter*)) + (defun make-empty-region () "Returns a region with start and end marks pointing to the start of one empty line. The start mark is right-inserting and the end mark is left-inserting." (let* ((line (make-line :chars "" :number 0 - :%buffer (incf *disembodied-buffer-counter*))) + :%buffer (next-disembodied-buffer-counter))) (start (mark line 0 :right-inserting)) (end (mark line 0 :left-inserting))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext2.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext2.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/htext2.lisp (revision 7833) @@ -67,5 +67,5 @@ (declare (simple-string string)) (do* ((index 0) - (buffer (incf *disembodied-buffer-counter*)) + (buffer (next-disembodied-buffer-counter)) (previous-line) (line (make-line :%buffer buffer)) @@ -243,5 +243,5 @@ mark) -(defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark)))) +(defun buffer-start (mark &optional (buffer (mark-buffer mark))) "Change Mark to point to the beginning of Buffer, which defaults to the buffer Mark is currently in." @@ -249,5 +249,5 @@ (move-mark mark (buffer-start-mark buffer))) -(defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark)))) +(defun buffer-end (mark &optional (buffer (mark-buffer mark))) "Change Mark to point to the end of Buffer, which defaults to the buffer Mark is currently in." @@ -392,5 +392,5 @@ (defun %print-before-mark (mark stream) - (let* ((hi::*current-buffer* (line-buffer (mark-line mark)))) + (let* ((hi::*current-buffer* (mark-buffer mark))) (if (mark-line mark) (let* ((line (mark-line mark)) @@ -415,5 +415,5 @@ (defun %print-after-mark (mark stream) - (let* ((hi::*current-buffer* (line-buffer (mark-line mark)))) + (let* ((hi::*current-buffer* (mark-buffer mark))) (if (mark-line mark) (let* ((line (mark-line mark)) @@ -446,5 +446,5 @@ (defun %print-hmark (structure stream d) (declare (ignore d)) - (let ((hi::*current-buffer* (line-buffer (mark-line structure)))) + (let ((hi::*current-buffer* (mark-buffer structure))) (write-string "# (length *kbdmac-text*) 1) - (kbdmac-emit `(insert-string-at-point - ,(key-vector-to-string *kbdmac-text*))) - (kbdmac-emit `(insert-character-at-point - ,(hemlock-ext:key-event-char (aref *kbdmac-text* 0)))))))) -;;; -(define-kbdmac-transform "Self Insert" #'self-insert-kbdmac-transform) -(define-kbdmac-transform "Lisp Insert )" #'self-insert-kbdmac-transform) - -;;;; Do-Nothing transform: -;;; -;;; These are useful for prefix-argument setting commands, since they have -;;; no semantics at macro-time. -;;; -(defun do-nothing-kbdmac-transform (command key) - (case key - (:invoke - (funcall (command-function command) (prefix-argument))))) -;;; -(define-kbdmac-transform "Argument Digit" #'do-nothing-kbdmac-transform) -(define-kbdmac-transform "Negative Argument" #'do-nothing-kbdmac-transform) -(define-kbdmac-transform "Universal Argument" #'do-nothing-kbdmac-transform) - - -;;;; Multiplicative transform -;;; -;;; Repititions of many commands can be turned into a call with an -;;; argument. -;;; -(defvar *kbdmac-count* 0 - "The number of occurrences we have counted of a given command.") - -(defun multiplicative-kbdmac-transform (command key) - (case key - (:start - (setq *kbdmac-count* 0)) - (:invoke - (let ((p (or (prefix-argument) 1))) - (funcall (command-function command) p) - (incf *kbdmac-count* p))) - (:finish - (kbdmac-emit `(,(command-function command) ,*kbdmac-count*))))) -;;; -(define-kbdmac-transform "Forward Character" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Character" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Forward Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Uppercase Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Lowercase Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Capitalize Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Kill Next Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Kill Previous Word" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Forward Kill Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Kill Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Forward Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Backward Form" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Delete Next Character" - #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Delete Previous Character" - #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Delete Previous Character Expanding Tabs" - #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Next Line" #'multiplicative-kbdmac-transform) -(define-kbdmac-transform "Previous Line" #'multiplicative-kbdmac-transform) - - -;;;; Vanilla transform -;;; -;;; These commands neither read input nor look at random silly variables. -;;; -(defun vanilla-kbdmac-transform (command key) - (case key - (:invoke - (let ((fun (command-function command)) - (p (prefix-argument))) - (funcall fun p) - (kbdmac-emit `(,fun ,p)))))) -;;; -(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "End of Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Indent for Lisp" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Delete Horizontal Space" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Kill Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Backward Kill Line" #'vanilla-kbdmac-transform) -(define-kbdmac-transform "Un-Kill" #'vanilla-kbdmac-transform) - - -;;;; MAKE-KBDMAC, INTERACTIVE, and kbdmac command loop. - -;;; Kbdmac-Command-Loop -- Internal -;;; -;;; Bind *invoke-hook* to call kbdmac transforms. -;;; -(defun kbdmac-command-loop () - (let* ((last-transform nil) - (last-command nil) - (last-ctype nil) - (*old-invoke-hook* *invoke-hook*) - (*invoke-hook* - #'(lambda (res p) - (declare (ignore p)) - (when (and (not (eq last-command res)) last-transform) - (funcall last-transform last-command :finish)) - (if (last-command-type) - (setq last-ctype t) - (when last-ctype - (kbdmac-emit '(clear-command-type)) - (setq last-ctype nil))) - (setq last-transform - (gethash res *kbdmac-transforms* #'default-kbdmac-transform)) - (unless (eq last-command res) - (funcall last-transform res :start)) - (funcall last-transform res :invoke) - (setq last-command res)))) - (declare (special *invoke-hook*)) - (setf (last-command-type) nil) - (recursive-edit nil))) - -(defun clear-command-type () - (setf (last-command-type) nil)) - - -(defvar *defining-a-keyboard-macro* ()) -(defvar *kbdmac-stream* #+later (make-kbdmac-stream)) -(defvar *in-a-keyboard-macro* () - "True if we are currently executing a keyboard macro.") - -;;; Interactive -- Public -;;; -;;; See whether we are in a keyboard macro. -;;; -(defun interactive () - "Return true if we are in a command invoked by the user. - This is primarily useful for commands which want to know - whether do something when an error happens, or just signal - an Editor-Error." - (not *in-a-keyboard-macro*)) - -(defvar *kbdmac-done* () - "Setting this causes the keyboard macro being executed to terminate - after the current iteration.") - -(defvar *kbdmac-dont-ask* () - "Setting this inhibits \"Keyboard Macro Query\"'s querying.") - -;;; Make-Kbdmac -- Internal -;;; -;;; This guy grabs the stuff lying around in *current-kbdmac* and -;;; whatnot and makes a lexical closure that can be used as the -;;; definition of a command. The prefix argument is a repitition -;;; count. -;;; -(defun make-kbdmac () - (let ((code (nreverse *current-kbdmac*)) - (input (copy-seq *kbdmac-input*))) - (if (zerop (length input)) - #'(lambda (p) - (let ((*in-a-keyboard-macro* t) - (*kbdmac-done* nil) - (*kbdmac-dont-ask* nil)) - (setf (last-command-type) nil) - (catch 'exit-kbdmac - (dotimes (i (or p 1)) - (catch 'abort-kbdmac-iteration - (dolist (form code) - (apply (car form) (cdr form)))) - (when *kbdmac-done* (return nil)))))) - #'(lambda (p) - (let* ((stream (or *kbdmac-stream* (make-kbdmac-stream))) - (*kbdmac-stream* nil) - (hi::*editor-input* stream) - (*in-a-keyboard-macro* t) - (*kbdmac-done* nil) - (*kbdmac-dont-ask* nil)) - (setf (last-command-type) nil) - (catch 'exit-kbdmac - (dotimes (i (or p 1)) - (setq stream (modify-kbdmac-stream stream input)) - (catch 'abort-kbdmac-iteration - (dolist (form code) - (apply (car form) (cdr form)))) - (when *kbdmac-done* (return nil))))))))) - - - - -;;;; Commands. - -(defmode "Def" :major-p nil) - -(defcommand "Define Keyboard Macro" (p) - "Define a keyboard macro." - "Define a keyboard macro." - (declare (ignore p)) - (when *defining-a-keyboard-macro* - (editor-error "Already defining a keyboard macro.")) - (define-keyboard-macro)) - -(defhvar "Define Keyboard Macro Key Confirm" - "When set, \"Define Keyboard Macro Key\" asks for confirmation before - clobbering an existing key binding." - :value t) - -(defcommand "Define Keyboard Macro Key" (p) - "Prompts for a key before going into a mode for defining keyboard macros. - The macro definition is bound to the key. IF the key is already bound, - this asks for confirmation before clobbering the binding." - "Prompts for a key before going into a mode for defining keyboard macros. - The macro definition is bound to the key. IF the key is already bound, - this asks for confirmation before clobbering the binding." - (declare (ignore p)) - (when *defining-a-keyboard-macro* - (editor-error "Already defining a keyboard macro.")) - (multiple-value-bind (key kind where) - (get-keyboard-macro-key) - (when key - (setf (buffer-minor-mode (current-buffer) "Def") t) - (let ((name (format nil "Keyboard Macro ~S" (gensym)))) - (make-command name "This is a user-defined keyboard macro." - (define-keyboard-macro)) - (bind-key name key kind where) - (message "~A bound to ~A." - (with-output-to-string (s) (hemlock-ext:print-pretty-key key s)) - name))))) - -;;; GET-KEYBOARD-MACRO-KEY gets a key from the user and confirms clobbering it -;;; if it is already bound to a command, or it is a :prefix. This returns nil -;;; if the user "aborts", otherwise it returns the key and location (kind -;;; where) of the binding. -;;; -(defun get-keyboard-macro-key () - (let* ((key (prompt-for-key :prompt "Bind keyboard macro to key: " - :must-exist nil))) - (multiple-value-bind (kind where) - (prompt-for-place "Kind of binding: " - "The kind of binding to make.") - (let* ((cmd (get-command key kind where))) - (cond ((not cmd) (values key kind where)) - ((commandp cmd) - (if (prompt-for-y-or-n - :prompt `("~A is bound to ~A. Rebind it? " - ,(with-output-to-string (s) - (hemlock-ext:print-pretty-key key s)) - ,(command-name cmd)) - :default nil) - (values key kind where) - nil)) - ((eq cmd :prefix) - (if (prompt-for-y-or-n - :prompt `("~A is a prefix for more than one command. ~ - Clobber it? " - ,(with-output-to-string (s) - (hemlock-ext:print-pretty-key key s))) - :default nil) - (values key kind where) - nil))))))) - -;;; DEFINE-KEYBOARD-MACRO gets input from the user and clobbers the function -;;; for the "Last Keyboard Macro" command. This returns the new function. -;;; -(defun define-keyboard-macro () - (setf (buffer-minor-mode (current-buffer) "Def") t) - (unwind-protect - (let* ((in *kbdmac-transcript*) - (*input-transcript* in) - (*defining-a-keyboard-macro* t)) - (setf (fill-pointer in) 0) - (setf (fill-pointer *kbdmac-input*) 0) - (setq *current-kbdmac* ()) - (catch 'punt-kbdmac - (kbdmac-command-loop)) - (setf (command-function (getstring "Last Keyboard Macro" *command-names*)) - (make-kbdmac))) - (setf (buffer-minor-mode (current-buffer) "Def") nil))) - - -(defcommand "End Keyboard Macro" (p) - "End the definition of a keyboard macro." - "End the definition of a keyboard macro." - (declare (ignore p)) - (unless *defining-a-keyboard-macro* - (editor-error "Not defining a keyboard macro.")) - (throw 'punt-kbdmac ())) -;;; -(define-kbdmac-transform "End Keyboard Macro" #'do-nothing-kbdmac-transform) - - -(defcommand "Last Keyboard Macro" (p) - "Execute the last keyboard macro defined. - With prefix argument execute it that many times." - "Execute the last keyboard macro P times." - (declare (ignore p)) - (editor-error "No keyboard macro defined.")) - -(defcommand "Name Keyboard Macro" (p &optional name) - "Name the \"Last Keyboard Macro\". - The last defined keboard macro is made into a named command." - "Make the \"Last Keyboard Macro\" a named command." - (declare (ignore p)) - (unless name - (setq name (prompt-for-string - :prompt "Macro name: " - :help "String name of command to make from keyboard macro."))) - (make-command - name "This is a named keyboard macro." - (command-function (getstring "Last Keyboard Macro" *command-names*)))) - -(defcommand "Keyboard Macro Query" (p) - "Keyboard macro conditional. - During the execution of a keyboard macro, this command prompts for - a single character command, similar to those of \"Query Replace\"." - "Prompt for action during keyboard macro execution." - (declare (ignore p)) - (unless (or (interactive) *kbdmac-dont-ask*) - (let ((hi::*editor-input* *real-editor-input*)) - (command-case (:prompt "Keyboard Macro Query: " - :help "Type one of these characters to say what to do:" - :change-window nil - :bind key-event) - (:exit - "Exit this keyboard macro immediately." - (throw 'exit-kbdmac nil)) - (:yes - "Proceed with this iteration of the keyboard macro.") - (:no - "Don't do this iteration of the keyboard macro, but continue to the next." - (throw 'abort-kbdmac-iteration nil)) - (:do-all - "Do all remaining repetitions of the keyboard macro without prompting." - (setq *kbdmac-dont-ask* t)) - (:do-once - "Do this iteration of the keyboard macro and then exit." - (setq *kbdmac-done* t)) - (:recursive-edit - "Do a recursive edit, then ask again." - (do-recursive-edit) - (reprompt)) - (t - (unget-key-event key-event hi::*editor-input*) - (throw 'exit-kbdmac nil)))))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/killcoms.lisp (revision 7833) @@ -128,5 +128,5 @@ (defun %buffer-push-buffer-mark (b mark activate-region) - (cond ((eq (line-buffer (mark-line mark)) b) + (cond ((eq (mark-buffer mark) b) (setf (mark-kind mark) :right-inserting) (let* ((old-mark (hi::buffer-%mark b))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/listener.lisp (revision 7833) @@ -554,7 +554,5 @@ ignored." (declare (ignore p)) - (clear-echo-area) - (write-string "Evaluating buffer in the editor ..." *echo-area-stream*) - (finish-output *echo-area-stream*) + (message "Evaluating buffer in the editor ...") (with-input-from-region (stream (buffer-region (current-buffer))) (let ((*standard-output* *echo-area-stream*)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 7833) @@ -71,5 +71,33 @@ ,@unsets)))) - +;; WITH-BUFFER-BINDINGS +;; +;; Execute body with buffer's bindings in effect. Also binds *current-buffer*, +;; (unless buffer _is_ *current-buffer*) because anything that looks at bindings +;; probably looks at *current-buffer* as well. + +(defmacro with-buffer-bindings ((buffer) &body body) + (let ((buffer-var (gensym))) + `(let ((,buffer-var ,buffer) + ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var)))) + (unwind-protect + (progn + (setup-buffer-bindings ,buffer-var) + ,@body) + (revert-buffer-bindings ,buffer-var))))) + + +;; MODIFYING-BUFFER-STORAGE +;; +;; This is kinda Cocoa-specific, but we'll pretend it's not. It gets wrapped around +;; possible multiple modifications of the buffer's text, so that the OS can defer +;; layout and redisplay until the end. +;; Buffer can be NIL to temporarily turn off the grouping. + +(defmacro modifying-buffer-storage ((buffer) &body body) + (if (eq buffer '*current-buffer*) + `(gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)) + `(let ((*current-buffer* ,buffer)) + (gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))))) @@ -186,12 +214,16 @@ (when (atom lambda-list) (error "Command argument list is not a list: ~S." lambda-list)) - (let (command-name function-name) + (let (command-name function-name extra-args) (cond ((listp name) - (setq command-name (car name) function-name (cadr name)) + (setq command-name (car name) function-name (cadr name)) (unless (symbolp function-name) - (error "Function name is not a symbol: ~S" function-name))) + (error "Function name is not a symbol: ~S" function-name)) + (if (keywordp function-name) + (setq function-name nil extra-args (cdr name)) + (setq extra-args (cddr name)))) (t - (setq command-name name - function-name (bash-string-to-symbol name '-command)))) + (setq command-name name))) + (when (null function-name) + (setq function-name (bash-string-to-symbol command-name '-command))) (unless (stringp command-name) (error "Command name is not a string: ~S." name)) @@ -199,5 +231,5 @@ (defun ,function-name ,lambda-list ,function-doc ,@forms) - (make-command ',name ,command-doc ',function-name) + (make-command ,command-name ,command-doc ',function-name ,@extra-args) ',function-name))) @@ -319,55 +351,12 @@ -(defmacro use-buffer (buffer &body forms) - "Use-Buffer Buffer {Form}* - Has The effect of making Buffer the current buffer during the evaluation - of the Forms. For restrictions see the manual." - (let ((gensym (gensym))) - `(let ((,gensym *current-buffer*) - (*current-buffer* ,buffer)) - (unwind-protect - (progn - (use-buffer-set-up ,gensym) - ,@forms) - (use-buffer-clean-up ,gensym))))) - - - - - ;;;; EDITOR-ERROR. - -(defun print-editor-error (condx s) - (apply #'format s (editor-error-format-string condx) - (editor-error-format-arguments condx))) - -(define-condition editor-error (error) - ((format-string :initform "" :initarg :format-string - :reader editor-error-format-string) - (format-arguments :initform '() :initarg :format-arguments - :reader editor-error-format-arguments)) - (:report print-editor-error)) -;;; -(setf (documentation 'editor-error-format-string 'function) - "Returns the FORMAT control string of the given editor-error condition.") -(setf (documentation 'editor-error-format-arguments 'function) - "Returns the FORMAT arguments for the given editor-error condition.") (defun editor-error (&rest args) "This function is called to signal minor errors within Hemlock; these are errors that a normal user could encounter in the course of editing - such as a search failing or an attempt to delete past the end of the buffer. - This function SIGNAL's an editor-error condition formed from args. Hemlock - invokes commands in a dynamic context with an editor-error condition handler - bound. This default handler beeps or flashes (or both) the display. If - args were supplied, it also invokes MESSAGE on them. The command in - progress is always aborted, and this function never returns." - (let ((condx (make-condition 'editor-error - :format-string (car args) - :format-arguments (cdr args)))) - (signal condx) - (error "Unhandled editor-error was signaled -- ~A." condx))) - - + such as a search failing or an attempt to delete past the end of the buffer." + (let ((message (and args (apply #'format nil args)))) + (abort-current-command message))) @@ -447,5 +436,5 @@ `(progn (setf ,',bind - (prompt-for-key-event* ,',n-prompt ,',n-change)) + (prompt-for-key-event :prompt ,',n-prompt :change-window ,',n-change)) (setf ,',bind-char (hemlock-ext:key-event-char ,',bind)) (go ,',again)))) @@ -453,5 +442,5 @@ (let* ((,n-prompt ,prompt) (,n-change ,change-window) - (,bind (prompt-for-key-event* ,n-prompt ,n-change)) + (,bind (prompt-for-key-event :prompt ,n-prompt :change-window ,n-change)) (,bind-char (hemlock-ext:key-event-char ,bind))) (declare (ignorable ,n-prompt ,n-change ,bind ,bind-char)) @@ -577,26 +566,5 @@ - - ;;;; Error handling stuff. - -(declaim (special *echo-area-stream*)) - -;;; LISP-ERROR-ERROR-HANDLER is in Macros.Lisp instead of Rompsite.Lisp because -;;; it uses WITH-POP-UP-DISPLAY, and Macros is compiled after Rompsite. It -;;; binds an error condition handler to get us out of here on a recursive error -;;; (we are already handling one if we are here). Since COMMAND-CASE uses -;;; EDITOR-ERROR for logical :abort characters, and this is a subtype of ERROR, -;;; we bind an editor-error condition handler just inside of the error handler. -;;; This keeps us from being thrown out into the debugger with supposedly -;;; recursive errors occuring. What we really want in this case is to simply -;;; get back to the command loop and forget about the error we are currently -;;; handling. -;;; - -(defun lisp-error-error-handler (condition &optional internalp) - (declare (ignore internalp)) - (report-hemlock-error condition) - (throw 'editor-top-level-catcher nil)) (defmacro handle-lisp-errors (&body body) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp (revision 7833) @@ -135,13 +135,4 @@ (defhvar "Delete Buffer Hook" "This hook is called with the buffer whenever a buffer is deleted.") - (defhvar "Enter Recursive Edit Hook" - "This hook is called with the new buffer when a recursive edit is - entered.") - (defhvar "Exit Recursive Edit Hook" - "This hook is called with the value returned when a recursive edit - is exited.") - (defhvar "Abort Recursive Edit Hook" - "This hook is called with the editor-error args when a recursive - edit is aborted.") (defhvar "Buffer Major Mode Hook" "This hook is called with the buffer and the new mode when a buffer's @@ -166,9 +157,4 @@ (defhvar "Buffer Package Hook" "This hook is called with the new package name whenever a (Lisp) buffer's package changes") - (defhvar "Set Buffer Hook" - "This hook is called with the new buffer when the current buffer is set.") - (defhvar "After Set Buffer Hook" - "This hook is invoked with the old buffer after the current buffer has - been changed.") (defhvar "Set Window Hook" "This hook is called with the new window when the current window @@ -236,5 +222,14 @@ the pathname fits. \"...\" indicates a truncated pathname." :value nil - :hooks (list 'maximum-modeline-pathname-length-hook))) + :hooks (list 'maximum-modeline-pathname-length-hook)) + (defhvar "Self Insert Command Name" + "The name of the command to invoke to handle quoted input (i.e. after c-q). + By default, this is \"Self Insert\"." + :value "Self Insert") + (defhvar "Default Command Name" + "The name of the command to invoke to handle keys that have no binding + defined. By default, this is \"Illegal\"." + :value "Illegal") + ) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 7833) @@ -108,11 +108,9 @@ (let* ((line-termination-string (case (buffer-line-termination buffer) - ((:unix nil)) - (:macos "CR") - (:cp/m "CRLF"))) - (doc (buffer-document buffer)) - (encoding-name (if doc - (document-encoding-name doc) - "Default"))) + ((:lf nil)) + ((:cr) "CR") + ((:crlf) "CRLF"))) + (encoding-name (or (buffer-encoding-name buffer) + "Default"))) (format nil "[~a~@[ ~a~]] " encoding-name line-termination-string)))) @@ -253,5 +251,4 @@ ;; it only wants to do so if the buffer's modified state changes. ; (add-hook hemlock::buffer-modified-hook 'queue-buffer-change) - (add-hook hemlock::window-buffer-hook 'queue-window-change) ) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/morecoms.lisp (revision 7833) @@ -39,4 +39,12 @@ (declare (ignore p))) + +(defcommand "Abort Command" (p) + "Abort reading a command in current view" + "Aborts c-q, multi-key commands (e.g. c-x), prefix translation (e.g. +ESC as Meta-), prefix arguments (e.g. c-u), ephemeral modes such as +i-search, and prompted input (e.g. m-x)" + (declare (ignore p)) + (abort-to-toplevel)) ;;;; Casing commands... @@ -175,5 +183,6 @@ (defun prompt-for-place (prompt help) (multiple-value-bind (word val) - (prompt-for-keyword *scope-table* :prompt prompt + (prompt-for-keyword :tables *scope-table* + :prompt prompt :help help :default "Global") (declare (ignore word)) @@ -184,5 +193,5 @@ (:mode (values :mode (prompt-for-keyword - (list *mode-names*) + :tables (list *mode-names*) :prompt "Mode: " :help "Mode to be local to." @@ -197,5 +206,5 @@ (multiple-value-call #'bind-key (values (prompt-for-keyword - (list *command-names*) + :tables (list *command-names*) :prompt "Command to bind: " :help "Name of command to bind to a key.")) @@ -259,51 +268,4 @@ (defhvar name doc :value val :hooks hooks) (defhvar name doc kind where :value val :hooks hooks))))) - - - - - -;;; This is used by the :edit-level modeline field which is defined in Main.Lisp. -;;; -(defvar *recursive-edit-count* 0) - -(defun do-recursive-edit () - "Does a recursive edit, wrapping []'s around the modeline of the current - window during its execution. The current window and buffer are saved - beforehand and restored afterward. If they have been deleted by the - time the edit is done then an editor-error is signalled." - (let* ((win (current-window)) - (buf (current-buffer))) - (unwind-protect - (let ((*recursive-edit-count* (1+ *recursive-edit-count*))) - (update-modeline-field *echo-area-buffer* *echo-area-window* - (modeline-field :edit-level)) - (recursive-edit)) - (update-modeline-field *echo-area-buffer* *echo-area-window* - (modeline-field :edit-level)) - (unless (and (member win *window-list*) (memq buf *buffer-list*)) - (editor-error "Old window or buffer has been deleted.")) - (setf (current-window) win) - (unless (eq (window-buffer win) buf) - (setf (window-buffer win) buf)) - (setf (current-buffer) buf)))) - -(defcommand "Exit Recursive Edit" (p) - "Exit a level of recursive edit. Signals an error when not in a - recursive edit." - "Exit a level of recursive edit. Signals an error when not in a - recursive edit." - (declare (ignore p)) - (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) - (exit-recursive-edit ())) - -(defcommand "Abort Recursive Edit" (p) - "Abort the current recursive edit. Signals an error when not in a - recursive edit." - "Abort the current recursive edit. Signals an error when not in a - recursive edit." - (declare (ignore p)) - (unless (in-recursive-edit) (editor-error "Not in a recursive edit!")) - (abort-recursive-edit "Recursive edit aborted.")) @@ -416,162 +378,4 @@ - - - - - -;;;; Mouse Commands. - -(defcommand "Do Nothing" (p) - "Do nothing. - With prefix argument, do it that many times." - "Do nothing p times." - (dotimes (i (or p 1))) - (setf (last-command-type) (last-command-type))) - -(defun do-nothing (&rest args) - (declare (ignore args)) - nil) - -(defun maybe-change-window (window) - (unless (eq window (current-window)) - (when (or (eq window *echo-area-window*) - (eq (current-window) *echo-area-window*) - (member window *random-typeout-buffers* - :key #'(lambda (cons) - (hi::random-typeout-stream-window (cdr cons))))) - (supply-generic-pointer-up-function #'do-nothing) - (editor-error "I'm afraid I can't let you do that Dave.")) - (setf (current-window) window) - (let ((buffer (window-buffer window))) - (unless (eq (current-buffer) buffer) - (setf (current-buffer) buffer))))) - -(defcommand "Top Line to Here" (p) - "Move the top line to the line the mouse is on. - If in the first two columns then scroll continuously until the button is - released." - "Move the top line to the line the mouse is on." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless y (editor-error)) - (cond ((< x 2) - (loop - (when (listen-editor-input hi::*editor-input*) (return)) - (scroll-window window -1) - (redisplay) - (editor-finish-output window))) - (t - (scroll-window window (- y)))))) - -(defcommand "Here to Top of Window" (p) - "Move the line the mouse is on to the top of the window. - If in the first two columns then scroll continuously until the button is - released." - "Move the line the mouse is on to the top of the window." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless y (editor-error)) - (cond ((< x 2) - (loop - (when (listen-editor-input hi::*editor-input*) (return)) - (scroll-window window 1) - (redisplay) - (editor-finish-output window))) - (t - (scroll-window window y))))) - - -(defvar *generic-pointer-up-fun* nil - "This is the function for the \"Generic Pointer Up\" command that defines - its action. Other commands set this in preparation for this command's - invocation.") -;;; -(defun supply-generic-pointer-up-function (fun) - "This provides the action \"Generic Pointer Up\" command performs." - (check-type fun function) - (setf *generic-pointer-up-fun* fun)) - -(defcommand "Generic Pointer Up" (p) - "Other commands determine this command's action by supplying functions that - this command invokes. The following built-in commands supply the following - generic up actions: - \"Point to Here\" - When the position of the pointer is different than the current - point, the action pushes a buffer mark at point and moves point - to the pointer's position. - \"Bufed Goto and Quit\" - The action is a no-op." - "Invoke whatever is on *generic-pointer-up-fun*." - (declare (ignore p)) - (unless *generic-pointer-up-fun* - (editor-error "No commands have supplied a \"Generic Pointer Up\" action.")) - (funcall *generic-pointer-up-fun*)) - - -(defcommand "Point to Here" (p) - "Move the point to the position of the mouse. - If in the modeline, move to the absolute position in the file indicated by - the position within the modeline, pushing the old position on the mark - stack. This supplies a function \"Generic Pointer Up\" invokes if it runs - without any intervening generic pointer up predecessors running. If the - position of the pointer is different than the current point when the user - invokes \"Generic Pointer Up\", then this function pushes a buffer mark at - point and moves point to the pointer's position. This allows the user to - mark off a region with the mouse." - "Move the point to the position of the mouse." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless x (editor-error)) - (maybe-change-window window) - (if y - (let ((m (cursorpos-to-mark x y window))) - (unless m (editor-error)) - (move-mark (current-point) m)) - (let* ((buffer (window-buffer window)) - (region (buffer-region buffer)) - (point (buffer-point buffer))) - (push-buffer-mark (copy-mark point)) - (move-mark point (region-start region)) - (line-offset point (round (* (1- (count-lines region)) x) - (1- (window-width window))))))) - (supply-generic-pointer-up-function #'point-to-here-up-action)) - -(defun point-to-here-up-action () - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless x (editor-error)) - (when y - (maybe-change-window window) - (let ((m (cursorpos-to-mark x y window))) - (unless m (editor-error)) - (when (eq (line-buffer (mark-line (current-point))) - (line-buffer (mark-line m))) - (unless (mark= m (current-point)) - (push-buffer-mark (copy-mark (current-point)) t))) - (move-mark (current-point) m))))) - - -(defcommand "Insert Kill Buffer" (p) - "Move current point to the mouse location and insert the kill buffer." - "Move current point to the mouse location and insert the kill buffer." - (declare (ignore p)) - (multiple-value-bind (x y window) - (last-key-event-cursorpos) - (unless x (editor-error)) - (maybe-change-window window) - (if y - (let ((m (cursorpos-to-mark x y window))) - (unless m (editor-error)) - (move-mark (current-point) m) - (un-kill-command nil)) - (editor-error "Can't insert kill buffer in modeline.")))) - - - - ;;;; Page commands & stuff. @@ -595,6 +399,5 @@ (name (prompt-for-string :prompt "Substring of page title: " :default (if againp - *goto-page-last-string* - *parse-default*))) + *goto-page-last-string*))) (dir (page-directory (current-buffer))) (i 1)) @@ -720,5 +523,5 @@ If the last character was an alphabetic character, then insert its capital form." - (let ((char (char-upcase (hemlock-ext:key-event-char *last-key-event-typed*)))) + (let ((char (char-upcase (last-char-typed)))) (if (and p (> p 1)) (insert-string (current-point) (make-string p :initial-element char)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7833) @@ -30,4 +30,5 @@ #:mark-charpos #:mark-kind + #:mark-buffer #:previous-character #:next-character @@ -69,5 +70,4 @@ #:push-buffer-mark #:change-to-buffer - #:previous-buffer #:make-buffer #:bufferp @@ -89,5 +89,4 @@ #:buffer-package #:delete-buffer - #:delete-buffer-if-possible #:make-modeline-field #:modeline-field-p @@ -185,9 +184,7 @@ #:reverse-find-not-attribute #:character-attribute-hooks - #:current-window #:make-window #:windowp #:delete-window - #:window-buffer #:window-display-start #:window-display-end @@ -238,9 +235,5 @@ #:find-file-buffer ;; #:ed - #:exit-hemlock #:pause-hemlock - #:get-key-event - #:unget-key-event - #:recursive-get-key-event #:clear-editor-input #:listen-editor-input @@ -330,4 +323,6 @@ (:import-from :ext #:complete-file) (:shadow #:char-code-limit) + #+clozure + (:import-from :ccl #:memq #:assq #:delq) ;; (:export @@ -390,5 +385,5 @@ #+sbcl :sb-gray #+scl :ext - #+openmcl :gray + #+clozure :gray ;; ;; Note the pacth i received from DTC mentions character-output and @@ -417,5 +412,5 @@ ;; rompsite.lisp - #:show-mark #:editor-sleep #:*input-transcript* #:fun-defined-from-pathname + #:show-mark #:editor-sleep #:fun-defined-from-pathname #:editor-describe-function #:pause-hemlock #:store-cut-string #:fetch-cut-string #:schedule-event #:remove-scheduled-event @@ -438,6 +433,6 @@ ;; from input.lisp - #:get-key-event #:unget-key-event #:clear-editor-input #:listen-editor-input - #:*last-key-event-typed* #:*key-event-history* + #:clear-editor-input #:listen-editor-input + #:last-key-event-typed #:*key-event-history* #:input-waiting #:last-key-event-cursorpos @@ -448,4 +443,8 @@ #:command-case #:reprompt #:with-output-to-mark #:with-input-from-region #:handle-lisp-errors #:with-pop-up-display #:*random-typeout-buffers* + + ;; from views.lisp + #:hemlock-view #:current-prefix-argument-state + #:abort-to-toplevel #:abort-current-command ;; from line.lisp @@ -489,17 +488,24 @@ ;; echo.lisp - #:*echo-area-buffer* #:*echo-area-stream* #:*echo-area-window* - #:*parse-starting-mark* #:*parse-input-region* - #:*parse-verification-function* #:*parse-string-tables* - #:*parse-value-must-exist* #:*parse-default* #:*parse-default-string* - #:*parse-prompt* #:*parse-help* #:clear-echo-area #:message #:loud-message + #:*echo-area-stream* + #:clear-echo-area #:message #:loud-message + #:current-echo-parse-state #:exit-echo-parse + #:eps-parse-type #:eps-parse-starting-mark #:eps-parse-input-region + #:eps-parse-verification-function #:eps-parse-string-tables + #:eps-parse-default #:eps-parse-help #:prompt-for-buffer #:prompt-for-file #:prompt-for-integer #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n - #:prompt-for-key-event #:prompt-for-key #:*logical-key-event-names* + #:prompt-for-key-event #:prompt-for-key #:prompt-for-command-key + #:*logical-key-event-names* #:logical-key-event-p #:logical-key-event-documentation #:logical-key-event-name #:logical-key-event-key-events - #:define-logical-key-event #:*parse-type* #:current-variable-tables - + #:define-logical-key-event #:current-variable-tables + + + ;; commands + #:make-prefix-argument-state #:prefix-argument-resetting-state + + ;; files.lisp #:read-file #:write-file @@ -540,5 +546,5 @@ #:bind-key #:delete-key-binding #:get-command #:map-bindings #:make-command #:command-name #:command-bindings #:last-command-type - #:prefix-argument #:exit-hemlock #:*invoke-hook* #:key-translation + #:prefix-argument #:*invoke-hook* #:key-translation @@ -546,5 +552,5 @@ #:*global-variable-names* #:*mode-names* #:*buffer-names* #:*character-attribute-names* #:*command-names* #:*buffer-list* - #:*window-list* #:*last-key-event-typed* #:after-editor-initializations + #:*window-list* #:last-key-event-typed #:after-editor-initializations ;; screen.lisp @@ -575,5 +581,5 @@ ;; window.lisp - #:current-window #:window-buffer #:modeline-field-width + #:modeline-field-width #:modeline-field-function #:make-modeline-field #:update-modeline-fields #:update-modeline-field #:modeline-field-name #:modeline-field Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/register.lisp (revision 7833) @@ -75,5 +75,5 @@ (do-registers (name value) (etypecase value - (mark (when (eq (line-buffer (mark-line value)) buffer) + (mark (when (eq (mark-buffer value) buffer) (free-register name))) (cons (free-register-value value buffer))))) @@ -90,5 +90,5 @@ (etypecase value (mark - (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer)) + (when (or (not buffer) (eq (mark-buffer value) buffer)) (delete-mark value))) (cons @@ -121,5 +121,5 @@ (unless (markp val) (editor-error "Register ~A does not hold a location." reg-name)) - (change-to-buffer (line-buffer (mark-line val))) + (change-to-buffer (mark-buffer val)) (move-mark (current-point) val))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp (revision 7833) @@ -87,282 +87,4 @@ (editor-error))) (clear-echo-area))) - - - - -;;;; Incremental searching. - -(defun i-search-pattern (string direction) - (setq *last-search-pattern* - (new-search-pattern (if (value string-search-ignore-case) - :string-insensitive - :string-sensitive) - direction string *last-search-pattern*))) - -;;; %I-SEARCH-ECHO-REFRESH refreshes the echo buffer for incremental -;;; search. -;;; -(defun %i-search-echo-refresh (string direction failure) - (when (interactive) - (clear-echo-area) - (format *echo-area-stream* - "~:[~;Failing ~]~:[~;Overwrapped ~]~:[Reverse I-Search~;I-Search~]: ~A" - failure *search-wrapped-p* (eq direction :forward) string))) - -(defcommand "Incremental Search" (p) - "Searches for input string as characters are provided. - These are the default I-Search command characters: ^Q quotes the - next character typed. Backspace cancels the last character typed. ^S - repeats forward, and ^R repeats backward. ^R or ^S with empty string - either changes the direction or yanks the previous search string. - Escape exits the search unless the string is empty. Escape with - an empty search string calls the non-incremental search command. - Other control characters cause exit and execution of the appropriate - command. If the search fails at some point, ^G and backspace may be - used to backup to a non-failing point; also, ^S and ^R may be used to - look the other way. ^W extends the search string to include the the word - after the point. ^G during a successful search aborts and returns - point to where it started." - "Search for input string as characters are typed in. - It sets up for the recursive searching and checks return values." - (declare (ignore p)) - (setf (last-command-type) nil) - (%i-search-echo-refresh "" :forward nil) - (let* ((*search-wrapped-p* nil) - (point (current-point)) - (save-start (copy-mark point :temporary))) - (with-mark ((here point)) - (when (eq (catch 'exit-i-search - (%i-search "" point here :forward nil)) - :control-g) - (move-mark point save-start) - (invoke-hook abort-hook) - (editor-error)) - (if (region-active-p) - (delete-mark save-start) - (push-buffer-mark save-start))))) - - -(defcommand "Reverse Incremental Search" (p) - "Searches for input string as characters are provided. - These are the default I-Search command characters: ^Q quotes the - next character typed. Backspace cancels the last character typed. ^S - repeats forward, and ^R repeats backward. ^R or ^S with empty string - either changes the direction or yanks the previous search string. - Altmode exits the search unless the string is empty. Altmode with - an empty search string calls the non-incremental search command. - Other control characters cause exit and execution of the appropriate - command. If the search fails at some point, ^G and backspace may be - used to backup to a non-failing point; also, ^S and ^R may be used to - look the other way. ^G during a successful search aborts and returns - point to where it started." - "Search for input string as characters are typed in. - It sets up for the recursive searching and checks return values." - (declare (ignore p)) - (setf (last-command-type) nil) - (%i-search-echo-refresh "" :backward nil) - (let* ((*search-wrapped-p* nil) - (point (current-point)) - (save-start (copy-mark point :temporary))) - (with-mark ((here point)) - (when (eq (catch 'exit-i-search - (%i-search "" point here :backward nil)) - :control-g) - (move-mark point save-start) - (invoke-hook abort-hook) - (editor-error)) - (if (region-active-p) - (delete-mark save-start) - (push-buffer-mark save-start))))) - -;;; %I-SEARCH recursively (with support functions) searches to provide -;;; incremental searching. There is a loop in case the recursion is ever -;;; unwound to some call. curr-point must be saved since point is clobbered -;;; with each recursive call, and the point must be moved back before a -;;; different letter may be typed at a given call. In the CASE at :cancel -;;; and :control-g, if the string is not null, an accurate pattern for this -;;; call must be provided when %I-SEARCH-CHAR-EVAL is called a second time -;;; since it is possible for ^S or ^R to be typed. -;;; -(defun %i-search (string point trailer direction failure) - (do* ((curr-point (copy-mark point :temporary)) - (curr-trailer (copy-mark trailer :temporary))) - (nil) - (let* ((next-key-event (recursive-get-key-event hi::*editor-input* t)) - (val (%i-search-char-eval next-key-event string point trailer - direction failure)) - (empty-string-p (zerop (length string)))) - (case val - (:mouse-exit - (clear-echo-area) - (throw 'exit-i-search nil)) - (:cancel - (%i-search-echo-refresh string direction failure) - (unless empty-string-p - (i-search-pattern string direction))) ;sets *last-search-pattern* - (:return-cancel ;backspace was typed - (if empty-string-p - (beep) - (return :cancel))) - (:control-g - (when failure (return :control-g)) - (%i-search-echo-refresh string direction nil) - (unless empty-string-p - (i-search-pattern string direction)))) ;*last-search-pattern* - (move-mark point curr-point) - (move-mark trailer curr-trailer)))) - -;;; %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes -;;; necessary actions. -;;; -(defun %i-search-char-eval (key-event string point trailer direction failure) - (declare (simple-string string)) - (cond ((let ((character (key-event-char key-event))) - (and character (standard-char-p character))) - (%i-search-printed-char key-event string point trailer - direction failure)) - ((or (logical-key-event-p key-event :forward-search) - (logical-key-event-p key-event :backward-search)) - (%i-search-control-s-or-r key-event string point trailer - direction failure)) - ((logical-key-event-p key-event :cancel) :return-cancel) - ((logical-key-event-p key-event :extend-search-word) - (with-mark ((end point)) - (word-offset end 1) - (let ((extension (region-to-string (region point end)))) - (%i-search-extend-string string extension point trailer direction failure)))) - ((logical-key-event-p key-event :abort) - (unless failure - (clear-echo-area) - (message "Search aborted.") - (throw 'exit-i-search :control-g)) - :control-g) - ((logical-key-event-p key-event :quote) - (%i-search-printed-char (get-key-event hi::*editor-input* t) - string point trailer direction failure)) - ((and (zerop (length string)) (logical-key-event-p key-event :exit)) - (if (eq direction :forward) - (forward-search-command nil) - (reverse-search-command nil)) - (throw 'exit-i-search nil)) - (t - (unless (logical-key-event-p key-event :exit) - (unget-key-event key-event hi::*editor-input*)) - (unless (zerop (length string)) - (setf *last-search-string* string)) - (throw 'exit-i-search nil)))) - -;;; %I-SEARCH-CONTROL-S-OR-R handles repetitions in the search. Note -;;; that there cannot be failure in the last COND branch: since the direction -;;; has just been changed, there cannot be a failure before trying a new -;;; direction. -;;; -(defun %i-search-control-s-or-r (key-event string point trailer - direction failure) - (let ((forward-direction-p (eq direction :forward)) - (forward-character-p (logical-key-event-p key-event :forward-search))) - (cond ((zerop (length string)) - (%i-search-empty-string point trailer direction forward-direction-p - forward-character-p)) - ((eq forward-direction-p forward-character-p) ;keep searching in the same direction - (cond ((eq failure :first-failure) - (cond (forward-direction-p - (buffer-start point) - (buffer-start trailer) - (character-offset trailer (length string))) - (t - (buffer-end point) - (buffer-end trailer))) - (push-buffer-mark (copy-mark point)) - (let ((*search-wrapped-p* t)) - (%i-search-echo-refresh string direction nil) - (%i-search-find-pattern string point trailer direction))) - (failure - (%i-search string point trailer direction t)) - (t - (%i-search-find-pattern string point (move-mark trailer point) - direction)))) - (t - (let ((new-direction (if forward-character-p :forward :backward))) - (%i-search-echo-refresh string new-direction nil) - (i-search-pattern string new-direction) ;sets *last-search-pattern* - (%i-search-find-pattern string point (move-mark trailer point) - new-direction)))))) - - -;;; %I-SEARCH-EMPTY-STRING handles the empty string case when a ^S -;;; or ^R is typed. If the direction and character typed do not agree, -;;; then merely switch directions. If there was a previous string, search -;;; for it, else flash at the guy. -;;; -(defun %i-search-empty-string (point trailer direction forward-direction-p - forward-character-p) - (cond ((eq forward-direction-p (not forward-character-p)) - (let ((direction (if forward-character-p :forward :backward))) - (%i-search-echo-refresh "" direction nil) - (%i-search "" point trailer direction nil))) - (*last-search-string* - (%i-search-echo-refresh *last-search-string* direction nil) - (i-search-pattern *last-search-string* direction) ;sets *last-search-pattern* - (%i-search-find-pattern *last-search-string* point trailer direction)) - (t (beep)))) - - -;;; %I-SEARCH-PRINTED-CHAR handles the case of standard character input. -;;; If the direction is backwards, we have to be careful not to MARK-AFTER -;;; the end of the buffer or to include the next character at the beginning -;;; of the search. -;;; -(defun %i-search-printed-char (key-event string point trailer direction failure) - (let ((tchar (hemlock-ext:key-event-char key-event))) - (unless tchar (editor-error "Not a text character -- ~S" (key-event-char - key-event))) - (when (interactive) - (insert-character (buffer-point *echo-area-buffer*) tchar) - (force-output *echo-area-stream*)) - (let ((new-string (concatenate 'simple-string string (string tchar)))) - (i-search-pattern new-string direction) ;sets *last-search-pattern* - (cond (failure (%i-search new-string point trailer direction failure)) - ((and (eq direction :backward) (next-character trailer)) - (%i-search-find-pattern new-string point (mark-after trailer) - direction)) - (t - (%i-search-find-pattern new-string point trailer direction)))))) - -(defun %i-search-extend-string (string extension point trailer direction failure) - (when (interactive) - (insert-string (buffer-point *echo-area-buffer*) extension) - (force-output *echo-area-stream*)) - (let ((new-string (concatenate 'simple-string string extension))) - (i-search-pattern new-string direction) ;sets *last-search-pattern* - (cond (failure (%i-search new-string point trailer direction failure)) - ((and (eq direction :backward) (next-character trailer)) - (%i-search-find-pattern new-string point (mark-after trailer) - direction)) - (t - (%i-search-find-pattern new-string point trailer direction))))) - - -;;; %I-SEARCH-FIND-PATTERN takes a pattern for a string and direction -;;; and finds it, updating necessary pointers for the next call to %I-SEARCH. -;;; If the search failed, tell the user and do not move any pointers. -;;; -(defun %i-search-find-pattern (string point trailer direction) - (let ((found-offset (find-pattern trailer *last-search-pattern*))) - (cond (found-offset - (cond ((eq direction :forward) - (character-offset (move-mark point trailer) found-offset)) - (t - (move-mark point trailer) - (character-offset trailer found-offset))) - (push-buffer-mark (copy-mark trailer) t) - (hi::note-selection-set-by-search) - (%i-search string point trailer direction nil)) - (t - (%i-search-echo-refresh string direction t) - (if (interactive) - (beep) - (editor-error "I-Search failed.")) - (%i-search string point trailer direction :first-failure))))) @@ -545,8 +267,4 @@ dumb) (return nil)) - (:recursive-edit - "Go into a recursive edit at the current position." - (do-recursive-edit) - (get-search-pattern target :forward)) (:exit "Exit immediately." (return nil)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/streams.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/streams.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/streams.lisp (revision 7833) @@ -76,34 +76,20 @@ stream) -(defmacro with-left-inserting-mark ((var form) &body forms) - (let ((change (gensym))) - `(let* ((,var ,form) - (,change (eq (mark-kind ,var) :right-inserting))) - (unwind-protect - (progn - (when ,change - (setf (mark-kind ,var) :left-inserting)) - ,@forms) - (when ,change - (setf (mark-kind ,var) :right-inserting)))))) - (defun hemlock-output-unbuffered-out (stream character) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (let* ((buffer (line-%buffer (mark-line mark)))) - (buffer-document-begin-editing buffer) - (unwind-protect - (insert-character mark character) - (buffer-document-end-editing buffer))))) + (let ((mark (hemlock-output-stream-mark stream))) + (modifying-buffer-storage ((mark-buffer mark)) + (insert-character mark character) + (unless (eq (mark-kind mark) :left-inserting) + (character-offset mark 1))))) (defun hemlock-output-unbuffered-sout (stream string start end) - (with-left-inserting-mark (mark (hemlock-output-stream-mark stream)) - (unless (and (eql start 0) - (eql end (length string))) - (setq string (subseq string start end))) - (let* ((buffer (line-%buffer (mark-line mark)))) - (buffer-document-begin-editing buffer) - (unwind-protect - (insert-string mark string) - (buffer-document-end-editing buffer))))) + (unless (and (eql start 0) + (eql end (length string))) + (setq string (subseq string start end))) + (let ((mark (hemlock-output-stream-mark stream))) + (modifying-buffer-storage ((mark-buffer mark)) + (insert-string mark string) + (unless (eq (mark-kind mark) :left-inserting) + (character-offset mark (- end start)))))) (defun hemlock-output-buffered-out (stream character) @@ -242,6 +228,5 @@ (let ((index (kbdmac-stream-index stream))) (setf (kbdmac-stream-index stream) (1+ index)) - (setq *last-key-event-typed* - (svref (kbdmac-stream-buffer stream) index)))) + (setf (last-key-event-typed) (svref (kbdmac-stream-buffer stream) index)))) (defun kbdmac-unget (ignore stream) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp (revision 7833) @@ -93,4 +93,6 @@ mode-objects ; list of buffer's mode objects bindings ; buffer's command table + bindings-wound-p ; true if all the mode bindings have been wound. + (shadow-syntax nil) ; buffer's changes to syntax attributes. point ; current position in buffer %mark ; a saved buffer position @@ -109,5 +111,5 @@ %modeline-fields ; List of modeline-field-info's. (delete-hook nil) ; List of functions to call upon deletion. - (line-termination :unix) ; Line-termination, for the time being + (line-termination :lf) ; Line-termination, for the time being process ; Maybe a listener (gap-context ) ; The value of *buffer-gap-context* @@ -172,4 +174,5 @@ cleanup-function ; Cleanup function for this mode bindings ; The mode's command table. + default-command ; If non-nil, default command transparent-p ; Are key-bindings transparent? hook-name ; The name of the mode hook. @@ -318,5 +321,5 @@ keyword documentation - vector + (vector #() :type (simple-array * (*))) hooks end-value) @@ -328,5 +331,5 @@ (defstruct (command (:constructor internal-make-command - (%name documentation function)) + (%name documentation function transparent-p)) (:copier nil) (:predicate commandp) @@ -335,4 +338,5 @@ documentation ;Command documentation string or function function ;The function which implements the command + transparent-p ;If true, this command is transparent %bindings) ;Places where command is bound @@ -384,5 +388,5 @@ (ignore-errors (buffer-name - (line-buffer (mark-line (random-typeout-stream-mark object))))))) + (mark-buffer (random-typeout-stream-mark object)))))) @@ -531,66 +535,4 @@ (format stream "#")) -;;; Device-hunks are used to claim a piece of the screen and for ordering -;;; pieces of the screen. Window motion primitives and splitting/merging -;;; primitives use hunks. Hunks are somewhat of an interface between the -;;; portable and non-portable parts of screen management, between what the -;;; user sees on the screen and how Hemlock internals deal with window -;;; sequencing and creation. Note: the echo area hunk is not hooked into -;;; the ring of other hunks via the next and previous fields. -;;; -(defstruct (device-hunk (:print-function %print-device-hunk)) - "This structure is used internally by Hemlock's screen management system." - window ; Window displayed in this hunk. - position ; Bottom Y position of hunk. - height ; Height of hunk in pixels or lines. - next ; Next and previous hunks. - previous - device) ; Display device hunk is on. - -(defun %print-device-hunk (object stream depth) - (declare (ignore depth)) - (format stream "#" - (device-hunk-position object) - (device-hunk-height object) - (let* ((window (device-hunk-window object)) - (buffer (if window (window-buffer window)))) - (if buffer (buffer-name buffer))))) - - -;;; Bitmap hunks. -;;; -;;; The lock field is no longer used. If events could be handled while we -;;; were in the middle of something with the hunk, then this could be set -;;; for exclusion purposes. -;;; -(defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|# - (:include device-hunk)) - width ; Pixel width. - char-height ; Height of text body in characters. - char-width ; Width in characters. - xwindow ; X window for this hunk. - gcontext ; X gcontext for xwindow. - start ; Head of dis-line list (no dummy). - end ; Exclusive end, i.e. nil if nil-terminated. - modeline-dis-line ; Dis-line for modeline, or NIL if none. - modeline-pos ; Position of modeline in pixels. - (lock t) ; Something going on, set trashed if we're changed. - trashed ; Something bad happened, recompute image. - font-family ; Font-family used in this window. - input-handler ; Gets hunk, char, x, y when char read. - changed-handler ; Gets hunk when size changed. - (thumb-bar-p nil) ; True if we draw a thumb bar in the top border. - window-group) ; The window-group to which this hunk belongs. - - -;;; Terminal hunks. -;;; -(defstruct (tty-hunk #|(:print-function %print-device-hunk)|# - (:include device-hunk)) - text-position ; Bottom Y position of text in hunk. - text-height) ; Number of lines of text. - - - ;;;; Some defsetfs: @@ -647,6 +589,4 @@ (defsetf ring-ref %set-ring-ref "Set an element in a ring.") (defsetf current-window %set-current-window "Set the current window.") -(defsetf current-buffer %set-current-buffer - "Set the current buffer, doing necessary stuff.") (defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.") (defsetf buffer-region %set-buffer-region "Set a buffer's region.") @@ -657,6 +597,6 @@ (defsetf last-command-type %set-last-command-type "Set the Last-Command-Type for use by the next command.") -(defsetf prefix-argument %set-prefix-argument - "Set the prefix argument for the next command.") +(defsetf last-key-event-typed %set-last-key-event-typed + "Set the last key event typed") (defsetf logical-key-event-p %set-logical-key-event-p "Change what Logical-Char= returns for the specified arguments.") Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp (revision 7833) @@ -34,5 +34,4 @@ attribute-vector/mask pairs for find-attribute and reverse-find-attribute.") -(eval-when (:compile-toplevel :execute :load-toplevel) (defconstant character-attribute-cache-size 13 "The number of buckets in the *character-attribute-cache*.") @@ -40,31 +39,62 @@ "The number of bits to use in each bucket of the *character-attribute-cache*.") -); eval-when (:compile-toplevel :execute :load-toplevel) - -;;; In addition, since a common pattern in code which uses find-attribute -;;; is to repeatedly call it with the same function and attribute, we -;;; remember the last attribute/test-function pair that was used, and check -;;; if it is the same pair beforehand, thus often avoiding the hastable lookup. -;;; -(defvar *last-find-attribute-attribute* () - "The attribute which we last did a find-attribute on.") -(defvar *last-find-attribute-function* () - "The last test-function used for find-attribute.") -(defvar *last-find-attribute-vector* () - "The %SP-Find-Character-With-Attribute vector corresponding to the last - attribute/function pair used for find-attribute.") -(defvar *last-find-attribute-mask* () - "The the mask to use with *last-find-attribute-vector* to do a search - for the last attribute/test-function pair.") -(defvar *last-find-attribute-end-wins* () - "The the value of End-Wins for the last attribute/test-function pair.") - + + +(defconstant character-attribute-cache-size 13 + "The number of buckets in the character-attribute-cache.") +(defconstant character-attribute-bucket-size 3 + "The number of bits to use in each bucket of the character-attribute-cache.") + +(defstruct (shadow-syntax (:conc-name "SS-")) + ;;; In addition, since a common pattern in code which uses find-attribute + ;;; is to repeatedly call it with the same function and attribute, we + ;;; remember the last attribute/test-function pair that was used, and check + ;;; if it is the same pair beforehand, thus often avoiding the hastable lookup. + ;; TODO: another common pattern is to use the same attribute but + ;; different functions (toggling between zerop and not-zerop), so + ;; should use a scheme that handles that - this doesn't. + ;; The attribute which we last did a find-attribute on + (last-find-attribute-attribute ()) + ;; The last test-function used for find-attribute. + (last-find-attribute-function ()) + ;; The %SP-Find-Character-With-Attribute vector corresponding to the last + ;; attribute/function pair used for find-attribute. + (last-find-attribute-vector ()) + ;; The the mask to use with *last-find-attribute-vector* to do a search + ;; for the last attribute/test-function pair. + (last-find-attribute-mask ()) + ;; The the value of End-Wins for the last attribute/test-function pair. + (last-find-attribute-end-wins ()) + + ;; The last character attribute which was asked for + (last-character-attribute-requested nil) + ;; The value of the most recent character attribute + (value-of-last-character-attribute-requested #() :type (simple-array * (*))) + + ;; list of shadowed bits. + (shadow-bit-descriptors ()) + ;; List of shadowed attribute vectors + (shadow-attributes ()) + ;; Syntax tick count at the time shadow info was computed. + (global-syntax-tick -1)) + +(defvar *global-syntax-tick* 0 "Tick count noting changes in global syntax settings") + +(declaim (special *current-buffer*)) + + +(declaim (inline current-buffer-shadow-syntax)) +(defun current-buffer-shadow-syntax () + (let ((buffer *current-buffer*)) + (when buffer + (let ((ss (buffer-shadow-syntax buffer))) + (if (and ss (eql (ss-global-syntax-tick ss) *global-syntax-tick*)) + ss + (progn + (%init-shadow-attributes buffer) + (buffer-shadow-syntax buffer))))))) (defvar *character-attributes* (make-hash-table :test #'eq) "A hash table which translates character attributes to their values.") -(defvar *last-character-attribute-requested* nil - "The last character attribute which was asked for, Do Not Bind.") -(defvar *value-of-last-character-attribute-requested* nil - "The value of the most recent character attribute, Do Not Bind.") (declaim (special *character-attribute-names*)) @@ -91,5 +121,5 @@ -(eval-when (:compile-toplevel :execute) + (defmacro allocate-bit (vec bit-num) `(progn @@ -99,5 +129,5 @@ :vector ,vec :mask (ash 1 (prog1 ,bit-num (incf ,bit-num)))) - *all-bit-descriptors*))))) + *all-bit-descriptors*)))) ;;; (defun %init-syntax-table () @@ -113,5 +143,4 @@ -(eval-when (:compile-toplevel :execute) #+NIL (defmacro hash-it (attribute function) @@ -133,32 +162,31 @@ ;;; (defmacro cached-attribute-lookup (attribute function vector mask end-wins) - `(if (and (eq ,function *last-find-attribute-function*) - (eq ,attribute *last-find-attribute-attribute*)) - (setq ,vector *last-find-attribute-vector* - ,mask *last-find-attribute-mask* - ,end-wins *last-find-attribute-end-wins*) - (let ((bit (svref *character-attribute-cache* - (hash-it ,attribute ,function)))) - ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins) - (new-cache-attribute ,attribute ,function)) - `(let ((b (car bit))) - (cond - ((and (eq (bit-descriptor-function b) - ,function) - (eq (bit-descriptor-attribute b) - ,attribute)) - (setq ,vector (bit-descriptor-vector b) - ,mask (bit-descriptor-mask b) - ,end-wins (bit-descriptor-end-wins b))) - (t - (setq bit (cdr bit)) ,res)))) - (count 0 (1+ count))) - ((= count character-attribute-bucket-size) res)) - (setq *last-find-attribute-attribute* ,attribute - *last-find-attribute-function* ,function - *last-find-attribute-vector* ,vector - *last-find-attribute-mask* ,mask - *last-find-attribute-end-wins* ,end-wins)))) -); eval-when (:compile-toplevel :execute) + `(let ((ss (current-buffer-shadow-syntax))) + (if (and (eq ,function (ss-last-find-attribute-function ss)) + (eq ,attribute (ss-last-find-attribute-attribute ss))) + (setq ,vector (ss-last-find-attribute-vector ss) + ,mask (ss-last-find-attribute-mask ss) + ,end-wins (ss-last-find-attribute-end-wins ss)) + (let ((b (or (loop for b in (ss-shadow-bit-descriptors ss) + when (and (eq (bit-descriptor-attribute b) ,attribute) + (eq (bit-descriptor-function b) ,function)) + return b) + (loop for b in (svref *character-attribute-cache* + (hash-it ,attribute ,function)) + when (and (eq (bit-descriptor-attribute b) ,attribute) + (eq (bit-descriptor-function b) ,function)) + return b)))) + (cond (b + (setq ,vector (bit-descriptor-vector b) + ,mask (bit-descriptor-mask b) + ,end-wins (bit-descriptor-end-wins b))) + (t + (multiple-value-setq (,vector ,mask ,end-wins) + (new-cache-attribute ,attribute ,function)))) + (setf (ss-last-find-attribute-attribute ss) ,attribute + (ss-last-find-attribute-function ss) ,function + (ss-last-find-attribute-vector ss) ,vector + (ss-last-find-attribute-mask ss) ,mask + (ss-last-find-attribute-end-wins ss) ,end-wins))))) ;;; NEW-CACHE-ATTRIBUTE -- Internal @@ -182,4 +210,5 @@ (bit-descriptor-function bit) function (bit-descriptor-end-wins bit) end-wins) + (incf *global-syntax-tick*) (setq values (attribute-descriptor-vector values)) (do ((mask (bit-descriptor-mask bit)) @@ -190,6 +219,6 @@ (declare (type (simple-array (mod 256)) vec)) (if (funcall fun (aref (the simple-array values) i)) - (setf (aref vec i) (logior (aref vec i) mask)) - (setf (aref vec i) (logandc2 (aref vec i) mask)))))) + (setf (aref vec i) (logior (aref vec i) mask)) + (setf (aref vec i) (logandc2 (aref vec i) mask)))))) @@ -222,4 +251,5 @@ (setf (getstring name *character-attribute-names*) attribute) (setf (gethash attribute *character-attributes*) new)) + (incf *global-syntax-tick*) name) @@ -229,20 +259,18 @@ ;;; giving error if it is not a defined attribute. ;;; -(eval-when (:compile-toplevel :execute) -(defmacro with-attribute (symbol &body forms) - `(let ((obj (gethash ,symbol *character-attributes*))) - (unless obj +(defmacro with-attribute ((obj symbol) &body forms) + `(let ((,obj (gethash ,symbol *character-attributes*))) + (unless ,obj (error "~S is not a defined character attribute." ,symbol)) ,@forms)) -); eval-when (:compile-toplevel :execute) (defun character-attribute-name (attribute) "Return the string-name of the character-attribute Attribute." - (with-attribute attribute + (with-attribute (obj attribute) (attribute-descriptor-name obj))) (defun character-attribute-documentation (attribute) "Return the documentation for the character-attribute Attribute." - (with-attribute attribute + (with-attribute (obj attribute) (attribute-descriptor-documentation obj))) @@ -250,36 +278,34 @@ "Return the hook-list for the character-attribute Attribute. This can be set with Setf." - (with-attribute attribute + (with-attribute (obj attribute) (attribute-descriptor-hooks obj))) (defun %set-character-attribute-hooks (attribute new-value) - (with-attribute attribute + (with-attribute (obj attribute) (setf (attribute-descriptor-hooks obj) new-value))) -(declaim (special *last-character-attribute-requested* - *value-of-last-character-attribute-requested*)) - ;;; CHARACTER-ATTRIBUTE -- Public ;;; ;;; Return the value of a character attribute for some character. ;;; -(declaim (inline character-attribute)) (defun character-attribute (attribute character) "Return the value of the the character-attribute Attribute for Character. If Character is Nil then return the end-value." - (if (and (eq attribute *last-character-attribute-requested*) character) - (aref (the simple-array *value-of-last-character-attribute-requested*) - (syntax-char-code character)) - (sub-character-attribute attribute character))) + (let ((ss (current-buffer-shadow-syntax))) + (if (and character ss (eq attribute (ss-last-character-attribute-requested ss))) + (aref (ss-value-of-last-character-attribute-requested ss) (syntax-char-code character)) + (sub-character-attribute attribute character)))) ;;; (defun sub-character-attribute (attribute character) - (with-attribute attribute - (setq *last-character-attribute-requested* attribute) - (setq *value-of-last-character-attribute-requested* - (attribute-descriptor-vector obj)) - (if character - (aref (the simple-array *value-of-last-character-attribute-requested*) - (syntax-char-code character)) - (attribute-descriptor-end-value obj)))) + (with-attribute (obj attribute) + (let* ((ss (current-buffer-shadow-syntax)) + (cell (and ss (cdr (assoc obj (ss-shadow-attributes ss) :test #'eq))))) + (if character + (let ((vec (if cell (car cell) (attribute-descriptor-vector obj)))) + (when ss + (setf (ss-last-character-attribute-requested ss) attribute) + (setf (ss-value-of-last-character-attribute-requested ss) vec)) + (aref (the simple-array vec) (syntax-char-code character))) + (if cell (cdr cell) (attribute-descriptor-end-value obj)))))) ;;; CHARACTER-ATTRIBUTE-P @@ -296,8 +322,8 @@ ;;; %SET-CHARACTER-ATTRIBUTE -- Internal ;;; -;;; Set the value of a character attribute. +;;; Set the global value of a character attribute. ;;; (defun %set-character-attribute (attribute character new-value) - (with-attribute attribute + (with-attribute (obj attribute) (invoke-hook hemlock::character-attribute-hook attribute character new-value) (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value) @@ -325,57 +351,55 @@ (when (eq (bit-descriptor-attribute bit) attribute) (setf (bit-descriptor-end-wins bit) - (funcall (bit-descriptor-function bit) new-value)))) - new-value)))) - - -(eval-when (:compile-toplevel :execute) -;;; swap-one-attribute -- Internal -;;; -;;; Install the mode-local values described by Vals for Attribute, whose -;;; representation vector is Value. -;;; - (defmacro swap-one-attribute (attribute value vals hooks) - `(progn - ;; Fix up any cached attribute vectors. - (dolist (bit *all-bit-descriptors*) - (when (eq ,attribute (bit-descriptor-attribute bit)) - (let ((fun (bit-descriptor-function bit)) - (vec (bit-descriptor-vector bit)) - (mask (bit-descriptor-mask bit))) - (declare (type (simple-array (mod 256)) vec) - (fixnum mask)) - (dolist (char ,vals) - (setf (aref vec (car char)) - (if (funcall fun (cdr char)) - (logior mask (aref vec (car char))) - (logandc1 mask (aref vec (car char))))))))) - ;; Invoke the attribute-hook. - (dolist (hook ,hooks) - (dolist (char ,vals) - (funcall hook ,attribute (code-char (car char)) (cdr char)))) - ;; Fix up the value vector. - (dolist (char ,vals) - (rotatef (aref ,value (car char)) (cdr char))))) -); eval-when (:compile-toplevel :execute) - - -;;; SWAP-CHAR-ATTRIBUTES -- Internal -;;; -;;; Swap the current values of character attributes and the ones -;;;specified by "mode". This is used in Set-Major-Mode. -;;; -(defun swap-char-attributes (mode) - (dolist (attribute (mode-object-character-attributes mode)) - (let* ((obj (car attribute)) - (sym (attribute-descriptor-keyword obj)) - (value (attribute-descriptor-vector obj)) - (hooks (attribute-descriptor-hooks obj))) - (declare (simple-array value)) - (swap-one-attribute sym value (cdr attribute) hooks)))) - - - - -(declaim (special *mode-names* *current-buffer*)) + (funcall (bit-descriptor-function bit) new-value)))))) + (incf *global-syntax-tick*) + new-value)) + + +;; This is called when change buffer mode. It used to invoke attribute-descriptor-hooks on +;; all the shadowed attributes. We don't do that any more, should update doc if any. +(defun invalidate-shadow-attributes (buffer) + (let ((ss (buffer-shadow-syntax buffer))) + (when ss (setf (ss-global-syntax-tick ss) -1)))) + +(defun %init-one-shadow-attribute (ss desc vals) + ;; Shadow all bits for this attribute + (loop with key = (attribute-descriptor-keyword desc) + for bit in *all-bit-descriptors* + when (eq key (bit-descriptor-attribute bit)) + do (let* ((fun (bit-descriptor-function bit)) + (b (or (find-if #'(lambda (b) + (and (eq (bit-descriptor-function b) fun) + (eq (bit-descriptor-attribute b) key))) + (ss-shadow-bit-descriptors ss)) + (let ((new (make-bit-descriptor + :attribute key + :function fun + :vector (copy-seq (bit-descriptor-vector bit)) + :mask (bit-descriptor-mask bit)))) + (push new (ss-shadow-bit-descriptors ss)) + new))) + (vec (bit-descriptor-vector b))) + (loop for (code . value) in vals + ;; Since we don't share the shadow vecs, no need to preserve other bits. + do (setf (aref vec code) (if (funcall fun value) #xFF #x00))))) + ;; Shadow the attribute values + (let ((vec (cadr (or (assoc desc (ss-shadow-attributes ss) :test #'eq) + (let ((new (list* desc + (copy-seq (attribute-descriptor-vector desc)) + (attribute-descriptor-end-value desc)))) + (push new (ss-shadow-attributes ss)) + new))))) + (loop for (code . value) in vals do (setf (aref vec code) value)))) + +(defun %init-shadow-attributes (buffer) + (let* ((mode (car (if (buffer-bindings-wound-p buffer) + (last (buffer-mode-objects buffer)) + (buffer-mode-objects buffer)))) + (ss (or (buffer-shadow-syntax buffer) + (setf (buffer-shadow-syntax buffer) (make-shadow-syntax))))) + (loop for (desc . vals) in (mode-object-character-attributes mode) + do (%init-one-shadow-attribute ss desc vals)))) + +(declaim (special *mode-names*)) ;;; SHADOW-ATTRIBUTE -- Public @@ -393,8 +417,5 @@ (let* ((current (assoc desc (mode-object-character-attributes obj))) (code (syntax-char-code character)) - (hooks (attribute-descriptor-hooks desc)) - (vec (attribute-descriptor-vector desc)) (cons (cons code value))) - (declare (simple-array vec)) (if current (let ((old (assoc code (cdr current)))) @@ -404,7 +425,5 @@ (push (list desc cons) (mode-object-character-attributes obj))) - (when (member obj (buffer-mode-objects *current-buffer*)) - (let ((vals (list cons))) - (swap-one-attribute attribute vec vals hooks))) + (incf *global-syntax-tick*) (invoke-hook hemlock::shadow-attribute-hook attribute character value mode))) attribute) @@ -423,15 +442,10 @@ (error "~S is not a defined Mode." mode)) (invoke-hook hemlock::shadow-attribute-hook mode attribute character) - (let* ((value (attribute-descriptor-vector desc)) - (hooks (attribute-descriptor-hooks desc)) - (current (assoc desc (mode-object-character-attributes obj))) + (let* ((current (assoc desc (mode-object-character-attributes obj))) (char (assoc (syntax-char-code character) (cdr current)))) - (declare (simple-array value)) (unless char (error "Character Attribute ~S is not defined for character ~S ~ in Mode ~S." attribute character mode)) - (when (member obj (buffer-mode-objects *current-buffer*)) - (let ((vals (list char))) - (swap-one-attribute attribute value vals hooks))) + (incf *global-syntax-tick*) (setf (cdr current) (delete char (the list (cdr current)))))) attribute) @@ -449,5 +463,4 @@ ;;; vector that we can use to do the search. ;;; -(eval-when (:compile-toplevel :execute) (defmacro normal-find-attribute (line start result vector mask) `(let ((chars (line-chars ,line))) @@ -471,5 +484,5 @@ (current-open-chars) (current-right-open-pos) (current-line-cache-length) ,vector ,mask)) (when ,result (decf ,result gap)))))) -); eval-when (:compile-toplevel :execute) + ;;; (defun find-attribute (mark attribute &optional (test #'not-zerop)) @@ -519,5 +532,4 @@ ;;; Line find-attribute, only goes backwards. ;;; -(eval-when (:compile-toplevel :execute) (defmacro rev-normal-find-attribute (line start result vector mask) `(let ((chars (line-chars ,line))) @@ -544,5 +556,4 @@ (current-open-chars) 0 (current-left-open-pos) ,vector ,mask)))))) -); eval-when (:compile-toplevel :execute) ;;; ;;; This moves the mark so that previous-character satisfies the test. Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/undo.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/undo.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/undo.lisp (revision 7833) @@ -210,5 +210,5 @@ (let ((mark (region-start region))) (delete-mark mark-or-region) - (when (line-buffer (mark-line mark)) + (when (mark-buffer mark) (delete-mark mark) (delete-mark (region-end region))))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp (revision 7832) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp (revision 7833) @@ -210,7 +210,7 @@ (let ((binding (make-binding prop new-binding vars symbol-name))) (cond ((member obj (buffer-mode-objects *current-buffer*)) - (let ((l (unwind-bindings obj))) + (let ((l (unwind-bindings *current-buffer* obj))) (setf (mode-object-var-values obj) binding) - (wind-bindings l))) + (wind-bindings *current-buffer* l))) (t (setf (mode-object-var-values obj) binding))))))) @@ -222,5 +222,5 @@ (let ((binding (make-binding prop new-binding vars symbol-name))) (setf (buffer-var-values buffer) binding) - (when (eq buffer *current-buffer*) + (when (buffer-bindings-wound-p buffer) (setf (variable-object-down new-binding) (car prop) (car prop) new-binding)))))) @@ -229,7 +229,8 @@ (unless (hemlock-bound-p symbol-name :global) (setf (variable-object-down new-binding) :global) - (let ((l (unwind-bindings nil))) - (setf (car prop) new-binding) - (wind-bindings l))))) + (when *current-buffer* + (let ((l (unwind-bindings *current-buffer* nil))) + (setf (car prop) new-binding) + (wind-bindings *current-buffer* l)))))) (setf (getstring name string-table) symbol-name) (when hook-p @@ -269,5 +270,5 @@ (delete-string sname (buffer-variables where)) (setf (buffer-var-values where) (delete-binding binding values)) - (when (eq where *current-buffer*) + (when (buffer-bindings-wound-p where) (setf (car (binding-cons binding)) (variable-object-down obj))))) (:mode @@ -278,8 +279,8 @@ (delete-string sname (mode-object-variables mode)) (if (member mode (buffer-mode-objects *current-buffer*)) - (let ((l (unwind-bindings mode))) + (let ((l (unwind-bindings *current-buffer* mode))) (setf (mode-object-var-values mode) (delete-binding binding values)) - (wind-bindings l)) + (wind-bindings *current-buffer* l)) (setf (mode-object-var-values mode) (delete-binding binding values))))) @@ -287,7 +288,7 @@ (invoke-hook hemlock::delete-variable-hook name :global nil) (delete-string sname *global-variable-names*) - (let ((l (unwind-bindings nil))) + (let ((l (unwind-bindings *current-buffer* nil))) (setf (get name 'hemlock-variable-value) nil) - (wind-bindings l))) + (wind-bindings *current-buffer* l))) (t (error "Invalid variable kind: ~S" kind))) nil)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7833) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7833) @@ -0,0 +1,214 @@ +;;; -*- Mode: Lisp; Package: hemlock-internals -*- + +(in-package :hemlock-internals) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; A HEMLOCK-VIEW represents text displayed in a (pane inside a) window. +;; Conceptually it consists of a text buffer, a modeline for semi-permanent status +;; info, an echo area for transient status info, and a text input area for reading +;; prompted input. Currently the last two are conflated. +;; +;; A HEMLOCK-VIEW never changes which text buffer it displays (unlike in emacs). A +;; text buffer can be displayed in multiple HEMLOCK-VIEW's, although currently there +;; is no UI to make that happen. But we try take care to distinguish per-buffer info +;; from per-view info. The former is stored in the buffer struct and in buffer +;; variables. The latter is currently stored in HEMLOCK-VIEW slots, although I'd +;; like to introduce user-definable "view variables" and get rid of some of these +;; user-level slots. [Note: currently, multiple views on a buffer are but a remote +;; dream. Basic things like the insertion point are still per buffer when they +;; should be per view] +;; +;; The user interacts with a HEMLOCK-VIEW using events. Each time the user presses a +;; key, the OS arranges to invoke our event handler. The event handler computes and +;; invokes a hemlock command bound to the key. The command is invoked in a +;; dynamic context most suitable for modifying the text buffer associated with the +;; HEMLOCK-VIEW, but by jumping through a few hoops, it can modify other buffers. + +(defvar *current-view* nil) + +(defclass hemlock-view () + ((buffer :initarg :buffer :reader hemlock-view-buffer) + (pane :initarg :pane :reader hemlock-view-pane) + (echo-area-buffer :initarg :echo-area-buffer :reader hemlock-echo-area-buffer) + (echo-area-pane :initarg :echo-area-pane :reader hemlock-echo-area-pane) + + (echo-area-stream :reader hemlock-echo-area-stream) + + ;; Input state + (quote-next-p :initform nil :accessor hemlock-view-quote-next-p) + (current-command :initform (make-array 10 :fill-pointer 0 :adjustable t) + :reader hemlock-current-command) + (current-translation :initform (make-array 10 :fill-pointer 0 :adjustable t) + :reader hemlock-current-translation) + (translate-key-temp :initform (make-array 10 :fill-pointer 0 :adjustable t) + :reader hemlock-translate-key-temp) + (prefix-argument-state :initform (make-prefix-argument-state) + :accessor hemlock-prefix-argument-state) + ;; If set, events are diverted to the echo area for reading prompt-for-xxx input. + (prompted-input-state :initform nil :accessor hemlock-prompted-input-state) + + (cancel-message :initform nil :accessor hemlock-cancel-message) + + ;; User level "view variables", for now give each its own slot. + (last-key-event-typed :initform nil :accessor hemlock-last-key-event-typed) + (last-command-type :initform nil :accessor hemlock-last-command-type) + (target-column :initform 0 :accessor hemlock-target-column) + )) + +(defmethod initialize-instance ((view hemlock-view) &key) + (call-next-method) + (with-slots (echo-area-buffer echo-area-stream) view + (setf echo-area-stream + (make-hemlock-output-stream (buffer-end-mark echo-area-buffer) :full)))) + +(defun current-prefix-argument-state () + (hemlock-prefix-argument-state *current-view*)) + +(defvar *log-event-errors* :backtrace) + +;; This handles errors in event handling. It assumes it's called in a normal +;; event handling context for some view. +(defun lisp-error-error-handler (condition) + (handler-case + (let ((emsg (ignore-errors (princ-to-string condition)))) + (when *log-event-errors* + ;; Put these in separate ignore-errors, so at least some of it can get thru + (ignore-errors (clear-output *debug-io*)) + (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition))) + (when (eq *log-event-errors* :backtrace) + (let ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t))))) + (when err + (ignore-errors (format *debug-io* "~&Error printing call history - ")) + (ignore-errors (print err *debug-io*)) + (ignore-errors (princ err *debug-io*)) + (ignore-errors (force-output *debug-io*)))))) + (report-hemlock-error condition) + (abort-to-toplevel emsg)) + (error (cc) + (ignore-errors (format t "~&Event error handling failed")) + (ignore-errors (format t ": ~a" cc)) + (abort)))) + + +;; This resets the command accumulation state in the current view. +(defmethod reset-command-state () + (let ((view *current-view*)) + ;; This resets c-q + (setf (hemlock-view-quote-next-p view) nil) + ;; This resets c-x (multi-key command) and c-c (modifier prefix command) + (setf (fill-pointer (hemlock-current-command view)) 0) + ;; This resets the numarg state. + (prefix-argument-resetting-state (hemlock-prefix-argument-state view)))) + +;; This is called for ^G and for lisp errors. It aborts all editor state, +;; including recursive reading input and incremental search. +(defun abort-to-toplevel (&optional (message "Cancelled")) + ;; This assumes it's called in normal event state. + (assert (and *current-view* (find-restart 'exit-event-handler))) + (reset-command-state) + (invoke-hook hemlock::abort-hook) ;; reset ephemeral modes such as i-search. + (setf (hemlock-cancel-message *current-view*) message) + (let ((eps (current-echo-parse-state :must-exist nil))) + (when eps + (exit-echo-parse eps :aborted))) + (exit-event-handler)) + +;; Called for editor errors. This aborts command accumulation and i-search, +;; but not recursive reading of input. +(defun abort-current-command (&optional (message "Cancelled")) + ;; This assumes it's called in normal event state. + (assert (and *current-view* (find-restart 'exit-event-handler))) + (reset-command-state) + (invoke-hook hemlock::abort-hook) + (setf (hemlock-cancel-message *current-view*) message) + (exit-event-handler)) + +(defun exit-event-handler (&optional message) + (when (and *current-view* message) + (setf (hemlock-cancel-message *current-view*) message)) + (let ((restart (find-restart 'exit-event-handler))) + (if restart + (ccl::invoke-restart-no-return restart) + (abort)))) + +(defmethod translate-and-lookup-current-command ((view hemlock-view)) + ;; Returns NIL if we're in the middle of a command (either multi-key, as in c-x, + ;; or translation prefix, as in ESC for Meta-), else a command. + (multiple-value-bind (translated-key prefix-p) + (translate-key (hemlock-current-command view) + (hemlock-current-translation view) + (hemlock-translate-key-temp view)) + (multiple-value-bind (res t-bindings) + (get-current-binding translated-key) + (etypecase res + (command + (values res t-bindings)) + (hash-table ;; we're part-way through a multi-key command + nil) + (null + (if prefix-p ;; we're part-way through a translation prefix + nil + (values (get-default-command) nil))))))) + + +;; This has a side effect of resetting the quoting state and current command. +(defmethod get-command-binding-for-key ((view hemlock-view) key) + (vector-push-extend key (hemlock-current-command view)) + (setf (hemlock-last-key-event-typed view) key) + (multiple-value-bind (main-binding t-bindings) + (if (shiftf (hemlock-view-quote-next-p view) nil) + (values (get-self-insert-command) nil) + (translate-and-lookup-current-command view)) + (when main-binding + (setf (fill-pointer (hemlock-current-command view)) 0)) + (values main-binding t-bindings))) + +(defvar *last-last-command-type*) +(defvar *last-prefix-argument*) + +(defmethod execute-hemlock-key ((view hemlock-view) key) + (if (or (symbolp key) (functionp key)) + (funcall key) + (multiple-value-bind (main-binding transparent-bindings) + (get-command-binding-for-key view key) + (when main-binding + (let* ((*last-last-command-type* (shiftf (hemlock-last-command-type view) nil)) + (*last-prefix-argument* (hemlock::prefix-argument-resetting-state)) + ;(*echo-area-stream* (hemlock-echo-area-stream view)) + ) + (dolist (binding transparent-bindings) + (funcall *invoke-hook* binding *last-prefix-argument*)) + (funcall *invoke-hook* main-binding *last-prefix-argument*)))))) + +(defmethod update-echo-area-after-command ((view hemlock-view)) + (let* ((eps (hemlock-prompted-input-state view))) + ;;if we're in the process of returning from a recursive parse, + ;; don't do anything, let the outer event handle it. + (unless (and eps (eps-parse-results eps)) + (let ((msg (shiftf (hemlock-cancel-message view) nil))) + (if msg + (loud-message msg) + ;; Echo command in progress if there is one, unless in a recursive parse + (unless eps + (let ((cmd (hemlock-current-command view))) + (unless (eql 0 (length cmd)) + (let ((cstr (with-output-to-string (s) + (loop for key across cmd + do (hemlock-ext:print-pretty-key key s) + do (write-char #\space s))))) + (message cstr)))))))))) + +(defmethod handle-hemlock-event ((view hemlock-view) key) + ;; Key can also be a function, in which case it will get executed in the view event context + (ccl::with-standard-abort-handling "Abort editor event handling" + (let* ((*current-view* view) + (*current-buffer* (if (hemlock-prompted-input-state view) + (hemlock-echo-area-buffer view) + (hemlock-view-buffer view)))) + (with-buffer-bindings (*current-buffer*) + (modifying-buffer-storage (*current-buffer*) + (restart-case + (handler-bind ((error #'lisp-error-error-handler)) + (execute-hemlock-key view key)) + (exit-event-handler () :report "Exit from hemlock event handler"))) + (update-echo-area-after-command view))))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/unused/kbdmac.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/unused/kbdmac.lisp (revision 7833) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/unused/kbdmac.lisp (revision 7833) @@ -0,0 +1,475 @@ +;;; -*- Log: hemlock.log; Package: Hemlock -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +#+CMU (ext:file-comment + "$Header$") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the implementation of keyboard macros for +;;; Hemlock. In itself it contains nothing particularly gross or +;;; implementation dependant, but it uses some hooks in the stream +;;; system and other stuff. +;;; + +(in-package :hemlock) + +;;; We have "Keyboard Macro Transforms" that help in making a keyboard +;;; macro. What they do is turn the sequence of commands into equivalent +;;; lisp code. They operate under the following principles: +;;; +;;; They are passed two arguments: +;;; 1] The command invoked. +;;; 2] A keyword, either :invoke, :start or :finish +;;; +;;; If the keyword is :invoke, then the transform is expected to +;;; invoke the command and do whatever is necessary to make the same +;;; thing happen again when the macro is invoked. The method does this +;;; by pushing forms on the list *current-kbdmac* and characters to +;;; simulate input of on *kbdmac-input*. *current-kbdmac* is kept +;;; in reverse order. Each form must be a function call, and none +;;; of the arguments are evaluated. If the transform is unwound, +;;; presumably due to an error in the invoked command, then nothing +;;; should be done at invocation time. +;;; +;;; If the keyword is :finish, then nothing need be done. This +;;; is to facilitate compaction of repetitions of the same command +;;; into one call. The transform is called with :finish when a run +;;; is broken. Similarly, the transform is called with :start +;;; before the first occurrence in a run. + +(defvar *kbdmac-transcript* (make-array 100 :fill-pointer 0 :adjustable t) + "The thing we bind *input-transcript* to during keyboard macro definition.") + +(defvar *kbdmac-input* (make-array 100 :fill-pointer 0 :adjustable t) + "Place where we stick input that will need to be simulated during keyboard + macro execution.") + +(defvar *current-kbdmac* () "Body of keyboard macro we are building.") + +(defvar *kbdmac-transforms* (make-hash-table :test #'eq) + "Hashtable of function that know how to do things.") + +(defvar *old-invoke-hook* () "Bound to *invoke-hook* by kbdmac-command-loop.") + +(defmacro define-kbdmac-transform (command function) + `(setf (gethash (getstring ,command *command-names*) + *kbdmac-transforms*) + ,function)) + +(defmacro kbdmac-emit (form) + `(push ,form *current-kbdmac*)) + + +(defun trash-character () + "Throw away a character on *editor-input*." + (get-key-event hi::*editor-input*)) + +;;; Save-Kbdmac-Input -- Internal +;;; +;;; Pushes any input read within the body on *kbdmac-input* so that +;;; it is read again at macro invocation time. It uses the (input-waiting) +;;; function which is a non-standard hook into the stream system. +;;; +(defmacro save-kbdmac-input (&body forms) + (let ((slen (gensym))) + `(let ((,slen (- (length *kbdmac-transcript*) (if (input-waiting) 1 0)))) + (multiple-value-prog1 + (progn ,@forms) + (do ((i ,slen (1+ i)) + (elen (length *kbdmac-transcript*))) + ((= i elen) + (when (input-waiting) + (kbdmac-emit '(trash-character)))) + (vector-push-extend (aref *kbdmac-transcript* i) + *kbdmac-input*)))))) + +;;;; The default transform +;;; +;;; This transform is called when none is defined for a command. +;;; +(defun default-kbdmac-transform (command key) + (case key + (:invoke + (let ((fun (command-function command)) + (arg (prefix-argument)) + (lastc *last-key-event-typed*)) + (save-kbdmac-input + (let ((*invoke-hook* *old-invoke-hook*)) + (funcall fun arg)) + (kbdmac-emit `(set *last-key-event-typed* ,lastc)) + (kbdmac-emit `(,fun ,arg))))))) + + +;;;; Self insert transform: +;;; +;;; For self insert we accumulate the text in a string and then +;;; insert it all at once. +;;; + +(defvar *kbdmac-text* (make-array 100 :fill-pointer 0 :adjustable t)) + +(defun insert-string-at-point (string) + (insert-string (buffer-point (current-buffer)) string)) +(defun insert-character-at-point (character) + (insert-character (buffer-point (current-buffer)) character)) + +(defun key-vector-to-string (key-vector) + (let ((string (make-array (length key-vector) :element-type 'base-char))) + (dotimes (i (length key-vector) string) + (setf (aref string i) (hemlock-ext:key-event-char (aref key-vector i)))))) + +(defun self-insert-kbdmac-transform (command key) + (case key + (:start + (setf (fill-pointer *kbdmac-text*) 0)) + (:invoke + (let ((p (or (prefix-argument) 1))) + (funcall (command-function command) p) + (dotimes (i p) + (vector-push-extend *last-key-event-typed* *kbdmac-text*)))) + (:finish + (if (> (length *kbdmac-text*) 1) + (kbdmac-emit `(insert-string-at-point + ,(key-vector-to-string *kbdmac-text*))) + (kbdmac-emit `(insert-character-at-point + ,(hemlock-ext:key-event-char (aref *kbdmac-text* 0)))))))) +;;; +(define-kbdmac-transform "Self Insert" #'self-insert-kbdmac-transform) +(define-kbdmac-transform "Lisp Insert )" #'self-insert-kbdmac-transform) + +;;;; Do-Nothing transform: +;;; +;;; These are useful for prefix-argument setting commands, since they have +;;; no semantics at macro-time. +;;; +(defun do-nothing-kbdmac-transform (command key) + (case key + (:invoke + (funcall (command-function command) (prefix-argument))))) +;;; +(define-kbdmac-transform "Argument Digit" #'do-nothing-kbdmac-transform) +(define-kbdmac-transform "Negative Argument" #'do-nothing-kbdmac-transform) +(define-kbdmac-transform "Universal Argument" #'do-nothing-kbdmac-transform) + + +;;;; Multiplicative transform +;;; +;;; Repititions of many commands can be turned into a call with an +;;; argument. +;;; +(defvar *kbdmac-count* 0 + "The number of occurrences we have counted of a given command.") + +(defun multiplicative-kbdmac-transform (command key) + (case key + (:start + (setq *kbdmac-count* 0)) + (:invoke + (let ((p (or (prefix-argument) 1))) + (funcall (command-function command) p) + (incf *kbdmac-count* p))) + (:finish + (kbdmac-emit `(,(command-function command) ,*kbdmac-count*))))) +;;; +(define-kbdmac-transform "Forward Character" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Character" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Forward Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Uppercase Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Lowercase Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Capitalize Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Kill Next Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Kill Previous Word" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Forward Kill Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Kill Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Forward Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Backward Form" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Delete Next Character" + #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Delete Previous Character" + #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Delete Previous Character Expanding Tabs" + #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Next Line" #'multiplicative-kbdmac-transform) +(define-kbdmac-transform "Previous Line" #'multiplicative-kbdmac-transform) + + +;;;; Vanilla transform +;;; +;;; These commands neither read input nor look at random silly variables. +;;; +(defun vanilla-kbdmac-transform (command key) + (case key + (:invoke + (let ((fun (command-function command)) + (p (prefix-argument))) + (funcall fun p) + (kbdmac-emit `(,fun ,p)))))) +;;; +(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "End of Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Beginning of Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Indent for Lisp" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Delete Horizontal Space" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Kill Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Backward Kill Line" #'vanilla-kbdmac-transform) +(define-kbdmac-transform "Un-Kill" #'vanilla-kbdmac-transform) + + +;;;; MAKE-KBDMAC, INTERACTIVE, and kbdmac command loop. + +;;; Kbdmac-Command-Loop -- Internal +;;; +;;; Bind *invoke-hook* to call kbdmac transforms. +;;; +(defun kbdmac-command-loop () + (let* ((last-transform nil) + (last-command nil) + (last-ctype nil) + (*old-invoke-hook* *invoke-hook*) + (*invoke-hook* + #'(lambda (res p) + (declare (ignore p)) + (when (and (not (eq last-command res)) last-transform) + (funcall last-transform last-command :finish)) + (if (last-command-type) + (setq last-ctype t) + (when last-ctype + (kbdmac-emit '(clear-command-type)) + (setq last-ctype nil))) + (setq last-transform + (gethash res *kbdmac-transforms* #'default-kbdmac-transform)) + (unless (eq last-command res) + (funcall last-transform res :start)) + (funcall last-transform res :invoke) + (setq last-command res)))) + (declare (special *invoke-hook*)) + (setf (last-command-type) nil) + (recursive-edit nil))) + +(defun clear-command-type () + (setf (last-command-type) nil)) + + +(defvar *defining-a-keyboard-macro* ()) +(defvar *kbdmac-stream* #+later (make-kbdmac-stream)) +(defvar *in-a-keyboard-macro* () + "True if we are currently executing a keyboard macro.") + +;;; Interactive -- Public +;;; +;;; See whether we are in a keyboard macro. +;;; +(defun interactive () + "Return true if we are in a command invoked by the user. + This is primarily useful for commands which want to know + whether do something when an error happens, or just signal + an Editor-Error." + (not *in-a-keyboard-macro*)) + +(defvar *kbdmac-done* () + "Setting this causes the keyboard macro being executed to terminate + after the current iteration.") + +(defvar *kbdmac-dont-ask* () + "Setting this inhibits \"Keyboard Macro Query\"'s querying.") + +;;; Make-Kbdmac -- Internal +;;; +;;; This guy grabs the stuff lying around in *current-kbdmac* and +;;; whatnot and makes a lexical closure that can be used as the +;;; definition of a command. The prefix argument is a repitition +;;; count. +;;; +(defun make-kbdmac () + (let ((code (nreverse *current-kbdmac*)) + (input (copy-seq *kbdmac-input*))) + (if (zerop (length input)) + #'(lambda (p) + (let ((*in-a-keyboard-macro* t) + (*kbdmac-done* nil) + (*kbdmac-dont-ask* nil)) + (setf (last-command-type) nil) + (catch 'exit-kbdmac + (dotimes (i (or p 1)) + (catch 'abort-kbdmac-iteration + (dolist (form code) + (apply (car form) (cdr form)))) + (when *kbdmac-done* (return nil)))))) + #'(lambda (p) + (let* ((stream (or *kbdmac-stream* (make-kbdmac-stream))) + (*kbdmac-stream* nil) + (hi::*editor-input* stream) + (*in-a-keyboard-macro* t) + (*kbdmac-done* nil) + (*kbdmac-dont-ask* nil)) + (setf (last-command-type) nil) + (catch 'exit-kbdmac + (dotimes (i (or p 1)) + (setq stream (modify-kbdmac-stream stream input)) + (catch 'abort-kbdmac-iteration + (dolist (form code) + (apply (car form) (cdr form)))) + (when *kbdmac-done* (return nil))))))))) + + + + +;;;; Commands. + +(defmode "Def" :major-p nil) + +(defcommand "Define Keyboard Macro" (p) + "Define a keyboard macro." + "Define a keyboard macro." + (declare (ignore p)) + (when *defining-a-keyboard-macro* + (editor-error "Already defining a keyboard macro.")) + (define-keyboard-macro)) + +(defhvar "Define Keyboard Macro Key Confirm" + "When set, \"Define Keyboard Macro Key\" asks for confirmation before + clobbering an existing key binding." + :value t) + +(defcommand "Define Keyboard Macro Key" (p) + "Prompts for a key before going into a mode for defining keyboard macros. + The macro definition is bound to the key. IF the key is already bound, + this asks for confirmation before clobbering the binding." + "Prompts for a key before going into a mode for defining keyboard macros. + The macro definition is bound to the key. IF the key is already bound, + this asks for confirmation before clobbering the binding." + (declare (ignore p)) + (when *defining-a-keyboard-macro* + (editor-error "Already defining a keyboard macro.")) + (multiple-value-bind (key kind where) + (get-keyboard-macro-key) + (when key + (setf (buffer-minor-mode (current-buffer) "Def") t) + (let ((name (format nil "Keyboard Macro ~S" (gensym)))) + (make-command name "This is a user-defined keyboard macro." + (define-keyboard-macro)) + (bind-key name key kind where) + (message "~A bound to ~A." + (with-output-to-string (s) (hemlock-ext:print-pretty-key key s)) + name))))) + +;;; GET-KEYBOARD-MACRO-KEY gets a key from the user and confirms clobbering it +;;; if it is already bound to a command, or it is a :prefix. This returns nil +;;; if the user "aborts", otherwise it returns the key and location (kind +;;; where) of the binding. +;;; +(defun get-keyboard-macro-key () + (let* ((key (prompt-for-key :prompt "Bind keyboard macro to key: " + :must-exist nil))) + (multiple-value-bind (kind where) + (prompt-for-place "Kind of binding: " + "The kind of binding to make.") + (let* ((cmd (get-command key kind where))) + (cond ((not cmd) (values key kind where)) + ((commandp cmd) + (if (prompt-for-y-or-n + :prompt `("~A is bound to ~A. Rebind it? " + ,(with-output-to-string (s) + (hemlock-ext:print-pretty-key key s)) + ,(command-name cmd)) + :default nil) + (values key kind where) + nil)) + ((eq cmd :prefix) + (if (prompt-for-y-or-n + :prompt `("~A is a prefix for more than one command. ~ + Clobber it? " + ,(with-output-to-string (s) + (hemlock-ext:print-pretty-key key s))) + :default nil) + (values key kind where) + nil))))))) + +;;; DEFINE-KEYBOARD-MACRO gets input from the user and clobbers the function +;;; for the "Last Keyboard Macro" command. This returns the new function. +;;; +(defun define-keyboard-macro () + (setf (buffer-minor-mode (current-buffer) "Def") t) + (unwind-protect + (let* ((in *kbdmac-transcript*) + (*input-transcript* in) + (*defining-a-keyboard-macro* t)) + (setf (fill-pointer in) 0) + (setf (fill-pointer *kbdmac-input*) 0) + (setq *current-kbdmac* ()) + (catch 'punt-kbdmac + (kbdmac-command-loop)) + (setf (command-function (getstring "Last Keyboard Macro" *command-names*)) + (make-kbdmac))) + (setf (buffer-minor-mode (current-buffer) "Def") nil))) + + +(defcommand "End Keyboard Macro" (p) + "End the definition of a keyboard macro." + "End the definition of a keyboard macro." + (declare (ignore p)) + (unless *defining-a-keyboard-macro* + (editor-error "Not defining a keyboard macro.")) + (throw 'punt-kbdmac ())) +;;; +(define-kbdmac-transform "End Keyboard Macro" #'do-nothing-kbdmac-transform) + + +(defcommand "Last Keyboard Macro" (p) + "Execute the last keyboard macro defined. + With prefix argument execute it that many times." + "Execute the last keyboard macro P times." + (declare (ignore p)) + (editor-error "No keyboard macro defined.")) + +(defcommand "Name Keyboard Macro" (p &optional name) + "Name the \"Last Keyboard Macro\". + The last defined keboard macro is made into a named command." + "Make the \"Last Keyboard Macro\" a named command." + (declare (ignore p)) + (unless name + (setq name (prompt-for-string + :prompt "Macro name: " + :help "String name of command to make from keyboard macro."))) + (make-command + name "This is a named keyboard macro." + (command-function (getstring "Last Keyboard Macro" *command-names*)))) + +(defcommand "Keyboard Macro Query" (p) + "Keyboard macro conditional. + During the execution of a keyboard macro, this command prompts for + a single character command, similar to those of \"Query Replace\"." + "Prompt for action during keyboard macro execution." + (declare (ignore p)) + (unless (or (interactive) *kbdmac-dont-ask*) + (let ((hi::*editor-input* *real-editor-input*)) + (command-case (:prompt "Keyboard Macro Query: " + :help "Type one of these characters to say what to do:" + :change-window nil + :bind key-event) + (:exit + "Exit this keyboard macro immediately." + (throw 'exit-kbdmac nil)) + (:yes + "Proceed with this iteration of the keyboard macro.") + (:no + "Don't do this iteration of the keyboard macro, but continue to the next." + (throw 'abort-kbdmac-iteration nil)) + (:do-all + "Do all remaining repetitions of the keyboard macro without prompting." + (setq *kbdmac-dont-ask* t)) + (:do-once + "Do this iteration of the keyboard macro and then exit." + (setq *kbdmac-done* t)) + (:recursive-edit + "Do a recursive edit, then ask again." + (do-recursive-edit) + (reprompt)) + (t + (unget-key-event key-event hi::*editor-input*) + (throw 'exit-kbdmac nil))))))