Changeset 15028


Ignore:
Timestamp:
Oct 19, 2011, 12:24:35 AM (8 years ago)
Author:
gz
Message:

First steps of remote debugging support. Note this is not complete and is not hooked up to anything yet, but if you manually set it up (see comment at top of cocoa-remote-lisp.lisp), the basic remote repl works.

Location:
trunk/source
Files:
1 added
5 edited

Legend:

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

    r14527 r15028  
    2222  (def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to use in editor windows, as a positive SINGLE-FLOAT")
    2323  (def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in characters"))
     24
     25(defclass cocoa-application (application)
     26  ())
    2427
    2528(defun init-cocoa-application ()
  • trunk/source/cocoa-ide/defsystem.lisp

    r14298 r15028  
    8080    "inspector"
    8181    "project"
     82    "cocoa-remote-lisp"
     83    "swank-listener"
    8284    "preferences"
    8385    "processes-window"
  • trunk/source/cocoa-ide/preferences.lisp

    r15021 r15028  
    8383  self)
    8484
    85 (eval-when (:compile-toplevel :load-toplevel :execute)
    86     (require :swank-listener))
    87 
    8885(objc:defmethod (#/windowDidLoad :void) ((self preferences-window-controller))
    8986  (let* ((window (#/window self))
  • trunk/source/cocoa-ide/start.lisp

    r14244 r15028  
    7373;;; Support for saving a stand-alone IDE
    7474
    75 
    76 (defclass cocoa-application (application)
    77   ())
    78 
    7975(defmethod ccl::application-error ((a cocoa-application) condition error-pointer)
    8076  (ccl::break-loop-handle-error condition error-pointer))
    81 
    8277
    8378(defmethod ccl::application-init-file ((a cocoa-application))
     
    9287(defmethod ccl::parse-application-arguments ((a cocoa-application))
    9388  (values nil nil nil nil))
    94 
    95 (eval-when (:compile-toplevel :load-toplevel :execute)
    96     (require :swank-listener))
    9789
    9890(defmethod toplevel-function ((a cocoa-application) init-file)
  • trunk/source/library/remote-lisp.lisp

    r15021 r15028  
    1717
    1818(in-package :ccl)
     19
     20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     21;;
     22;; Client-side remote lisp support
     23;;
     24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     25
     26;; (export '(remote-lisp-thread remote-listener-function toplevel-form-text))
     27
     28(defclass remote-lisp-connection ()
     29  ((lock :initform (make-lock) :reader rlisp-lock)
     30   (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)
     33   (threads :initform () :accessor rlisp-threads)
     34
     35   (features :initform nil :accessor rlisp-features)
     36   (lisp-implementation-type :initform "???" :accessor rlisp-lisp-implementation-type)
     37   (lisp-implementation-version :initform "???" :accessor rlisp-lisp-implementation-version)
     38   (machine-instance :initform "???" :accessor rlisp-machine-instance)))
     39
     40(defmacro with-rlisp-lock ((conn &rest args) &body body)
     41  `(with-lock-grabbed ((rlisp-lock ,conn) ,@args)
     42     (without-interrupts ;; without callbacks
     43      ,@body)))
     44
     45(defmethod update-rlisp-connection-info ((conn remote-lisp-connection)
     46                                         &key lisp-implementation-type
     47                                              lisp-implementation-version
     48                                              machine-instance
     49                                              (features nil featuresp))
     50  (with-rlisp-lock (conn)
     51    (when featuresp
     52      (setf (rlisp-features conn) features))
     53    (when machine-instance
     54      (setf (rlisp-machine-instance conn) machine-instance))
     55    (when lisp-implementation-type
     56      (setf (rlisp-lisp-implementation-type conn) lisp-implementation-type))
     57    (when lisp-implementation-version
     58      (setf (rlisp-lisp-implementation-version conn) lisp-implementation-version))))
     59
     60(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)))
     65
     66;; Invoke callback in the process that registered it.
     67(defun invoke-rlisp-callback (conn id &rest values)
     68  (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))))
     76    (when callback
     77      (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))))
     82
     83(defclass remote-lisp-thread ()
     84  ((conn :initarg :connection :reader rlisp-thread-connection)
     85   ;; Local process running the local repl
     86   (thread-process :initform nil :accessor rlisp-thread-process)
     87   ;; Remote process doing the evaluation for this process.
     88   (thread-id :initarg :thread-id :reader rlisp-thread-id)))
     89
     90(defmethod rlisp-host-description ((rthread remote-lisp-thread))
     91  (rlisp-host-description (rlisp-thread-connection rthread)))
     92
     93(defmethod print-object ((rthread remote-lisp-thread) stream)
     94  (print-unreadable-object (rthread stream :type t :identity t)
     95    (format stream "~a thread ~a"
     96            (rlisp-host-description rthread)
     97            (rlisp-thread-id rthread))))
     98
     99(defmethod rlisp-thread-id ((thread-id integer)) thread-id)
     100
     101(defmethod rlisp-thread-id ((thread-id symbol)) (or thread-id t))
     102
     103(defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp-thread))
     104  thread)
     105
     106(defmethod rlisp-thread ((conn remote-lisp-connection) (id integer))
     107  (with-rlisp-lock (conn)
     108    (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))))
     112
     113(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
     114  (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rthread))
     115
     116(defmethod rlisp/toplevel ((rthread remote-lisp-thread) &key)
     117  (rlisp/toplevel (rlisp-thread-connection rthread) :thread rthread))
     118
     119(defmethod rlisp/execute ((rthread remote-lisp-thread) form continuation &key)
     120  (rlisp/execute (rlisp-thread-connection rthread) form continuation :thread rthread))
     121
     122(defmethod rlisp/interrupt ((rthread remote-lisp-thread) &key)
     123  (rlisp/interrupt (rlisp-thread-connection rthread) :thread rthread))
     124
     125(defmethod remote-listener-eval ((rthread remote-lisp-thread) text &rest keys &key &allow-other-keys)
     126  (apply #'remote-listener-eval (rlisp-thread-connection rthread) text :thread rthread keys))
     127
     128(defclass swank-rlisp-connection (remote-lisp-connection)
     129  (
     130   ;; The socket to the swank server.  Only the connection process reads from it, without locking.
     131   ;;  Anyone can write, but should grab the connection lock.
     132   (command-stream :initarg :stream :reader swank-command-stream)
     133   (read-buffer :initform (make-array 1024 :element-type 'character) :accessor swank-read-buffer)))
     134
     135(defmethod rlisp-host-description ((conn swank-rlisp-connection))
     136  (let ((socket (swank-command-stream conn)))
     137    (if (open-stream-p socket)
     138      (format nil "~a:~a" (ipaddr-to-dotted (remote-host socket)) (remote-port socket))
     139      ":CLOSED")))
     140
     141(defmethod print-object ((conn swank-rlisp-connection) stream)
     142  (print-unreadable-object (conn stream :type t :identity t)
     143    (format stream "~a @~a"
     144            (rlisp-host-description conn)
     145            (rlisp-machine-instance conn))))
     146
     147(defmethod start-rlisp-server ((conn swank-rlisp-connection))
     148  ;; TODO: Make sure closing the connection kills the process or vice versa.
     149  (assert (null (rlisp-server-process conn)))
     150  (flet ((swank-event-loop (conn)
     151           (setf (rlisp-server-process conn) *current-process*)
     152           (loop
     153             (let ((sexp (read-swank-event conn)))
     154               (handle-swank-event conn (car sexp) (cdr sexp))))))
     155    (setf (rlisp-server-process conn)
     156          (process-run-function (format nil "Swank Client ~a" (remote-port (swank-command-stream conn)))
     157                                #'swank-event-loop conn)))
     158  (let ((sem (make-semaphore)) (abort nil))
     159    ;; Patch up swank.  To be replaced someday by our own set of remote functions...
     160    (rlisp/execute conn
     161                  "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
     162                     (CL:DEFUN SWANK::EVAL-REGION (STRING)
     163                       (CL:WITH-INPUT-FROM-STRING (STREAM STRING)
     164                         (CL:LET (CL:- VALUES)
     165                           (CL:LOOP
     166                             (CL:LET ((FORM (CL:READ STREAM () STREAM)))
     167                               (CL:WHEN (CL:EQ FORM STREAM)
     168                                 (CL:FINISH-OUTPUT)
     169                                 (CL:RETURN (CL:VALUES VALUES CL:-)))
     170                               (CL:UNLESS (CCL::CHECK-TOPLEVEL-COMMAND FORM)
     171                                 (CL:SETQ VALUES (CCL::TOPLEVEL-EVAL (CL:SETQ CL:- FORM))))
     172                               (CL:FINISH-OUTPUT))))))
     173                     (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
     174                       (SWANK::CREATE-REPL ())
     175                       (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*EMACS-CONNECTION*)))
     176                         (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
     177                         (SWANK::THREAD-ID THREAD)))
     178                     (CL:DEFUN CCL::LISTENER-EVAL-FOR-IDE (STRING)
     179                       (CL:LET ((SWANK::*SEND-REPL-RESULTS-FUNCTION*
     180                                 #'(CL:LAMBDA (_) (CL:RETURN-FROM CCL::LISTENER-EVAL-FOR-IDE
     181                                                    (CL:MAPCAR #'CL:WRITE-TO-STRING _)))))
     182                         (SWANK::REPL-EVAL STRING)))
     183                     (CL:SETQ SWANK::*LISTENER-EVAL-FUNCTION* 'CCL::LISTENER-EVAL-FOR-IDE))"
     184                   (lambda (error result)
     185                     (declare (ignore result))
     186                     (when error
     187                       (unwind-protect
     188                           (error "Error initializing SWANK: ~s" error)
     189                         (setq abort t)
     190                         (signal-semaphore sem)))
     191                     (signal-semaphore sem)))
     192    (wait-on-semaphore sem)
     193    (when abort (return-from start-rlisp-server nil))
     194    (rlisp/execute conn "(SWANK:CONNECTION-INFO)"
     195                   (lambda (error info)
     196                     (unless error
     197                       (destructuring-bind (&key (features nil featuresp)
     198                                                 machine
     199                                                 lisp-implementation
     200                                                 &allow-other-keys) info
     201                         (let ((args nil))
     202                           (when featuresp
     203                             (setq args (list* :features features args)))
     204                           (when (consp machine)
     205                             (destructuring-bind (&key instance &allow-other-keys) machine
     206                               (setq args (list* :machine-instance instance args))))
     207                           (when (consp lisp-implementation)
     208                             (destructuring-bind (&key type version &allow-other-keys) lisp-implementation
     209                               (setq args (list* :lisp-implementation-type type
     210                                                 :lisp-implementation-version version
     211                                                 args))))
     212                           (when args
     213                             (apply #'update-rlisp-connection-info conn args)))))
     214                     (signal-semaphore sem)))
     215    (wait-on-semaphore sem)
     216    conn))
     217
     218(defmethod output-stream-for-remote-lisp ((app application))
     219  *standard-output*)
     220
     221(defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
     222  (case event
     223    (:return
     224     (destructuring-bind (value id) args
     225       (when id (invoke-rlisp-callback conn id value))))
     226    (:invalid-rpc
     227     (destructuring-bind (id message) args
     228       (when id (remove-rlisp-callback conn id))
     229       (error "Invalid swank rpc: ~s" message)))
     230    ((:debug :debug-activate :debug-return :debug-condition)
     231     (destructuring-bind (thread-id &rest event-args) args
     232       (let ((rthread (rlisp-thread conn thread-id)))
     233         (unless (rlisp-thread-process rthread)
     234           (error "Got swank event ~s ~s for thread ~s with no process" event args rthread))
     235         (process-interrupt (rlisp-thread-process rthread)
     236                            #'handle-swank-event
     237                            rthread event event-args))))
     238    (:new-features
     239     (destructuring-bind (features) args
     240       (update-rlisp-connection-info conn :features features)))
     241    (:indentation-update
     242     (destructuring-bind (name-indent-alist) args
     243       (declare (ignore name-indent-alist))))
     244    (:write-string
     245     (destructuring-bind (string) args
     246       (let ((stream (output-stream-for-remote-lisp *application*)))
     247         (if (> (length string) 500)
     248           (process-run-function "Long Swank Output" #'write-string string stream)
     249           (write-string string stream)))))
     250    (t (warn "Received unknown event ~s with args ~s" event args))))
     251
     252(defmethod handle-swank-event ((rthread remote-lisp-thread) event args)
     253  (assert (eq (rlisp-thread-process rthread) *current-process*))
     254  (ecase event
     255    (:debug     ;; SLDB-SETUP
     256     (destructuring-bind (level (condition-text condition-type extras)
     257                                ;; list of (restart-name restart-description)
     258                                restarts
     259                                ;; list of (index frame-description &key restartable)
     260                                backtrace
     261                                ;; callbacks currently being evaluated in this thread.
     262                                ;; Wonder what emacs does with that.
     263                                pending-callbacks) args
     264       (declare (ignorable condition-type extras backtrace pending-callbacks))
     265       (format t "~&Error: ~a" condition-text)
     266       (when *show-restarts-on-break*
     267         (format t "~&Remote restarts:")
     268         (loop for (name description) in restarts
     269           do (format t "~&~a ~a" name description))
     270         (fresh-line))
     271       (rlisp-read-loop rthread :break-level level)))
     272    (:debug-activate ;; SLDB-ACTIVATE
     273     (destructuring-bind (level flag) args
     274       (declare (ignore flag))
     275       (unless (eql level *break-level*)
     276         (warn "break level confusion is ~s expected ~s" *break-level* level))))
     277    (:debug-condition ;; This seems to have something to do with errors in the debugger
     278     (destructuring-bind (message) args
     279       (format t "~&Swank error: ~s" message)))
     280    (:debug-return
     281     (destructuring-bind (level stepping-p) args
     282       (declare (ignore stepping-p))
     283       (unless (eql level *break-level*)
     284         (invoke-restart 'debug-return level))))))
     285
     286
     287;; This assumes connection process is the only thing that reads from the socket stream and uses
     288;; the read-buffer, so don't need locking.
     289(defun read-swank-event (conn)
     290  (assert (eq (rlisp-server-process conn) *current-process*))
     291  (let* ((stream (swank-command-stream conn))
     292         (buffer (swank-read-buffer conn))
     293         (count (stream-read-vector stream buffer 0 6)))
     294    (when (< count 6) (signal-eof-error stream))
     295    (setq count (parse-integer buffer :end 6 :radix 16))
     296    (when (< (length buffer) count)
     297      (setf (swank-read-buffer conn)
     298            (setq buffer (make-array count :element-type 'character))))
     299    (let ((len (stream-read-vector stream buffer 0 count)))
     300      (when (< len count) (signal-eof-error stream))
     301      ;; TODO: catch errors here and report them sanely.
     302      ;; TODO: check that there aren't more forms in the string.
     303      (with-standard-io-syntax
     304          (let ((*package* +swank-io-package+)
     305                (*read-eval* nil))
     306            (read-from-string buffer t nil :end count))))))
     307
     308
     309(defmethod make-rrepl-thread ((conn swank-rlisp-connection) name)
     310  (let* ((semaphore (make-semaphore))
     311         (return-error nil)
     312         (return-id nil))
     313    (rlisp/execute conn (format nil "(CCL::MAKE-SWANK-REPL-FOR-IDE ~s)" name)
     314                   (lambda (error id)
     315                     (setf return-error error)
     316                     (setq return-id id)
     317                     (signal-semaphore semaphore)))
     318    (wait-on-semaphore semaphore)
     319    (when return-error
     320      (error "Remote eval error ~s" return-error))
     321    (rlisp-thread conn return-id)))
     322
     323;; TODO: "coding-system".
     324(defun connect-to-swank (host port &key (secret-file "home:.slime-secret"))
     325  (let* ((socket (make-socket :remote-host host :remote-port port :nodelay t))
     326         (conn (make-instance 'swank-rlisp-connection :stream socket)))
     327    (when secret-file
     328      (with-open-file (stream secret-file :if-does-not-exist nil)
     329        (when stream
     330          (let ((secret (read-line stream nil nil)))
     331            (when secret
     332              (send-string-to-swank conn secret))))))
     333    (start-rlisp-server conn)))
     334
     335(defmethod close ((conn swank-rlisp-connection) &key abort)
     336  ;; TODO: kill process.
     337  (close (swank-command-stream conn) :abort abort))
     338
     339(defun send-string-to-swank (conn string)
     340  (let ((stream (swank-command-stream conn)))
     341    (with-rlisp-lock (conn)
     342      (format stream "~6,'0,X" (length string))
     343      (write-string string stream))
     344    (force-output stream)))
     345
     346(defvar +swank-io-package+
     347  (loop as name = (gensym "SwankIO/") while (find-package name)
     348    finally (let ((package (make-package name :use nil)))
     349              (import '(nil t quote) package)
     350              (return package))))
     351
     352(defun send-sexp-to-swank (conn sexp)
     353  (send-string-to-swank conn (with-standard-io-syntax
     354                                 (let ((*package* +swank-io-package+))
     355                                   (prin1-to-string sexp)))))
     356
     357(defun format-for-swank (fmt-string fmt-args)
     358  (with-standard-io-syntax
     359      (let ((*package* +swank-io-package+))
     360        (apply #'format nil fmt-string fmt-args))))
     361
     362(defun thread-id-for-execute (thread)
     363  (typecase thread
     364    (null t) ;; don't care
     365    (remote-lisp-thread (rlisp-thread-id thread))
     366    (t thread)))
     367
     368
     369;; Continuation is executed in the same process that invoked remote-execute.
     370(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string continuation &key package thread)
     371  (flet ((continuation (result)
     372           (ecase (car result)
     373             (:ok (apply continuation nil (cdr result)))
     374             (:abort (apply continuation (or (cadr result) '"NIL") (or (cddr result) '(nil)))))))
     375    (let* ((sexp `(:emacs-rex ,form-or-string
     376                              ,package
     377                              ,(thread-id-for-execute thread)
     378                              ,(and continuation (register-rlisp-callback conn #'continuation)))))
     379      (if (stringp form-or-string)
     380        (send-string-to-swank conn (format-for-swank "(~s ~a ~s ~s ~s)" sexp))
     381        (send-sexp-to-swank conn sexp)))))
     382
     383
     384(defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key thread)
     385  ;; TODO: if had a way to harvest old continuations, could check for error.  But since this
     386  ;; will normally not return, don't register a continuation for it.
     387  (rlisp/execute conn `(invoke-restart ',name) nil :thread thread))
     388
     389(defmethod rlisp/toplevel ((conn swank-rlisp-connection) &key thread)
     390  (rlisp/execute conn `(toplevel) nil :thread thread))
     391
     392(defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread)
     393  (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thread))))
     394 
     395;;(defmethod rlisp/return-string ((conn swank-rlisp-connection) tag string &key thread)
     396;;  (send-sexp-to-swank conn `(:emacs-return-string ,(thread-id-for-execute thread) ,tag ,string)))
     397
     398;;(defmethod swank/remote-return ((conn swank-rlisp-connection) tag value &key thread)
     399;;  (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute thread) ,tag ,value)))
     400
     401(defmethod toplevel-form-text ((stream input-stream))
     402  ;; Return text for remote evaluation.
     403  (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))))
     409
     410(defmethod toplevel-form-text ((stream synonym-stream))
     411  (toplevel-form-text (symbol-value (synonym-stream-symbol stream))))
     412
     413(defmethod toplevel-form-text ((stream two-way-stream))
     414  (if (typep stream 'echo-stream)
     415    (call-next-method)
     416    (toplevel-form-text (two-way-stream-input-stream stream))))
     417
     418;; pass this as the initial-function in make-mcl-listener-process
     419(defmethod remote-listener-function ((rthread remote-lisp-thread))
     420  (setf (rlisp-thread-process rthread) *current-process*)
     421  (unless (or *inhibit-greeting* *quiet-flag*)
     422    (let ((conn (rlisp-thread-connection rthread)))
     423      (format t "~&Welcome to ~A ~A on ~A!"
     424              (rlisp-lisp-implementation-type conn)
     425              (rlisp-lisp-implementation-version conn)
     426              (rlisp-machine-instance conn))))
     427  (rlisp-read-loop rthread :break-level 0))
     428 
     429(defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level)
     430  (let* ((*break-level* break-level)  ;; used by prompt printing
     431         (*last-break-level* break-level)  ;; ditto
     432         (debug-return nil))
     433    ;; When the user invokes a restart from a list, it will be a remote restart and
     434    ;; we will pass the request to the remote.  However, there are some UI actions that invoke local
     435    ;; restarts by name, e.g. cmd-/ will invoke 'continue.  We need catch those and pass them to
     436    ;; the remote.  The remote will then do whatever the restart does, and will send 'debug-return's
     437    ;; as needed.
     438    (unwind-protect
     439        (loop
     440          (restart-case
     441              ;; Do continue with a restart bind because don't want to abort whatever form is
     442              ;; about to be sent for evaluation, just in case the continue doesn't end up doing
     443              ;; anything on the remote end.
     444              (restart-bind ((continue (lambda () (rlisp/invoke-restart rthread 'continue))))
     445                (catch :toplevel
     446                  (loop
     447                    (catch :abort
     448                      (loop
     449                        (catch-cancel ;; exactly like :abort except prints Cancelled.
     450                         (rlisp-read-loop-internal rthread))
     451                        (rlisp/invoke-restart rthread 'abort)
     452                        (format *terminal-io* "~&Cancelled")))
     453                    (rlisp/invoke-restart rthread 'abort)))
     454                (rlisp/toplevel rthread))
     455            (abort () ;; intercept local attempt to abort
     456              (rlisp/invoke-restart rthread 'abort))
     457            (abort-break () ;; intercept local attempt to abort-break
     458              (if (eq break-level 0)
     459                (rlisp/invoke-restart rthread 'abort)
     460                (rlisp/invoke-restart rthread 'abort-break)))
     461            (muffle-warning (&optional condition) ;; not likely to be invoked interactively, but...
     462              (assert (null condition)) ;; no way to pass that!
     463              (rlisp/invoke-restart rthread 'muffle-warning))
     464            (debug-return (target-level)
     465               (when (> target-level break-level)
     466                 (error "Missed target level in debug-return - want ~s have ~s" target-level break-level))
     467               (when (< target-level break-level)
     468                 (setq debug-return t)
     469                 (invoke-restart 'debug-return target-level))))
     470          (clear-input)
     471          (fresh-line))
     472      (unless debug-return
     473        (warn "Unknown exit from rlisp-read-loop!")))))
     474
     475(defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
     476  (let* ((input-stream *standard-input*)
     477         (output-stream *standard-output*)
     478         (sem (make-semaphore))
     479         (eof-count 0))
     480    (loop
     481      (force-output output-stream)
     482      (print-listener-prompt output-stream t)
     483      (multiple-value-bind (text env) (toplevel-form-text input-stream)
     484        (if (null text) ;; eof
     485          (progn
     486            (when (> (incf eof-count) *consecutive-eof-limit*)
     487              (#_ _exit 0))
     488            (unless (and (not *batch-flag*)
     489                         (not *quit-on-eof*)
     490                         (stream-eof-transient-p input-stream))
     491              (exit-interactive-process *current-process*))
     492            (stream-clear-input input-stream)
     493            (rlisp/invoke-restart rthread 'abort-break))
     494          (progn
     495            (setq eof-count 0)
     496            ;;(let* ((values (toplevel-eval form env)))
     497            ;;      (if print-result (toplevel-print values)))
     498            (let* ((package-name (loop for sym in (car env) for val in (cdr env)
     499                                  when (eq sym '*package*) do (return val)))
     500                   (values (remote-listener-eval rthread text :package package-name :semaphore sem)))
     501              (fresh-line output-stream)
     502              (dolist (val values) (princ val output-stream) (terpri output-stream)))))))))
     503
     504
     505(defmethod remote-listener-eval ((conn swank-rlisp-connection) text
     506                                 &key package thread (semaphore (make-semaphore)))
     507  (let* ((form (format nil "(SWANK::LISTENER-EVAL ~s)" text))
     508         (return-values nil)
     509         (return-error nil))
     510    (rlisp/execute conn
     511                   form
     512                   (lambda (error values)
     513                     (setq return-error error)
     514                     (setq return-values values)
     515                     (signal-semaphore semaphore))
     516                   :package package
     517                   :thread thread)
     518    (wait-on-semaphore semaphore)
     519    (when return-error
     520      (error "Remote eval error ~s" return-error))
     521    ;; a list of strings representing each return value
     522    return-values))
     523
     524
     525
     526
     527
     528
    19529
    20530;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Note: See TracChangeset for help on using the changeset viewer.