Changeset 597

Timestamp:

Mar 1, 2004, 9:01:42 AM (21 years ago)

Author:

Gary Byers

Message:

More changes. Every day, more changes. (Listeners kind of work now.)

Location:

trunk/ccl

Files:

• examples/cocoa-editor.lisp (modified) (6 diffs)
• examples/cocoa-listener.lisp (modified) (5 diffs)
• examples/cocoa-window.lisp (modified) (1 diff)
• examples/cocoa.lisp (modified) (1 diff)
• examples/compile-hemlock.lisp (modified) (1 diff)
• hemlock/src/buffer.lisp (modified) (2 diffs)
• hemlock/src/listener.lisp (modified) (5 diffs)
• hemlock/src/modeline.lisp (modified) (4 diffs)
• hemlock/src/struct.lisp (modified) (1 diff)

trunk/ccl/examples/cocoa-editor.lisp

@@ -171 +171 @@
                      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 +490 @@
 ;;; Hook things up so that the modeline is updated whenever certain buffer
 ;;; attributes change.
-(hi::%init-redisplay)
+(hi::%init-mode-redisplay)
 
 
@@ -869 +870 @@
 
 (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 +887 @@
      #'(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 +908 @@
           (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 +924 @@
         (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)

trunk/ccl/examples/cocoa-listener.lisp

@@ -100 +100 @@
       (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 +125 @@
 |#
 
-;;; 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 +173 @@
   (: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 +220 @@
         (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 +254 @@
 |#
 
-
-
+(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)))))
+
+       
+  

trunk/ccl/examples/cocoa-window.lisp

@@ -353 +353 @@
       (send dict :set-object color :for-key #@"NSColor"))
     dict))
+

trunk/ccl/examples/cocoa.lisp

@@ -11 +11 @@
 (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")

trunk/ccl/examples/compile-hemlock.lisp

@@ -158 +158 @@
                     (mapcar #'hemlock-binary-pathname *hemlock-files*)
                     :if-exists :supersede)
+  (provide "HEMLOCK")
   )

trunk/ccl/hemlock/src/buffer.lisp

@@ -460 +460 @@
 (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 +491 @@
                   :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)))
 

trunk/ccl/hemlock/src/listener.lisp

@@ -42 +42 @@
        (t
         (message
-         "Ignoring \"package\" file option -- cannot convert to a string."))))))
+         "Ignoring \"package\" file option -- cannot convert to a string."))))
+))
 
 
@@ -83 +84 @@
 (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 +147 @@
   :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 +183 @@
   (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 +395 @@
 ;;; Other stuff.
 
-(defmode "Editor")
+(defmode "Editor" :hidden t)
 
 (defcommand "Editor Mode" (p)

trunk/ccl/hemlock/src/modeline.lisp

@@ -132 +132 @@
                "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 +213 @@
  :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 +233 @@
   "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 +239 @@
   (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))
 

trunk/ccl/hemlock/src/struct.lisp

@@ -163 +163 @@
   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)