Changeset 6682

Timestamp:

Jun 8, 2007, 3:12:53 PM (17 years ago)

Author:

Gary Byers

Message:

Use are real stream to write to input.
Default-style stuff.

File:

• branches/ide-1.0/ccl/examples/cocoa-listener.lisp (modified) (8 diffs)

branches/ide-1.0/ccl/examples/cocoa-listener.lisp

@@ -43 +43 @@
     ((input-stream :reader cocoa-listener-process-input-stream)
      (output-stream :reader cocoa-listener-process-output-stream)
+     (input-peer-stream :reader cocoa-listener-process-input-peer-stream)
      (backtrace-contexts :initform nil
                          :accessor cocoa-listener-process-backtrace-contexts)
@@ -64 +65 @@
                                          #$_PC_MAX_INPUT)
                                         :encoding :utf-8))
+         (peer-stream (make-fd-stream peer-fd :direction :output
+                                      :sharing :lock
+                                      :elements-per-buffer
+                                      (#_fpathconf
+                                         peer-fd
+                                         #$_PC_MAX_INPUT)
+                                      :encoding :utf-8))
          (proc
           (make-mcl-listener-process 
@@ -87 +95 @@
     (setf (slot-value proc 'input-stream) input-stream)
     (setf (slot-value proc 'output-stream) output-stream)
+    (setf (slot-value proc 'input-peer-stream) peer-stream)
     (setf (slot-value proc 'window) window)
     (setf (slot-value proc 'buffer) buffer)
@@ -204 +213 @@
   (:metaclass ns:+ns-object))
 
+(defmethod hi::document-encoding-name ((doc hemlock-listener-document))
+  "UTF-8")
+
+(defmethod user-input-style ((doc hemlock-listener-document))
+  hi::*listener-input-style*)
+  
 (defmethod textview-background-color ((doc hemlock-listener-document))
   (#/colorWithCalibratedRed:green:blue:alpha:
@@ -270 +285 @@
     doc))
 
-(def-cocoa-default *initial-listener-x-pos* :float 400.0f0 "X position of upper-left corner of initial listener")
-
-(def-cocoa-default *initial-listener-y-pos* :float 400.0f0 "Y position of upper-left corner of initial listener")
+(def-cocoa-default *initial-listener-x-pos* :float -100.0f0 "X position of upper-left corner of initial listener")
+
+(def-cocoa-default *initial-listener-y-pos* :float 100.0f0 "Y position of upper-left corner of initial listener")
 
 (defloadvar *next-listener-x-pos* nil) ; set after defaults initialized
@@ -284 +299 @@
                   *listener-rows*
                   t
-                  (textview-background-color self)))
+                  (textview-background-color self)
+                  (user-input-style self)))
          (controller (make-instance
                       'hemlock-listener-window-controller
@@ -298 +314 @@
     (#/release controller)
     (ns:with-ns-point (current-point
-                       (or *next-listener-x-pos* *initial-listener-x-pos*)
-                       (or *next-listener-y-pos* *initial-listener-y-pos*))
+                       (or *next-listener-x-pos*
+                           (x-pos-for-window window *initial-listener-x-pos*))
+                       (or *next-listener-y-pos*
+                           (y-pos-for-window window *initial-listener-y-pos*)))
       (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
         (setf *next-listener-x-pos* (ns:ns-point-x new-point)
@@ -393 +411 @@
 (defmethod hi::send-string-to-listener-process ((process cocoa-listener-process)
                                                 string &key path package)
-  (let* ((fd (selection-input-stream-peer-fd (cocoa-listener-process-input-stream process))))
-    (%stack-block ((buf 512))
-      (let* ((nout 0))
-         (labels ((flush ()
-                    (when (> nout 0)
-                    (fd-write fd buf nout)
-                    (setq nout 0)))
-                  (out-raw-char (ch)
-                    (when (= nout 512)
-                      (flush))
-                    (let* ((code (char-code ch)))
-                      (if (> code 255)
-                        (setq code (char-code #\Sub)))
-                      (setf (%get-unsigned-byte buf nout) code)
-                      (incf nout)))
-                  (out-ch (ch)
-                      (when (or (eql ch #\^v)
-                                (eql ch #\^p)
-                                (eql ch #\newline)
-                                (eql ch #\^q))
-                        (out-raw-char #\^q))
-                      (out-raw-char ch))
-                  (out-string (s)
-                    (dotimes (i (length s))
-                      (out-ch (char s i)))))
-           (out-raw-char #\^p)
-           (when package (out-string package))
-           (out-raw-char #\newline)
-           (out-raw-char #\^v)
-           (when path (out-string path))
-           (out-raw-char #\newline)
-           (out-string string)
-           (flush))))))
+  (let* ((stream (cocoa-listener-process-input-peer-stream process)))
+    (labels ((out-raw-char (ch)
+               (write-char ch stream))
+             (out-ch (ch)
+               (when (or (eql ch #\^v)
+                         (eql ch #\^p)
+                         (eql ch #\newline)
+                         (eql ch #\^q))
+                 (out-raw-char #\^q))
+               (out-raw-char ch))
+             (out-string (s)
+               (dotimes (i (length s))
+                 (out-ch (char s i)))))
+      (out-raw-char #\^p)
+      (when package (out-string package))
+      (out-raw-char #\newline)
+      (out-raw-char #\^v)
+      (when path (out-string path))
+      (out-raw-char #\newline)
+      (out-string string)
+      (force-output stream))))