Index: /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp =================================================================== --- /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (revision 15030) +++ /trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (revision 15031) @@ -1,5 +1,5 @@ ;;;-*- Mode: Lisp; Package: CCL -*- ;;; -;;; Copyright (C) 2011 Clozureremote- Associates +;;; Copyright (C) 2011 Clozure Associates ;;; This file is part of Clozure CL. ;;; @@ -18,12 +18,26 @@ ;; **** THIS IS NOT COMPLETE AND NOT HOOKED UP TO ANYTHING YET ***** ;; -;; For testing, start a ccl running swank, then in the IDE create a second listener and: -;; (setq conn (ccl::connect-to-swank "localhost" 4025)) ;; or wherever your swank lisp is -;; (setq thread (ccl::make-rrepl-thread conn "IDE Listener")) -;; (gui::connect-listener-to-remote (cadr (gui::active-listener-windows)) thread) (in-package "GUI") -;; In the future, there should be something like a "New Remote Listener" command +#+debug ;; For testing, start a ccl running swank, then call this in the ide. +(defun cl-user::rlisp-test (port &optional host) + (declare (special conn thread)) + (when (boundp 'conn) (close conn)) + (setq conn (ccl::connect-to-swank (or host "localhost") port)) + (setq thread (ccl::make-rrepl-thread conn "IDE Listener")) + (let* ((old ccl::*inhibit-greeting*) + (listener (unwind-protect + (progn + (setq ccl::*inhibit-greeting* t) + (new-listener)) + (setq ccl::*inhibit-greeting* old)))) + (connect-listener-to-remote listener thread))) + + +(defclass remote-cocoa-listener-process (cocoa-listener-process) + ((remote-thread :initarg :remote-thread :reader process-remote-thread))) + +;; in the future, there should be something like a "New Remote Listener" command ;; which should pass relevant info through to new-cocoa-listener-process. ;; But this will do for testing: take an existing normal listener and convert it. @@ -49,5 +63,6 @@ name (ccl::rlisp-host-description rthread) (ccl::rlisp-thread-id rthread)) window - :class 'cocoa-listener-process + :class 'remote-cocoa-listener-process + :initargs `(:remote-thread ,rthread) :initial-function (lambda () @@ -57,4 +72,7 @@ (defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application)) (hemlock-ext:top-listener-output-stream)) + +(defmethod ccl::input-stream-for-remote-lisp ((app cocoa-application)) + (hemlock-ext:top-listener-input-stream)) (defmethod ccl::toplevel-form-text ((stream cocoa-listener-input-stream)) Index: /trunk/source/library/remote-lisp.lisp =================================================================== --- /trunk/source/library/remote-lisp.lisp (revision 15030) +++ /trunk/source/library/remote-lisp.lisp (revision 15031) @@ -29,6 +29,6 @@ ((lock :initform (make-lock) :reader rlisp-lock) (server-process :initform nil :accessor rlisp-server-process) - (callback-counter :initform most-negative-fixnum :accessor rlisp-callback-counter) - (callbacks :initform () :accessor rlisp-callbacks) + (object-counter :initform most-negative-fixnum :accessor rlisp-object-counter) + (objects :initform () :accessor rlisp-objects) (threads :initform () :accessor rlisp-threads) @@ -58,26 +58,31 @@ (setf (rlisp-lisp-implementation-version conn) lisp-implementation-version)))) +(defun register-rlisp-object (conn object) + (with-rlisp-lock (conn) + (let* ((id (incf (rlisp-object-counter conn)))) + (push (cons id object) (rlisp-objects conn)) + id))) + +(defun find-rlisp-object (conn id) + (with-rlisp-lock (conn) + (let ((cell (assoc id (rlisp-objects conn)))) + (unless cell + (warn "Missing remote object ~s" id)) + (setf (rlisp-objects conn) (delq cell (rlisp-objects conn))) + (cdr cell)))) + +(defun remove-rlisp-object (conn id) + (with-rlisp-lock (conn) + (setf (rlisp-objects conn) (delete id (rlisp-objects conn) :key #'car)))) + (defun register-rlisp-callback (conn callback) - (with-rlisp-lock (conn) - (let* ((id (incf (rlisp-callback-counter conn)))) - (push (list* id callback *current-process*) (rlisp-callbacks conn)) - id))) + (register-rlisp-object conn (cons callback *current-process*))) ;; Invoke callback in the process that registered it. (defun invoke-rlisp-callback (conn id &rest values) (declare (dynamic-extent values)) - (destructuring-bind (callback . process) - (with-rlisp-lock (conn) - (let ((cell (assoc id (rlisp-callbacks conn)))) - (unless cell - (warn "Missing swank callback ~s" id)) - (setf (rlisp-callbacks conn) (delq cell (rlisp-callbacks conn))) - (or (cdr cell) '(nil . nil)))) + (destructuring-bind (callback . process) (or (find-rlisp-object conn id) '(nil . nil)) (when callback (apply #'process-interrupt process callback values)))) - -(defun remove-rlisp-callback (conn id) - (with-rlisp-lock (conn) - (setf (rlisp-callbacks conn) (delete id (rlisp-callbacks conn) :key #'car)))) (defclass remote-lisp-thread () @@ -101,13 +106,15 @@ (defmethod rlisp-thread-id ((thread-id symbol)) (or thread-id t)) -(defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread)) +(defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread) &key (create t)) + (declare (ignore create)) thread) -(defmethod rlisp-thread ((conn remote-lisp-connection) (id integer)) +(defmethod rlisp-thread ((conn remote-lisp-connection) (id integer) &key (create t)) (with-rlisp-lock (conn) (or (find id (rlisp-threads conn) :key #'rlisp-thread-id) - (let ((rthread (make-instance 'remote-lisp-thread :connection conn :thread-id id))) - (push rthread (rlisp-threads conn)) - rthread)))) + (and create + (let ((rthread (make-instance 'remote-lisp-thread :connection conn :thread-id id))) + (push rthread (rlisp-threads conn)) + rthread))))) (defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key) @@ -219,4 +226,7 @@ *standard-output*) +(defmethod input-stream-for-remote-lisp ((app application)) + *standard-input*) + (defmethod handle-swank-event ((conn swank-rlisp-connection) event args) (case event @@ -226,7 +236,7 @@ (:invalid-rpc (destructuring-bind (id message) args - (when id (remove-rlisp-callback conn id)) + (when id (remove-rlisp-object conn id)) (error "Invalid swank rpc: ~s" message))) - ((:debug :debug-activate :debug-return :debug-condition) + ((:debug :debug-activate :debug-return :debug-condition :read-aborted) (destructuring-bind (thread-id &rest event-args) args (let ((rthread (rlisp-thread conn thread-id))) @@ -246,11 +256,43 @@ (let ((stream (output-stream-for-remote-lisp *application*))) (if (> (length string) 500) - (process-run-function "Long Swank Output" #'write-string string stream) + (process-run-function "Long Remote Output" #'write-string string stream) (write-string string stream))))) + (:read-string + (destructuring-bind (thread-id tag) args + (let ((rthread (rlisp-thread conn thread-id :create nil))) + (if (and rthread (rlisp-thread-process rthread)) + (process-interrupt (rlisp-thread-process rthread) + #'handle-swank-event + rthread event `(,tag)) + ;; not a listener thread. + ;; TODO: this needs to be wrapped in some error handling. + (process-run-function (format nil "Remote Input (~s)" thread-id) + #'rlisp-read-string + conn + (input-stream-for-remote-lisp *application*) + thread-id + tag))))) (t (warn "Received unknown event ~s with args ~s" event args)))) + +(define-condition rlisp-read-aborted () + ((tag :initarg :tag :reader rlisp-read-aborted-tag))) + +(defun rlisp-read-string (conn stream thread-id tag) + (handler-bind ((rlisp-read-aborted (lambda (c) + (when (eql tag (rlisp-read-aborted-tag c)) + (return-from rlisp-read-string))))) + (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof + (read-available-text stream)))) + (send-sexp-to-swank conn `(:emacs-return-string ,thread-id ,tag ,text))))) (defmethod handle-swank-event ((rthread remote-lisp-thread) event args) (assert (eq (rlisp-thread-process rthread) *current-process*)) (ecase event + (:read-string + (destructuring-bind (tag) args + (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag))) + (:read-aborted + (destructuring-bind (tag) args + (signal 'rlisp-read-aborted :tag tag))) (:debug ;; SLDB-SETUP (destructuring-bind (level (condition-text condition-type extras) @@ -399,12 +441,15 @@ ;; (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute thread) ,tag ,value))) +(defun read-available-text (stream) + (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0) + for ch = (stream-read-char-no-hang stream) + until (or (eq ch :eof) (null ch)) + do (vector-push-extend ch buffer) + finally (return buffer))) + +;; Return text for remote evaluation. (defmethod toplevel-form-text ((stream input-stream)) - ;; Return text for remote evaluation. (when (peek-char t stream nil) ;; wait for the first one. - (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0) - for ch = (stream-read-char-no-hang stream) - until (or (eq ch :eof) (null ch)) - do (vector-push-extend ch buffer) - finally (return buffer)))) + (read-available-text stream))) (defmethod toplevel-form-text ((stream synonym-stream))