source: trunk/source/cocoa-ide/cocoa-remote-lisp.lisp @ 15031

Last change on this file since 15031 was 15031, checked in by gz, 8 years ago

Support for reading user input from remote lisp. Easier test setup for remote listener

File size: 4.9 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2011 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;  Use the IDE to debug a remote ccl.
18;;  **** THIS IS NOT COMPLETE AND NOT HOOKED UP TO ANYTHING YET *****
19;;
20
21(in-package "GUI")
22
23#+debug ;; For testing, start a ccl running swank, then call this in the ide.
24(defun cl-user::rlisp-test (port &optional host)
25  (declare (special conn thread))
26  (when (boundp 'conn) (close conn))
27  (setq conn (ccl::connect-to-swank (or host "localhost") port))
28  (setq thread (ccl::make-rrepl-thread conn "IDE Listener"))
29  (let* ((old ccl::*inhibit-greeting*)
30         (listener (unwind-protect
31                       (progn
32                         (setq ccl::*inhibit-greeting* t)
33                         (new-listener))
34                     (setq ccl::*inhibit-greeting* old))))
35    (connect-listener-to-remote listener thread)))
36
37
38(defclass remote-cocoa-listener-process (cocoa-listener-process)
39  ((remote-thread :initarg :remote-thread :reader process-remote-thread)))
40
41;; in the future, there should be something like a "New Remote Listener" command
42;; which should pass relevant info through to new-cocoa-listener-process.
43;; But this will do for testing: take an existing normal listener and convert it.
44(defmethod connect-listener-to-remote (object rthread)
45  (let ((view (hemlock-view object)))
46    (connect-listener-to-remote (or view (require-type object 'hi:hemlock-view)) rthread)))
47
48(defmethod connect-listener-to-remote ((view hi:hemlock-view) (rthread ccl::remote-lisp-thread))
49  (let* ((doc (hi::buffer-document (hi:hemlock-view-buffer view)))
50         (process (or (hemlock-document-process doc)
51                      (error "Not a listener: ~s" view)))
52         (name (process-name process))
53         (window (cocoa-listener-process-window process)))
54    (when (eq process *current-process*)
55      (error "Cannot connect current listener"))
56    (setf (hemlock-document-process doc) nil) ;; so killing the process doesn't close the window
57    (process-kill process)
58    (let ((pos (search " [Remote " name :from-end t)))
59      (when pos
60        (setq name (subseq name 0 pos))))
61    (setf (hemlock-document-process doc)
62          (new-cocoa-listener-process (format nil "~a [Remote ~a(~a)]"
63                                              name (ccl::rlisp-host-description rthread) (ccl::rlisp-thread-id rthread))
64                                      window
65                                      :class 'remote-cocoa-listener-process
66                                      :initargs  `(:remote-thread ,rthread)
67                                      :initial-function
68                                      (lambda ()
69                                        (setf (hemlock-document-process doc) *current-process*)
70                                        (ccl::remote-listener-function rthread))))))
71
72(defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application))
73  (hemlock-ext:top-listener-output-stream))
74
75(defmethod ccl::input-stream-for-remote-lisp ((app cocoa-application))
76  (hemlock-ext:top-listener-input-stream))
77
78(defmethod ccl::toplevel-form-text ((stream cocoa-listener-input-stream))
79  (with-slots (read-lock queue-lock queue queue-semaphore text-semaphore) stream
80    (with-lock-grabbed (read-lock)
81      (assert (with-slots (cur-sstream) stream (null cur-sstream)))
82      (wait-on-semaphore queue-semaphore nil "Toplevel Read")
83      (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
84        (cond ((stringp val) ;; listener input
85               (assert (with-slots (text-semaphore) stream
86                         (timed-wait-on-semaphore text-semaphore 0))
87                       ()
88                       "text/queue mismatch!")
89               (values val nil t))
90              (t
91               ;; TODO: this is bogus, the package may not exist on this side, so must be a string,
92               ;; but we can't bind *package* to a string.  So this assumes the caller will know
93               ;; not to progv the env.
94               (destructuring-bind (string package-name pathname offset) val ;; queued form
95                 (declare (ignore offset))
96                 (let ((env (cons '(*loading-file-source-file*)
97                                  (list pathname))))
98                   (when package-name
99                     (push '*package* (car env))
100                     (push package-name (cdr env)))
101                   (values string env)))))))))
Note: See TracBrowser for help on using the repository browser.