source: branches/working-0711/ccl/cocoa-ide/cocoa-listener.lisp @ 7804

Last change on this file since 7804 was 7804, checked in by gb, 13 years ago

sync with trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 24.7 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                                                    #@"Monaco" 10.0))
11                   "Default font for listener input")
12(def-cocoa-default *listener-output-font* :font #'(lambda ()
13                                                    (#/fontWithName:size:
14                                                     ns:ns-font
15                                                     #@"Monaco" 10.0))
16                   "Default font for listener output")
17
18(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters")
19(def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters")
20
21(def-cocoa-default hi::*listener-output-style* :int 1 "Text style index for listener output")
22
23(def-cocoa-default hi::*listener-input-style* :int 0 "Text style index for listener output")
24
25(def-cocoa-default *listener-background-color* :color '(1.0 1.0 1.0 1.0) "Listener default background color")
26
27(def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output")
28
29;;; Setup the server end of a pty pair.
30(defun setup-server-pty (pty)
31  (set-tty-raw pty)
32  pty)
33
34;;; Setup the client end of a pty pair.
35(defun setup-client-pty (pty)
36  ;; Since the same (Unix) process will be reading from and writing
37  ;; to the pty, it's critical that we make the pty non-blocking.
38  ;; Has this been true for the last few years (native threads) ?
39  ;(fd-set-flag pty #$O_NONBLOCK)
40  (set-tty-raw pty)
41  #+no
42  (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG))
43  #+no
44  (disable-tty-output-modes pty #$ONLCR) 
45  pty)
46
47
48(defloadvar *cocoa-listener-count* 0)
49
50(defclass cocoa-listener-process (process)
51    ((input-stream :reader cocoa-listener-process-input-stream)
52     (output-stream :reader cocoa-listener-process-output-stream)
53     (input-peer-stream :reader cocoa-listener-process-input-peer-stream)
54     (backtrace-contexts :initform nil
55                         :accessor cocoa-listener-process-backtrace-contexts)
56     (window :reader cocoa-listener-process-window)
57     (buffer :initform nil :reader cocoa-listener-process-buffer)))
58 
59
60(defun new-cocoa-listener-process (procname input-fd output-fd peer-fd window buffer)
61  (let* ((input-stream (ccl::make-selection-input-stream
62                        input-fd
63                        :peer-fd peer-fd
64                        :elements-per-buffer (#_fpathconf
65                                              input-fd
66                                              #$_PC_MAX_INPUT)
67                        :encoding :utf-8))
68         (output-stream (ccl::make-fd-stream output-fd :direction :output
69                                             :sharing :lock
70                                             :elements-per-buffer
71                                             (#_fpathconf
72                                              output-fd
73                                              #$_PC_MAX_INPUT)
74                                             :encoding :utf-8))
75         (peer-stream (ccl::make-fd-stream peer-fd :direction :output
76                                           :sharing :lock
77                                           :elements-per-buffer
78                                           (#_fpathconf
79                                            peer-fd
80                                            #$_PC_MAX_INPUT)
81                                           :encoding :utf-8))
82         (proc
83          (ccl::make-mcl-listener-process 
84           procname
85           input-stream
86           output-stream
87           #'(lambda ()`
88               (let* ((buf (find *current-process* hi:*buffer-list*
89                                 :key #'hi::buffer-process))
90                      (doc (if buf (hi::buffer-document buf))))
91                 (when doc
92                   (setf (hi::buffer-process buf) nil)
93                   (#/performSelectorOnMainThread:withObject:waitUntilDone:
94                    doc
95                    (@selector #/close)
96                    +null-ptr+
97                    nil))))
98           :initial-function
99           #'(lambda ()
100               (setq ccl::*listener-autorelease-pool* (create-autorelease-pool))
101               (ccl::listener-function))
102           :class 'cocoa-listener-process)))
103    (setf (slot-value proc 'input-stream) input-stream)
104    (setf (slot-value proc 'output-stream) output-stream)
105    (setf (slot-value proc 'input-peer-stream) peer-stream)
106    (setf (slot-value proc 'window) window)
107    (setf (slot-value proc 'buffer) buffer)
108    proc))
109         
110
111(defclass hemlock-listener-frame (hemlock-frame)
112    ()
113  (:metaclass ns:+ns-object))
114(declaim (special hemlock-listener-frame))
115
116
117(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
118    ((filehandle :foreign-type :id)     ;Filehandle for I/O
119     (clientfd :foreign-type :int)      ;Client (listener)'s side of pty
120     (nextra :foreign-type :int)        ;count of untranslated bytes remaining
121     (translatebuf :foreign-type :address) ;buffer for utf8 translation
122     (bufsize :foreign-type :int)       ;size of translatebuf
123     )
124  (:metaclass ns:+ns-object)
125  )
126(declaim (special hemlock-listener-window-controller))
127
128;;; Listener documents are never (or always) ediited.  Don't cause their
129;;; close boxes to be highlighted.
130(objc:defmethod (#/setDocumentEdited: :void)
131    ((self hemlock-listener-window-controller) (edited :<BOOL>))
132  (declare (ignorable edited)))
133 
134
135(objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w)
136  (let* ((new (call-next-method w)))
137    (unless (%null-ptr-p new)
138      (multiple-value-bind (server client) (ignore-errors (open-pty-pair))
139        (when server
140          (let* ((fh (make-instance
141                      'ns:ns-file-handle
142                      :with-file-descriptor (setup-server-pty server)
143                      :close-on-dealloc t)))
144            (setf (slot-value new 'filehandle) fh)
145            (setf (slot-value new 'clientfd) (setup-client-pty client))
146            (let* ((bufsize #$BUFSIZ)
147                   (buffer (#_malloc bufsize)))
148              (setf (slot-value new 'translatebuf) buffer
149                    (slot-value new 'bufsize) bufsize
150                    (slot-value new 'nextra) 0))
151            (#/addObserver:selector:name:object:
152             (#/defaultCenter ns:ns-notification-center)
153             new
154             (@selector #/gotData:)
155             #&NSFileHandleReadCompletionNotification
156             fh)
157            (#/readInBackgroundAndNotify fh)))))
158    new))
159
160(objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller)
161                                    notification)
162  (with-slots (filehandle nextra translatebuf bufsize) self
163    (let* ((data (#/objectForKey: (#/userInfo notification)
164                                  #&NSFileHandleNotificationDataItem))
165           (document (#/document self))
166           (encoding (load-time-value (get-character-encoding :utf-8)))
167           (data-length (#/length data))
168           (buffer (hemlock-document-buffer document))
169           (n nextra)
170           (cursize bufsize)
171           (need (+ n data-length))
172           (xlate translatebuf)
173           (fh filehandle))
174      (when (> need cursize)
175        (let* ((new (#_malloc need)))
176          (dotimes (i n) (setf (%get-unsigned-byte new i)
177                               (%get-unsigned-byte xlate i)))
178          (#_free xlate)
179          (setq xlate new translatebuf new bufsize need)))
180      #+debug (#_NSLog #@"got %d bytes of data" :int data-length)
181      (with-macptrs ((target (%inc-ptr xlate n)))
182        (#/getBytes:range: data target (ns:make-ns-range 0 data-length)))
183      (let* ((total (+ n data-length)))
184        (multiple-value-bind (nchars noctets-used)
185            (funcall (ccl::character-encoding-length-of-memory-encoding-function encoding)
186                     xlate
187                     total
188                     0)
189          (let* ((string (make-string nchars)))
190            (funcall (ccl::character-encoding-memory-decode-function encoding)
191                     xlate
192                     noctets-used
193                     0
194                     string)
195            (unless (zerop (setq n (- total noctets-used)))
196              ;; By definition, the number of untranslated octets
197              ;; can't be more than 3.
198              (dotimes (i n)
199                (setf (%get-unsigned-byte xlate i)
200                      (%get-unsigned-byte xlate (+ noctets-used i)))))
201            (setq nextra n)
202            (hi::enqueue-buffer-operation
203             buffer
204             #'(lambda ()
205                 (unwind-protect
206                      (progn
207                        (hi::buffer-document-begin-editing buffer)
208                        (hemlock::append-buffer-output buffer string))
209                   (hi::buffer-document-end-editing buffer))))
210            (#/readInBackgroundAndNotify fh)))))))
211             
212
213
214(objc:defmethod (#/dealloc :void) ((self hemlock-listener-window-controller))
215  (#/removeObserver: (#/defaultCenter ns:ns-notification-center) self)
216  (call-next-method))
217
218(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
219  (let* ((doc (#/document self)))
220    (if (or (%null-ptr-p doc)
221            (not (%null-ptr-p (#/fileURL doc))))
222      (call-next-method name)
223      (let* ((buffer (hemlock-document-buffer doc))
224             (bufname (if buffer (hi::buffer-name buffer))))
225        (if bufname
226          (%make-nsstring bufname)
227          (call-next-method name))))))
228
229
230;;; The HemlockListenerDocument class.
231
232
233(defclass hemlock-listener-document (hemlock-editor-document)
234    ()
235  (:metaclass ns:+ns-object))
236(declaim (special hemlock-listener-document))
237
238(defmethod update-buffer-package ((doc hemlock-listener-document) buffer)
239  (declare (ignore buffer)))
240
241(defmethod hi::document-encoding-name ((doc hemlock-listener-document))
242  "UTF-8")
243
244(defmethod user-input-style ((doc hemlock-listener-document))
245  hi::*listener-input-style*)
246 
247(defmethod textview-background-color ((doc hemlock-listener-document))
248  *listener-background-color*)
249
250
251(defun hemlock::listener-document-send-string (document string)
252  (let* ((buffer (hemlock-document-buffer document))
253         (process (if buffer (hi::buffer-process buffer))))
254    (if process
255      (hi::send-string-to-listener-process process string))))
256
257
258(objc:defmethod #/topListener ((self +hemlock-listener-document))
259  (let* ((all-documents (#/orderedDocuments *NSApp*)))
260    (dotimes (i (#/count all-documents) +null-ptr+)
261      (let* ((doc (#/objectAtIndex: all-documents i)))
262        (when (eql (#/class doc) self)
263          (return doc))))))
264
265(defun symbol-value-in-top-listener-process (symbol)
266  (let* ((listenerdoc (#/topListener hemlock-listener-document))
267         (buffer (unless (%null-ptr-p listenerdoc)
268                   (hemlock-document-buffer listenerdoc)))
269         (process (if buffer (hi::buffer-process buffer))))
270     (if process
271       (ignore-errors (symbol-value-in-process symbol process))
272       (values nil t))))
273 
274(defun hi::top-listener-output-stream ()
275  (let* ((doc (#/topListener hemlock-listener-document)))
276    (unless (%null-ptr-p doc)
277      (let* ((buffer (hemlock-document-buffer doc))
278             (process (if buffer (hi::buffer-process buffer))))
279        (when (typep process 'cocoa-listener-process)
280          (cocoa-listener-process-output-stream process))))))
281
282
283
284(objc:defmethod (#/isDocumentEdited :<BOOL>) ((self hemlock-listener-document))
285  nil)
286
287
288
289(objc:defmethod #/init ((self hemlock-listener-document))
290  (let* ((doc (call-next-method)))
291    (unless (%null-ptr-p doc)
292      (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*))
293                            "Listener"
294                            (format nil
295                                    "Listener-~d" *cocoa-listener-count*)))
296             (buffer (hemlock-document-buffer doc)))
297        (setf (hi::buffer-pathname buffer) nil
298              (hi::buffer-minor-mode buffer "Listener") t
299              (hi::buffer-name buffer) listener-name)
300        (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
301    doc))
302
303(def-cocoa-default *initial-listener-x-pos* :float -100.0f0 "X position of upper-left corner of initial listener")
304
305(def-cocoa-default *initial-listener-y-pos* :float 100.0f0 "Y position of upper-left corner of initial listener")
306
307(defloadvar *next-listener-x-pos* nil) ; set after defaults initialized
308(defloadvar *next-listener-y-pos* nil) ; likewise
309
310(objc:defmethod (#/close :void) ((self hemlock-listener-document))
311  (if (zerop (decf *cocoa-listener-count*))
312    (setq *next-listener-x-pos* nil
313          *next-listener-y-pos* nil))
314  (call-next-method))
315
316(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document))
317  (let* ((textstorage (slot-value self 'textstorage))
318         (window (%hemlock-frame-for-textstorage
319                  hemlock-listener-frame
320                  textstorage
321                  *listener-columns*
322                  *listener-rows*
323                  t
324                  (textview-background-color self)
325                  (user-input-style self)))
326         (listener-styles (#/arrayWithObjects: ns:ns-mutable-array
327                                               (rme-create-text-attributes
328                                                :font *listener-input-font*)
329                                               (rme-create-text-attributes
330                                                :font *listener-output-font*)
331                                               +null-ptr+))
332         (controller (make-instance
333                      'hemlock-listener-window-controller
334                      :with-window window))
335         (listener-name (hi::buffer-name (hemlock-document-buffer self))))
336    (with-slots (styles) textstorage
337      ;; We probably should be more disciplined about
338      ;; Cocoa memory management.  Having retain/release in
339      ;; random places all over the code is going to get
340      ;; unwieldy.
341      (#/release styles)
342      (setf styles (#/retain listener-styles)))
343    ;; Disabling background layout on listeners is an attempt to work
344    ;; around a bug.  The bug's probably gone ...
345    (let* ((layout-managers (#/layoutManagers textstorage)))
346      (dotimes (i (#/count layout-managers))
347        (let* ((layout (#/objectAtIndex: layout-managers i)))
348          (#/setBackgroundLayoutEnabled: layout nil))))
349    (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)   
350    (#/addWindowController: self controller)
351    (#/release controller)
352    (ns:with-ns-point (current-point
353                       (or *next-listener-x-pos*
354                           (x-pos-for-window window *initial-listener-x-pos*))
355                       (or *next-listener-y-pos*
356                           (y-pos-for-window window *initial-listener-y-pos*)))
357      (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
358        (setf *next-listener-x-pos* (ns:ns-point-x new-point)
359              *next-listener-y-pos* (ns:ns-point-y new-point))))
360    (setf (hi::buffer-process (hemlock-document-buffer self))
361          (let* ((tty (slot-value controller 'clientfd))
362                 (peer-tty (#/fileDescriptor (slot-value controller 'filehandle))))
363            (new-cocoa-listener-process listener-name tty tty peer-tty window (hemlock-document-buffer self))))
364    controller))
365
366(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :<BOOL>)
367    ((self hemlock-listener-document)
368     tv
369     (range :<NSR>ange)
370     string)
371  (declare (ignore tv string))
372  (let* ((range-start (ns:ns-range-location range))
373         (range-end (+ range-start (ns:ns-range-length range)))
374         (buffer (hemlock-document-buffer self))
375         (protected-region (hi::buffer-protected-region buffer)))
376    (if protected-region
377      (let* ((prot-start (mark-absolute-position (hi::region-start protected-region)))
378             (prot-end (mark-absolute-position (hi::region-end protected-region))))
379        (not (or (and (>= range-start prot-start)
380                      (< range-start prot-end))
381                 (and (>= range-end prot-start)
382                      (< range-end prot-end)))))
383      t)))
384   
385   
386;;; Action methods
387(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender)
388  (declare (ignore sender))
389  (let* ((buffer (hemlock-document-buffer self))
390         (process (if buffer (hi::buffer-process buffer))))
391    (when (typep process 'cocoa-listener-process)
392      (ccl::force-break-in-listener process))))
393
394
395
396(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender)
397  (declare (ignore sender))
398  (let* ((buffer (hemlock-document-buffer self))
399         (process (if buffer (hi::buffer-process buffer))))
400    (when (typep process 'cocoa-listener-process)
401      (process-interrupt process #'abort-break))))
402
403(defmethod listener-backtrace-context ((proc cocoa-listener-process))
404  (car (cocoa-listener-process-backtrace-contexts proc)))
405
406(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
407  (let* ((buffer (hemlock-document-buffer self))
408         (process (if buffer (hi::buffer-process buffer))))
409    (when (typep process 'cocoa-listener-process)
410      (let* ((context (listener-backtrace-context process)))
411        (when context
412          (#/showWindow: (backtrace-controller-for-context context) sender))))))
413
414(defun restarts-controller-for-context (context)
415  (or (car (ccl::bt.restarts context))
416      (setf (car (ccl::bt.restarts context))
417            (let* ((tcr (ccl::bt.tcr context))
418                   (tsp-range (inspector::make-tsp-stack-range tcr context))
419                   (vsp-range (inspector::make-vsp-stack-range tcr context))
420                   (csp-range (inspector::make-csp-stack-range tcr context))
421                   (process (context-process context)))
422              (make-instance 'sequence-window-controller
423                             :sequence (cdr (ccl::bt.restarts context))
424                             :result-callback #'(lambda (r)
425                                                  (process-interrupt
426                                                   process
427                                                   #'invoke-restart-interactively
428                                                   r))
429                             :display #'(lambda (item stream)
430                                          (let* ((ccl::*aux-vsp-ranges* vsp-range)
431                                                 (ccl::*aux-tsp-ranges* tsp-range)
432                                                 (ccl::*aux-csp-ranges* csp-range))
433                                          (princ item stream)))
434                             :title (format nil "Restarts for ~a(~d), break level ~d"
435                                            (process-name process)
436                                            (process-serial-number process)
437                                            (ccl::bt.break-level context)))))))
438                           
439(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender)
440  (let* ((buffer (hemlock-document-buffer self))
441         (process (if buffer (hi::buffer-process buffer))))
442    (when (typep process 'cocoa-listener-process)
443      (let* ((context (listener-backtrace-context process)))
444        (when context
445          (#/showWindow: (restarts-controller-for-context context) sender))))))
446
447(objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
448  (declare (ignore sender))
449  (let* ((buffer (hemlock-document-buffer self))
450         (process (if buffer (hi::buffer-process buffer))))
451    (when (typep process 'cocoa-listener-process)
452      (let* ((context (listener-backtrace-context process)))
453        (when context
454          (process-interrupt process #'invoke-restart-interactively 'continue))))))
455
456
457
458
459
460
461;;; Menu item action validation.  It'd be nice if we could distribute this a
462;;; bit better, so that this method didn't have to change whenever a new
463;;; action was implemented in this class.  For now, we have to do so.
464
465(defmethod document-validate-menu-item ((doc hemlock-listener-document) item)
466  ;; Return two values: the first is true if the second is definitive.
467  ;; So far, all actions demand that there be an underlying process, so
468  ;; check for that first.
469  (let* ((buffer (hemlock-document-buffer doc))
470         (process (if buffer (hi::buffer-process buffer))))
471    (if (typep process 'cocoa-listener-process)
472      (let* ((action (#/action item)))
473        (cond
474          ((or (eql action (@selector #/revertDocumentToSaved:))
475               (eql action (@selector #/saveDocument:))
476               (eql action (@selector #/saveDocumentAs:)))
477           (values t nil))
478          ((eql action (@selector #/interrupt:)) (values t t))
479          ((eql action (@selector #/continue:))
480           (let* ((context (listener-backtrace-context process)))
481             (values
482              t
483              (and context
484                   (find 'continue (cdr (ccl::bt.restarts context))
485                         :key #'restart-name)))))
486          ((or (eql action (@selector #/backtrace:))
487               (eql action (@selector #/exitBreak:))
488               (eql action (@selector #/restarts:)))
489           (values t
490                   (not (null (listener-backtrace-context process)))))))
491      (values nil nil))))
492
493(objc:defmethod (#/validateMenuItem: :<BOOL>)
494    ((self hemlock-listener-document) item)
495  (multiple-value-bind (have-opinion opinion)
496      (document-validate-menu-item self item)
497    (if have-opinion
498      opinion
499      (call-next-method item))))
500
501(defun shortest-package-name (package)
502  (let* ((name (package-name package))
503         (len (length name)))
504    (dolist (nick (package-nicknames package) name)
505      (let* ((nicklen (length nick)))
506        (if (< nicklen len)
507          (setq name nick len nicklen))))))
508
509(defmethod ui-object-note-package ((app ns:ns-application) package)
510  (with-autorelease-pool
511      (process-interrupt *cocoa-event-process*
512                         #'(lambda (proc name)
513                             (dolist (buf hi::*buffer-list*)
514                               (when (eq proc (hi::buffer-process buf))
515                                 (setf (hi::variable-value 'hemlock::current-package :buffer buf) name))))
516                         *current-process*
517                         (shortest-package-name package))))
518
519;;; This is basically used to provide INPUT to the listener process, by
520;;; writing to an fd which is conntected to that process's standard
521;;; input.
522(defmethod hi::send-string-to-listener-process ((process cocoa-listener-process)
523                                                string &key path package)
524  (let* ((stream (cocoa-listener-process-input-peer-stream process)))
525    (labels ((out-raw-char (ch)
526               (write-char ch stream))
527             (out-ch (ch)
528               (when (or (eql ch #\^v)
529                         (eql ch #\^p)
530                         (eql ch #\newline)
531                         (eql ch #\^q)
532                         (eql ch #\^d))
533                 (out-raw-char #\^q))
534               (out-raw-char ch))
535             (out-string (s)
536               (dotimes (i (length s))
537                 (out-ch (char s i)))))
538      (out-raw-char #\^p)
539      (when package (out-string package))
540      (out-raw-char #\newline)
541      (out-raw-char #\^v)
542      (when path (out-string path))
543      (out-raw-char #\newline)
544      (out-string string)
545      (out-raw-char #\^d)
546      (force-output stream))))
547
548
549(defun hemlock::evaluate-input-selection (selection)
550  (ccl::application-ui-operation *application* :eval-selection selection))
551 
552(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application)
553                                                    selection)
554  (declare (ignore selection))
555  (#/performSelectorOnMainThread:withObject:waitUntilDone:
556   (#/delegate *NSApp*) (@selector #/ensureListener:) +null-ptr+ #$YES)
557  (let* ((top-listener-document (#/topListener hemlock-listener-document)))
558    (if top-listener-document
559      (let* ((buffer (hemlock-document-buffer top-listener-document)))
560        (if buffer
561          (let* ((proc (hi::buffer-process buffer)))
562            (if (typep proc 'cocoa-listener-process)
563              proc)))))))
564
565(defmethod ui-object-eval-selection ((app ns:ns-application)
566                                     selection)
567  (let* ((target-listener (ui-object-choose-listener-for-selection
568                           app selection)))
569    (if (typep target-listener 'cocoa-listener-process)
570        (destructuring-bind (package path string) selection
571        (hi::send-string-to-listener-process target-listener string :package package :path path)))))
572
573(defmethod ui-object-load-buffer ((app ns:ns-application) selection)
574  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
575    (if (typep target-listener 'cocoa-listener-process)
576        (destructuring-bind (package path) selection
577          (let ((string (format nil "(load ~S)" path)))
578            (hi::send-string-to-listener-process target-listener string :package package :path path))))))
579
580(defmethod ui-object-compile-buffer ((app ns:ns-application) selection)
581  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
582    (if (typep target-listener 'cocoa-listener-process)
583        (destructuring-bind (package path) selection
584          (let ((string (format nil "(compile-file ~S)" path)))
585            (hi::send-string-to-listener-process target-listener string :package package :path path))))))
586
587(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection)
588  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
589    (if (typep target-listener 'cocoa-listener-process)
590        (destructuring-bind (package path) selection
591          (let ((string (format nil "(progn (compile-file ~S)(load ~S))" 
592                                path
593                                (make-pathname :directory (pathname-directory path)
594                                               :name (pathname-name path)
595                                               :type (pathname-type path)))))
596            (hi::send-string-to-listener-process target-listener string :package package :path path))))))
597
598       
599 
Note: See TracBrowser for help on using the repository browser.