Changeset 15031

Timestamp:

Oct 20, 2011, 12:24:21 PM (13 years ago)

Author:

gz

Message:

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

Location:

trunk/source

Files:

• cocoa-ide/cocoa-remote-lisp.lisp (modified) (4 diffs)
• library/remote-lisp.lisp (modified) (7 diffs)

trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

@@ -1 +1 @@
 ;;;-*- Mode: Lisp; Package: CCL -*-
 ;;;
-;;;   Copyright (C) 2011 Clozureremote- Associates
+;;;   Copyright (C) 2011 Clozure Associates
 ;;;   This file is part of Clozure CL.  
 ;;;
@@ -18 +18 @@
 ;;  **** 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 +63 @@
                                               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 +72 @@
 (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))

trunk/source/library/remote-lisp.lisp

@@ -29 +29 @@
   ((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 +58 @@
       (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 +106 @@
 (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 +226 @@
   *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 +236 @@
     (: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 +256 @@
        (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 +441 @@
 ;;  (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))