| 1 | ;;;-*-Mode: LISP; Package: GUI -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2007 Clozure Associates |
|---|
| 4 | |
|---|
| 5 | (in-package "GUI") |
|---|
| 6 | |
|---|
| 7 | (def-cocoa-default *listener-input-font* :font #'(lambda () |
|---|
| 8 | (#/fontWithName:size: |
|---|
| 9 | ns:ns-font |
|---|
| 10 | #+darwin-target |
|---|
| 11 | #@"Monaco" |
|---|
| 12 | #-darwin-target |
|---|
| 13 | #@"Courier New" |
|---|
| 14 | (font-size-kludge 10.0))) |
|---|
| 15 | "Default font for listener input") |
|---|
| 16 | (def-cocoa-default *listener-output-font* :font #'(lambda () |
|---|
| 17 | (#/fontWithName:size: |
|---|
| 18 | ns:ns-font |
|---|
| 19 | #+darwin-target |
|---|
| 20 | #@"Monaco" |
|---|
| 21 | #-darwin-target |
|---|
| 22 | #@"Courier New" |
|---|
| 23 | (font-size-kludge 10.0))) |
|---|
| 24 | "Default font for listener output") |
|---|
| 25 | |
|---|
| 26 | (def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters") |
|---|
| 27 | (def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters") |
|---|
| 28 | |
|---|
| 29 | (def-cocoa-default hi::*listener-output-style* :int 1 "Text style index for listener output") |
|---|
| 30 | |
|---|
| 31 | (def-cocoa-default hi::*listener-input-style* :int 0 "Text style index for listener output") |
|---|
| 32 | |
|---|
| 33 | (def-cocoa-default *listener-background-color* :color '(1.0 1.0 1.0 1.0) "Listener default background color") |
|---|
| 34 | |
|---|
| 35 | (def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output") |
|---|
| 36 | |
|---|
| 37 | (defun hemlock-ext:read-only-listener-p () |
|---|
| 38 | *read-only-listener*) |
|---|
| 39 | |
|---|
| 40 | |
|---|
| 41 | (defclass cocoa-listener-input-stream (fundamental-character-input-stream) |
|---|
| 42 | ((queue :initform ()) |
|---|
| 43 | (queue-lock :initform (make-lock)) |
|---|
| 44 | (read-lock :initform (make-lock)) |
|---|
| 45 | (queue-semaphore :initform (make-semaphore)) ;; total queue count |
|---|
| 46 | (text-semaphore :initform (make-semaphore)) ;; text-only queue count |
|---|
| 47 | (cur-string :initform nil) |
|---|
| 48 | (cur-string-pos :initform 0) |
|---|
| 49 | (cur-env :initform nil) |
|---|
| 50 | (cur-sstream :initform nil) |
|---|
| 51 | (cur-offset :initform nil) |
|---|
| 52 | (source-map :initform nil) |
|---|
| 53 | (reading-line :initform nil :accessor hi:input-stream-reading-line))) |
|---|
| 54 | |
|---|
| 55 | (defmethod interactive-stream-p ((stream cocoa-listener-input-stream)) |
|---|
| 56 | t) |
|---|
| 57 | |
|---|
| 58 | |
|---|
| 59 | |
|---|
| 60 | |
|---|
| 61 | (defmethod dequeue-listener-char ((stream cocoa-listener-input-stream) wait-p) |
|---|
| 62 | (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream |
|---|
| 63 | (with-lock-grabbed (read-lock) |
|---|
| 64 | (or (with-lock-grabbed (queue-lock) |
|---|
| 65 | (when (< cur-string-pos (length cur-string)) |
|---|
| 66 | (prog1 (aref cur-string cur-string-pos) (incf cur-string-pos)))) |
|---|
| 67 | (loop |
|---|
| 68 | (unless (if wait-p |
|---|
| 69 | (wait-on-semaphore text-semaphore nil "Listener Input") |
|---|
| 70 | (timed-wait-on-semaphore text-semaphore 0)) |
|---|
| 71 | (return nil)) |
|---|
| 72 | (assert (timed-wait-on-semaphore queue-semaphore 0) () "queue/text mismatch!") |
|---|
| 73 | (with-lock-grabbed (queue-lock) |
|---|
| 74 | (let* ((s (find-if #'stringp queue))) |
|---|
| 75 | (assert s () "queue/semaphore mismatch!") |
|---|
| 76 | (setq queue (delq s queue 1)) |
|---|
| 77 | (when (< 0 (length s)) |
|---|
| 78 | (setf cur-string s cur-string-pos 1) |
|---|
| 79 | (return (aref s 0)))))))))) |
|---|
| 80 | |
|---|
| 81 | (defmethod ccl::read-toplevel-form ((stream cocoa-listener-input-stream) &key eof-value) |
|---|
| 82 | (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos cur-sstream |
|---|
| 83 | cur-env source-map cur-offset) |
|---|
| 84 | stream |
|---|
| 85 | (with-lock-grabbed (read-lock) |
|---|
| 86 | (loop |
|---|
| 87 | (when cur-sstream |
|---|
| 88 | #+debug (log-debug "About to recursively read from sstring in env: ~s" cur-env) |
|---|
| 89 | (let* ((env cur-env) |
|---|
| 90 | (form (progv (car env) (cdr env) |
|---|
| 91 | (ccl::read-toplevel-form cur-sstream |
|---|
| 92 | :eof-value eof-value |
|---|
| 93 | :file-name *loading-file-source-file* |
|---|
| 94 | :start-offset cur-offset |
|---|
| 95 | :map source-map))) |
|---|
| 96 | (last-form-in-selection (not (listen cur-sstream)))) |
|---|
| 97 | #+debug (log-debug " --> ~s" form) |
|---|
| 98 | (when last-form-in-selection |
|---|
| 99 | (setf cur-sstream nil cur-env nil)) |
|---|
| 100 | (return (values form env (or last-form-in-selection ccl::*verbose-eval-selection*))))) |
|---|
| 101 | (when (with-lock-grabbed (queue-lock) |
|---|
| 102 | (loop |
|---|
| 103 | unless (< cur-string-pos (length cur-string)) return nil |
|---|
| 104 | unless (whitespacep (aref cur-string cur-string-pos)) return t |
|---|
| 105 | do (incf cur-string-pos))) |
|---|
| 106 | (return (values (call-next-method) nil t))) |
|---|
| 107 | (wait-on-semaphore queue-semaphore nil "Toplevel Read") |
|---|
| 108 | (let ((val (with-lock-grabbed (queue-lock) (pop queue)))) |
|---|
| 109 | (cond ((stringp val) |
|---|
| 110 | (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!") |
|---|
| 111 | (setq cur-string val cur-string-pos 0)) |
|---|
| 112 | (t |
|---|
| 113 | (destructuring-bind (string package-name pathname offset) val |
|---|
| 114 | ;; This env is used both for read and eval. |
|---|
| 115 | (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location* |
|---|
| 116 | ccl::*nx-source-note-map*) |
|---|
| 117 | (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil |
|---|
| 118 | source-map)))) |
|---|
| 119 | (when package-name |
|---|
| 120 | (push '*package* (car env)) |
|---|
| 121 | (push (ccl::pkg-arg package-name) (cdr env))) |
|---|
| 122 | (if source-map |
|---|
| 123 | (clrhash source-map) |
|---|
| 124 | (setf source-map (make-hash-table :test 'eq :shared nil))) |
|---|
| 125 | (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset)))))))))) |
|---|
| 126 | |
|---|
| 127 | (defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname offset) |
|---|
| 128 | (with-slots (queue-lock queue queue-semaphore) stream |
|---|
| 129 | (with-lock-grabbed (queue-lock) |
|---|
| 130 | (setq queue (nconc queue (list (list string package-name pathname offset)))) |
|---|
| 131 | (signal-semaphore queue-semaphore)))) |
|---|
| 132 | |
|---|
| 133 | (defmethod enqueue-listener-input ((stream cocoa-listener-input-stream) string) |
|---|
| 134 | (with-slots (queue-lock queue queue-semaphore text-semaphore) stream |
|---|
| 135 | (with-lock-grabbed (queue-lock) |
|---|
| 136 | (setq queue (nconc queue (list string))) |
|---|
| 137 | (signal-semaphore queue-semaphore) |
|---|
| 138 | (signal-semaphore text-semaphore)))) |
|---|
| 139 | |
|---|
| 140 | (defmethod stream-read-char-no-hang ((stream cocoa-listener-input-stream)) |
|---|
| 141 | (dequeue-listener-char stream nil)) |
|---|
| 142 | |
|---|
| 143 | (defmethod stream-read-char ((stream cocoa-listener-input-stream)) |
|---|
| 144 | (dequeue-listener-char stream t)) |
|---|
| 145 | |
|---|
| 146 | (defmethod stream-unread-char ((stream cocoa-listener-input-stream) char) |
|---|
| 147 | ;; Can't guarantee the right order of reads/unreads, just make sure not to |
|---|
| 148 | ;; introduce any internal inconsistencies (and dtrt for the non-conflict case). |
|---|
| 149 | (with-slots (queue queue-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream |
|---|
| 150 | (with-lock-grabbed (queue-lock) |
|---|
| 151 | (cond ((>= cur-string-pos (length cur-string)) |
|---|
| 152 | (push (string char) queue) |
|---|
| 153 | (signal-semaphore queue-semaphore) |
|---|
| 154 | (signal-semaphore text-semaphore)) |
|---|
| 155 | ((< 0 cur-string-pos) |
|---|
| 156 | (decf cur-string-pos) |
|---|
| 157 | (setf (aref cur-string cur-string-pos) char)) |
|---|
| 158 | (t (setf cur-string (concatenate 'string (string char) cur-string))))))) |
|---|
| 159 | |
|---|
| 160 | (defmethod ccl::stream-eof-transient-p ((stream cocoa-listener-input-stream)) |
|---|
| 161 | t) |
|---|
| 162 | |
|---|
| 163 | (defmethod stream-clear-input ((stream cocoa-listener-input-stream)) |
|---|
| 164 | (with-slots (queue-lock cur-string cur-string-pos cur-sstream cur-env) stream |
|---|
| 165 | (with-lock-grabbed (queue-lock) |
|---|
| 166 | (setf (hi::input-stream-reading-line stream) nil) |
|---|
| 167 | (setf cur-string nil cur-string-pos 0 cur-sstream nil cur-env nil)))) |
|---|
| 168 | |
|---|
| 169 | (defmethod stream-read-line ((stream cocoa-listener-input-stream)) |
|---|
| 170 | (let* ((old-reading-line (hi:input-stream-reading-line stream))) |
|---|
| 171 | (unwind-protect |
|---|
| 172 | (progn |
|---|
| 173 | (setf (hi::input-stream-reading-line stream) t) |
|---|
| 174 | (call-next-method)) |
|---|
| 175 | (setf (hi:input-stream-reading-line stream) old-reading-line)))) |
|---|
| 176 | |
|---|
| 177 | (defparameter $listener-flush-limit 4095) |
|---|
| 178 | |
|---|
| 179 | (defclass cocoa-listener-output-stream (fundamental-character-output-stream) |
|---|
| 180 | ((lock :initform (make-lock)) |
|---|
| 181 | (hemlock-view :initarg :hemlock-view) |
|---|
| 182 | (data :initform (make-array (1+ $listener-flush-limit) |
|---|
| 183 | :adjustable t :fill-pointer 0 |
|---|
| 184 | :element-type 'character)) |
|---|
| 185 | (limit :initform $listener-flush-limit))) |
|---|
| 186 | |
|---|
| 187 | (defmethod stream-element-type ((stream cocoa-listener-output-stream)) |
|---|
| 188 | (with-slots (data) stream |
|---|
| 189 | (array-element-type data))) |
|---|
| 190 | |
|---|
| 191 | (defmethod ccl:stream-write-char ((stream cocoa-listener-output-stream) char) |
|---|
| 192 | (with-slots (data lock limit) stream |
|---|
| 193 | (when (with-lock-grabbed (lock) |
|---|
| 194 | (>= (vector-push-extend char data) limit)) |
|---|
| 195 | (stream-force-output stream)))) |
|---|
| 196 | |
|---|
| 197 | ;; This isn't really thread safe, but it's not too bad... I'll take a chance - trying |
|---|
| 198 | ;; to get it to execute in the gui thread is too deadlock-prone. |
|---|
| 199 | (defmethod hemlock-listener-output-mark-column ((view hi::hemlock-view)) |
|---|
| 200 | (let* ((output-region (hi::variable-value 'hemlock::current-output-font-region |
|---|
| 201 | :buffer (hi::hemlock-view-buffer view)))) |
|---|
| 202 | (hi::mark-charpos (hi::region-end output-region)))) |
|---|
| 203 | |
|---|
| 204 | ;; TODO: doesn't do the right thing for embedded tabs (in buffer or data) |
|---|
| 205 | (defmethod ccl:stream-line-column ((stream cocoa-listener-output-stream)) |
|---|
| 206 | (with-slots (hemlock-view data lock) stream |
|---|
| 207 | (with-lock-grabbed (lock) |
|---|
| 208 | (let* ((n (length data)) |
|---|
| 209 | (pos (position #\Newline data :from-end t))) |
|---|
| 210 | (if (null pos) |
|---|
| 211 | (+ (hemlock-listener-output-mark-column hemlock-view) n) |
|---|
| 212 | (- n pos 1)))))) |
|---|
| 213 | |
|---|
| 214 | (defmethod ccl:stream-fresh-line ((stream cocoa-listener-output-stream)) |
|---|
| 215 | (with-slots (hemlock-view data lock limit) stream |
|---|
| 216 | (when (with-lock-grabbed (lock) |
|---|
| 217 | (let ((n (length data))) |
|---|
| 218 | (unless (if (= n 0) |
|---|
| 219 | (= (hemlock-listener-output-mark-column hemlock-view) 0) |
|---|
| 220 | (eq (aref data (1- n)) #\Newline)) |
|---|
| 221 | (>= (vector-push-extend #\Newline data) limit)))) |
|---|
| 222 | (stream-force-output stream)))) |
|---|
| 223 | |
|---|
| 224 | (defmethod ccl::stream-finish-output ((stream cocoa-listener-output-stream)) |
|---|
| 225 | (stream-force-output stream)) |
|---|
| 226 | |
|---|
| 227 | (defmethod ccl:stream-force-output ((stream cocoa-listener-output-stream)) |
|---|
| 228 | (if (typep *current-process* 'appkit-process) |
|---|
| 229 | (with-slots (hemlock-view data lock) stream |
|---|
| 230 | (with-lock-grabbed (lock) |
|---|
| 231 | (when (> (fill-pointer data) 0) |
|---|
| 232 | (append-output hemlock-view data) |
|---|
| 233 | (setf (fill-pointer data) 0)))) |
|---|
| 234 | (with-slots (data) stream |
|---|
| 235 | (when (> (fill-pointer data) 0) |
|---|
| 236 | (queue-for-gui #'(lambda () (stream-force-output stream))))))) |
|---|
| 237 | |
|---|
| 238 | (defmethod ccl:stream-clear-output ((stream cocoa-listener-output-stream)) |
|---|
| 239 | (with-slots (data lock) stream |
|---|
| 240 | (with-lock-grabbed (lock) |
|---|
| 241 | (setf (fill-pointer data) 0)))) |
|---|
| 242 | |
|---|
| 243 | (defmethod ccl:stream-line-length ((stream cocoa-listener-output-stream)) |
|---|
| 244 | (with-slots (hemlock-view) stream |
|---|
| 245 | (values (hemlock-view-size hemlock-view)))) |
|---|
| 246 | |
|---|
| 247 | (defloadvar *cocoa-listener-count* 0) |
|---|
| 248 | |
|---|
| 249 | (defclass cocoa-listener-process (process) |
|---|
| 250 | ((input-stream :reader cocoa-listener-process-input-stream) |
|---|
| 251 | (output-stream :reader cocoa-listener-process-output-stream) |
|---|
| 252 | (backtrace-contexts :initform nil |
|---|
| 253 | :accessor cocoa-listener-process-backtrace-contexts) |
|---|
| 254 | (window :reader cocoa-listener-process-window :initform nil))) |
|---|
| 255 | |
|---|
| 256 | (defloadvar *first-listener* t) |
|---|
| 257 | |
|---|
| 258 | (defun new-cocoa-listener-process (procname window) |
|---|
| 259 | (declare (special *standalone-cocoa-ide*)) |
|---|
| 260 | (let* ((input-stream (make-instance 'cocoa-listener-input-stream)) |
|---|
| 261 | (output-stream (make-instance 'cocoa-listener-output-stream |
|---|
| 262 | :hemlock-view (hemlock-view window))) |
|---|
| 263 | |
|---|
| 264 | (proc |
|---|
| 265 | (ccl::make-mcl-listener-process |
|---|
| 266 | procname |
|---|
| 267 | input-stream |
|---|
| 268 | output-stream |
|---|
| 269 | ;; cleanup function |
|---|
| 270 | #'(lambda () |
|---|
| 271 | (mapcar #'(lambda (buf) |
|---|
| 272 | (when (eq (buffer-process buf) *current-process*) |
|---|
| 273 | (let ((doc (hi::buffer-document buf))) |
|---|
| 274 | (when doc |
|---|
| 275 | (setf (hemlock-document-process doc) nil) ;; so #/close doesn't kill it. |
|---|
| 276 | (#/performSelectorOnMainThread:withObject:waitUntilDone: |
|---|
| 277 | doc |
|---|
| 278 | (@selector #/close) |
|---|
| 279 | +null-ptr+ |
|---|
| 280 | nil))))) |
|---|
| 281 | hi:*buffer-list*)) |
|---|
| 282 | :initial-function |
|---|
| 283 | #'(lambda () |
|---|
| 284 | (setq ccl::*listener-autorelease-pool* (create-autorelease-pool)) (when (and *standalone-cocoa-ide* |
|---|
| 285 | (prog1 *first-listener* (setq *first-listener* nil))) |
|---|
| 286 | (ccl::startup-ccl (ccl::application-init-file ccl::*application*)) |
|---|
| 287 | (ui-object-note-package *nsapp* *package*)) |
|---|
| 288 | (ccl::listener-function)) |
|---|
| 289 | :echoing nil |
|---|
| 290 | :class 'cocoa-listener-process))) |
|---|
| 291 | (setf (slot-value proc 'input-stream) input-stream) |
|---|
| 292 | (setf (slot-value proc 'output-stream) output-stream) |
|---|
| 293 | (setf (slot-value proc 'window) window) |
|---|
| 294 | proc)) |
|---|
| 295 | |
|---|
| 296 | (defclass hemlock-listener-frame (hemlock-frame) |
|---|
| 297 | () |
|---|
| 298 | (:metaclass ns:+ns-object)) |
|---|
| 299 | (declaim (special hemlock-listener-frame)) |
|---|
| 300 | |
|---|
| 301 | (objc:defmethod (#/setDocumentEdited: :void) ((w hemlock-listener-frame) |
|---|
| 302 | (edited #>BOOL)) |
|---|
| 303 | (declare (ignorable edited))) |
|---|
| 304 | |
|---|
| 305 | (objc:defmethod (#/windowShouldClose: #>BOOL) ((w hemlock-listener-frame) |
|---|
| 306 | sender) |
|---|
| 307 | (let* ((doc (#/document (#/windowController w)))) |
|---|
| 308 | (if (or (%null-ptr-p doc) |
|---|
| 309 | (and (hemlock-document-process doc) |
|---|
| 310 | (perform-close-kills-process-p doc))) |
|---|
| 311 | t |
|---|
| 312 | (progn |
|---|
| 313 | (#/orderOut: w sender) |
|---|
| 314 | nil)))) |
|---|
| 315 | |
|---|
| 316 | |
|---|
| 317 | |
|---|
| 318 | (defclass hemlock-listener-window-controller (hemlock-editor-window-controller) |
|---|
| 319 | () |
|---|
| 320 | (:metaclass ns:+ns-object) |
|---|
| 321 | ) |
|---|
| 322 | (declaim (special hemlock-listener-window-controller)) |
|---|
| 323 | |
|---|
| 324 | ;;; Listener documents are never (or always) ediited. Don't cause their |
|---|
| 325 | ;;; close boxes to be highlighted. |
|---|
| 326 | (objc:defmethod (#/setDocumentEdited: :void) |
|---|
| 327 | ((self hemlock-listener-window-controller) (edited :<BOOL>)) |
|---|
| 328 | (declare (ignorable edited))) |
|---|
| 329 | |
|---|
| 330 | |
|---|
| 331 | |
|---|
| 332 | (objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name) |
|---|
| 333 | (let* ((doc (#/document self))) |
|---|
| 334 | (if (or (%null-ptr-p doc) |
|---|
| 335 | (not (%null-ptr-p (#/fileURL doc)))) |
|---|
| 336 | (call-next-method name) |
|---|
| 337 | (let* ((buffer (hemlock-buffer doc)) |
|---|
| 338 | (bufname (if buffer (hi::buffer-name buffer)))) |
|---|
| 339 | (if bufname |
|---|
| 340 | (%make-nsstring bufname) |
|---|
| 341 | (call-next-method name)))))) |
|---|
| 342 | |
|---|
| 343 | |
|---|
| 344 | ;;; The HemlockListenerDocument class. |
|---|
| 345 | |
|---|
| 346 | |
|---|
| 347 | (defclass hemlock-listener-document (hemlock-editor-document) |
|---|
| 348 | ((process :reader %hemlock-document-process :writer (setf hemlock-document-process) :initform nil)) |
|---|
| 349 | (:metaclass ns:+ns-object)) |
|---|
| 350 | (declaim (special hemlock-listener-document)) |
|---|
| 351 | |
|---|
| 352 | (defgeneric hemlock-document-process (doc) |
|---|
| 353 | (:method ((unknown t)) nil) |
|---|
| 354 | (:method ((doc hemlock-listener-document)) (%hemlock-document-process doc))) |
|---|
| 355 | |
|---|
| 356 | ;; Nowadays this is nil except for listeners. |
|---|
| 357 | (defun buffer-process (buffer) |
|---|
| 358 | (hemlock-document-process (hi::buffer-document buffer))) |
|---|
| 359 | |
|---|
| 360 | (defmethod update-buffer-package ((doc hemlock-listener-document) buffer) |
|---|
| 361 | (declare (ignore buffer))) |
|---|
| 362 | |
|---|
| 363 | (defmethod document-encoding-name ((doc hemlock-listener-document)) |
|---|
| 364 | "UTF-8") |
|---|
| 365 | |
|---|
| 366 | (defmethod user-input-style ((doc hemlock-listener-document)) |
|---|
| 367 | hi::*listener-input-style*) |
|---|
| 368 | |
|---|
| 369 | (defmethod textview-background-color ((doc hemlock-listener-document)) |
|---|
| 370 | *listener-background-color*) |
|---|
| 371 | |
|---|
| 372 | ;; For use with the :process-info listener modeline field |
|---|
| 373 | (defmethod hemlock-ext:buffer-process-description (buffer) |
|---|
| 374 | (let ((proc (buffer-process buffer))) |
|---|
| 375 | (when proc |
|---|
| 376 | (format nil "~a(~d) [~a]" |
|---|
| 377 | (ccl:process-name proc) |
|---|
| 378 | (ccl::process-serial-number proc) |
|---|
| 379 | ;; TODO: this doesn't really work as a modeline item, because the modeline |
|---|
| 380 | ;; doesn't get notified when it changes. |
|---|
| 381 | (ccl:process-whostate proc))))) |
|---|
| 382 | |
|---|
| 383 | (objc:defmethod #/topListener ((self +hemlock-listener-document)) |
|---|
| 384 | (let* ((all-windows (#/orderedWindows *NSApp*))) |
|---|
| 385 | (dotimes (i (#/count all-windows) +null-ptr+) |
|---|
| 386 | (let* ((w (#/objectAtIndex: all-windows i))) |
|---|
| 387 | (when (#/isVisible w) |
|---|
| 388 | (let* ((wc (#/windowController w)) |
|---|
| 389 | (doc (#/document wc))) |
|---|
| 390 | (unless (%null-ptr-p doc) |
|---|
| 391 | (when (#/isKindOfClass: doc self) |
|---|
| 392 | (return doc))))))))) |
|---|
| 393 | |
|---|
| 394 | (defun symbol-value-in-top-listener-process (symbol) |
|---|
| 395 | (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document)))) |
|---|
| 396 | (if process |
|---|
| 397 | (ignore-errors (symbol-value-in-process symbol process)) |
|---|
| 398 | (values nil t)))) |
|---|
| 399 | |
|---|
| 400 | (defun hemlock-ext:top-listener-output-stream () |
|---|
| 401 | (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document)))) |
|---|
| 402 | (when process |
|---|
| 403 | (setq process (require-type process 'cocoa-listener-process)) |
|---|
| 404 | (cocoa-listener-process-output-stream process)))) |
|---|
| 405 | |
|---|
| 406 | (defun hemlock-ext:top-listener-input-stream () |
|---|
| 407 | (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document)))) |
|---|
| 408 | (when process |
|---|
| 409 | (setq process (require-type process 'cocoa-listener-process)) |
|---|
| 410 | (cocoa-listener-process-input-stream process)))) |
|---|
| 411 | |
|---|
| 412 | |
|---|
| 413 | |
|---|
| 414 | (objc:defmethod (#/isDocumentEdited :<BOOL>) ((self hemlock-listener-document)) |
|---|
| 415 | nil) |
|---|
| 416 | |
|---|
| 417 | |
|---|
| 418 | |
|---|
| 419 | (objc:defmethod #/init ((self hemlock-listener-document)) |
|---|
| 420 | (let* ((doc (call-next-method))) |
|---|
| 421 | (unless (%null-ptr-p doc) |
|---|
| 422 | (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*)) |
|---|
| 423 | "Listener" |
|---|
| 424 | (format nil |
|---|
| 425 | "Listener-~d" *cocoa-listener-count*))) |
|---|
| 426 | (buffer (hemlock-buffer doc))) |
|---|
| 427 | (setf (hi::buffer-pathname buffer) nil |
|---|
| 428 | (hi::buffer-minor-mode buffer "Listener") t |
|---|
| 429 | (hi::buffer-name buffer) listener-name) |
|---|
| 430 | (hi::set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*))) |
|---|
| 431 | doc)) |
|---|
| 432 | |
|---|
| 433 | (def-cocoa-default *initial-listener-x-pos* :float -100.0f0 "X position of upper-left corner of initial listener") |
|---|
| 434 | |
|---|
| 435 | (def-cocoa-default *initial-listener-y-pos* :float 100.0f0 "Y position of upper-left corner of initial listener") |
|---|
| 436 | |
|---|
| 437 | (defloadvar *next-listener-x-pos* nil) ; set after defaults initialized |
|---|
| 438 | (defloadvar *next-listener-y-pos* nil) ; likewise |
|---|
| 439 | |
|---|
| 440 | (objc:defmethod (#/dealloc :void) ((self hemlock-listener-document)) |
|---|
| 441 | (if (zerop (decf *cocoa-listener-count*)) |
|---|
| 442 | (setq *next-listener-x-pos* nil |
|---|
| 443 | *next-listener-y-pos* nil)) |
|---|
| 444 | (let* ((p (shiftf (hemlock-document-process self) nil))) |
|---|
| 445 | (when p |
|---|
| 446 | (process-kill p))) |
|---|
| 447 | (call-next-method)) |
|---|
| 448 | |
|---|
| 449 | |
|---|
| 450 | |
|---|
| 451 | |
|---|
| 452 | (objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document)) |
|---|
| 453 | (let* ((textstorage (slot-value self 'textstorage)) |
|---|
| 454 | (window (%hemlock-frame-for-textstorage |
|---|
| 455 | hemlock-listener-frame |
|---|
| 456 | textstorage |
|---|
| 457 | *listener-columns* |
|---|
| 458 | *listener-rows* |
|---|
| 459 | t |
|---|
| 460 | (textview-background-color self) |
|---|
| 461 | (user-input-style self))) |
|---|
| 462 | (listener-styles (#/arrayWithObjects: ns:ns-mutable-array |
|---|
| 463 | (rme-create-text-attributes |
|---|
| 464 | :font *listener-input-font*) |
|---|
| 465 | (rme-create-text-attributes |
|---|
| 466 | :font *listener-output-font*) |
|---|
| 467 | +null-ptr+)) |
|---|
| 468 | (controller (make-instance |
|---|
| 469 | 'hemlock-listener-window-controller |
|---|
| 470 | :with-window window)) |
|---|
| 471 | (listener-name (hi::buffer-name (hemlock-buffer self))) |
|---|
| 472 | (path (#/windowTitleForDocumentDisplayName: controller (#/displayName self )))) |
|---|
| 473 | (when (slot-exists-p textstorage 'styles) |
|---|
| 474 | (with-slots (styles) textstorage |
|---|
| 475 | ;; We probably should be more disciplined about |
|---|
| 476 | ;; Cocoa memory management. Having retain/release in |
|---|
| 477 | ;; random places all over the code is going to get |
|---|
| 478 | ;; unwieldy. |
|---|
| 479 | (#/release styles) |
|---|
| 480 | (setf styles (#/retain listener-styles)))) |
|---|
| 481 | ;; Disabling background layout on listeners is an attempt to work |
|---|
| 482 | ;; around a bug. The bug's probably gone ... |
|---|
| 483 | #-cocotron ;no concept of background layout |
|---|
| 484 | (let* ((layout-managers (#/layoutManagers textstorage))) |
|---|
| 485 | (dotimes (i (#/count layout-managers)) |
|---|
| 486 | (let* ((layout (#/objectAtIndex: layout-managers i))) |
|---|
| 487 | (#/setBackgroundLayoutEnabled: layout nil)))) |
|---|
| 488 | (#/setDelegate: window controller) |
|---|
| 489 | (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self) |
|---|
| 490 | (#/setShouldCascadeWindows: controller nil) |
|---|
| 491 | (#/addWindowController: self controller) |
|---|
| 492 | (#/release controller) |
|---|
| 493 | (unless (hemlock-document-process self) |
|---|
| 494 | (setf (hemlock-document-process self) |
|---|
| 495 | (new-cocoa-listener-process listener-name window))) |
|---|
| 496 | (when path |
|---|
| 497 | (unless (#/setFrameAutosaveName: window path) |
|---|
| 498 | (setq path nil))) |
|---|
| 499 | (unless (and path |
|---|
| 500 | (when (#/setFrameUsingName: window path) |
|---|
| 501 | (let* ((frame (#/frame window))) |
|---|
| 502 | (ns:with-ns-point (current-point |
|---|
| 503 | (ns:ns-rect-x frame) |
|---|
| 504 | (+ (ns:ns-rect-y frame) |
|---|
| 505 | (ns:ns-rect-height frame))) |
|---|
| 506 | (let* ((next-point (#/cascadeTopLeftFromPoint: |
|---|
| 507 | window |
|---|
| 508 | current-point))) |
|---|
| 509 | (setq *next-listener-x-pos* |
|---|
| 510 | (ns:ns-point-x next-point) |
|---|
| 511 | *next-listener-y-pos* |
|---|
| 512 | (ns:ns-point-y next-point))))) |
|---|
| 513 | t)) |
|---|
| 514 | (ns:with-ns-point (current-point |
|---|
| 515 | (or *next-listener-x-pos* |
|---|
| 516 | (x-pos-for-window window *initial-listener-x-pos*)) |
|---|
| 517 | (or *next-listener-y-pos* |
|---|
| 518 | (y-pos-for-window window *initial-listener-y-pos*))) |
|---|
| 519 | (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point))) |
|---|
| 520 | (setf *next-listener-x-pos* (ns:ns-point-x new-point) |
|---|
| 521 | *next-listener-y-pos* (ns:ns-point-y new-point))))) |
|---|
| 522 | (#/synchronizeWindowTitleWithDocumentName controller) |
|---|
| 523 | controller)) |
|---|
| 524 | |
|---|
| 525 | (objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :<BOOL>) |
|---|
| 526 | ((self hemlock-listener-document) |
|---|
| 527 | tv |
|---|
| 528 | (range :<NSR>ange) |
|---|
| 529 | string) |
|---|
| 530 | (declare (ignore tv string)) |
|---|
| 531 | (let* ((range-start (ns:ns-range-location range)) |
|---|
| 532 | (range-end (+ range-start (ns:ns-range-length range))) |
|---|
| 533 | (buffer (hemlock-buffer self)) |
|---|
| 534 | (protected-region (hi::buffer-protected-region buffer))) |
|---|
| 535 | (if protected-region |
|---|
| 536 | (let* ((prot-start (hi:mark-absolute-position (hi::region-start protected-region))) |
|---|
| 537 | (prot-end (hi:mark-absolute-position (hi::region-end protected-region)))) |
|---|
| 538 | (not (or (and (>= range-start prot-start) |
|---|
| 539 | (< range-start prot-end)) |
|---|
| 540 | (and (>= range-end prot-start) |
|---|
| 541 | (< range-end prot-end))))) |
|---|
| 542 | t))) |
|---|
| 543 | |
|---|
| 544 | |
|---|
| 545 | ;;; Action methods |
|---|
| 546 | (objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender) |
|---|
| 547 | (declare (ignore sender)) |
|---|
| 548 | (let* ((process (hemlock-document-process self))) |
|---|
| 549 | (when process |
|---|
| 550 | (ccl::force-break-in-listener process)))) |
|---|
| 551 | |
|---|
| 552 | |
|---|
| 553 | |
|---|
| 554 | (objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender) |
|---|
| 555 | (declare (ignore sender)) |
|---|
| 556 | (let* ((process (hemlock-document-process self))) |
|---|
| 557 | #+debug (log-debug "~&exitBreak process ~s" process) |
|---|
| 558 | (when process |
|---|
| 559 | (process-interrupt process #'abort-break)))) |
|---|
| 560 | |
|---|
| 561 | (defmethod listener-backtrace-context ((proc cocoa-listener-process)) |
|---|
| 562 | (car (cocoa-listener-process-backtrace-contexts proc))) |
|---|
| 563 | |
|---|
| 564 | (objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender) |
|---|
| 565 | (let* ((process (hemlock-document-process self))) |
|---|
| 566 | (when process |
|---|
| 567 | (let* ((context (listener-backtrace-context process))) |
|---|
| 568 | (when context |
|---|
| 569 | (#/makeKeyAndOrderFront: (#/windowForSheet self) nil) |
|---|
| 570 | (#/showWindow: (backtrace-controller-for-context context) sender)))))) |
|---|
| 571 | |
|---|
| 572 | (defun restarts-controller-for-context (context) |
|---|
| 573 | (or (car (ccl::bt.restarts context)) |
|---|
| 574 | (setf (car (ccl::bt.restarts context)) |
|---|
| 575 | (let* ((tcr (ccl::bt.tcr context)) |
|---|
| 576 | (tsp-range (inspector::make-tsp-stack-range tcr context)) |
|---|
| 577 | (vsp-range (inspector::make-vsp-stack-range tcr context)) |
|---|
| 578 | (csp-range (inspector::make-csp-stack-range tcr context)) |
|---|
| 579 | (process (ccl::tcr->process tcr))) |
|---|
| 580 | (make-instance 'sequence-window-controller |
|---|
| 581 | :sequence (cdr (ccl::bt.restarts context)) |
|---|
| 582 | :result-callback #'(lambda (r) |
|---|
| 583 | (process-interrupt |
|---|
| 584 | process |
|---|
| 585 | #'invoke-restart-interactively |
|---|
| 586 | r)) |
|---|
| 587 | :display #'(lambda (item stream) |
|---|
| 588 | (let* ((ccl::*aux-vsp-ranges* vsp-range) |
|---|
| 589 | (ccl::*aux-tsp-ranges* tsp-range) |
|---|
| 590 | (ccl::*aux-csp-ranges* csp-range)) |
|---|
| 591 | (princ item stream))) |
|---|
| 592 | :title (format nil "Restarts for ~a(~d), break level ~d" |
|---|
| 593 | (process-name process) |
|---|
| 594 | (process-serial-number process) |
|---|
| 595 | (ccl::bt.break-level context))))))) |
|---|
| 596 | |
|---|
| 597 | (objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender) |
|---|
| 598 | (let* ((process (hemlock-document-process self))) |
|---|
| 599 | (when process |
|---|
| 600 | (let* ((context (listener-backtrace-context process))) |
|---|
| 601 | (when context |
|---|
| 602 | (#/showWindow: (restarts-controller-for-context context) sender)))))) |
|---|
| 603 | |
|---|
| 604 | (objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender) |
|---|
| 605 | (declare (ignore sender)) |
|---|
| 606 | (let* ((process (hemlock-document-process self))) |
|---|
| 607 | (when process |
|---|
| 608 | (let* ((context (listener-backtrace-context process))) |
|---|
| 609 | (when context |
|---|
| 610 | (process-interrupt process #'invoke-restart-interactively 'continue)))))) |
|---|
| 611 | |
|---|
| 612 | |
|---|
| 613 | |
|---|
| 614 | |
|---|
| 615 | |
|---|
| 616 | |
|---|
| 617 | ;;; Menu item action validation. It'd be nice if we could distribute this a |
|---|
| 618 | ;;; bit better, so that this method didn't have to change whenever a new |
|---|
| 619 | ;;; action was implemented in this class. For now, we have to do so. |
|---|
| 620 | |
|---|
| 621 | (defmethod document-validate-menu-item ((doc hemlock-listener-document) item) |
|---|
| 622 | ;; Return two values: the first is true if the second is definitive. |
|---|
| 623 | ;; So far, all actions demand that there be an underlying process, so |
|---|
| 624 | ;; check for that first. |
|---|
| 625 | (let* ((process (hemlock-document-process doc))) |
|---|
| 626 | (if process |
|---|
| 627 | (let* ((action (#/action item))) |
|---|
| 628 | (cond |
|---|
| 629 | ((or (eql action (@selector #/revertDocumentToSaved:)) |
|---|
| 630 | (eql action (@selector #/saveDocument:)) |
|---|
| 631 | (eql action (@selector #/saveDocumentAs:))) |
|---|
| 632 | (values t nil)) |
|---|
| 633 | ((eql action (@selector #/interrupt:)) (values t t)) |
|---|
| 634 | ((eql action (@selector #/continue:)) |
|---|
| 635 | (let* ((context (listener-backtrace-context process))) |
|---|
| 636 | (values |
|---|
| 637 | t |
|---|
| 638 | (and context |
|---|
| 639 | (find 'continue (cdr (ccl::bt.restarts context)) |
|---|
| 640 | :key #'restart-name))))) |
|---|
| 641 | ((or (eql action (@selector #/backtrace:)) |
|---|
| 642 | (eql action (@selector #/exitBreak:)) |
|---|
| 643 | (eql action (@selector #/restarts:))) |
|---|
| 644 | (values t |
|---|
| 645 | (not (null (listener-backtrace-context process))))))) |
|---|
| 646 | (values nil nil)))) |
|---|
| 647 | |
|---|
| 648 | (objc:defmethod (#/validateMenuItem: :<BOOL>) |
|---|
| 649 | ((self hemlock-listener-document) item) |
|---|
| 650 | (multiple-value-bind (have-opinion opinion) |
|---|
| 651 | (document-validate-menu-item self item) |
|---|
| 652 | (if have-opinion |
|---|
| 653 | opinion |
|---|
| 654 | (call-next-method item)))) |
|---|
| 655 | |
|---|
| 656 | (defmethod perform-close-kills-process-p ((self hemlock-listener-document)) |
|---|
| 657 | t) |
|---|
| 658 | |
|---|
| 659 | (defun shortest-package-name (package) |
|---|
| 660 | (let* ((name (package-name package)) |
|---|
| 661 | (len (length name))) |
|---|
| 662 | (dolist (nick (package-nicknames package) name) |
|---|
| 663 | (let* ((nicklen (length nick))) |
|---|
| 664 | (if (< nicklen len) |
|---|
| 665 | (setq name nick len nicklen)))))) |
|---|
| 666 | |
|---|
| 667 | (defmethod ui-object-note-package ((app ns:ns-application) package) |
|---|
| 668 | (let ((proc *current-process*) |
|---|
| 669 | (name (shortest-package-name package))) |
|---|
| 670 | (execute-in-gui #'(lambda () |
|---|
| 671 | (dolist (buf hi::*buffer-list*) |
|---|
| 672 | (when (eq proc (buffer-process buf)) |
|---|
| 673 | (setf (hi::variable-value 'hemlock::current-package :buffer buf) name))))))) |
|---|
| 674 | |
|---|
| 675 | |
|---|
| 676 | (defmethod eval-in-listener-process ((process cocoa-listener-process) |
|---|
| 677 | string &key path package offset) |
|---|
| 678 | (enqueue-toplevel-form (cocoa-listener-process-input-stream process) string |
|---|
| 679 | :package-name package :pathname path :offset offset)) |
|---|
| 680 | |
|---|
| 681 | ;;; This is basically used to provide INPUT to the listener process, by |
|---|
| 682 | ;;; writing to an fd which is connected to that process's standard |
|---|
| 683 | ;;; input. |
|---|
| 684 | (defun hemlock-ext:send-string-to-listener (listener-buffer string) |
|---|
| 685 | (let* ((process (buffer-process listener-buffer))) |
|---|
| 686 | (unless process |
|---|
| 687 | (error "No listener process found for ~s" listener-buffer)) |
|---|
| 688 | (enqueue-listener-input (cocoa-listener-process-input-stream process) string))) |
|---|
| 689 | |
|---|
| 690 | (defmethod ui-object-choose-listener-for-selection ((app ns:ns-application) |
|---|
| 691 | selection) |
|---|
| 692 | (declare (ignore selection)) |
|---|
| 693 | (#/performSelectorOnMainThread:withObject:waitUntilDone: |
|---|
| 694 | (#/delegate *NSApp*) |
|---|
| 695 | (@selector #/ensureListener:) |
|---|
| 696 | +null-ptr+ |
|---|
| 697 | #$YES) |
|---|
| 698 | (hemlock-document-process (#/topListener hemlock-listener-document))) |
|---|
| 699 | |
|---|
| 700 | (defmethod ui-object-eval-selection ((app ns:ns-application) |
|---|
| 701 | selection) |
|---|
| 702 | (let* ((target-listener (ui-object-choose-listener-for-selection |
|---|
| 703 | app selection))) |
|---|
| 704 | (when target-listener |
|---|
| 705 | (destructuring-bind (package path string &optional offset) selection |
|---|
| 706 | (eval-in-listener-process target-listener string :package package :path path :offset offset))))) |
|---|
| 707 | |
|---|
| 708 | (defmethod ui-object-load-buffer ((app ns:ns-application) selection) |
|---|
| 709 | (let* ((target-listener (ui-object-choose-listener-for-selection app nil))) |
|---|
| 710 | (when target-listener |
|---|
| 711 | (destructuring-bind (package path) selection |
|---|
| 712 | (let ((string (format nil "(load ~S)" path))) |
|---|
| 713 | (eval-in-listener-process target-listener string :package package)))))) |
|---|
| 714 | |
|---|
| 715 | (defmethod ui-object-compile-buffer ((app ns:ns-application) selection) |
|---|
| 716 | (let* ((target-listener (ui-object-choose-listener-for-selection app nil))) |
|---|
| 717 | (when target-listener |
|---|
| 718 | (destructuring-bind (package path) selection |
|---|
| 719 | (let ((string (format nil "(compile-file ~S)" path))) |
|---|
| 720 | (eval-in-listener-process target-listener string :package package)))))) |
|---|
| 721 | |
|---|
| 722 | (defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection) |
|---|
| 723 | (let* ((target-listener (ui-object-choose-listener-for-selection app nil))) |
|---|
| 724 | (when target-listener |
|---|
| 725 | (destructuring-bind (package path) selection |
|---|
| 726 | (let ((string (format nil "(progn (compile-file ~S)(load ~S))" |
|---|
| 727 | path |
|---|
| 728 | (make-pathname :directory (pathname-directory path) |
|---|
| 729 | :name (pathname-name path) |
|---|
| 730 | :type (pathname-type path))))) |
|---|
| 731 | (eval-in-listener-process target-listener string :package package)))))) |
|---|
| 732 | |
|---|
| 733 | |
|---|
| 734 | ;;; Support for background processes that acquire listener window/document/ |
|---|
| 735 | ;;; buffer infrastructure iff they try to do I/O to *TERMINAL-IO*. |
|---|
| 736 | |
|---|
| 737 | (defclass hemlock-background-listener-document (hemlock-listener-document) |
|---|
| 738 | () |
|---|
| 739 | (:metaclass ns:+ns-object)) |
|---|
| 740 | |
|---|
| 741 | (defmethod perform-close-kills-process-p ((self hemlock-background-listener-document)) |
|---|
| 742 | nil) |
|---|
| 743 | |
|---|
| 744 | (defstruct deferred-cocoa-listener-stream-info |
|---|
| 745 | real-input-stream |
|---|
| 746 | real-output-stream |
|---|
| 747 | process |
|---|
| 748 | window) |
|---|
| 749 | |
|---|
| 750 | |
|---|
| 751 | (defclass deferred-cocoa-listener-stream (fundamental-character-stream) |
|---|
| 752 | ((info :initarg :info :accessor deferred-cocoa-listener-stream-info))) |
|---|
| 753 | |
|---|
| 754 | (defmethod ensure-deferred-stream-info-for-io ((s deferred-cocoa-listener-stream)) |
|---|
| 755 | (let* ((info (slot-value s 'info))) |
|---|
| 756 | (when info |
|---|
| 757 | (unless (deferred-cocoa-listener-stream-info-window info) |
|---|
| 758 | (with-autorelease-pool |
|---|
| 759 | (let* ((doc (make-instance 'hemlock-background-listener-document)) |
|---|
| 760 | (buffer (hemlock-buffer doc)) |
|---|
| 761 | (process (deferred-cocoa-listener-stream-info-process info))) |
|---|
| 762 | (setf (hi::buffer-name buffer) |
|---|
| 763 | (format nil "~a(~d)" (process-name process) (process-serial-number process)) |
|---|
| 764 | (hemlock-document-process doc) process) |
|---|
| 765 | (execute-in-gui (lambda () (#/makeWindowControllers doc))) |
|---|
| 766 | (let* ((wc (#/lastObject (#/windowControllers doc))) |
|---|
| 767 | (window (#/window wc))) |
|---|
| 768 | (setf |
|---|
| 769 | (deferred-cocoa-listener-stream-info-real-input-stream info) |
|---|
| 770 | (make-instance 'cocoa-listener-input-stream) |
|---|
| 771 | (deferred-cocoa-listener-stream-info-real-output-stream info) |
|---|
| 772 | (make-instance 'cocoa-listener-output-stream |
|---|
| 773 | :hemlock-view (hemlock-view window)) |
|---|
| 774 | (deferred-cocoa-listener-stream-info-window info) |
|---|
| 775 | window |
|---|
| 776 | (slot-value process 'window) window) |
|---|
| 777 | (ui-object-note-package *nsapp* *package*)))))) |
|---|
| 778 | info)) |
|---|
| 779 | |
|---|
| 780 | |
|---|
| 781 | |
|---|
| 782 | (defclass deferred-cocoa-listener-output-stream |
|---|
| 783 | (fundamental-character-output-stream deferred-cocoa-listener-stream) |
|---|
| 784 | ()) |
|---|
| 785 | |
|---|
| 786 | (defmethod stream-element-type ((s deferred-cocoa-listener-output-stream)) |
|---|
| 787 | 'character) |
|---|
| 788 | |
|---|
| 789 | |
|---|
| 790 | (defmethod underlying-output-stream ((s deferred-cocoa-listener-output-stream)) |
|---|
| 791 | (let* ((info (ensure-deferred-stream-info-for-io s))) |
|---|
| 792 | (if info |
|---|
| 793 | (progn |
|---|
| 794 | (let* ((window (deferred-cocoa-listener-stream-info-window info))) |
|---|
| 795 | (unless (#/isVisible window) |
|---|
| 796 | (execute-in-gui |
|---|
| 797 | (lambda () |
|---|
| 798 | (#/makeKeyAndOrderFront: window (%null-ptr))))) |
|---|
| 799 | (deferred-cocoa-listener-stream-info-real-output-stream info))) |
|---|
| 800 | (ccl::stream-is-closed s)))) |
|---|
| 801 | |
|---|
| 802 | (defmethod ccl:stream-write-char ((s deferred-cocoa-listener-output-stream) |
|---|
| 803 | char) |
|---|
| 804 | (with-autorelease-pool |
|---|
| 805 | (stream-write-char (underlying-output-stream s) char))) |
|---|
| 806 | |
|---|
| 807 | (defmethod ccl:stream-line-column ((s deferred-cocoa-listener-output-stream)) |
|---|
| 808 | (stream-line-column (underlying-output-stream s))) |
|---|
| 809 | |
|---|
| 810 | (defmethod ccl:stream-fresh-line ((s deferred-cocoa-listener-output-stream)) |
|---|
| 811 | (stream-fresh-line (underlying-output-stream s))) |
|---|
| 812 | |
|---|
| 813 | (defmethod ccl::stream-finish-output ((s deferred-cocoa-listener-output-stream)) |
|---|
| 814 | (stream-force-output s)) |
|---|
| 815 | |
|---|
| 816 | (defmethod ccl:stream-force-output ((s deferred-cocoa-listener-output-stream)) |
|---|
| 817 | (let* ((info (slot-value s 'info))) |
|---|
| 818 | (if info |
|---|
| 819 | (let* ((out (deferred-cocoa-listener-stream-info-real-output-stream info))) |
|---|
| 820 | (if out |
|---|
| 821 | (stream-force-output out))) |
|---|
| 822 | (ccl::stream-is-closed s)))) |
|---|
| 823 | |
|---|
| 824 | (defmethod ccl:stream-clear-output ((s deferred-cocoa-listener-output-stream)) |
|---|
| 825 | (stream-clear-output (underlying-output-stream s))) |
|---|
| 826 | |
|---|
| 827 | (defmethod ccl:stream-line-length ((s deferred-cocoa-listener-output-stream)) |
|---|
| 828 | (stream-line-length (underlying-output-stream s))) |
|---|
| 829 | |
|---|
| 830 | (defmethod close ((s deferred-cocoa-listener-output-stream) |
|---|
| 831 | &key abort) |
|---|
| 832 | (let* ((info (slot-value s 'info))) |
|---|
| 833 | (when info |
|---|
| 834 | (let* ((out (deferred-cocoa-listener-stream-info-real-output-stream info))) |
|---|
| 835 | (when out |
|---|
| 836 | (stream-force-output out) |
|---|
| 837 | (close out :abort abort))) |
|---|
| 838 | (setf (slot-value s 'info) nil) |
|---|
| 839 | t))) |
|---|
| 840 | |
|---|
| 841 | |
|---|
| 842 | (defclass deferred-cocoa-listener-input-stream |
|---|
| 843 | (fundamental-character-input-stream deferred-cocoa-listener-stream) |
|---|
| 844 | ((reading-line :initform nil :accessor hi:input-stream-reading-line))) |
|---|
| 845 | |
|---|
| 846 | |
|---|
| 847 | (defmethod underlying-input-stream ((s deferred-cocoa-listener-input-stream)) |
|---|
| 848 | (let* ((info (ensure-deferred-stream-info-for-io s))) |
|---|
| 849 | (if info |
|---|
| 850 | (progn |
|---|
| 851 | (let* ((window (deferred-cocoa-listener-stream-info-window info))) |
|---|
| 852 | (unless (#/isVisible window) |
|---|
| 853 | (execute-in-gui |
|---|
| 854 | (lambda () |
|---|
| 855 | (#/makeKeyAndOrderFront: window (%null-ptr))))) |
|---|
| 856 | (deferred-cocoa-listener-stream-info-real-input-stream info))) |
|---|
| 857 | (ccl::stream-is-closed s)))) |
|---|
| 858 | |
|---|
| 859 | (defmethod interactive-stream-p ((s deferred-cocoa-listener-input-stream)) |
|---|
| 860 | t) |
|---|
| 861 | |
|---|
| 862 | (defmethod ccl::read-toplevel-form ((s deferred-cocoa-listener-input-stream) |
|---|
| 863 | &key eof-value) |
|---|
| 864 | (ccl::read-toplevel-form (underlying-input-stream s) :eof-value eof-value)) |
|---|
| 865 | |
|---|
| 866 | (defmethod enqueue-toplevel-form ((s deferred-cocoa-listener-input-stream) string &rest args &key &allow-other-keys) |
|---|
| 867 | (apply #'enqueue-toplevel-form (underlying-input-stream s) string args)) |
|---|
| 868 | |
|---|
| 869 | (defmethod enqueue-listener-input ((s deferred-cocoa-listener-input-stream) string) |
|---|
| 870 | (enqueue-listener-input (underlying-input-stream s) string)) |
|---|
| 871 | |
|---|
| 872 | (defmethod stream-read-char-no-hang ((s deferred-cocoa-listener-input-stream)) |
|---|
| 873 | (stream-read-char-no-hang (underlying-input-stream s))) |
|---|
| 874 | |
|---|
| 875 | (defmethod stream-read-char ((s deferred-cocoa-listener-input-stream)) |
|---|
| 876 | (stream-read-char (underlying-input-stream s))) |
|---|
| 877 | |
|---|
| 878 | (defmethod stream-unread-char ((s deferred-cocoa-listener-input-stream) char) |
|---|
| 879 | (stream-unread-char (underlying-input-stream s) char)) |
|---|
| 880 | |
|---|
| 881 | (defmethod stream-clear-input ((s deferred-cocoa-listener-input-stream)) |
|---|
| 882 | (stream-clear-input (underlying-input-stream s))) |
|---|
| 883 | |
|---|
| 884 | (defmethod stream-read-line ((s deferred-cocoa-listener-input-stream)) |
|---|
| 885 | (let* ((old-reading-line (hi:input-stream-reading-line s))) |
|---|
| 886 | (unwind-protect |
|---|
| 887 | (progn |
|---|
| 888 | (setf (hi::input-stream-reading-line s) t) |
|---|
| 889 | (stream-read-line (underlying-input-stream s))) |
|---|
| 890 | (setf (hi:input-stream-reading-line s) old-reading-line)))) |
|---|
| 891 | |
|---|
| 892 | (defclass background-cocoa-listener-process (cocoa-listener-process) |
|---|
| 893 | ()) |
|---|
| 894 | |
|---|
| 895 | (defun background-process-run-function (keywords function) |
|---|
| 896 | (destructuring-bind (&key (name "Anonymous") |
|---|
| 897 | (priority 0) |
|---|
| 898 | (stack-size ccl::*default-control-stack-size*) |
|---|
| 899 | (vstack-size ccl::*default-value-stack-size*) |
|---|
| 900 | (tstack-size ccl::*default-temp-stack-size*) |
|---|
| 901 | (initial-bindings ()) |
|---|
| 902 | (persistent nil) |
|---|
| 903 | (use-standard-initial-bindings t) |
|---|
| 904 | (termination-semaphore nil) |
|---|
| 905 | (allocation-quantum (default-allocation-quantum))) |
|---|
| 906 | keywords |
|---|
| 907 | (setq priority (require-type priority 'fixnum)) |
|---|
| 908 | (let* ((process (make-process name |
|---|
| 909 | :class 'background-cocoa-listener-process |
|---|
| 910 | :priority priority |
|---|
| 911 | :stack-size stack-size |
|---|
| 912 | :vstack-size vstack-size |
|---|
| 913 | :tstack-size tstack-size |
|---|
| 914 | :persistent persistent |
|---|
| 915 | :use-standard-initial-bindings use-standard-initial-bindings |
|---|
| 916 | :initial-bindings initial-bindings |
|---|
| 917 | :termination-semaphore termination-semaphore |
|---|
| 918 | :allocation-quantum allocation-quantum)) |
|---|
| 919 | (info (make-deferred-cocoa-listener-stream-info :process process)) |
|---|
| 920 | (input-stream (make-instance 'deferred-cocoa-listener-input-stream |
|---|
| 921 | :info info)) |
|---|
| 922 | (output-stream (make-instance 'deferred-cocoa-listener-output-stream |
|---|
| 923 | :info info))) |
|---|
| 924 | (setf (slot-value process 'input-stream) input-stream |
|---|
| 925 | (slot-value process 'output-stream) output-stream) |
|---|
| 926 | (process-preset process |
|---|
| 927 | (lambda () |
|---|
| 928 | (let* ((*terminal-io* (make-two-way-stream input-stream output-stream))) |
|---|
| 929 | (ccl::add-auto-flush-stream output-stream) |
|---|
| 930 | (unwind-protect |
|---|
| 931 | (funcall function) |
|---|
| 932 | (remove-auto-flush-stream output-stream) |
|---|
| 933 | (let* ((w (slot-value process 'window))) |
|---|
| 934 | (when w |
|---|
| 935 | (let* ((doc (#/document w))) |
|---|
| 936 | (unless (%null-ptr-p doc) |
|---|
| 937 | (when (eq *current-process* |
|---|
| 938 | (hemlock-document-process doc)) |
|---|
| 939 | (setf (hemlock-document-process doc) nil)))) |
|---|
| 940 | (cond ((#/isVisible w) |
|---|
| 941 | (format output-stream "~%~%{process ~s exiting}~%" *current-process*)) |
|---|
| 942 | (t |
|---|
| 943 | (#/performSelectorOnMainThread:withObject:waitUntilDone: |
|---|
| 944 | w |
|---|
| 945 | (@selector #/close) |
|---|
| 946 | +null-ptr+ |
|---|
| 947 | t))) |
|---|
| 948 | (close input-stream) |
|---|
| 949 | (close output-stream))))))) |
|---|
| 950 | (process-enable process)))) |
|---|
