[Openmcl-cvs-notifications] r15028 - in /trunk/source: cocoa-ide/cocoa-remote-lisp.lisp cocoa-ide/cocoa-window.lisp cocoa-ide/defsystem.lisp cocoa-ide/preferences.lisp cocoa-ide/start.lisp library/remote-lisp.lisp
gz at clozure.com
gz at clozure.com
Tue Oct 18 19:24:36 CDT 2011
Author: gz
Date: Tue Oct 18 19:24:35 2011
New Revision: 15028
Log:
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 a=
t top of cocoa-remote-lisp.lisp), the basic remote repl works.
Added:
trunk/source/cocoa-ide/cocoa-remote-lisp.lisp
Modified:
trunk/source/cocoa-ide/cocoa-window.lisp
trunk/source/cocoa-ide/defsystem.lisp
trunk/source/cocoa-ide/preferences.lisp
trunk/source/cocoa-ide/start.lisp
trunk/source/library/remote-lisp.lisp
Added: trunk/source/cocoa-ide/cocoa-remote-lisp.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-remote-lisp.lisp (added)
+++ trunk/source/cocoa-ide/cocoa-remote-lisp.lisp Tue Oct 18 19:24:35 2011
@@ -1,0 +1,83 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;; Copyright (C) 2011 Clozureremote- Associates
+;;; This file is part of Clozure CL. =
+;;;
+;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
+;;; License , known as the LLGPL and distributed with Clozure CL as the
+;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
+;;; which is distributed with Clozure CL as the file "LGPL". Where these
+;;; conflict, the preamble takes precedence. =
+;;;
+;;; Clozure CL is referenced in the preamble as the "LIBRARY."
+;;;
+;;; The LLGPL is also available online at
+;;; http://opensource.franz.com/preamble.html
+
+;; Use the IDE to debug a remote ccl.
+;; **** 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 you=
r 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" c=
ommand
+;; which should pass relevant info through to new-cocoa-listener-process.
+;; But this will do for testing: take an existing normal listener and conv=
ert it.
+(defmethod connect-listener-to-remote (object rthread)
+ (let ((view (hemlock-view object)))
+ (connect-listener-to-remote (or view (require-type object 'hi:hemlock-=
view)) rthread)))
+
+(defmethod connect-listener-to-remote ((view hi:hemlock-view) (rthread ccl=
::remote-lisp-thread))
+ (let* ((doc (hi::buffer-document (hi:hemlock-view-buffer view)))
+ (process (or (hemlock-document-process doc)
+ (error "Not a listener: ~s" view)))
+ (name (process-name process))
+ (window (cocoa-listener-process-window process)))
+ (when (eq process *current-process*)
+ (error "Cannot connect current listener"))
+ (setf (hemlock-document-process doc) nil) ;; so killing the process do=
esn't close the window
+ (process-kill process)
+ (let ((pos (search " [Remote " name :from-end t)))
+ (when pos
+ (setq name (subseq name 0 pos))))
+ (setf (hemlock-document-process doc)
+ (new-cocoa-listener-process (format nil "~a [Remote ~a(~a)]"
+ name (ccl::rlisp-host-descri=
ption rthread) (ccl::rlisp-thread-id rthread))
+ window
+ :class 'cocoa-listener-process
+ :initial-function
+ (lambda ()
+ (setf (hemlock-document-process do=
c) *current-process*)
+ (ccl::remote-listener-function rth=
read))))))
+
+(defmethod ccl::output-stream-for-remote-lisp ((app cocoa-application))
+ (hemlock-ext:top-listener-output-stream))
+
+(defmethod ccl::toplevel-form-text ((stream cocoa-listener-input-stream))
+ (with-slots (read-lock queue-lock queue queue-semaphore text-semaphore) =
stream
+ (with-lock-grabbed (read-lock)
+ (assert (with-slots (cur-sstream) stream (null cur-sstream)))
+ (wait-on-semaphore queue-semaphore nil "Toplevel Read")
+ (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
+ (cond ((stringp val) ;; listener input
+ (assert (with-slots (text-semaphore) stream
+ (timed-wait-on-semaphore text-semaphore 0))
+ ()
+ "text/queue mismatch!")
+ (values val nil t))
+ (t
+ ;; TODO: this is bogus, the package may not exist on this s=
ide, so must be a string,
+ ;; but we can't bind *package* to a string. So this assume=
s the caller will know
+ ;; not to progv the env.
+ (destructuring-bind (string package-name pathname offset) v=
al ;; queued form
+ (declare (ignore offset))
+ (let ((env (cons '(*loading-file-source-file*)
+ (list pathname))))
+ (when package-name
+ (push '*package* (car env))
+ (push package-name (cdr env)))
+ (values string env)))))))))
Modified: trunk/source/cocoa-ide/cocoa-window.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-window.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-window.lisp Tue Oct 18 19:24:35 2011
@@ -21,6 +21,9 @@
(def-cocoa-default *default-font-name* :string "Courier" "Name of font t=
o use in editor windows")
(def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to us=
e in editor windows, as a positive SINGLE-FLOAT")
(def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in cha=
racters"))
+
+(defclass cocoa-application (application)
+ ())
=
(defun init-cocoa-application ()
(with-autorelease-pool
Modified: trunk/source/cocoa-ide/defsystem.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/defsystem.lisp (original)
+++ trunk/source/cocoa-ide/defsystem.lisp Tue Oct 18 19:24:35 2011
@@ -79,6 +79,8 @@
"cocoa-backtrace"
"inspector"
"project"
+ "cocoa-remote-lisp"
+ "swank-listener"
"preferences"
"processes-window"
"apropos-window"
Modified: trunk/source/cocoa-ide/preferences.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/preferences.lisp (original)
+++ trunk/source/cocoa-ide/preferences.lisp Tue Oct 18 19:24:35 2011
@@ -82,9 +82,6 @@
=
self)
=
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (require :swank-listener))
-
(objc:defmethod (#/windowDidLoad :void) ((self preferences-window-controll=
er))
(let* ((window (#/window self))
(port-field (swank-listener-port self))
Modified: trunk/source/cocoa-ide/start.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/start.lisp (original)
+++ trunk/source/cocoa-ide/start.lisp Tue Oct 18 19:24:35 2011
@@ -72,13 +72,8 @@
=
;;; Support for saving a stand-alone IDE
=
-
-(defclass cocoa-application (application)
- ())
-
(defmethod ccl::application-error ((a cocoa-application) condition error-p=
ointer)
(ccl::break-loop-handle-error condition error-pointer))
-
=
(defmethod ccl::application-init-file ((a cocoa-application))
(unless (shift-key-now-p)
@@ -91,9 +86,6 @@
;;; bit better ... I'd tend to agree.)
(defmethod ccl::parse-application-arguments ((a cocoa-application))
(values nil nil nil nil))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (require :swank-listener))
=
(defmethod toplevel-function ((a cocoa-application) init-file)
(declare (ignore init-file))
Modified: trunk/source/library/remote-lisp.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/library/remote-lisp.lisp (original)
+++ trunk/source/library/remote-lisp.lisp Tue Oct 18 19:24:35 2011
@@ -16,6 +16,516 @@
;;;
=
(in-package :ccl)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Client-side remote lisp support
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (export '(remote-lisp-thread remote-listener-function toplevel-form-tex=
t))
+
+(defclass remote-lisp-connection ()
+ ((lock :initform (make-lock) :reader rlisp-lock)
+ (server-process :initform nil :accessor rlisp-server-process)
+ (callback-counter :initform most-negative-fixnum :accessor rlisp-callba=
ck-counter)
+ (callbacks :initform () :accessor rlisp-callbacks)
+ (threads :initform () :accessor rlisp-threads)
+
+ (features :initform nil :accessor rlisp-features)
+ (lisp-implementation-type :initform "???" :accessor rlisp-lisp-implemen=
tation-type)
+ (lisp-implementation-version :initform "???" :accessor rlisp-lisp-imple=
mentation-version)
+ (machine-instance :initform "???" :accessor rlisp-machine-instance)))
+
+(defmacro with-rlisp-lock ((conn &rest args) &body body)
+ `(with-lock-grabbed ((rlisp-lock ,conn) , at args)
+ (without-interrupts ;; without callbacks
+ , at body)))
+
+(defmethod update-rlisp-connection-info ((conn remote-lisp-connection)
+ &key lisp-implementation-type
+ lisp-implementation-version
+ machine-instance
+ (features nil featuresp))
+ (with-rlisp-lock (conn)
+ (when featuresp
+ (setf (rlisp-features conn) features))
+ (when machine-instance
+ (setf (rlisp-machine-instance conn) machine-instance))
+ (when lisp-implementation-type
+ (setf (rlisp-lisp-implementation-type conn) lisp-implementation-type=
))
+ (when lisp-implementation-version
+ (setf (rlisp-lisp-implementation-version conn) lisp-implementation-v=
ersion))))
+
+(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)))
+
+;; 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-c=
allbacks conn)))
+ (or (cdr cell) '(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 ()
+ ((conn :initarg :connection :reader rlisp-thread-connection)
+ ;; Local process running the local repl
+ (thread-process :initform nil :accessor rlisp-thread-process)
+ ;; Remote process doing the evaluation for this process.
+ (thread-id :initarg :thread-id :reader rlisp-thread-id)))
+
+(defmethod rlisp-host-description ((rthread remote-lisp-thread))
+ (rlisp-host-description (rlisp-thread-connection rthread)))
+
+(defmethod print-object ((rthread remote-lisp-thread) stream)
+ (print-unreadable-object (rthread stream :type t :identity t)
+ (format stream "~a thread ~a"
+ (rlisp-host-description rthread)
+ (rlisp-thread-id rthread))))
+
+(defmethod rlisp-thread-id ((thread-id integer)) thread-id)
+
+(defmethod rlisp-thread-id ((thread-id symbol)) (or thread-id t))
+
+(defmethod rlisp-thread ((conn remote-lisp-connection) (thread remote-lisp=
-thread))
+ thread)
+
+(defmethod rlisp-thread ((conn remote-lisp-connection) (id integer))
+ (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))))
+
+(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name &key)
+ (rlisp/invoke-restart (rlisp-thread-connection rthread) name :thread rth=
read))
+
+(defmethod rlisp/toplevel ((rthread remote-lisp-thread) &key)
+ (rlisp/toplevel (rlisp-thread-connection rthread) :thread rthread))
+
+(defmethod rlisp/execute ((rthread remote-lisp-thread) form continuation &=
key)
+ (rlisp/execute (rlisp-thread-connection rthread) form continuation :thre=
ad rthread))
+
+(defmethod rlisp/interrupt ((rthread remote-lisp-thread) &key)
+ (rlisp/interrupt (rlisp-thread-connection rthread) :thread rthread))
+
+(defmethod remote-listener-eval ((rthread remote-lisp-thread) text &rest k=
eys &key &allow-other-keys)
+ (apply #'remote-listener-eval (rlisp-thread-connection rthread) text :th=
read rthread keys))
+
+(defclass swank-rlisp-connection (remote-lisp-connection)
+ (
+ ;; The socket to the swank server. Only the connection process reads f=
rom it, without locking.
+ ;; Anyone can write, but should grab the connection lock.
+ (command-stream :initarg :stream :reader swank-command-stream)
+ (read-buffer :initform (make-array 1024 :element-type 'character) :acce=
ssor swank-read-buffer)))
+
+(defmethod rlisp-host-description ((conn swank-rlisp-connection))
+ (let ((socket (swank-command-stream conn)))
+ (if (open-stream-p socket)
+ (format nil "~a:~a" (ipaddr-to-dotted (remote-host socket)) (remote-=
port socket))
+ ":CLOSED")))
+
+(defmethod print-object ((conn swank-rlisp-connection) stream)
+ (print-unreadable-object (conn stream :type t :identity t)
+ (format stream "~a @~a"
+ (rlisp-host-description conn)
+ (rlisp-machine-instance conn))))
+
+(defmethod start-rlisp-server ((conn swank-rlisp-connection))
+ ;; TODO: Make sure closing the connection kills the process or vice vers=
a.
+ (assert (null (rlisp-server-process conn)))
+ (flet ((swank-event-loop (conn)
+ (setf (rlisp-server-process conn) *current-process*)
+ (loop
+ (let ((sexp (read-swank-event conn)))
+ (handle-swank-event conn (car sexp) (cdr sexp))))))
+ (setf (rlisp-server-process conn)
+ (process-run-function (format nil "Swank Client ~a" (remote-port=
(swank-command-stream conn)))
+ #'swank-event-loop conn)))
+ (let ((sem (make-semaphore)) (abort nil))
+ ;; Patch up swank. To be replaced someday by our own set of remote fu=
nctions...
+ (rlisp/execute conn
+ "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
+ (CL:DEFUN SWANK::EVAL-REGION (STRING)
+ (CL:WITH-INPUT-FROM-STRING (STREAM STRING)
+ (CL:LET (CL:- VALUES)
+ (CL:LOOP
+ (CL:LET ((FORM (CL:READ STREAM () STREAM)))
+ (CL:WHEN (CL:EQ FORM STREAM)
+ (CL:FINISH-OUTPUT)
+ (CL:RETURN (CL:VALUES VALUES CL:-)))
+ (CL:UNLESS (CCL::CHECK-TOPLEVEL-COMMAND FOR=
M)
+ (CL:SETQ VALUES (CCL::TOPLEVEL-EVAL (CL:S=
ETQ CL:- FORM))))
+ (CL:FINISH-OUTPUT))))))
+ (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
+ (SWANK::CREATE-REPL ())
+ (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*E=
MACS-CONNECTION*)))
+ (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
+ (SWANK::THREAD-ID THREAD)))
+ (CL:DEFUN CCL::LISTENER-EVAL-FOR-IDE (STRING)
+ (CL:LET ((SWANK::*SEND-REPL-RESULTS-FUNCTION*
+ #'(CL:LAMBDA (_) (CL:RETURN-FROM CCL::LIS=
TENER-EVAL-FOR-IDE
+ (CL:MAPCAR #'CL:WRITE-=
TO-STRING _)))))
+ (SWANK::REPL-EVAL STRING)))
+ (CL:SETQ SWANK::*LISTENER-EVAL-FUNCTION* 'CCL::LISTEN=
ER-EVAL-FOR-IDE))"
+ (lambda (error result)
+ (declare (ignore result))
+ (when error
+ (unwind-protect
+ (error "Error initializing SWANK: ~s" error)
+ (setq abort t)
+ (signal-semaphore sem)))
+ (signal-semaphore sem)))
+ (wait-on-semaphore sem)
+ (when abort (return-from start-rlisp-server nil))
+ (rlisp/execute conn "(SWANK:CONNECTION-INFO)"
+ (lambda (error info)
+ (unless error
+ (destructuring-bind (&key (features nil featuresp)
+ machine
+ lisp-implementation
+ &allow-other-keys) info
+ (let ((args nil))
+ (when featuresp
+ (setq args (list* :features features args)))
+ (when (consp machine)
+ (destructuring-bind (&key instance &allow-oth=
er-keys) machine
+ (setq args (list* :machine-instance instanc=
e args))))
+ (when (consp lisp-implementation)
+ (destructuring-bind (&key type version &allow=
-other-keys) lisp-implementation
+ (setq args (list* :lisp-implementation-type=
type
+ :lisp-implementation-vers=
ion version
+ args))))
+ (when args
+ (apply #'update-rlisp-connection-info conn ar=
gs)))))
+ (signal-semaphore sem)))
+ (wait-on-semaphore sem)
+ conn))
+
+(defmethod output-stream-for-remote-lisp ((app application))
+ *standard-output*)
+
+(defmethod handle-swank-event ((conn swank-rlisp-connection) event args)
+ (case event
+ (:return
+ (destructuring-bind (value id) args
+ (when id (invoke-rlisp-callback conn id value))))
+ (:invalid-rpc
+ (destructuring-bind (id message) args
+ (when id (remove-rlisp-callback conn id))
+ (error "Invalid swank rpc: ~s" message)))
+ ((:debug :debug-activate :debug-return :debug-condition)
+ (destructuring-bind (thread-id &rest event-args) args
+ (let ((rthread (rlisp-thread conn thread-id)))
+ (unless (rlisp-thread-process rthread)
+ (error "Got swank event ~s ~s for thread ~s with no process" ev=
ent args rthread))
+ (process-interrupt (rlisp-thread-process rthread)
+ #'handle-swank-event
+ rthread event event-args))))
+ (:new-features
+ (destructuring-bind (features) args
+ (update-rlisp-connection-info conn :features features)))
+ (:indentation-update
+ (destructuring-bind (name-indent-alist) args
+ (declare (ignore name-indent-alist))))
+ (:write-string
+ (destructuring-bind (string) args
+ (let ((stream (output-stream-for-remote-lisp *application*)))
+ (if (> (length string) 500)
+ (process-run-function "Long Swank Output" #'write-string string=
stream)
+ (write-string string stream)))))
+ (t (warn "Received unknown event ~s with args ~s" event args))))
+
+(defmethod handle-swank-event ((rthread remote-lisp-thread) event args)
+ (assert (eq (rlisp-thread-process rthread) *current-process*))
+ (ecase event
+ (:debug ;; SLDB-SETUP
+ (destructuring-bind (level (condition-text condition-type extras)
+ ;; list of (restart-name restart-descripti=
on)
+ restarts
+ ;; list of (index frame-description &key r=
estartable)
+ backtrace
+ ;; callbacks currently being evaluated in =
this thread.
+ ;; Wonder what emacs does with that.
+ pending-callbacks) args
+ (declare (ignorable condition-type extras backtrace pending-callbac=
ks))
+ (format t "~&Error: ~a" condition-text)
+ (when *show-restarts-on-break*
+ (format t "~&Remote restarts:")
+ (loop for (name description) in restarts
+ do (format t "~&~a ~a" name description))
+ (fresh-line))
+ (rlisp-read-loop rthread :break-level level)))
+ (:debug-activate ;; SLDB-ACTIVATE
+ (destructuring-bind (level flag) args
+ (declare (ignore flag))
+ (unless (eql level *break-level*)
+ (warn "break level confusion is ~s expected ~s" *break-level* lev=
el))))
+ (:debug-condition ;; This seems to have something to do with errors in=
the debugger
+ (destructuring-bind (message) args
+ (format t "~&Swank error: ~s" message)))
+ (:debug-return
+ (destructuring-bind (level stepping-p) args
+ (declare (ignore stepping-p))
+ (unless (eql level *break-level*)
+ (invoke-restart 'debug-return level))))))
+
+
+;; This assumes connection process is the only thing that reads from the s=
ocket stream and uses
+;; the read-buffer, so don't need locking.
+(defun read-swank-event (conn)
+ (assert (eq (rlisp-server-process conn) *current-process*))
+ (let* ((stream (swank-command-stream conn))
+ (buffer (swank-read-buffer conn))
+ (count (stream-read-vector stream buffer 0 6)))
+ (when (< count 6) (signal-eof-error stream))
+ (setq count (parse-integer buffer :end 6 :radix 16))
+ (when (< (length buffer) count)
+ (setf (swank-read-buffer conn)
+ (setq buffer (make-array count :element-type 'character))))
+ (let ((len (stream-read-vector stream buffer 0 count)))
+ (when (< len count) (signal-eof-error stream))
+ ;; TODO: catch errors here and report them sanely.
+ ;; TODO: check that there aren't more forms in the string.
+ (with-standard-io-syntax
+ (let ((*package* +swank-io-package+)
+ (*read-eval* nil))
+ (read-from-string buffer t nil :end count))))))
+
+
+(defmethod make-rrepl-thread ((conn swank-rlisp-connection) name)
+ (let* ((semaphore (make-semaphore))
+ (return-error nil)
+ (return-id nil))
+ (rlisp/execute conn (format nil "(CCL::MAKE-SWANK-REPL-FOR-IDE ~s)" na=
me)
+ (lambda (error id)
+ (setf return-error error)
+ (setq return-id id)
+ (signal-semaphore semaphore)))
+ (wait-on-semaphore semaphore)
+ (when return-error
+ (error "Remote eval error ~s" return-error))
+ (rlisp-thread conn return-id)))
+
+;; TODO: "coding-system".
+(defun connect-to-swank (host port &key (secret-file "home:.slime-secret"))
+ (let* ((socket (make-socket :remote-host host :remote-port port :nodelay=
t))
+ (conn (make-instance 'swank-rlisp-connection :stream socket)))
+ (when secret-file
+ (with-open-file (stream secret-file :if-does-not-exist nil)
+ (when stream
+ (let ((secret (read-line stream nil nil)))
+ (when secret
+ (send-string-to-swank conn secret))))))
+ (start-rlisp-server conn)))
+
+(defmethod close ((conn swank-rlisp-connection) &key abort)
+ ;; TODO: kill process.
+ (close (swank-command-stream conn) :abort abort))
+
+(defun send-string-to-swank (conn string)
+ (let ((stream (swank-command-stream conn)))
+ (with-rlisp-lock (conn)
+ (format stream "~6,'0,X" (length string))
+ (write-string string stream))
+ (force-output stream)))
+
+(defvar +swank-io-package+ =
+ (loop as name =3D (gensym "SwankIO/") while (find-package name)
+ finally (let ((package (make-package name :use nil)))
+ (import '(nil t quote) package)
+ (return package))))
+
+(defun send-sexp-to-swank (conn sexp)
+ (send-string-to-swank conn (with-standard-io-syntax
+ (let ((*package* +swank-io-package+))
+ (prin1-to-string sexp)))))
+
+(defun format-for-swank (fmt-string fmt-args)
+ (with-standard-io-syntax
+ (let ((*package* +swank-io-package+))
+ (apply #'format nil fmt-string fmt-args))))
+
+(defun thread-id-for-execute (thread)
+ (typecase thread
+ (null t) ;; don't care
+ (remote-lisp-thread (rlisp-thread-id thread))
+ (t thread)))
+
+
+;; Continuation is executed in the same process that invoked remote-execut=
e.
+(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string con=
tinuation &key package thread)
+ (flet ((continuation (result)
+ (ecase (car result)
+ (:ok (apply continuation nil (cdr result)))
+ (:abort (apply continuation (or (cadr result) '"NIL") (or (cd=
dr result) '(nil)))))))
+ (let* ((sexp `(:emacs-rex ,form-or-string
+ ,package
+ ,(thread-id-for-execute thread)
+ ,(and continuation (register-rlisp-callback =
conn #'continuation)))))
+ (if (stringp form-or-string)
+ (send-string-to-swank conn (format-for-swank "(~s ~a ~s ~s ~s)" se=
xp))
+ (send-sexp-to-swank conn sexp)))))
+
+
+(defmethod rlisp/invoke-restart ((conn swank-rlisp-connection) name &key t=
hread)
+ ;; TODO: if had a way to harvest old continuations, could check for erro=
r. But since this
+ ;; will normally not return, don't register a continuation for it.
+ (rlisp/execute conn `(invoke-restart ',name) nil :thread thread))
+
+(defmethod rlisp/toplevel ((conn swank-rlisp-connection) &key thread)
+ (rlisp/execute conn `(toplevel) nil :thread thread))
+
+(defmethod rlisp/interrupt ((conn swank-rlisp-connection) &key thread)
+ (send-sexp-to-swank conn `(:emacs-interrupt ,(thread-id-for-execute thre=
ad))))
+ =
+;;(defmethod rlisp/return-string ((conn swank-rlisp-connection) tag string=
&key thread)
+;; (send-sexp-to-swank conn `(:emacs-return-string ,(thread-id-for-execut=
e thread) ,tag ,string)))
+
+;;(defmethod swank/remote-return ((conn swank-rlisp-connection) tag value =
&key thread)
+;; (send-sexp-to-swank conn `(:emacs-return ,(thread-id-for-execute threa=
d) ,tag ,value)))
+
+(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 =3D (make-array 100 :element-type 'character :adjust=
able t :fill-pointer 0)
+ for ch =3D (stream-read-char-no-hang stream)
+ until (or (eq ch :eof) (null ch))
+ do (vector-push-extend ch buffer)
+ finally (return buffer))))
+
+(defmethod toplevel-form-text ((stream synonym-stream))
+ (toplevel-form-text (symbol-value (synonym-stream-symbol stream))))
+
+(defmethod toplevel-form-text ((stream two-way-stream))
+ (if (typep stream 'echo-stream)
+ (call-next-method)
+ (toplevel-form-text (two-way-stream-input-stream stream))))
+
+;; pass this as the initial-function in make-mcl-listener-process
+(defmethod remote-listener-function ((rthread remote-lisp-thread))
+ (setf (rlisp-thread-process rthread) *current-process*)
+ (unless (or *inhibit-greeting* *quiet-flag*)
+ (let ((conn (rlisp-thread-connection rthread)))
+ (format t "~&Welcome to ~A ~A on ~A!"
+ (rlisp-lisp-implementation-type conn)
+ (rlisp-lisp-implementation-version conn)
+ (rlisp-machine-instance conn))))
+ (rlisp-read-loop rthread :break-level 0))
+ =
+(defmethod rlisp-read-loop ((rthread remote-lisp-thread) &key break-level)
+ (let* ((*break-level* break-level) ;; used by prompt printing
+ (*last-break-level* break-level) ;; ditto
+ (debug-return nil))
+ ;; When the user invokes a restart from a list, it will be a remote re=
start and
+ ;; we will pass the request to the remote. However, there are some UI=
actions that invoke local
+ ;; restarts by name, e.g. cmd-/ will invoke 'continue. We need catch =
those and pass them to
+ ;; the remote. The remote will then do whatever the restart does, and=
will send 'debug-return's
+ ;; as needed.
+ (unwind-protect
+ (loop
+ (restart-case
+ ;; Do continue with a restart bind because don't want to abo=
rt whatever form is
+ ;; about to be sent for evaluation, just in case the continu=
e doesn't end up doing
+ ;; anything on the remote end.
+ (restart-bind ((continue (lambda () (rlisp/invoke-restart rt=
hread 'continue))))
+ (catch :toplevel
+ (loop
+ (catch :abort
+ (loop
+ (catch-cancel ;; exactly like :abort except prints=
Cancelled.
+ (rlisp-read-loop-internal rthread))
+ (rlisp/invoke-restart rthread 'abort)
+ (format *terminal-io* "~&Cancelled")))
+ (rlisp/invoke-restart rthread 'abort)))
+ (rlisp/toplevel rthread))
+ (abort () ;; intercept local attempt to abort
+ (rlisp/invoke-restart rthread 'abort))
+ (abort-break () ;; intercept local attempt to abort-break
+ (if (eq break-level 0)
+ (rlisp/invoke-restart rthread 'abort)
+ (rlisp/invoke-restart rthread 'abort-break)))
+ (muffle-warning (&optional condition) ;; not likely to be invo=
ked interactively, but...
+ (assert (null condition)) ;; no way to pass that!
+ (rlisp/invoke-restart rthread 'muffle-warning))
+ (debug-return (target-level)
+ (when (> target-level break-level)
+ (error "Missed target level in debug-return - want ~s hav=
e ~s" target-level break-level))
+ (when (< target-level break-level)
+ (setq debug-return t)
+ (invoke-restart 'debug-return target-level))))
+ (clear-input)
+ (fresh-line))
+ (unless debug-return
+=01 (warn "Unknown exit from rlisp-read-loop!")))))
+
+(defmethod rlisp-read-loop-internal ((rthread remote-lisp-thread))
+ (let* ((input-stream *standard-input*)
+ (output-stream *standard-output*)
+ (sem (make-semaphore))
+ (eof-count 0))
+ (loop
+ (force-output output-stream)
+ (print-listener-prompt output-stream t)
+ (multiple-value-bind (text env) (toplevel-form-text input-stream)
+ (if (null text) ;; eof
+ (progn
+ (when (> (incf eof-count) *consecutive-eof-limit*)
+ (#_ _exit 0))
+ (unless (and (not *batch-flag*)
+ (not *quit-on-eof*)
+ (stream-eof-transient-p input-stream))
+ (exit-interactive-process *current-process*))
+ (stream-clear-input input-stream)
+ (rlisp/invoke-restart rthread 'abort-break))
+ (progn
+ (setq eof-count 0)
+ ;;(let* ((values (toplevel-eval form env)))
+ ;; (if print-result (toplevel-print values)))
+ (let* ((package-name (loop for sym in (car env) for val in (cd=
r env)
+ when (eq sym '*package*) do (return val)=
))
+ (values (remote-listener-eval rthread text :package pac=
kage-name :semaphore sem)))
+ (fresh-line output-stream)
+ (dolist (val values) (princ val output-stream) (terpri outpu=
t-stream)))))))))
+
+
+(defmethod remote-listener-eval ((conn swank-rlisp-connection) text
+ &key package thread (semaphore (make-sema=
phore)))
+ (let* ((form (format nil "(SWANK::LISTENER-EVAL ~s)" text))
+ (return-values nil)
+ (return-error nil))
+ (rlisp/execute conn
+ form
+ (lambda (error values)
+ (setq return-error error)
+ (setq return-values values)
+ (signal-semaphore semaphore))
+ :package package
+ :thread thread)
+ (wait-on-semaphore semaphore)
+ (when return-error
+ (error "Remote eval error ~s" return-error))
+ ;; a list of strings representing each return value
+ return-values))
+
+
+
+
+
+
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
More information about the Openmcl-cvs-notifications
mailing list