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))))))))) |
---|