source: trunk/ccl/cocoa-ide/cocoa-listener.lisp @ 7580

Last change on this file since 7580 was 7580, checked in by rme, 13 years ago

Let user select different fonts for listener input and output.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 24.9 KB
Line 
1;;-*- Mode: LISP; Package: CCL -*-
2
3(in-package "CCL")
4
5(eval-when (:compile-toplevel :load-toplevel :execute)
6  (require "COCOA-EDITOR")
7  (require "PTY"))
8
9(def-cocoa-default *listener-input-font* :font #'(lambda ()
10                                                   (#/fontWithName:size:
11                                                    ns:ns-font
12                                                    #@"Monaco" 10.0))
13                   "Default font for listener input")
14(def-cocoa-default *listener-output-font* :font #'(lambda ()
15                                                    (#/fontWithName:size:
16                                                     ns:ns-font
17                                                     #@"Monaco" 10.0))
18                   "Default font for listener output")
19
20(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters")
21(def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters")
22
23(def-cocoa-default hi::*listener-output-style* :int 1 "Text style index for listener output")
24
25(def-cocoa-default hi::*listener-input-style* :int 0 "Text style index for listener output")
26
27(def-cocoa-default *listener-background-color* :color '(1.0 1.0 1.0 1.0) "Listener default background color")
28
29(def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output")
30
31;;; Setup the server end of a pty pair.
32(defun setup-server-pty (pty)
33  (set-tty-raw pty)
34  pty)
35
36;;; Setup the client end of a pty pair.
37(defun setup-client-pty (pty)
38  ;; Since the same (Unix) process will be reading from and writing
39  ;; to the pty, it's critical that we make the pty non-blocking.
40  ;; Has this been true for the last few years (native threads) ?
41  ;(fd-set-flag pty #$O_NONBLOCK)
42  (set-tty-raw pty)
43  #+no
44  (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG))
45  #+no
46  (disable-tty-output-modes pty #$ONLCR) 
47  pty)
48
49
50(defloadvar *cocoa-listener-count* 0)
51
52(defclass cocoa-listener-process (process)
53    ((input-stream :reader cocoa-listener-process-input-stream)
54     (output-stream :reader cocoa-listener-process-output-stream)
55     (input-peer-stream :reader cocoa-listener-process-input-peer-stream)
56     (backtrace-contexts :initform nil
57                         :accessor cocoa-listener-process-backtrace-contexts)
58     (window :reader cocoa-listener-process-window)
59     (buffer :initform nil :reader cocoa-listener-process-buffer)))
60 
61
62(defun new-cocoa-listener-process (procname input-fd output-fd peer-fd window buffer)
63  (let* ((input-stream (make-selection-input-stream
64                        input-fd
65                        :peer-fd peer-fd
66                        :elements-per-buffer (#_fpathconf
67                                              input-fd
68                                              #$_PC_MAX_INPUT)
69                        :encoding :utf-8))
70         (output-stream (make-fd-stream output-fd :direction :output
71                                        :sharing :lock
72                                        :elements-per-buffer
73                                        (#_fpathconf
74                                         output-fd
75                                         #$_PC_MAX_INPUT)
76                                        :encoding :utf-8))
77         (peer-stream (make-fd-stream peer-fd :direction :output
78                                      :sharing :lock
79                                      :elements-per-buffer
80                                      (#_fpathconf
81                                         peer-fd
82                                         #$_PC_MAX_INPUT)
83                                      :encoding :utf-8))
84         (proc
85          (make-mcl-listener-process 
86           procname
87           input-stream
88           output-stream
89           #'(lambda ()`
90               (let* ((buf (find *current-process* hi:*buffer-list*
91                                 :key #'hi::buffer-process))
92                      (doc (if buf (hi::buffer-document buf))))
93                 (when doc
94                   (setf (hi::buffer-process buf) nil)
95                   (#/performSelectorOnMainThread:withObject:waitUntilDone:
96                    doc
97                    (@selector #/close)
98                    +null-ptr+
99                    nil))))
100           :initial-function
101           #'(lambda ()
102               (setq *listener-autorelease-pool* (create-autorelease-pool))
103               (listener-function))
104           :class 'cocoa-listener-process)))
105    (setf (slot-value proc 'input-stream) input-stream)
106    (setf (slot-value proc 'output-stream) output-stream)
107    (setf (slot-value proc 'input-peer-stream) peer-stream)
108    (setf (slot-value proc 'window) window)
109    (setf (slot-value proc 'buffer) buffer)
110    proc))
111         
112
113(defclass hemlock-listener-frame (hemlock-frame)
114    ()
115  (:metaclass ns:+ns-object))
116
117
118(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
119    ((filehandle :foreign-type :id)     ;Filehandle for I/O
120     (clientfd :foreign-type :int)      ;Client (listener)'s side of pty
121     (nextra :foreign-type :int)        ;count of untranslated bytes remaining
122     (translatebuf :foreign-type :address) ;buffer for utf8 translation
123     (bufsize :foreign-type :int)       ;size of translatebuf
124     )
125  (:metaclass ns:+ns-object)
126  )
127
128
129;;; Listener documents are never (or always) ediited.  Don't cause their
130;;; close boxes to be highlighted.
131(objc:defmethod (#/setDocumentEdited: :void)
132    ((self hemlock-listener-window-controller) (edited :<BOOL>))
133  (declare (ignorable edited)))
134 
135
136(objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w)
137  (let* ((new (call-next-method w)))
138    (unless (%null-ptr-p new)
139      (multiple-value-bind (server client) (ignore-errors (open-pty-pair))
140        (when server
141          (let* ((fh (make-instance
142                      'ns:ns-file-handle
143                      :with-file-descriptor (setup-server-pty server)
144                      :close-on-dealloc t)))
145            (setf (slot-value new 'filehandle) fh)
146            (setf (slot-value new 'clientfd) (setup-client-pty client))
147            (let* ((bufsize #$BUFSIZ)
148                   (buffer (#_malloc bufsize)))
149              (setf (slot-value new 'translatebuf) buffer
150                    (slot-value new 'bufsize) bufsize
151                    (slot-value new 'nextra) 0))
152            (#/addObserver:selector:name:object:
153             (#/defaultCenter ns:ns-notification-center)
154             new
155             (@selector #/gotData:)
156             #&NSFileHandleReadCompletionNotification
157             fh)
158            (#/readInBackgroundAndNotify fh)))))
159    new))
160
161(objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller)
162                                    notification)
163  (with-slots (filehandle nextra translatebuf bufsize) self
164    (let* ((data (#/objectForKey: (#/userInfo notification)
165                                  #&NSFileHandleNotificationDataItem))
166           (document (#/document self))
167           (encoding (load-time-value (get-character-encoding :utf-8)))
168           (data-length (#/length data))
169           (buffer (hemlock-document-buffer document))
170           (n nextra)
171           (cursize bufsize)
172           (need (+ n data-length))
173           (xlate translatebuf)
174           (fh filehandle))
175      (when (> need cursize)
176        (let* ((new (#_malloc need)))
177          (dotimes (i n) (setf (%get-unsigned-byte new i)
178                               (%get-unsigned-byte xlate i)))
179          (#_free xlate)
180          (setq xlate new translatebuf new bufsize need)))
181      #+debug (#_NSLog #@"got %d bytes of data" :int data-length)
182      (with-macptrs ((target (%inc-ptr xlate n)))
183        (#/getBytes:range: data target (ns:make-ns-range 0 data-length)))
184      (let* ((total (+ n data-length)))
185        (multiple-value-bind (nchars noctets-used)
186            (funcall (character-encoding-length-of-memory-encoding-function encoding)
187                     xlate
188                     total
189                     0)
190          (let* ((string (make-string nchars)))
191            (funcall (character-encoding-memory-decode-function encoding)
192                     xlate
193                     noctets-used
194                     0
195                     string)
196            (unless (zerop (setq n (- total noctets-used)))
197              ;; By definition, the number of untranslated octets
198              ;; can't be more than 3.
199              (dotimes (i n)
200                (setf (%get-unsigned-byte xlate i)
201                      (%get-unsigned-byte xlate (+ noctets-used i)))))
202            (setq nextra n)
203            (hi::enqueue-buffer-operation
204             buffer
205             #'(lambda ()
206                 (unwind-protect
207                      (progn
208                        (hi::buffer-document-begin-editing buffer)
209                        (hemlock::append-buffer-output buffer string))
210                   (hi::buffer-document-end-editing buffer))))
211            (#/readInBackgroundAndNotify fh)))))))
212             
213
214
215(objc:defmethod (#/dealloc :void) ((self hemlock-listener-window-controller))
216  (#/removeObserver: (#/defaultCenter ns:ns-notification-center) self)
217  (call-next-method))
218
219(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
220  (let* ((doc (#/document self)))
221    (if (or (%null-ptr-p doc)
222            (not (%null-ptr-p (#/fileURL doc))))
223      (call-next-method name)
224      (let* ((buffer (hemlock-document-buffer doc))
225             (bufname (if buffer (hi::buffer-name buffer))))
226        (if bufname
227          (%make-nsstring bufname)
228          (call-next-method name))))))
229
230
231;;; The HemlockListenerDocument class.
232
233
234(defclass hemlock-listener-document (hemlock-editor-document)
235    ()
236  (:metaclass ns:+ns-object))
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 (bt.restarts context))
416      (setf (car (bt.restarts context))
417            (let* ((tcr (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 (tcr->process (bt.tcr context))))
422              (make-instance 'sequence-window-controller
423                             :sequence (cdr (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                                            (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 (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  (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.