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

Last change on this file since 7698 was 7698, checked in by gz, 13 years ago

A new package and a reorg:

I put all the cocoa-ide files (except for a greatly stripped-down
cocoa.lisp and cocoa-application.lisp) in a new package named "GUI".

The package is defined in defsystem.lisp, which also defines a
function to load all the files explicitly, putting the fasls in
cocoa-ide;fasls; I stripped out all pretense that the files can or
should be loaded individually. Also, it is no longer necessary or
appropriate to compile hemlock separately, as it now compiles as
needed as part of the normal loading sequence. (Over time I am hoping
to get hemlock more and more integrated into the IDE, and having to
maintain it as if it still were a separate package is an unnecessary
burden).

Updated the README file appropriately.

  • 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.