source: trunk/source/cocoa-ide/cocoa-listener.lisp @ 12859

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 30.8 KB
Line 
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"
14                                                    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"
23                                                     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.  *nx-source-note-map* is for the latter.
115                   (let ((env (cons '(*loading-file-source-file* *loading-toplevel-location* ccl::*nx-source-note-map*)
116                                    (list pathname nil source-map))))
117                     (when package-name
118                       (push '*package* (car env))
119                       (push (ccl::pkg-arg package-name) (cdr env)))
120                     (if source-map
121                       (clrhash source-map)
122                       (setf source-map (make-hash-table :test 'eq :shared nil)))
123                     (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset))))))))))
124
125(defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname offset)
126  (with-slots (queue-lock queue queue-semaphore) stream
127    (with-lock-grabbed (queue-lock)
128      (setq queue (nconc queue (list (list string package-name pathname offset))))
129      (signal-semaphore queue-semaphore))))
130
131(defmethod enqueue-listener-input ((stream cocoa-listener-input-stream) string)
132  (with-slots (queue-lock queue queue-semaphore text-semaphore) stream
133    (with-lock-grabbed (queue-lock)
134      (setq queue (nconc queue (list string)))
135      (signal-semaphore queue-semaphore)
136      (signal-semaphore text-semaphore))))
137
138(defmethod stream-read-char-no-hang ((stream cocoa-listener-input-stream))
139  (dequeue-listener-char stream nil))
140
141(defmethod stream-read-char ((stream cocoa-listener-input-stream))
142  (dequeue-listener-char stream t))
143
144(defmethod stream-unread-char ((stream cocoa-listener-input-stream) char)
145  ;; Can't guarantee the right order of reads/unreads, just make sure not to
146  ;; introduce any internal inconsistencies (and dtrt for the non-conflict case).
147  (with-slots (queue queue-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
148    (with-lock-grabbed (queue-lock)
149      (cond ((>= cur-string-pos (length cur-string))
150             (push (string char) queue)
151             (signal-semaphore queue-semaphore)
152             (signal-semaphore text-semaphore))
153            ((< 0 cur-string-pos)
154             (decf cur-string-pos)
155             (setf (aref cur-string cur-string-pos) char))
156            (t (setf cur-string (concatenate 'string (string char) cur-string)))))))
157
158(defmethod ccl::stream-eof-transient-p ((stream cocoa-listener-input-stream))
159  t)
160
161(defmethod stream-clear-input ((stream cocoa-listener-input-stream))
162  (with-slots (queue-lock cur-string cur-string-pos cur-sstream cur-env) stream
163    (with-lock-grabbed (queue-lock)
164      (setf (hi::input-stream-reading-line stream) nil)
165      (setf cur-string nil cur-string-pos 0 cur-sstream nil cur-env nil))))
166
167(defmethod stream-read-line ((stream cocoa-listener-input-stream))
168  (let* ((old-reading-line (hi:input-stream-reading-line stream)))
169    (unwind-protect
170         (progn
171           (setf (hi::input-stream-reading-line stream) t)
172           (call-next-method))
173      (setf (hi:input-stream-reading-line stream) old-reading-line))))
174
175(defparameter $listener-flush-limit 4095)
176
177(defclass cocoa-listener-output-stream (fundamental-character-output-stream)
178  ((lock :initform (make-lock))
179   (hemlock-view :initarg :hemlock-view)
180   (data :initform (make-array (1+ $listener-flush-limit)
181                               :adjustable t :fill-pointer 0
182                               :element-type 'character))
183   (limit :initform $listener-flush-limit)))
184
185(defmethod stream-element-type ((stream cocoa-listener-output-stream))
186  (with-slots (data) stream
187    (array-element-type data)))
188
189(defmethod ccl:stream-write-char ((stream cocoa-listener-output-stream) char)
190  (with-slots (data lock limit) stream
191    (when (with-lock-grabbed (lock)
192            (>= (vector-push-extend char data) limit))
193      (stream-force-output stream))))
194
195;; This isn't really thread safe, but it's not too bad...  I'll take a chance - trying
196;; to get it to execute in the gui thread is too deadlock-prone.
197(defmethod hemlock-listener-output-mark-column ((view hi::hemlock-view))
198  (let* ((output-region (hi::variable-value 'hemlock::current-output-font-region
199                                            :buffer (hi::hemlock-view-buffer view))))
200    (hi::mark-charpos (hi::region-end output-region))))
201
202;; TODO: doesn't do the right thing for embedded tabs (in buffer or data)
203(defmethod ccl:stream-line-column ((stream cocoa-listener-output-stream))
204  (with-slots (hemlock-view data lock) stream
205    (with-lock-grabbed (lock)
206      (let* ((n (length data))
207             (pos (position #\Newline data :from-end t)))
208        (if (null pos)
209          (+ (hemlock-listener-output-mark-column hemlock-view) n)
210          (- n pos 1))))))
211
212(defmethod ccl:stream-fresh-line  ((stream cocoa-listener-output-stream))
213  (with-slots (hemlock-view data lock limit) stream
214    (when (with-lock-grabbed (lock)
215            (let ((n (length data)))
216              (unless (if (= n 0)
217                        (= (hemlock-listener-output-mark-column hemlock-view) 0)
218                        (eq (aref data (1- n)) #\Newline))
219                (>= (vector-push-extend #\Newline data) limit))))
220      (stream-force-output stream))))
221
222(defmethod ccl::stream-finish-output ((stream cocoa-listener-output-stream))
223  (stream-force-output stream))
224
225(defmethod ccl:stream-force-output ((stream cocoa-listener-output-stream))
226  (if (typep *current-process* 'appkit-process)
227    (with-slots (hemlock-view data lock) stream
228      (with-lock-grabbed (lock)
229        (when (> (fill-pointer data) 0)
230          (append-output hemlock-view data)
231          (setf (fill-pointer data) 0))))
232    (with-slots (data) stream
233      (when (> (fill-pointer data) 0)
234        (queue-for-gui #'(lambda () (stream-force-output stream)))))))
235
236(defmethod ccl:stream-clear-output ((stream cocoa-listener-output-stream))
237  (with-slots (data lock) stream
238    (with-lock-grabbed (lock)
239      (setf (fill-pointer data) 0))))
240
241(defmethod ccl:stream-line-length ((stream cocoa-listener-output-stream))
242  ;; TODO: ** compute length from window size **
243  80)
244
245
246(defloadvar *cocoa-listener-count* 0)
247
248(defclass cocoa-listener-process (process)
249    ((input-stream :reader cocoa-listener-process-input-stream)
250     (output-stream :reader cocoa-listener-process-output-stream)
251     (backtrace-contexts :initform nil
252                         :accessor cocoa-listener-process-backtrace-contexts)
253     (window :reader cocoa-listener-process-window)))
254 
255(defloadvar *first-listener* t)
256
257(defun new-cocoa-listener-process (procname window)
258  (declare (special *standalone-cocoa-ide*))
259  (let* ((input-stream (make-instance 'cocoa-listener-input-stream))
260         (output-stream (make-instance 'cocoa-listener-output-stream
261                          :hemlock-view (hemlock-view window)))
262         
263         (proc
264          (ccl::make-mcl-listener-process 
265           procname
266           input-stream
267           output-stream
268           ;; cleanup function
269           #'(lambda ()
270               (mapcar #'(lambda (buf)
271                           (when (eq (buffer-process buf) *current-process*)
272                             (let ((doc (hi::buffer-document buf)))
273                               (when doc
274                                 (setf (hemlock-document-process doc) nil) ;; so #/close doesn't kill it.
275                                 (#/performSelectorOnMainThread:withObject:waitUntilDone:
276                                  doc
277                                  (@selector #/close)
278                                  +null-ptr+
279                                  nil)))))
280                       hi:*buffer-list*))
281           :initial-function
282           #'(lambda ()
283               (setq ccl::*listener-autorelease-pool* (create-autorelease-pool))
284               (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
306(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
307    ()
308  (:metaclass ns:+ns-object)
309  )
310(declaim (special hemlock-listener-window-controller))
311
312;;; Listener documents are never (or always) ediited.  Don't cause their
313;;; close boxes to be highlighted.
314(objc:defmethod (#/setDocumentEdited: :void)
315    ((self hemlock-listener-window-controller) (edited :<BOOL>))
316  (declare (ignorable edited)))
317
318
319
320(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
321  (let* ((doc (#/document self)))
322    (if (or (%null-ptr-p doc)
323            (not (%null-ptr-p (#/fileURL doc))))
324      (call-next-method name)
325      (let* ((buffer (hemlock-buffer doc))
326             (bufname (if buffer (hi::buffer-name buffer))))
327        (if bufname
328          (%make-nsstring bufname)
329          (call-next-method name))))))
330
331
332;;; The HemlockListenerDocument class.
333
334
335(defclass hemlock-listener-document (hemlock-editor-document)
336  ((process :reader %hemlock-document-process :writer (setf hemlock-document-process)))
337  (:metaclass ns:+ns-object))
338(declaim (special hemlock-listener-document))
339
340(defgeneric hemlock-document-process (doc)
341  (:method ((unknown t)) nil)
342  (:method ((doc hemlock-listener-document)) (%hemlock-document-process doc)))
343
344;; Nowadays this is nil except for listeners.
345(defun buffer-process (buffer)
346  (hemlock-document-process (hi::buffer-document buffer)))
347
348(defmethod update-buffer-package ((doc hemlock-listener-document) buffer)
349  (declare (ignore buffer)))
350
351(defmethod document-encoding-name ((doc hemlock-listener-document))
352  "UTF-8")
353
354(defmethod user-input-style ((doc hemlock-listener-document))
355  hi::*listener-input-style*)
356 
357(defmethod textview-background-color ((doc hemlock-listener-document))
358  *listener-background-color*)
359
360;; For use with the :process-info listener modeline field
361(defmethod hemlock-ext:buffer-process-description (buffer)
362  (let ((proc (buffer-process buffer)))
363    (when proc
364      (format nil "~a(~d) [~a]"
365              (ccl:process-name proc)
366              (ccl::process-serial-number proc)
367              ;; TODO: this doesn't really work as a modeline item, because the modeline
368              ;; doesn't get notified when it changes.
369              (ccl:process-whostate proc)))))
370
371(objc:defmethod #/topListener ((self +hemlock-listener-document))
372  (let* ((all-documents (#/orderedDocuments *NSApp*)))
373    (dotimes (i (#/count all-documents) +null-ptr+)
374      (let* ((doc (#/objectAtIndex: all-documents i)))
375        (when (eql (#/class doc) self)
376          (return doc))))))
377
378(defun symbol-value-in-top-listener-process (symbol)
379  (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document))))
380     (if process
381       (ignore-errors (symbol-value-in-process symbol process))
382       (values nil t))))
383 
384(defun hemlock-ext:top-listener-output-stream ()
385  (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document))))
386    (when process
387      (setq process (require-type process 'cocoa-listener-process))
388      (cocoa-listener-process-output-stream process))))
389
390(defun hemlock-ext:top-listener-input-stream ()
391  (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document))))
392    (when process
393      (setq process (require-type process 'cocoa-listener-process))
394      (cocoa-listener-process-input-stream process))))
395
396
397
398(objc:defmethod (#/isDocumentEdited :<BOOL>) ((self hemlock-listener-document))
399  nil)
400
401
402
403(objc:defmethod #/init ((self hemlock-listener-document))
404  (let* ((doc (call-next-method)))
405    (unless (%null-ptr-p doc)
406      (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*))
407                              "Listener"
408                              (format nil
409                                      "Listener-~d" *cocoa-listener-count*)))
410             (buffer (hemlock-buffer doc)))
411        (setf (hi::buffer-pathname buffer) nil
412              (hi::buffer-minor-mode buffer "Listener") t
413              (hi::buffer-name buffer) listener-name)
414        (hi::set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
415    doc))
416
417(def-cocoa-default *initial-listener-x-pos* :float -100.0f0 "X position of upper-left corner of initial listener")
418
419(def-cocoa-default *initial-listener-y-pos* :float 100.0f0 "Y position of upper-left corner of initial listener")
420
421(defloadvar *next-listener-x-pos* nil) ; set after defaults initialized
422(defloadvar *next-listener-y-pos* nil) ; likewise
423
424(objc:defmethod (#/close :void) ((self hemlock-listener-document))
425  (if (zerop (decf *cocoa-listener-count*))
426    (setq *next-listener-x-pos* nil
427          *next-listener-y-pos* nil))
428  (let* ((p (shiftf (hemlock-document-process self) nil)))
429    (when p
430      (process-kill p)))
431  (call-next-method))
432
433
434
435(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document))
436  (let* ((textstorage (slot-value self 'textstorage))
437         (window (%hemlock-frame-for-textstorage
438                  hemlock-listener-frame
439                  textstorage
440                  *listener-columns*
441                  *listener-rows*
442                  t
443                  (textview-background-color self)
444                  (user-input-style self)))
445         (listener-styles (#/arrayWithObjects: ns:ns-mutable-array
446                                               (rme-create-text-attributes
447                                                :font *listener-input-font*)
448                                               (rme-create-text-attributes
449                                                :font *listener-output-font*)
450                                               +null-ptr+))
451         (controller (make-instance
452                      'hemlock-listener-window-controller
453                      :with-window window))
454         (listener-name (hi::buffer-name (hemlock-buffer self)))
455         (path (#/windowTitleForDocumentDisplayName: controller (#/displayName self ))))
456    (when (slot-exists-p textstorage 'styles)
457      (with-slots (styles) textstorage
458        ;; We probably should be more disciplined about
459        ;; Cocoa memory management.  Having retain/release in
460        ;; random places all over the code is going to get
461        ;; unwieldy.
462        (#/release styles)
463        (setf styles (#/retain listener-styles))))
464    ;; Disabling background layout on listeners is an attempt to work
465    ;; around a bug.  The bug's probably gone ...
466    #-cocotron                          ;no concept of background layout
467    (let* ((layout-managers (#/layoutManagers textstorage)))
468      (dotimes (i (#/count layout-managers))
469        (let* ((layout (#/objectAtIndex: layout-managers i)))
470          (#/setBackgroundLayoutEnabled: layout nil))))
471    (#/setDelegate: window controller)
472    (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
473    (#/setShouldCascadeWindows: controller nil)
474    (#/addWindowController: self controller)
475    (#/release controller)
476    (setf (hemlock-document-process self)
477          (new-cocoa-listener-process listener-name window))
478    (when path
479      (unless (#/setFrameAutosaveName: window path)
480        (setq path nil)))
481    (unless (and path
482                 (when (#/setFrameUsingName: window path)
483                   (let* ((frame (#/frame window)))
484                     (ns:with-ns-point (current-point
485                                        (ns:ns-rect-x frame)
486                                        (+ (ns:ns-rect-y frame)
487                                           (ns:ns-rect-height frame)))
488                        (let* ((next-point (#/cascadeTopLeftFromPoint:
489                                            window
490                                            current-point)))
491                     (setq *next-listener-x-pos*
492                           (ns:ns-point-x next-point)
493                           *next-listener-y-pos*
494                           (ns:ns-point-y next-point)))))
495                   t))
496      (ns:with-ns-point (current-point
497                         (or *next-listener-x-pos*
498                             (x-pos-for-window window *initial-listener-x-pos*))
499                         (or *next-listener-y-pos*
500                             (y-pos-for-window window *initial-listener-y-pos*)))
501        (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
502          (setf *next-listener-x-pos* (ns:ns-point-x new-point)
503                *next-listener-y-pos* (ns:ns-point-y new-point)))))
504    (#/synchronizeWindowTitleWithDocumentName controller)
505    controller))
506
507(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :<BOOL>)
508    ((self hemlock-listener-document)
509     tv
510     (range :<NSR>ange)
511     string)
512  (declare (ignore tv string))
513  (let* ((range-start (ns:ns-range-location range))
514         (range-end (+ range-start (ns:ns-range-length range)))
515         (buffer (hemlock-buffer self))
516         (protected-region (hi::buffer-protected-region buffer)))
517    (if protected-region
518      (let* ((prot-start (hi:mark-absolute-position (hi::region-start protected-region)))
519             (prot-end (hi:mark-absolute-position (hi::region-end protected-region))))
520        (not (or (and (>= range-start prot-start)
521                      (< range-start prot-end))
522                 (and (>= range-end prot-start)
523                      (< range-end prot-end)))))
524      t)))
525   
526   
527;;; Action methods
528(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender)
529  (declare (ignore sender))
530  (let* ((process (hemlock-document-process self)))
531    (when process
532      (ccl::force-break-in-listener process))))
533
534
535
536(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender)
537  (declare (ignore sender))
538  (let* ((process (hemlock-document-process self)))
539    #+debug (log-debug  "~&exitBreak process ~s" process)
540    (when process
541      (process-interrupt process #'abort-break))))
542
543(defmethod listener-backtrace-context ((proc cocoa-listener-process))
544  (car (cocoa-listener-process-backtrace-contexts proc)))
545
546(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
547  (let* ((process (hemlock-document-process self)))
548    (when process
549      (let* ((context (listener-backtrace-context process)))
550        (when context
551          (#/makeKeyAndOrderFront: (#/windowForSheet self) nil)
552          (#/showWindow: (backtrace-controller-for-context context) sender))))))
553
554(defun restarts-controller-for-context (context)
555  (or (car (ccl::bt.restarts context))
556      (setf (car (ccl::bt.restarts context))
557            (let* ((tcr (ccl::bt.tcr context))
558                   (tsp-range (inspector::make-tsp-stack-range tcr context))
559                   (vsp-range (inspector::make-vsp-stack-range tcr context))
560                   (csp-range (inspector::make-csp-stack-range tcr context))
561                   (process (ccl::tcr->process tcr)))
562              (make-instance 'sequence-window-controller
563                             :sequence (cdr (ccl::bt.restarts context))
564                             :result-callback #'(lambda (r)
565                                                  (process-interrupt
566                                                   process
567                                                   #'invoke-restart-interactively
568                                                   r))
569                             :display #'(lambda (item stream)
570                                          (let* ((ccl::*aux-vsp-ranges* vsp-range)
571                                                 (ccl::*aux-tsp-ranges* tsp-range)
572                                                 (ccl::*aux-csp-ranges* csp-range))
573                                          (princ item stream)))
574                             :title (format nil "Restarts for ~a(~d), break level ~d"
575                                            (process-name process)
576                                            (process-serial-number process)
577                                            (ccl::bt.break-level context)))))))
578                           
579(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender)
580  (let* ((process (hemlock-document-process self)))
581    (when process
582      (let* ((context (listener-backtrace-context process)))
583        (when context
584          (#/showWindow: (restarts-controller-for-context context) sender))))))
585
586(objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
587  (declare (ignore sender))
588  (let* ((process (hemlock-document-process self)))
589    (when process
590      (let* ((context (listener-backtrace-context process)))
591        (when context
592          (process-interrupt process #'invoke-restart-interactively 'continue))))))
593
594
595
596
597
598
599;;; Menu item action validation.  It'd be nice if we could distribute this a
600;;; bit better, so that this method didn't have to change whenever a new
601;;; action was implemented in this class.  For now, we have to do so.
602
603(defmethod document-validate-menu-item ((doc hemlock-listener-document) item)
604  ;; Return two values: the first is true if the second is definitive.
605  ;; So far, all actions demand that there be an underlying process, so
606  ;; check for that first.
607  (let* ((process (hemlock-document-process doc)))
608    (if process
609      (let* ((action (#/action item)))
610        (cond
611          ((or (eql action (@selector #/revertDocumentToSaved:))
612               (eql action (@selector #/saveDocument:))
613               (eql action (@selector #/saveDocumentAs:)))
614           (values t nil))
615          ((eql action (@selector #/interrupt:)) (values t t))
616          ((eql action (@selector #/continue:))
617           (let* ((context (listener-backtrace-context process)))
618             (values
619              t
620              (and context
621                   (find 'continue (cdr (ccl::bt.restarts context))
622                         :key #'restart-name)))))
623          ((or (eql action (@selector #/backtrace:))
624               (eql action (@selector #/exitBreak:))
625               (eql action (@selector #/restarts:)))
626           (values t
627                   (not (null (listener-backtrace-context process)))))))
628      (values nil nil))))
629
630(objc:defmethod (#/validateMenuItem: :<BOOL>)
631    ((self hemlock-listener-document) item)
632  (multiple-value-bind (have-opinion opinion)
633      (document-validate-menu-item self item)
634    (if have-opinion
635      opinion
636      (call-next-method item))))
637
638(defun shortest-package-name (package)
639  (let* ((name (package-name package))
640         (len (length name)))
641    (dolist (nick (package-nicknames package) name)
642      (let* ((nicklen (length nick)))
643        (if (< nicklen len)
644          (setq name nick len nicklen))))))
645
646(defmethod ui-object-note-package ((app ns:ns-application) package)
647  (let ((proc *current-process*)
648        (name (shortest-package-name package)))
649    (execute-in-gui #'(lambda ()
650                        (dolist (buf hi::*buffer-list*)
651                          (when (eq proc (buffer-process buf))
652                            (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))))))
653
654
655(defmethod eval-in-listener-process ((process cocoa-listener-process)
656                                     string &key path package offset)
657  (enqueue-toplevel-form (cocoa-listener-process-input-stream process) string
658                         :package-name package :pathname path :offset offset))
659
660;;; This is basically used to provide INPUT to the listener process, by
661;;; writing to an fd which is connected to that process's standard
662;;; input.
663(defun hemlock-ext:send-string-to-listener (listener-buffer string)
664  (let* ((process (buffer-process listener-buffer)))
665    (unless process
666      (error "No listener process found for ~s" listener-buffer))
667    (enqueue-listener-input (cocoa-listener-process-input-stream process) string)))
668
669(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application)
670                                                    selection)
671  (declare (ignore selection))
672  (#/performSelectorOnMainThread:withObject:waitUntilDone:
673   (#/delegate *NSApp*)
674   (@selector #/ensureListener:)
675   +null-ptr+
676   #$YES)
677  (hemlock-document-process (#/topListener hemlock-listener-document)))
678
679(defmethod ui-object-eval-selection ((app ns:ns-application)
680                                     selection)
681  (let* ((target-listener (ui-object-choose-listener-for-selection
682                           app selection)))
683    (when target-listener
684      (destructuring-bind (package path string &optional offset) selection
685        (eval-in-listener-process target-listener string :package package :path path :offset offset)))))
686
687(defmethod ui-object-load-buffer ((app ns:ns-application) selection)
688  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
689    (when target-listener
690      (destructuring-bind (package path) selection
691        (let ((string (format nil "(load ~S)" path)))
692          (eval-in-listener-process target-listener string :package package))))))
693
694(defmethod ui-object-compile-buffer ((app ns:ns-application) selection)
695  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
696    (when target-listener
697      (destructuring-bind (package path) selection
698        (let ((string (format nil "(compile-file ~S)" path)))
699          (eval-in-listener-process target-listener string :package package))))))
700
701(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection)
702  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
703    (when target-listener
704      (destructuring-bind (package path) selection
705        (let ((string (format nil "(progn (compile-file ~S)(load ~S))" 
706                              path
707                              (make-pathname :directory (pathname-directory path)
708                                             :name (pathname-name path)
709                                             :type (pathname-type path)))))
710          (eval-in-listener-process target-listener string :package package))))))
711
712       
713 
Note: See TracBrowser for help on using the repository browser.