[Openmcl-cvs-notifications] r15105 - in /trunk/source: cocoa-ide/cocoa-remote-lisp.lisp level-1/l1-boot-2.lisp lib/compile-ccl.lisp lib/swink.lisp lib/systems.lisp library/remote-lisp.lisp library/swank-loader.lisp
gz at clozure.com
gz at clozure.com
Fri Dec 2 15:57:48 CST 2011
Author: gz
Date: Fri Dec 2 15:57:48 2011
New Revision: 15105
Log:
Rewrite the remote lisp client to use swink rather than swank. Move swank =
utilities to a separate file since no longer use it here.
Added:
trunk/source/library/swank-loader.lisp
Modified:
trunk/source/cocoa-ide/cocoa-remote-lisp.lisp
trunk/source/level-1/l1-boot-2.lisp
trunk/source/lib/compile-ccl.lisp
trunk/source/lib/swink.lisp
trunk/source/lib/systems.lisp
trunk/source/library/remote-lisp.lisp
Modified: 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 (original)
+++ trunk/source/cocoa-ide/cocoa-remote-lisp.lisp Fri Dec 2 15:57:48 2011
@@ -24,7 +24,7 @@
(defun cl-user::rlisp-test (port &optional host)
(declare (special cl-user::conn))
(when (boundp 'cl-user::conn) (close cl-user::conn))
- (setq cl-user::conn (ccl::connect-to-swank (or host "localhost") port))
+ (setq cl-user::conn (ccl::connect-to-swink (or host "localhost") port))
(ccl::make-rrepl-thread cl-user::conn "IDE Listener"))
=
(defclass remote-listener-hemlock-view (hi:hemlock-view)
@@ -73,7 +73,7 @@
(new-cocoa-listener-process (format nil "~a [Remote ~a(~a)]"
name
(ccl::rlisp-host-description=
rthread)
- (ccl::rlisp-thread-id rthrea=
d))
+ (swink:thread-id rthread))
(#/window (hi::hemlock-view-pane vie=
w))
:class 'remote-cocoa-listener-process
:initargs `(:remote-thread ,rthread)
@@ -106,33 +106,43 @@
;; Cause the other side to enter a breakloop, which it will inform us of=
when it happens.
(ccl::rlisp/interrupt (process-remote-thread p)))
=
-(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::wait-for-toplevel-form ((stream cocoa-listener-input-strea=
m))
+ (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)))
+ (loop
+ (wait-on-semaphore queue-semaphore nil "Toplevel Read")
+ (without-interrupts ;; yes, we're screwed if an interrupt happens =
just before, oh well.
+ (with-lock-grabbed (queue-lock)
+ (let ((val (car queue)))
+ (unless (and (stringp val) (every #'whitespacep val))
+ (signal-semaphore queue-semaphore) ;; return it.
+ (return t)))
+ (pop queue)))))))
=
(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)))))))))
+ (loop
+ (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!")
+ (unless (every #'whitespacep val)
+ (return (values val nil t))))
+ (t
+ ;; TODO: this is bogus, the package may not exist on this=
side, so must be a string,
+ ;; but we can't bind *package* to a string. So this assu=
mes the caller will know
+ ;; not to progv the env.
+ (destructuring-bind (string package-name pathname offset)=
val ;; 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)))
+ (return (values string env)))))))))))
Modified: trunk/source/level-1/l1-boot-2.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/level-1/l1-boot-2.lisp (original)
+++ trunk/source/level-1/l1-boot-2.lisp Fri Dec 2 15:57:48 2011
@@ -353,6 +353,7 @@
(bin-load-provide "LEAKS" "leaks")
(bin-load-provide "CORE-FILES" "core-files")
(bin-load-provide "DOMINANCE" "dominance")
+ (bin-load-provide "SWANK-LOADER" "swank-loader")
(bin-load-provide "REMOTE-LISP" "remote-lisp")
(bin-load-provide "MCL-COMPAT" "mcl-compat")
(require "LOOP")
Modified: trunk/source/lib/compile-ccl.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/lib/compile-ccl.lisp (original)
+++ trunk/source/lib/compile-ccl.lisp Fri Dec 2 15:57:48 2011
@@ -231,6 +231,7 @@
leaks
core-files
dominance
+ swank-loader
remote-lisp
;; asdf has peculiar compile-time side-effects
;;asdf
Modified: trunk/source/lib/swink.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/lib/swink.lisp (original)
+++ trunk/source/lib/swink.lisp Fri Dec 2 15:57:48 2011
@@ -290,7 +290,7 @@
=
(defmethod make-new-thread ((conn connection) &optional (process *current-=
process*))
(with-connection-lock (conn)
- (assert (not (find-thread conn process)))
+ (assert (not (find-thread conn process :key #'thread-process)))
(let ((thread (make-instance (thread-class conn) :connection conn :pro=
cess process)))
(push thread (connection-threads conn))
thread)))
@@ -423,7 +423,7 @@
(close socket :abort t)
(with-swink-lock ()
(remf *listener-sockets* info)))))))
- (log-event "Swink awaiting ~s instructions on ~s" external-format sock=
et)
+ (log-event "Swink awaiting ~s instructions on port ~s ~s" external-for=
mat local-port socket)
local-port))
=
(defun stop-server (port)
@@ -516,11 +516,13 @@
(setq returned-string string)
(signal-semaphore return-signal=
))))
(send-event conn `(:read-string ,thread ,tag))
- (let ((current-thread (find-thread conn *current-process*)))
- (if current-thread ;; we're running in a repl, process event=
s while waiting.
- (with-event-handling (current-thread)
- (wait-on-semaphore return-signal))
- (wait-on-semaphore return-signal)))
+
+ (let ((current-thread (find-thread conn *current-process* :key=
#'thread-process)))
+ (with-interrupts-enabled
+ (if current-thread ;; we're running in a repl, process e=
vents while waiting.
+ (with-event-handling (current-thread)
+ (wait-on-semaphore return-signal))
+ (wait-on-semaphore return-signal))))
returned-string)
(unless returned-string
;; Something interrupted us and aborted, tell client to stop rea=
ding as well.
Modified: trunk/source/lib/systems.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/lib/systems.lisp (original)
+++ trunk/source/lib/systems.lisp Fri Dec 2 15:57:48 2011
@@ -227,7 +227,8 @@
(leaks "ccl:bin;leaks" ("ccl:library;leaks.lisp"=
))
(core-files "ccl:bin;core-files" ("ccl:library;core-files.=
lisp"))
(dominance "ccl:bin;dominance" ("ccl:library;dominance.l=
isp"))
- (remote-lisp "ccl:bin;remote-lisp" ("ccl:library;remote-lisp.l=
isp"))
+ (swank-loader "ccl:bin;swank-loader" ("ccl:library;swank-loade=
r.lisp")) =
+ (remote-lisp "ccl:bin;remote-lisp" ("ccl:library;remote-lisp=
.lisp" "ccl:lib;swink.lisp"))
=
(prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;p=
repare-mcl-environment.lisp"))
(defsystem "ccl:tools;defsystem" ("ccl:tools;defsystem.lis=
p"))
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 Fri Dec 2 15:57:48 2011
@@ -19,35 +19,25 @@
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
-;; Client-side remote lisp support
+;; swink client -- use this ccl to debug a remote ccl.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
=
-;; (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)
- (object-counter :initform most-negative-fixnum :accessor rlisp-object-c=
ounter)
- (objects :initform () :accessor rlisp-objects)
- (threads :initform () :accessor rlisp-threads)
-
- (features :initform nil :accessor rlisp-features)
+(defclass remote-lisp-connection (swink:connection)
+ ((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 swink:thread-id ((conn remote-lisp-connection)) nil)
=
(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)
+ (features nil featuresp)
+ &allow-other-keys)
+ (swink:with-connection-lock (conn)
(when featuresp
(setf (rlisp-features conn) features))
(when machine-instance
@@ -57,497 +47,169 @@
(when lisp-implementation-version
(setf (rlisp-lisp-implementation-version conn) lisp-implementation-v=
ersion))))
=
-(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)
- (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) (or (find-rlisp-object conn id)=
'(nil . nil))
- (when callback
- (apply #'process-interrupt process callback values))))
-
-(defclass remote-lisp-thread ()
- ((conn :initarg :connection :reader rlisp-thread-connection)
- ;; Local process running the local repl: interacting with user, sending=
to remote for execution.
- (thread-process :initform nil :accessor rlisp-thread-process)
- (break-level :initform nil :accessor rlisp-thread-break-level)
- ;; Id of remote process doing the evaluation for the local process.
- (thread-id :initarg :thread-id :reader rlisp-thread-id)
- (event-queue :initform nil :accessor rlisp-thread-event-queue)))
+;; Proxy for a thread on the remote server. =
+(defclass remote-lisp-thread (swink:thread)
+ (;; Local process running the local repl: interacting with user, sending=
to remote for execution.
+ =15;; (the swink:thread-process slot has thread-id of the remote pro=
cess)
+ (control-process :initform nil :accessor swink:thread-control-process)
+ (break-level :initform nil :accessor rthread-break-level)))
+
+(defmethod swink:thread-class ((conn remote-lisp-connection)) 'remote-lisp=
-thread)
=
(defmethod rlisp-host-description ((rthread remote-lisp-thread))
- (rlisp-host-description (rlisp-thread-connection rthread)))
+ (rlisp-host-description (swink: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) &key (create t))
- (declare (ignore create))
- thread)
-
-(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)
- (and create
- (let ((rthread (make-instance 'remote-lisp-thread :connection=
conn :thread-id id)))
- (push rthread (rlisp-threads conn))
- rthread)))))
-
-(defmethod rlisp-thread ((conn remote-lisp-connection) (process process) &=
key (create nil))
- (with-rlisp-lock (conn)
- (or (find process (rlisp-threads conn) :key #'rlisp-thread-process)
- (and create
- (assert (not create))))))
-
-(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)))
+ (swink:thread-id rthread))))
+
+(defmethod rlisp/invoke-restart ((rthread remote-lisp-thread) name)
+ (swink:send-event rthread `(:invoke-restart ,name)))
+
+(defmethod rlisp/toplevel ((rthread remote-lisp-thread))
+ (swink:send-event rthread `(:toplevel)))
+
+(defmethod rlisp/interrupt ((rthread remote-lisp-thread))
+ (swink:send-event rthread `(:interrupt)))
+
+(defmethod rlisp-host-description ((conn remote-lisp-connection))
+ (let ((socket (swink:connection-control-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)
+(defmethod print-object ((conn remote-lisp-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-event-loop ~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...
- ;; TODO: advise send-to-emacs to intercept :write-string and add in t=
he thread id.
- (rlisp/execute conn
- "(CL:LET ((CCL:*WARN-IF-REDEFINE* ()))
- (CL:DEFUN SWANK::SPAWN-REPL-THREAD (CONN NAME) (CCL::=
RDEBUG-SPAWN-REPL-THREAD CONN NAME))
- (CL:DEFUN SWANK::DEBUG-IN-EMACS (CONN) (CCL::RDEBUG-I=
NVOKE-DEBUGGER CONN))
- (CCL:ADVISE SWANK::DISPATCH-EVENT
- (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
- (COMMAND (CL:CAR EVENT)))
- (CL:IF (CCL:MEMQ COMMAND '(:EMACS-REX :=
RETURN :EMACS-INTERRUPT
- :=
EMACS-PONG :EMACS-RETURN :EMACS-RETURN-STRING
- :=
EMACS-CHANNEL-SEND :END-OF-STREAM :READER-ERROR))
- (:DO-IT)
- (SWANK::ENCODE-MESSAGE EVENT (SWANK::=
CURRENT-SOCKET-IO))))
- :WHEN :AROUND
- :NAME CCL::UNRESTRICTED-OUTGOING-MESSAGES
- :DYNAMIC-EXTENT-ARGLIST CL:T)
- (CCL:ADVISE SWANK::SEND-TO-EMACS
- (CL:LET* ((EVENT (CL:CAR CCL::ARGLIST))
- (COMMAND (CL:CAR EVENT)))
- (CL:WHEN (CL:EQ COMMAND :WRITE-STRING)
- (CL:SETF (CL:CDDR EVENT) (CL:LIST (S=
WANK::CURRENT-THREAD-ID)))))
- :WHEN :BEFORE
- :NAME CCL::SEND-THREAD-WITH-WRITE-STRING)
- (CL:DEFUN SWANK::SIMPLE-BREAK ()
- (CCL::FORCE-BREAK-IN-LISTENER CCL::*CURRENT-PROCESS=
*))
- (CL:SETF (CCL::APPLICATION-UI-OBJECT CCL::*APPLICATIO=
N*)
- (CL:MAKE-INSTANCE 'CCL::RDEBUG-UI-OBJECT :C=
ONNECTION SWANK::*EMACS-CONNECTION*))
-
- (CL:SETQ CCL::*INVOKE-DEBUGGER-HOOK-ON-INTERRUPT* CL:=
NIL) ;; let it go thru to break.
-
- (CL:SETQ CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* 'CCL::=
RDEBUG-FIND-REPL-THREAD)
-
- (CL:DEFUN CCL::EXIT-SWANK-LOOP (LEVEL)
- (SWANK::SEND-TO-EMACS `(:DEBUG-RETURN
- ,(SWANK::CURRENT-THREAD-ID)=
,LEVEL ,SWANK::*SLDB-STEPPING-P*))
- (SWANK::WAIT-FOR-EVENT `(:SLDB-RETURN ,(CL:1+ LEVEL=
)) CL:T)
- (CL:WHEN (CL:> LEVEL 1)
- (SWANK::SEND-EVENT (SWANK::CURRENT-THREAD) `(:SLD=
B-RETURN ,LEVEL))))
-
- (CL:DEFUN CCL::MAKE-SWANK-REPL-FOR-IDE (NAME)
- (SWANK::CREATE-REPL ()) ;; set up connection.env wi=
th redirect threads.
- (CL:LET ((THREAD (SWANK::FIND-REPL-THREAD SWANK::*E=
MACS-CONNECTION*)))
- (CL:SETF (CCL:PROCESS-NAME THREAD) NAME)
- (SWANK::THREAD-ID THREAD)))
- CL:T)"
- (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)
- ;; TODO: should at least kill server process.
- (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 input-stream-for-remote-lisp ((app application))
- *standard-input*)
-
-(defun process-output-stream (process)
- (let ((stream (symbol-value-in-process '*standard-output* process)))
- (loop
- (typecase stream
- (synonym-stream
- (setq stream (symbol-value-in-process (synonym-stream-symbol stre=
am) process)))
- (two-way-stream
- (setq stream (two-way-stream-output-stream stream)))
- (t (return stream))))))
-
-(defvar *signal-swank-events* nil)
-
-(define-condition swank-events () ())
-
-(defmacro with-swank-events ((rthread &key abort) &body body)
- (let ((rthread-var (gensym "RTHREAD")))
- (if abort
- ;; When body is no re-entrant, abort it before handling the event.
- `(let ((,rthread-var ,rthread))
- (loop
- (handler-case (return (let ((*signal-swank-events* t))
- (when (rlisp-thread-event-queue ,rthrea=
d-var)
- (let ((*signal-swank-events* nil))
- (handle-swank-events ,rthread-var)))
- , at body))
- (swank-events () (let ((*signal-swank-events* nil))
- (handle-swank-events rthread))))))
- `(let ((,rthread-var ,rthread))
- (handler-bind ((swank-events (lambda (c)
- (declare (ignore c))
- (handle-swank-events ,rthread-var)=
)))
- (let ((*signal-swank-events* t))
- (when (rlisp-thread-event-queue ,rthread-var)
- (let ((*signal-swank-events* nil))
- (handle-swank-events ,rthread-var)))
- , at body))))))
-
-(defun signal-swank-event (rthread event args)
- (with-rlisp-lock ((rlisp-thread-connection rthread)) ;; this is quick, n=
ot worth a separate lock
- (setf (rlisp-thread-event-queue rthread)
- (nconc (rlisp-thread-event-queue rthread) (list `(,event , at args)=
))))
- (process-interrupt (or (rlisp-thread-process rthread)
- (error "Got event ~s ~s for thread ~s with no pro=
cess" event args rthread))
- (lambda ()
- (when *signal-swank-events*
- (let ((*signal-swank-events* nil))
- (signal 'swank-events))))))
-
-(defun handle-swank-events (rthread)
- (loop for event =3D (with-rlisp-lock ((rlisp-thread-connection rthread))=
;; this is quick, not worth a separate lock
- (pop (rlisp-thread-event-queue rthread)))
- while event do (handle-swank-event rthread (car event) (cdr event))))
-
-(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-object conn id))
- (error "Invalid rpc: ~s" message)))
- (:enter-break ;; Starting a new repl (possibly due to an error in a no=
n-repl process)
- ;; For now, this is assumed to create the listener before processing =
another command, so
- ;; the remote can send commands to it right away.
- ;; If that becomes a problem, can make a protocol so the other side w=
ill explicitly wait,
- ;; and then we can spawn off a worker thread to do this.
- (destructuring-bind (thread-id break-level) args
- (let ((rthread (rlisp-thread conn thread-id)))
- (enter-rlisp-listener rthread break-level)
- ;; TODO: this isn't really right. Need to wait for process conte=
xt to be set up. Perhaps
- ;; make sure thread-process is not set until the process is runni=
ng in full context.
- (process-wait "REPL startup" #'rlisp-thread-process rthread)
- ;(signal-swank-event rthread event (cdr args))
- )))
- (:exit-break
- (destructuring-bind (thread-id) args
- (let ((rthread (rlisp-thread conn thread-id)))
- (when (and rthread (rlisp-thread-process rthread))
- (exit-rlisp-listener rthread)))))
- ((:read-loop :values :debug-return :debug-condition :read-aborted)
- ;; TODO: this needs to make sure the process is in the right dynamic =
state (with all restarts established etc)
- ;; Need our own interrupt queue, with-event-handling macro...
- (destructuring-bind (thread-id &rest event-args) args
- (let ((rthread (rlisp-thread conn thread-id)))
- (signal-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))))
- ;; TODO: make the i/o streams be thread-specific, so we know which lis=
tener to use even if some other
- ;; thread is doing the i/o. I.e. this should send a thread id of the =
owner of the stream, not of the
- ;; thread that happens to write it, so it will always be a listener th=
read.
- (:write-string
- (destructuring-bind (string thread-id) args
- (let* ((rthread (rlisp-thread conn thread-id :create nil))
- (stream (if (and rthread (rlisp-thread-process rthread))
- (process-output-stream (rlisp-thread-process rthre=
ad))
- (output-stream-for-remote-lisp *application*))))
- (if (> (length string) 500)
- (process-run-function "Long Remote Output" #'write-string strin=
g stream)
- (write-string string stream)))))
- (:ping ;; flow control for output
- (destructuring-bind (thread-id tag) args
- ;; TODO: I guess we're supposed to wait til the previous output is =
finished or something.
- (send-sexp-to-swank conn `(:emacs-pong ,thread-id ,tag))))
- (:read-string
- (destructuring-bind (thread-id tag) args
- (let ((rthread (rlisp-thread conn thread-id :create nil)))
- (if (and rthread (rlisp-thread-process rthread))
- (signal-swank-event rthread event (cdr args))
- ;; 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 *applicatio=
n*)
- thread-id
- tag)))))
- (t (warn "Received unknown event ~s with args ~s" event args))))
-
-
+(defmethod start-rlisp-process ((conn remote-lisp-connection))
+ (assert (null (swink:connection-control-process conn)))
+ (setf (swink:connection-control-process conn)
+ (process-run-function (format nil "swank-event-loop ~a" (remote-po=
rt (swink:connection-control-stream conn)))
+ (lambda ()
+ (setf (swink:connection-control-process conn) *current-process=
*)
+ (with-simple-restart (swink:close-connection "Close connection=
")
+ (loop (dispatch-event conn (swink:read-sexp conn)))))))
+ (let ((info (send-event-for-value conn `(:connection-info))))
+ (when info
+ (apply #'update-rlisp-connection-info conn info)))
+ conn)
+
+
+(defmethod dispatch-event ((conn remote-lisp-connection) thread.event)
+ (swink::log-event "Dispatch-event ~s" thread.event)
+ (destructuring-bind (sender-id . event) thread.event
+ (swink:destructure-case event
+ ((:end-connection condition)
+ (declare (ignore condition))
+ (swink:close-connection conn))
+ ((:start-repl break-level)
+ ;; Starting a new repl (possibly due to an error in a non-repl proc=
ess)
+ (let ((rthread (swink:make-new-thread conn sender-id)))
+ (start-remote-listener rthread break-level)))
+ ((:exit-repl)
+ (let ((rthread (swink:find-thread conn sender-id)))
+ (when (and rthread (swink:thread-control-process rthread))
+ (exit-remote-listener rthread))))
+ ((:return local-tag &rest values)
+ ;; Note this interrupts the process rather than going through the e=
vent mechanism,
+ ;; the caller has to set up the callback environment before sending=
the request.
+ (when local-tag
+ (apply #'swink:invoke-callback conn local-tag values)))
+ ((:cancel-return local-tag)
+ (when local-tag
+ (let ((process (cdr (swink:tagged-object conn local-tag)))) ;; th=
is removes the tag.
+ (when process
+ (process-interrupt process (lambda () (signal 'rlisp-cancel-r=
eturn :tag local-tag)))))))
+ (((:read-string :abort-read :write-string) stream-thread-id &rest ar=
gs)
+ ;; Do I/O stuff in the stream listener process, not the caller's li=
stener
+ ;; process (which might not even exist)
+ (let ((stream-listener (swink:find-thread conn stream-thread-id)))
+ (if stream-listener
+ (swink:signal-event stream-listener (cons (car event) args))
+ (warn "Missing listener for ~s" event))))
+ (t (let ((thread (swink:find-thread conn sender-id)))
+ (when thread
+ (swink:signal-event thread event)))))))
+
+(define-condition rlisp-cancel-return ()
+ ((tag :initarg :tag :reader rlisp-cancel-return-tag)))
=
(define-condition rlisp-read-aborted ()
((tag :initarg :tag :reader rlisp-read-aborted-tag)))
=
-(defun rlisp-read-string (conn stream thread-id tag)
+(defun rlisp-read-string (rthread tag)
(handler-bind ((rlisp-read-aborted (lambda (c)
(when (eql tag (rlisp-read-aborted-=
tag c))
(return-from rlisp-read-string)))=
))
- (peek-char t stream) ;; wait for first one, error if none.
- (let ((text (and (peek-char t stream nil) ;; wait for first one, nil m=
eans eof
- (read-available-text stream))))
- (send-sexp-to-swank conn `(:emacs-return-string ,thread-id ,tag ,tex=
t)))))
-
-(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-inpu=
t* (rlisp-thread-id rthread) tag)))
- (:read-aborted ;; huh?
- (destructuring-bind (tag) args
- (signal 'rlisp-read-aborted :tag tag)))
- (:read-loop ;; enter (or re-enter after an abort) a break loop.
- (destructuring-bind (level) args
- (when (eql level *break-level*) ;; restart at same level, aborted c=
urrent expression.
- (invoke-restart 'debug-restart level))
- (unless (eql level (1+ *break-level*))
- (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *=
break-level*)))
- ;(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-condition ;; This seems to have something to do with errors i=
n the debugger
- (destructuring-bind (message) args
- (format t "~&Swank error: ~s" message)))
- (:debug-return ;; return from level LEVEL read loop
- (destructuring-bind (level stepping-p) args
- (declare (ignore stepping-p))
- (invoke-restart 'debug-return level)))
- (:values ;; intermediate values when multiple forms in selection.
- (destructuring-bind (values) args
- (when values
- (fresh-line)
- (dolist (val values) (write val) (terpri)))
- (force-output)
- (print-listener-prompt *standard-output*)))))
-
-
-;; 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)))
- (multiple-value-bind (form updated-buffer) (read-remote-event stream b=
uffer)
- (unless (eq updated-buffer buffer)
- (setf (swank-read-buffer conn) updated-buffer))
- form)))
-
-(defun read-remote-event (stream &optional buffer)
- (let* ((header (or buffer (make-string 6)))
- (count (stream-read-vector stream header 0 6)))
- (when (< count 6) (signal-eof-error stream))
- (setq count (parse-integer header :end 6 :radix 16))
- (assert (> count 0))
- (when (< (length buffer) count)
- (setq buffer (make-string count)))
- (let ((len (stream-read-vector stream buffer 0 count)))
- (when (< len count) (signal-eof-error stream))
- ;; TODO: check that there aren't more forms in the string.
- (values (handler-case
- (with-standard-io-syntax
- (let ((*package* +swank-io-package+)
- (*read-eval* nil))
- (read-from-string buffer t nil :end count)))
- (reader-error (c) `(:reader-error ,(copy-seq buffer) ,c)))
- buffer))))
-
-(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 ((text (and (swink:with-event-handling (rthread :restart t)
+ (peek-char nil *standard-input* nil)) ;; wait for f=
irst one, nil means eof
+ (read-available-text *standard-input*))))
+ (swink:send-event (swink:thread-connection rthread) `(:return ,tag ,=
text)))))
+
+(defun send-event-for-value (target event &key (semaphore (make-semaphore)=
))
+ (let* ((return-values nil)
+ (conn (etypecase target
+ (remote-lisp-connection target)
+ (remote-lisp-thread (swink:thread-connection target))))
+ (tag (swink:tag-callback conn
+ (lambda (&rest values)
+ (setq return-values values)
+ (signal-semaphore semaphore))))
+ (event-with-callback `(, at event ,tag)))
+ (handler-bind ((rlisp-cancel-return
+ ;; This is called if the call got aborted for any reas=
on, so we can clean up.
+ (lambda (c)
+ (when (eq (rlisp-cancel-return-tag c) tag)
+ (signal-semaphore semaphore)))))
+ (swink:send-event target event-with-callback)
+ (if (eq target conn)
+ (wait-on-semaphore semaphore)
+ (swink:with-event-handling (target)
+ (wait-on-semaphore semaphore)))
+ (apply #'values return-values))))
+
+(defmethod swink:handle-event ((rthread remote-lisp-thread) event)
+ (assert (eq (swink:thread-control-process rthread) *current-process*))
+ (swink::log-event "Handle-event in thread ~s: ~s" (swink:thread-id rthre=
ad) event)
+ (swink:destructure-case event
+ ((:read-string remote-tag)
+ (rlisp-read-string rthread remote-tag))
+ ((:abort-read remote-tag)
+ (signal 'rlisp-read-aborted :tag remote-tag))
+ ((:write-string string)
+ (write-string string))
+ ((:read-loop level) ;; enter (or re-enter after an abort) a break loop.
+ (when (eql level *break-level*) ;; restart at same level, aborted cur=
rent expression.
+ (invoke-restart 'debug-restart level))
+ (unless (eql level (1+ *break-level*))
+ (warn ":READ-LOOP level confusion got ~s expected ~s" level (1+ *br=
eak-level*)))
+ ;(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-return level) ;; return from level LEVEL read loop
+ (invoke-restart 'debug-return level))))
+
+(defmethod make-rrepl-thread ((conn remote-lisp-connection) name)
+ (swink:send-event conn `(:spawn-repl ,name)))
+
+(defun connect-to-swink (host port)
(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)
+ (conn (make-instance 'remote-lisp-connection :control-stream sock=
et)))
+ (start-rlisp-process conn)))
+
+(defmethod close ((conn remote-lisp-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 will be executed in the current process.
-(defmethod rlisp/execute ((conn swank-rlisp-connection) form-or-string con=
tinuation &key 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
- nil
- ,(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))))
+ (close (swink:connection-control-stream conn) :abort abort))
=
(defun read-available-text (stream)
(loop with buffer =3D (make-array 100 :element-type 'character :adjustab=
le t :fill-pointer 0)
@@ -557,45 +219,54 @@
finally (return buffer)))
=
;; Return text for remote evaluation.
-(defmethod toplevel-form-text ((stream input-stream))
- (when (peek-char t stream nil) ;; wait for the first one.
- (read-available-text stream)))
-
+(defmethod wait-for-toplevel-form ((stream input-stream)) (peek-char t str=
eam nil))
+(defmethod toplevel-form-text ((stream input-stream)) (read-available-text=
stream))
+
+(defmethod wait-for-toplevel-form ((stream synonym-stream))
+ (wait-for-toplevel-form (symbol-value (synonym-stream-symbol stream))))
(defmethod toplevel-form-text ((stream synonym-stream))
(toplevel-form-text (symbol-value (synonym-stream-symbol stream))))
=
+(defmethod wait-for-toplevel-form ((stream two-way-stream))
+ (if (typep stream 'echo-stream)
+ (call-next-method)
+ (wait-for-toplevel-form (two-way-stream-input-stream 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))))
=
+
+(defmethod start-remote-listener ((rthread remote-lisp-thread) break-level)
+ (when (swink:thread-control-process rthread) (error "Attempting to re-en=
ter active listener"))
+ (setf (rthread-break-level rthread) break-level)
+ (create-rlisp-listener *application* rthread)
+ ;; This is running in the server control process. Don't process any oth=
er events until
+ ;; the thread actually starts up.
+ (process-wait "REPL startup" #'swink:thread-control-process rthread))
+
+;; This can be invoked when the connection dies or break-loop is exited in=
a non-repl process.
+(defmethod exit-remote-listener ((rthread remote-lisp-thread))
+ (application-ui-operation *application* :deactivate-rlisp-listener rthre=
ad) ;; deactivate listener window
+ (let ((process (swink:thread-control-process rthread)))
+ (setf (swink:thread-control-process rthread) nil)
+ (when process
+ ;; This runs unwind-protects, which should clean up any streams
+ (process-kill process))))
+
;; 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*)
+ (setf (swink:thread-control-process rthread) *current-process*)
(unless (or *inhibit-greeting* *quiet-flag*)
- (let ((conn (rlisp-thread-connection rthread)))
+ (let ((conn (swink: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 (rlisp-thread-break-level rthread)=
))
-
-;; This can be invoked when the connection dies or break-loop is exited in=
a non-repl process.
-(defmethod exit-rlisp-listener ((rthread remote-lisp-thread))
- (application-ui-operation *application* :deactivate-rlisp-listener rthre=
ad) ;; deactivate listener
- (let ((process (rlisp-thread-process rthread)))
- (setf (rlisp-thread-process rthread) nil)
- (process-kill process)))
-
-(defmethod enter-rlisp-listener ((rthread remote-lisp-thread) break-level)
- (when (rlisp-thread-process rthread)
- (error "Attempting to re-enter active listener"))
- (setf (rlisp-thread-break-level rthread) break-level)
- ;; The process creation would be a little different
- (create-rlisp-listener *application* rthread))
+ (rlisp-read-loop rthread :break-level (rthread-break-level rthread)))
=
(defmethod create-rlisp-listener ((application application) rthread)
- (assert (null (rlisp-thread-process rthread)))
+ (assert (null (swink:thread-control-process rthread)))
;; see make-mcl-listener-process
(error "Not implemented yet"))
=
@@ -606,7 +277,7 @@
(debug-return nil))
(unwind-protect
(loop
- (setf (rlisp-thread-break-level rthread) break-level)
+ (setf (rthread-break-level rthread) break-level)
(restart-case
;; There are some UI actions that invoke local restarts by n=
ame, e.g. cmd-/ will invoke 'continue.
;; Catch those and just pass them to the remote. The remote=
will then do whatever the restart
@@ -651,18 +322,15 @@
=
(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)
- ;; Reading is not re-entrant so events during r=
eading need
- ;; to abort the read to be handled.
- (with-swank-events (rthread :abort t)
- (toplevel-form-text input-stream))
+ (force-output)
+ (print-listener-prompt *standard-output* t)
+ =
+ (swink:with-event-handling (rthread :restart t)
+ (wait-for-toplevel-form input-stream))
+ (multiple-value-bind (text env) (toplevel-form-text input-stream)
(if (null text) ;; eof
(progn
(when (> (incf eof-count) *consecutive-eof-limit*)
@@ -678,293 +346,12 @@
;;(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)))
- (assert thread)
- (let* ((form (format nil "(CCL::RDEBUG-LISTENER-EVAL ~s ~s ~s)"
- text package =
- ;; This will send intermediate :values messages
- (and *verbose-eval-selection* t)))
- (return-values nil))
- (rlisp/execute conn
- form
- (lambda (error values)
- ;; Error just means evaluation was aborted but we don=
't yet know why. We will
- ;; be told to either restart a readloop or exit it. =
Stay in semaphore wait
- ;; until then.
- (unless error
- (setq return-values values)
- (signal-semaphore semaphore)))
- :thread thread)
- (with-swank-events (thread)
- (wait-on-semaphore semaphore))
- ;; a list of strings representing each return value
- return-values))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Server-side: support for a remote debugger
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;;TODO: This is per application but we may want to allow multiple remote d=
ebuggers, and have this track
-;; all connections. See also process-ui-object.
-(defclass rdebug-ui-object (ui-object)
- ((connection :initarg :connection :accessor rdebug-ui-connection)))
-
-;; Currently built on swank.
-
-(defun swankvar (name &optional (package :swank))
- (symbol-value (find-symbol name package)))
-
-(defun (setf swankvar) (value name &optional (package :swank))
- (let ((sym (find-symbol name package)))
- (if (null sym)
- (warn "Couldn't find ~a::~a" package name)
- (set sym value))))
-
-(defun swankfun (name &optional (package :swank))
- (symbol-function (find-symbol name package)))
-
-#-bootstrapped
-(declaim (special *read-loop-function*))
-
-(defun rdebug-send (event)
- (funcall (swankfun "SEND-TO-EMACS")
- (mapcar (lambda (x) (if (processp x) (funcall (swankfun "THREAD=
-ID") x) x)) event)))
-
-(defun rdebug-listener-eval (string package-name verbose-eval-selection)
- (if package-name
- (let ((*package* (or (find-package package-name) *package*)))
- (rdebug-listener-eval string nil verbose-eval-selection))
- (with-input-from-string (sstream string)
- (let ((values nil))
- (loop
- (let ((form (read-toplevel-form sstream :eof-value sstream)))
- (when (eq form sstream)
- (finish-output)
- (return values))
- (when verbose-eval-selection
- (rdebug-send `(:values ,*current-process* ,values)))
- ;; there is more.
- (unless (check-toplevel-command form)
- ;; TODO: toplevel-eval checks package change and invokes app=
lication-ui-operation, need to send that back.
- (setq values (toplevel-eval form nil))
- (setq /// // // / / values)
- (unless (eq (car values) (%unbound-marker))
- (setq *** ** ** * * (%car values)))
- (setq values (mapcar #'write-to-string values)))))))))
-
-(defun rdebug-spawn-repl-thread (conn name)
- (process-run-function name
- (lambda ()
- (funcall (swankfun "CALL-WITH-CONNECTION") conn
- (lambda ()
- (rdebug-send `(:enter-break ,*current=
-process* 0))
- (let ((*read-loop-function* 'rdebug-r=
ead-loop)
- (*debugger-hook* nil)
- (*break-hook* nil))
- (unwind-protect
- (toplevel-loop)
- (rdebug-send `(:exit-break ,*curr=
ent-process*)))))))))
-
-;; Debugger invoked in a non-repl process. This is called with all swank =
stuff already set up.
-(defun rdebug-invoke-debugger (condition)
- (when (eq *read-loop-function* 'rdebug-read-loop)
- (return-from rdebug-invoke-debugger))
- (rdebug-send `(:enter-break ,*current-process* 1))
- (unwind-protect
- (let ((*read-loop-function* 'rdebug-read-loop)
- (*debugger-hook* nil)
- (*break-hook* nil))
- (%break-message *break-loop-type* condition)
- ;; Like toplevel-loop but run break-loop to set up error context=
before going into read-loop
- (loop
- (catch :toplevel
- (break-loop condition))
- (when (eq *current-process* *initial-process*)
- (toplevel))))
- (rdebug-send `(:exit-break ,*current-process*))))
-
-
-;; swank-like read loop except with all the standard ccl restarts and catc=
hes.
-;; TODO: try to make the standard read-loop customizable enough to do this=
so don't have to replace it.
-(defun rdebug-read-loop (&key (break-level 0) &allow-other-keys)
- ;; CCL calls this with :input-stream/:output-stream *debug-io*, but that=
won't do anything even if those
- ;; are set to something non-standard, since swank doesn't hang its proto=
col on the streams.
- (let ((*break-level* break-level)
- (*loading-file-source-file* nil)
- (*loading-toplevel-location* nil)
- *** ** * +++ ++ + /// // / -)
- (flet ((repl-until-abort ()
- (rdebug-send `(:read-loop ,*current-process* ,break-level))
- (restart-case
- (catch :abort
- (catch-cancel
- (loop
- (setq *break-level* break-level)
- (let ((event (funcall (swankfun "WAIT-FOR-EVENT")
- `(or (:emacs-rex . _)
- ;; some internal swank kl=
udge...
- (:sldb-return ,(1+ break-=
level))))))
- (when (eql (car event) :sldb-return)
- (abort))
- ;; Execute some basic protocol function (not user =
code).
- (apply (swankfun "EVAL-FOR-EMACS") (cdr event))))))
- (abort ()
- :report (lambda (stream)
- (if (eq break-level 0)
- (format stream "Return to toplevel")
- (format stream "Return to break level ~D" bre=
ak-level)))
- nil)
- (abort-break () (unless (eql break-level 0) (abort))))))
- (declare (ftype (function) exit-swank-loop))
- (unwind-protect
- (loop
- (repl-until-abort)
- ;(clear-input)
- ;(terpri)
- )
- (exit-swank-loop break-level)))))
-
- (defun safe-condition-string (condition)
- (or (ignore-errors (princ-to-string condition))
- (ignore-errors (prin1-to-string condition))
- (ignore-errors (format nil "Condition of type ~s"
- (type-of condition)))
- (ignore-errors (and (typep condition 'error)
- "<Unprintable error>"))
- "<Unprintable condition>"))
-
-;; Find process to handle interactive abort, i.e. a local ^c.
-(defun rdebug-find-repl-thread ()
- (let ((conn (funcall (swankfun "DEFAULT-CONNECTION"))))
- (when conn
- ;; TODO: select the frontmost listener (this selects the last create=
d one).
- (funcall (swankfun "FIND-REPL-THREAD") conn))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; =
-;; Standard swank startup
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; (export '(load-swank start-swank-server start-swank-loader stop-swank-l=
oader))
-
-(defun load-swank (load-path)
- (when (find-package :swank-loader) (delete-package :swank-loader)) ;; so=
can tell if loaded
- (load (merge-pathnames load-path "swank-loader.lisp"))
- (unless (and (find-package :swank-loader)
- (find-symbol "INIT" :swank-loader))
- (error "~s is not a swank loader path" load-path))
- (funcall (find-symbol "INIT" :swank-loader))
- (unless (and (find-package :swank)
- (find-symbol "CREATE-SERVER" :swank))
- (error "Incompatible swank version loaded from ~s" load-path)))
-
-(defun start-swank-server (&key
- (port (swankvar "DEFAULT-SERVER-PORT"))
- (debug (swankvar "*LOG-EVENTS*"))
- (dedicated-output-port (and (swankvar "*USE-DED=
ICATED-OUTPUT-STREAM*")
- (swankvar "*DEDICAT=
ED-OUTPUT-STREAM-PORT*")))
- (globally-redirect-io (swankvar "*GLOBALLY-REDI=
RECT-IO*"))
- (global-debugger (swankvar "*GLOBAL-DEBUGGER*"))
- (indentation-updates (swankvar "*CONFIGURE-EMAC=
S-INDENTATION*"))
- (dont-close (swankvar "*DONT-CLOSE*"))
- (coding-system "iso-latin-1-unix")
- (style :spawn))
- "Assuming SWANK is already loaded, create a swank server on the specifie=
d port"
- (when debug
- (setf (swankvar "*LOG-EVENTS*" :swank-rpc) t)
- (setf (swankvar "*SWANK-DEBUG-P*") t)
- (setf (swankvar "*DEBUG-ON-SWANK-PROTOCOL-ERROR*") t))
- (when (setf (swankvar "*USE-DEDICATED-OUTPUT-STREAM*") (not (null dedica=
ted-output-port)))
- (setf (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*") dedicated-output-por=
t))
- (setf (swankvar "*GLOBALLY-REDIRECT-IO*") globally-redirect-io)
- (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
- (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
- (funcall (swankfun "CREATE-SERVER")
- :style style
- :port port
- :dont-close dont-close
- :coding-system coding-system))
-
-
-(defun swank-port-active? (port)
- (and (find-package :swank) (getf (swankvar "*LISTENER-SOCKETS*") port)))
-
-
-;; Special ccl slime extension to allow the client to specify the swank pa=
th
-
-(defvar *swank-loader-process* nil)
-(defparameter $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]")
-(defparameter *default-swank-loader-port* 4884)
-
-(defun stop-swank-loader ()
- (when *swank-loader-process*
- (process-kill (shiftf *swank-loader-process* nil))))
-
-(defun start-swank-loader (&optional (port *default-swank-loader-port*))
- (ignore-errors (stop-swank-loader))
- (let ((semaphore (make-semaphore))
- (errorp nil))
- (setq *swank-loader-process*
- ;; Wait for either a swank client to connect or the special ccl =
slime kludge
- (process-run-function "Swank Loader"
- (lambda (sem)
- (setq *swank-loader-process* *current-pr=
ocess*)
- (unwind-protect
- (with-open-socket (socket :connect :=
passive :local-port port
- :reuse-add=
ress t)
- (signal-semaphore (shiftf sem nil))
- (loop
- (let* ((stream (accept-connectio=
n socket))
- (line (read-line stream n=
il)))
- (multiple-value-bind (path por=
t)
- (parse-em=
acs-ccl-swank-request line)
- (let ((message (handler-case
- (if (swan=
k-port-active? port)
- (format=
nil "Swank is already active on port ~s" port)
- (progn
- (load=
-swank path)
- (star=
t-swank-server :port port)
- nil))
- (error (c) =
(princ-to-string c)))))
- (prin1 `(:active (and (swa=
nk-port-active? port) t)
- :loader ,=
path
- :message =
,message
- :port ,po=
rt)
- stream)
- (finish-output stream))))))
- (when sem ;; in case exit before finis=
hed startup
- (setq errorp t)
- (signal-semaphore sem))))
- semaphore))
- (wait-on-semaphore semaphore)
- (when errorp
- (ignore-errors (process-kill (shiftf *swank-loader-process* nil))))
- *swank-loader-process*))
-
-(defun parse-emacs-ccl-swank-request (line)
- (let ((start (length $emacs-ccl-swank-request-marker)))
- (when (and (< start (length line))
- (string=3D $emacs-ccl-swank-request-marker line :end2 start=
))
- (let* ((split-pos (position #\: line :start start))
- (port (parse-integer line :junk-allowed nil :start start :end=
split-pos))
- (path-pos (position-if-not #'whitespacep line
- :start (if split-pos (1+ split-pos=
) start)))
- (path (subseq line path-pos
- (1+ (position-if-not #'whitespacep line :from-e=
nd t)))))
- (values path port)))))
-
-
-
-
+ when (eq sym '*package*) do (return val=
))))
+ (if *verbose-eval-selection*
+ (let ((state (send-event-for-value rthread `(:read-eval-pr=
int-one ,text ,package-name) :semaphore sem)))
+ (loop while state
+ do (force-output)
+ do (print-listener-prompt *standard-output* t)
+ do (send-event-for-value rthread `(:read-eval-print-ne=
xt ,state) :semaphore sem)))
+ (send-event-for-value rthread `(:read-eval-all-print-last =
,text ,package-name) :semaphore sem)))))))))
+
Added: trunk/source/library/swank-loader.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/swank-loader.lisp (added)
+++ trunk/source/library/swank-loader.lisp Fri Dec 2 15:57:48 2011
@@ -1,0 +1,145 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;; Copyright (C) 2011 Clozure 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
+;;;
+
+(in-package :ccl)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; =
+;; Standard swank startup
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;=
;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (export '(load-swank start-swank-server start-swank-loader stop-swank-l=
oader))
+
+(defun swankvar (name &optional (package :swank))
+ (symbol-value (find-symbol name package)))
+
+(defun (setf swankvar) (value name &optional (package :swank))
+ (let ((sym (find-symbol name package)))
+ (if (null sym)
+ (warn "Couldn't find ~a::~a" package name)
+ (set sym value))))
+
+(defun load-swank (load-path)
+ (when (find-package :swank-loader) (delete-package :swank-loader)) ;; so=
can tell if loaded
+ (load (merge-pathnames load-path "swank-loader.lisp"))
+ (unless (and (find-package :swank-loader)
+ (find-symbol "INIT" :swank-loader))
+ (error "~s is not a swank loader path" load-path))
+ (funcall (find-symbol "INIT" :swank-loader))
+ (unless (and (find-package :swank)
+ (find-symbol "CREATE-SERVER" :swank))
+ (error "Incompatible swank version loaded from ~s" load-path)))
+
+(defun start-swank-server (&key
+ (port (swankvar "DEFAULT-SERVER-PORT"))
+ (debug (swankvar "*LOG-EVENTS*"))
+ (dedicated-output-port (and (swankvar "*USE-DED=
ICATED-OUTPUT-STREAM*")
+ (swankvar "*DEDICAT=
ED-OUTPUT-STREAM-PORT*")))
+ (globally-redirect-io (swankvar "*GLOBALLY-REDI=
RECT-IO*"))
+ (global-debugger (swankvar "*GLOBAL-DEBUGGER*"))
+ (indentation-updates (swankvar "*CONFIGURE-EMAC=
S-INDENTATION*"))
+ (dont-close (swankvar "*DONT-CLOSE*"))
+ (coding-system "iso-latin-1-unix")
+ (style :spawn))
+ "Assuming SWANK is already loaded, create a swank server on the specifie=
d port"
+ (when debug
+ (setf (swankvar "*LOG-EVENTS*" :swank-rpc) t)
+ (setf (swankvar "*SWANK-DEBUG-P*") t)
+ (setf (swankvar "*DEBUG-ON-SWANK-PROTOCOL-ERROR*") t))
+ (when (setf (swankvar "*USE-DEDICATED-OUTPUT-STREAM*") (not (null dedica=
ted-output-port)))
+ (setf (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*") dedicated-output-por=
t))
+ (setf (swankvar "*GLOBALLY-REDIRECT-IO*") globally-redirect-io)
+ (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
+ (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
+ (funcall (find-symbol "CREATE-SERVER" :swank)
+ :style style
+ :port port
+ :dont-close dont-close
+ :coding-system coding-system))
+
+
+(defun swank-port-active? (port)
+ (and (find-package :swank) (getf (swankvar "*LISTENER-SOCKETS*") port)))
+
+
+;; Special ccl slime extension to allow the client to specify the swank pa=
th
+
+(defvar *swank-loader-process* nil)
+(defparameter $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]")
+(defparameter *default-swank-loader-port* 4884)
+
+(defun stop-swank-loader ()
+ (when *swank-loader-process*
+ (process-kill (shiftf *swank-loader-process* nil))))
+
+(defun start-swank-loader (&optional (port *default-swank-loader-port*))
+ (ignore-errors (stop-swank-loader))
+ (let ((semaphore (make-semaphore))
+ (errorp nil))
+ (setq *swank-loader-process*
+ ;; Wait for either a swank client to connect or the special ccl =
slime kludge
+ (process-run-function "Swank Loader"
+ (lambda (sem)
+ (setq *swank-loader-process* *current-pr=
ocess*)
+ (unwind-protect
+ (with-open-socket (socket :connect :=
passive :local-port port
+ :reuse-add=
ress t)
+ (signal-semaphore (shiftf sem nil))
+ (loop
+ (let* ((stream (accept-connectio=
n socket))
+ (line (read-line stream n=
il)))
+ (multiple-value-bind (path por=
t)
+ (parse-em=
acs-ccl-swank-request line)
+ (let ((message (handler-case
+ (if (swan=
k-port-active? port)
+ (format=
nil "Swank is already active on port ~s" port)
+ (progn
+ (load=
-swank path)
+ (star=
t-swank-server :port port)
+ nil))
+ (error (c) =
(princ-to-string c)))))
+ (prin1 `(:active (and (swa=
nk-port-active? port) t)
+ :loader ,=
path
+ :message =
,message
+ :port ,po=
rt)
+ stream)
+ (finish-output stream))))))
+ (when sem ;; in case exit before finis=
hed startup
+ (setq errorp t)
+ (signal-semaphore sem))))
+ semaphore))
+ (wait-on-semaphore semaphore)
+ (when errorp
+ (ignore-errors (process-kill (shiftf *swank-loader-process* nil))))
+ *swank-loader-process*))
+
+(defun parse-emacs-ccl-swank-request (line)
+ (let ((start (length $emacs-ccl-swank-request-marker)))
+ (when (and (< start (length line))
+ (string=3D $emacs-ccl-swank-request-marker line :end2 start=
))
+ (let* ((split-pos (position #\: line :start start))
+ (port (parse-integer line :junk-allowed nil :start start :end=
split-pos))
+ (path-pos (position-if-not #'whitespacep line
+ :start (if split-pos (1+ split-pos=
) start)))
+ (path (subseq line path-pos
+ (1+ (position-if-not #'whitespacep line :from-e=
nd t)))))
+ (values path port)))))
+
+
+
+
More information about the Openmcl-cvs-notifications
mailing list