Changeset 15031


Ignore:
Timestamp:
Oct 20, 2011, 7:24:21 PM (8 years ago)
Author:
gz
Message:

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

Location:
trunk/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/cocoa-ide/cocoa-remote-lisp.lisp

    r15028 r15031  
    11;;;-*- Mode: Lisp; Package: CCL -*-
    22;;;
    3 ;;;   Copyright (C) 2011 Clozureremote- Associates
     3;;;   Copyright (C) 2011 Clozure Associates
    44;;;   This file is part of Clozure CL. 
    55;;;
     
    1818;;  **** THIS IS NOT COMPLETE AND NOT HOOKED UP TO ANYTHING YET *****
    1919;;
    20 ;; For testing, start a ccl running swank, then in the IDE create a second listener and:
    21 ;; (setq conn (ccl::connect-to-swank "localhost" 4025)) ;; or wherever your swank lisp is
    22 ;; (setq thread (ccl::make-rrepl-thread conn "IDE Listener"))
    23 ;; (gui::connect-listener-to-remote (cadr (gui::active-listener-windows)) thread)
    2420
    2521(in-package "GUI")
    2622
    27 ;; In the future, there should be something like a "New Remote Listener" command
     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
    2842;; which should pass relevant info through to new-cocoa-listener-process.
    2943;; But this will do for testing: take an existing normal listener and convert it.
     
    4963                                              name (ccl::rlisp-host-description rthread) (ccl::rlisp-thread-id rthread))
    5064                                      window
    51                                       :class 'cocoa-listener-process
     65                                      :class 'remote-cocoa-listener-process
     66                                      :initargs  `(:remote-thread ,rthread)
    5267                                      :initial-function
    5368                                      (lambda ()
     
    5772(defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application))
    5873  (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))
    5977
    6078(defmethod ccl::toplevel-form-text ((stream cocoa-listener-input-stream))
  • trunk/source/library/remote-lisp.lisp

    r15028 r15031  
    2929  ((lock :initform (make-lock) :reader rlisp-lock)
    3030   (server-process :initform nil :accessor rlisp-server-process)
    31    (callback-counter :initform most-negative-fixnum :accessor rlisp-callback-counter)
    32    (callbacks :initform () :accessor rlisp-callbacks)
     31   (object-counter :initform most-negative-fixnum :accessor rlisp-object-counter)
     32   (objects :initform () :accessor rlisp-objects)
    3333   (threads :initform () :accessor rlisp-threads)
    3434
     
    5858      (setf (rlisp-lisp-implementation-version conn) lisp-implementation-version))))
    5959
     60(defun register-rlisp-object (conn object)
     61  (with-rlisp-lock (conn)
     62    (let* ((id (incf (rlisp-object-counter conn))))
     63      (push (cons id object) (rlisp-objects conn))
     64      id)))
     65
     66(defun find-rlisp-object (conn id)
     67  (with-rlisp-lock (conn)
     68    (let ((cell (assoc id (rlisp-objects conn))))
     69      (unless cell
     70        (warn "Missing remote object ~s" id))
     71      (setf (rlisp-objects conn) (delq cell (rlisp-objects conn)))
     72      (cdr cell))))
     73
     74(defun remove-rlisp-object (conn id)
     75  (with-rlisp-lock (conn)
     76    (setf (rlisp-objects conn) (delete id (rlisp-objects conn) :key #'car))))
     77
    6078(defun register-rlisp-callback (conn callback)
    61   (with-rlisp-lock (conn)
    62     (let* ((id (incf (rlisp-callback-counter conn))))
    63       (push (list* id callback *current-process*) (rlisp-callbacks conn))
    64       id)))
     79  (register-rlisp-object conn (cons callback *current-process*)))
    6580
    6681;; Invoke callback in the process that registered it.
    6782(defun invoke-rlisp-callback (conn id &rest values)
    6883  (declare (dynamic-extent values))
    69   (destructuring-bind (callback . process)
    70                       (with-rlisp-lock (conn)
    71                         (let ((cell (assoc id (rlisp-callbacks conn))))
    72                           (unless cell
    73                             (warn "Missing swank callback ~s" id))
    74                           (setf (rlisp-callbacks conn) (delq cell (rlisp-callbacks conn)))
    75                           (or (cdr cell) '(nil . nil))))
     84  (destructuring-bind (callback . process) (or (find-rlisp-object conn id) '(nil . nil))
    7685    (when callback
    7786      (apply #'process-interrupt process callback values))))
    78 
    79 (defun remove-rlisp-callback (conn id)
    80   (with-rlisp-lock (conn)
    81     (setf (rlisp-callbacks conn) (delete id (rlisp-callbacks conn) :key #'car))))
    8287
    8388(defclass remote-lisp-thread ()
     
    101106(defmethod rlisp-thread-id ((thread-id symbol)) (or thread-id t))
    102107
    103 (defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread))
     108(defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread) &key (create t))
     109  (declare (ignore create))
    104110  thread)
    105111
    106 (defmethod rlisp-thread ((conn remote-lisp-connection) (id integer))
     112(defmethod rlisp-thread ((conn remote-lisp-connection) (id integer) &key (create t))
    107113  (with-rlisp-lock (conn)
    108114    (or (find id (rlisp-threads conn) :key #'rlisp-thread-id)
    109         (let ((rthread (make-instance 'remote-lisp-thread :connection conn :thread-id id)))
    110           (push rthread (rlisp-threads conn))
    111           rthread))))
     115        (and create
     116             (let ((rthread (make-instance 'remote-lisp-thread :connection conn :thread-id id)))
     117               (push rthread (rlisp-threads conn))
     118               rthread)))))
    112119
    113120(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
     
    219226  *standard-output*)
    220227
     228(defmethod input-stream-for-remote-lisp ((app application))
     229  *standard-input*)
     230
    221231(defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
    222232  (case event
     
    226236    (:invalid-rpc
    227237     (destructuring-bind (id message) args
    228        (when id (remove-rlisp-callback conn id))
     238       (when id (remove-rlisp-object conn id))
    229239       (error "Invalid swank rpc: ~s" message)))
    230     ((:debug :debug-activate :debug-return :debug-condition)
     240    ((:debug :debug-activate :debug-return :debug-condition :read-aborted)
    231241     (destructuring-bind (thread-id &rest event-args) args
    232242       (let ((rthread (rlisp-thread conn thread-id)))
     
    246256       (let ((stream (output-stream-for-remote-lisp *application*)))
    247257         (if (> (length string) 500)
    248            (process-run-function "Long Swank Output" #'write-string string stream)
     258           (process-run-function "Long Remote Output" #'write-string string stream)
    249259           (write-string string stream)))))
     260    (:read-string
     261     (destructuring-bind (thread-id tag) args
     262       (let ((rthread (rlisp-thread conn thread-id :create nil)))
     263         (if (and rthread (rlisp-thread-process rthread))
     264           (process-interrupt (rlisp-thread-process rthread)
     265                              #'handle-swank-event
     266                              rthread event `(,tag))
     267           ;; not a listener thread.
     268           ;; TODO: this needs to be wrapped in some error handling.
     269           (process-run-function (format nil "Remote Input (~s)" thread-id)
     270                                 #'rlisp-read-string
     271                                 conn
     272                                 (input-stream-for-remote-lisp *application*)
     273                                 thread-id
     274                                 tag)))))
    250275    (t (warn "Received unknown event ~s with args ~s" event args))))
     276
     277(define-condition rlisp-read-aborted ()
     278  ((tag :initarg :tag :reader rlisp-read-aborted-tag)))
     279
     280(defun rlisp-read-string (conn stream thread-id tag)
     281  (handler-bind ((rlisp-read-aborted (lambda (c)
     282                                       (when (eql tag (rlisp-read-aborted-tag c))
     283                                         (return-from rlisp-read-string)))))
     284    (let ((text (and (peek-char t stream nil) ;; wait for first one, nil means eof
     285                     (read-available-text stream))))
     286      (send-sexp-to-swank conn `(:emacs-return-string ,thread-id ,tag ,text)))))
    251287
    252288(defmethod handle-swank-event ((rthread remote-lisp-thread) event args)
    253289  (assert (eq (rlisp-thread-process rthread) *current-process*))
    254290  (ecase event
     291    (:read-string
     292     (destructuring-bind (tag) args
     293       (rlisp-read-string (rlisp-thread-connection rthread) *standard-input* (rlisp-thread-id rthread) tag)))
     294    (:read-aborted
     295     (destructuring-bind (tag) args
     296       (signal 'rlisp-read-aborted :tag tag)))
    255297    (:debug     ;; SLDB-SETUP
    256298     (destructuring-bind (level (condition-text condition-type extras)
     
    399441;;  (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute thread) ,tag ,value)))
    400442
     443(defun read-available-text (stream)
     444  (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0)
     445    for ch = (stream-read-char-no-hang stream)
     446    until (or (eq ch :eof) (null ch))
     447    do (vector-push-extend ch buffer)
     448    finally (return buffer)))
     449 
     450;; Return text for remote evaluation.
    401451(defmethod toplevel-form-text ((stream input-stream))
    402   ;; Return text for remote evaluation.
    403452  (when (peek-char t stream nil) ;; wait for the first one.
    404     (loop with buffer = (make-array 100 :element-type 'character :adjustable t :fill-pointer 0)
    405       for ch = (stream-read-char-no-hang stream)
    406       until (or (eq ch :eof) (null ch))
    407       do (vector-push-extend ch buffer)
    408       finally (return buffer))))
     453    (read-available-text stream)))
    409454
    410455(defmethod toplevel-form-text ((stream synonym-stream))
Note: See TracChangeset for help on using the changeset viewer.