Index: /trunk/ccl/examples/cocoa-editor.lisp =================================================================== --- /trunk/ccl/examples/cocoa-editor.lisp (revision 596) +++ /trunk/ccl/examples/cocoa-editor.lisp (revision 597) @@ -171,7 +171,8 @@ hemlock-buffer-string) (let* ((cache (hemlock-buffer-string-cache self))) - (or (buffer-cache-buflen cache) - (setf (buffer-cache-buflen cache) - (hemlock-buffer-length (buffer-cache-buffer cache)))))) + (force-output) + (or (buffer-cache-buflen cache) + (setf (buffer-cache-buflen cache) + (hemlock-buffer-length (buffer-cache-buffer cache)))))) @@ -489,5 +490,5 @@ ;;; Hook things up so that the modeline is updated whenever certain buffer ;;; attributes change. -(hi::%init-redisplay) +(hi::%init-mode-redisplay) @@ -869,5 +870,10 @@ (defun hi::document-end-editing (document) - (send (slot-value document 'textstorage) 'end-editing)) + (let* ((textstorage (slot-value document 'textstorage))) + (send textstorage 'end-editing) + (for-each-textview-using-storage + textstorage + #'(lambda (tv) + (send tv :scroll-range-to-visible (send tv 'selected-range)))))) (defun hi::document-set-point-position (document) @@ -881,6 +887,5 @@ #'(lambda (tv) (slet ((selection (ns-make-range pos 0))) - (send tv :set-selected-range selection) - (send tv :scroll-range-to-visible selection)))))) + (send tv :set-selected-range selection)))))) @@ -903,5 +908,5 @@ (unless (eq (hi::mark-%kind mark) :right-inserting) (decf pos n)) - #+debug 0 + #+debug (format t "~&pos = ~d, n = ~d" pos n) (let* ((display (hemlock-buffer-string-cache (send textstorage 'string)))) @@ -919,12 +924,14 @@ (let* ((pos (mark-absolute-position mark))) (setq n (abs n)) + #+debug + (format t "~& pos = ~d, n = ~d" pos n) + (force-output) + (send textstorage + :edited #$NSTextStorageEditedCharacters + :range (ns-make-range pos n) + :change-in-length (- n)) (let* ((cache (hemlock-buffer-string-cache (send textstorage 'string)))) (reset-buffer-cache cache) - (update-line-cache-for-index cache pos)) - - (send textstorage - :edited #$NSTextStorageEditedAttributes - :range (ns-make-range pos n) - :change-in-length (- n))))))) + (update-line-cache-for-index cache pos))))))) (defun hi::set-document-modified (document flag) Index: /trunk/ccl/examples/cocoa-listener.lisp =================================================================== --- /trunk/ccl/examples/cocoa-listener.lisp (revision 596) +++ /trunk/ccl/examples/cocoa-listener.lisp (revision 597) @@ -100,5 +100,8 @@ (declare (dynamic-extent string)) (%copy-ptr-to-ivector (send data 'bytes) 0 string 0 data-length) - (hi::insert-string (hi::buffer-point buffer) string) + (let* ((input-mark (hi::variable-value 'hemlock::buffer-input-mark :buffer buffer))) + (hi:with-mark ((mark input-mark :left-inserting)) + (hi::insert-string mark string) + (hi::move-mark input-mark mark))) (send fh 'read-in-background-and-notify)))) @@ -122,14 +125,8 @@ |# -;;; Action methods implemented by the controller (in its role as the -;;; textview's delegate). - - -(define-objc-method ((:void :send-string string) - lisp-listener-window-controller) - (send (slot-value self 'filehandle) - :write-data (send string - :data-using-encoding #$NSASCIIStringEncoding - :allow-lossy-conversion t))) + + + + @@ -176,4 +173,16 @@ (:metaclass ns:+ns-object)) +(defun hemlock::listener-document-send-string (document string) + (let* ((controller (send (send document 'window-controllers) + :object-at-index 0)) + (filehandle (slot-value controller 'filehandle)) + (len (length string)) + (data (send (make-objc-instance 'ns-mutable-data + :with-length len) 'autorelease)) + (bytes (send data 'mutable-bytes))) + (%copy-ivector-to-ptr string 0 bytes 0 len) + (send filehandle :write-data data) + (send filehandle 'synchronize-file))) + (define-objc-class-method ((:id top-listener) lisp-listener-document) @@ -211,5 +220,6 @@ (setf (hi::buffer-pathname buffer) nil (hi::buffer-minor-mode buffer "Listener") t - (hi::buffer-name buffer) listener-name))) + (hi::buffer-name buffer) listener-name) + (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*))) doc)) @@ -244,4 +254,18 @@ |# - - +(defun cocoa-ide-note-package (package) + (process-interrupt *cocoa-event-process* + #'(lambda (proc name) + (dolist (buf hi::*buffer-list*) + (when (eq proc (hi::buffer-process buf)) + (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))) + *current-process* + (package-name package))) + +(defmethod ui-object-do-operation ((o cocoa-ide-ui-object) + operation &rest args) + (case operation + (:note-package (cocoa-ide-note-package (car args))))) + + + Index: /trunk/ccl/examples/cocoa-window.lisp =================================================================== --- /trunk/ccl/examples/cocoa-window.lisp (revision 596) +++ /trunk/ccl/examples/cocoa-window.lisp (revision 597) @@ -353,2 +353,3 @@ (send dict :set-object color :for-key #@"NSColor")) dict)) + Index: /trunk/ccl/examples/cocoa.lisp =================================================================== --- /trunk/ccl/examples/cocoa.lisp (revision 596) +++ /trunk/ccl/examples/cocoa.lisp (revision 597) @@ -11,5 +11,8 @@ (fake-cfbundle-path "ccl:OpenMCL.app;Contents;MacOS;dppccl")) +(defclass cocoa-ide-ui-object (ui-object) + ()) +(setf (application-ui-object *application*) (make-instance 'cocoa-ide-ui-object)) (require "OBJC-SUPPORT") Index: /trunk/ccl/examples/compile-hemlock.lisp =================================================================== --- /trunk/ccl/examples/compile-hemlock.lisp (revision 596) +++ /trunk/ccl/examples/compile-hemlock.lisp (revision 597) @@ -158,3 +158,4 @@ (mapcar #'hemlock-binary-pathname *hemlock-files*) :if-exists :supersede) + (provide "HEMLOCK") ) Index: /trunk/ccl/hemlock/src/buffer.lisp =================================================================== --- /trunk/ccl/hemlock/src/buffer.lisp (revision 596) +++ /trunk/ccl/hemlock/src/buffer.lisp (revision 597) @@ -460,5 +460,5 @@ (defun defmode (name &key (setup-function #'identity) (cleanup-function #'identity) major-p transparent-p - precedence documentation) + precedence documentation hidden) "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 @@ -491,5 +491,6 @@ :variables (make-string-table) :bindings (make-hash-table) - :hook-name (getstring hook-str *global-variable-names*))) + :hook-name (getstring hook-str *global-variable-names*) + :hidden hidden)) (setf (getstring name *mode-names*) mode))) Index: /trunk/ccl/hemlock/src/listener.lisp =================================================================== --- /trunk/ccl/hemlock/src/listener.lisp (revision 596) +++ /trunk/ccl/hemlock/src/listener.lisp (revision 597) @@ -42,5 +42,6 @@ (t (message - "Ignoring \"package\" file option -- cannot convert to a string.")))))) + "Ignoring \"package\" file option -- cannot convert to a string.")))) +)) @@ -83,4 +84,9 @@ (defmode "Listener" :major-p nil :setup-function #'setup-listener-mode) +(defparameter *listener-modeline-fields* + (list (modeline-field :package) + (modeline-field :modes) + (modeline-field :process-info))) + (defun listener-mode-lisp-mode-hook (buffer on) "Turn on Lisp mode when we go into Listener Mode." @@ -141,4 +147,34 @@ :mode "Listener") +(defun balanced-expressions-in-region (region) + "Return true if there's at least one syntactically well-formed S-expression +between the region's start and end, and if there are no ill-formed expressions in that region." + ;; It helps to know that END-MARK immediately follows a #\newline. + (let* ((start-mark (region-start region)) + (end-mark (region-end region)) + (end-line (mark-line end-mark)) + (end-charpos (mark-charpos end-mark))) + (with-mark ((m start-mark)) + (pre-command-parse-check m) + (when (form-offset m 1) + (let* ((skip-whitespace t)) + (loop + (let* ((current-line (mark-line m)) + (current-charpos (mark-charpos m))) + (when (and (eq current-line end-line) + (eql current-charpos end-charpos)) + (return t)) + (if skip-whitespace + (progn + (scan-char m :whitespace nil) + (setq skip-whitespace nil)) + (progn + (pre-command-parse-check m) + (unless (form-offset m 1) + (return nil)) + (setq skip-whitespace t)))))))))) + + + (defcommand "Confirm Listener Input" (p) "Evaluate Listener Mode input between point and last prompt." @@ -147,27 +183,23 @@ (let ((input-region (get-interactive-input))) (when input-region - (let* ((output (value eval-output-stream)) - (*standard-output* output) - (*error-output* output) - (*trace-output* output)) - (fresh-line) - (in-lisp - ;; Copy the region to keep the output and input streams from interacting - ;; since input-region is made of permanent marks into the buffer. - (with-input-from-region (stream (copy-region input-region)) - (loop - (let ((form (read stream nil lispbuf-eof))) - (when (eq form lispbuf-eof) - ;; Move the buffer's input mark to the end of the buffer. - (move-mark (region-start input-region) - (region-end input-region)) - (return)) - (setq +++ ++ ++ + + - - form) - (let ((this-eval (multiple-value-list (eval form)))) - (fresh-line) - (dolist (x this-eval) (prin1 x) (terpri)) - (show-prompt) - (setq /// // // / / this-eval) - (setq *** ** ** * * (car this-eval))))))))))) + (insert-character (current-point) #\NewLine) + (when (balanced-expressions-in-region input-region) + (let* ((string (region-to-string input-region))) + (move-mark (value buffer-input-mark) (current-point)) + (listener-document-send-string (hi::buffer-document (current-buffer)) string)))))) + +(defvar *control-d-string* (make-string 1 :initial-element (code-char (logand (char-code #\d) #x1f)))) + +(defcommand "EOF or Delete Forward" (p) + "Send an EOF if input-mark is at buffer's end, else delete forward character." + "Send an EOF if input-mark is at buffer's end, else delete forward character." + (let* ((input-mark (value buffer-input-mark)) + (point (current-point))) + (if (and (null (next-character point)) + (null (next-character input-mark))) + (listener-document-send-string (hi::buffer-document (current-buffer)) *control-d-string*) + (delete-next-character-command p)))) + + (defcommand "Abort Listener Input" (p) @@ -363,5 +395,5 @@ ;;; Other stuff. -(defmode "Editor") +(defmode "Editor" :hidden t) (defcommand "Editor Mode" (p) Index: /trunk/ccl/hemlock/src/modeline.lisp =================================================================== --- /trunk/ccl/hemlock/src/modeline.lisp (revision 596) +++ /trunk/ccl/hemlock/src/modeline.lisp (revision 597) @@ -132,5 +132,9 @@ "Returns buffer's modes followed by one space." (declare (ignore window)) - (format nil "~A " (buffer-modes buffer)))) + (let* ((m ())) + (dolist (mode (buffer-mode-objects buffer)) + (unless (hi::mode-object-hidden mode) + (push (mode-object-name mode) m))) + (format nil "~A " (nreverse m))))) (make-modeline-field @@ -209,4 +213,14 @@ :function 'buffer-pathname-ml-field-fun) +(make-modeline-field + :name :process-info + :function #'(lambda (buffer window) + (declare (ignore window)) + (let* ((proc (buffer-process buffer))) + (when proc + (format nil "~a(~d) [~a]" + (ccl::process-name proc) + (ccl::process-serial-number proc) + (ccl::process-whostate proc)))))) (defvar *default-modeline-fields* @@ -219,5 +233,5 @@ "This is the default value for \"Default Modeline Fields\".") -(defun %init-redisplay () +(defun %init-mode-redisplay () (add-hook hemlock::buffer-major-mode-hook 'queue-buffer-change) (add-hook hemlock::buffer-minor-mode-hook 'queue-buffer-change) @@ -225,4 +239,5 @@ (add-hook hemlock::buffer-pathname-hook 'queue-buffer-change) (add-hook hemlock::buffer-modified-hook 'queue-buffer-change) + (add-hook hemlock:: (add-hook hemlock::window-buffer-hook 'queue-window-change)) Index: /trunk/ccl/hemlock/src/struct.lisp =================================================================== --- /trunk/ccl/hemlock/src/struct.lisp (revision 596) +++ /trunk/ccl/hemlock/src/struct.lisp (revision 597) @@ -163,5 +163,7 @@ variables ; String-table of mode variables var-values ; Alist for saving mode variables - documentation) ; Introductory comments for mode describing commands. + documentation ; Introductory comments for mode describing commands. + hidden ; Not listed in modeline fields +) (defun %print-hemlock-mode (object stream depth)