Index: /trunk/source/cocoa-ide/preferences.lisp =================================================================== --- /trunk/source/cocoa-ide/preferences.lisp (revision 15020) +++ /trunk/source/cocoa-ide/preferences.lisp (revision 15021) @@ -143,6 +143,5 @@ sender) (declare (ignore sender)) - (unless (or *ccl-swank-active-p* - (maybe-start-swank-listener :override-user-preference t)) + (unless (maybe-start-swank-listener :override-user-preference t) (alert-window :message "Unable to start the Swank server."))) Index: /trunk/source/cocoa-ide/swank-listener.lisp =================================================================== --- /trunk/source/cocoa-ide/swank-listener.lisp (revision 15020) +++ /trunk/source/cocoa-ide/swank-listener.lisp (revision 15021) @@ -1,3 +1,18 @@ ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*- +;;; +;;; 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 + ;;;; *********************************************************************** ;;;; FILE IDENTIFICATION @@ -15,16 +30,6 @@ (in-package :GUI) -(defparameter *ccl-swank-active-p* nil) +(defparameter *active-gui-swank-listener-port* nil) (defparameter *default-swank-listener-port* 4884) -(defparameter *active-gui-swank-listener-port* nil) -(defparameter *ccl-swank-listener-active-p* nil) -(defvar *swank-listener-process* nil) - -(defun swank-listener-active? () - (and *swank-listener-process* - (typep *swank-listener-process* 'process) - (not (member (process-whostate *swank-listener-process*) - '("Reset" "Exhausted") - :test 'string-equal)))) ;;; preference-swank-listener-port @@ -33,5 +38,5 @@ (with-autorelease-pool (let* ((defaults (handler-case (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)) - (serious-condition (c) + (error (c) (progn (log-debug "~%ERROR: Unable to get preferences from the Shared User Defaults Controller: ~A" c) @@ -48,7 +53,6 @@ (or port *default-swank-listener-port*)) ;; parsing the port number failed - (serious-condition (c) + (error (c) (declare (ignore c)) - (setf *ccl-swank-listener-active-p* nil) (#_NSLog #@"\nError starting swank listener; the user preference is not a valid port number: %@\n" :id swank-port-pref) @@ -66,5 +70,5 @@ (with-autorelease-pool (let* ((defaults (handler-case (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller)) - (serious-condition (c) + (error (c) (progn (log-debug "~%ERROR: Unable to get preferences from the Shared User Defaults Controller: ~a" c) nil)))) @@ -99,118 +103,4 @@ nil)))))) -;;; start-swank-listener -;;; ----------------------------------------------------------------- -;;; starts up CCL's swank-listener server on the specified port - -;;; aux utils - -(defvar $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]") - -(defvar $last-swank-message-sent nil) - -(defun swank-server-running? () - (and (find-package :swank) - (let ((active-listeners (symbol-value (intern "*LISTENER-SOCKETS*" :swank)))) - (and (not (null active-listeners)) - (first active-listeners))))) - -(defstruct (swank-status (:conc-name swank-)) - (active? nil :read-only t) - (message nil :read-only t) - (requested-loader nil :read-only t) - (requested-port nil :read-only t)) - -(defun read-swank-ping (tcp-stream) - (read-line tcp-stream nil nil nil)) - -(defun parse-swank-ping (p) - (let ((sentinel-end (length $emacs-ccl-swank-request-marker))) - (if (typep p 'string) - (if (string= p $emacs-ccl-swank-request-marker :start1 0 :end1 sentinel-end) - (let* ((request (subseq p sentinel-end)) - (split-pos (position #\: request)) - (port-str (if split-pos - (subseq request 0 split-pos) - nil)) - (port (when port-str (parse-integer port-str :junk-allowed nil))) - (path-str (if split-pos - (subseq request (1+ split-pos)) - request))) - (values (string-trim '(#\space #\tab #\return #\newline) path-str) port)) - nil) - nil))) - - -(defun load-and-start-swank (path requested-port) - (handler-case (let* ((active-swank-port (swank-server-running?)) - (msg (format nil "A swank server is already running on port ~A" active-swank-port))) - (if active-swank-port - (progn - (log-debug msg) - (make-swank-status :active? t :message msg :requested-loader path :requested-port requested-port)) - (progn - (load path) - (let ((swank-loader-package (find-package :swank-loader))) - (if swank-loader-package - ;; swank loaded. start the server - (progn - (funcall (intern "LOAD-SWANK" swank-loader-package)) - (funcall (intern "CREATE-SERVER" (find-package :swank)) :port requested-port :dont-close t) - (make-swank-status :active? t :requested-loader path :requested-port requested-port)) - ;; swank failed to load. return failure status - (make-swank-status :active? nil :message "swank load failed" :requested-loader path :requested-port requested-port)))))) - (ccl::socket-creation-error (e) (log-debug "Unable to start a swank server on port: ~A; ~A" - requested-port e) - (make-swank-status :active? nil :message "socket-creation error" - :requested-loader path :requested-port requested-port)) - (serious-condition (e) (log-debug "There was a problem creating the swank server on port ~A: ~A" - requested-port e) - (make-swank-status :active? nil :message "error loading or starting swank" - :requested-loader path :requested-port requested-port)))) - -(defun swank-ready? (status) - (swank-active? status)) - -(defun send-swank-response (tcp-stream status) - (let ((response - (let ((*print-case* :downcase)) - (format nil "(:active ~S :loader ~S :message ~S :port ~D)" - (swank-active? status) - (swank-requested-loader status) - (swank-message status) - (swank-requested-port status))))) - (format tcp-stream response) - (finish-output tcp-stream))) - -(defun handle-swank-client (c) - (let* ((msg (read-swank-ping c))) - (multiple-value-bind (swank-path requested-port) - (parse-swank-ping msg) - (load-and-start-swank swank-path requested-port)))) - -(defun stop-swank-listener () - (process-kill *swank-listener-process*) - (setq *swank-listener-process* nil)) - -;;; the real deal -;;; if it succeeds, it returns a PROCESS object -;;; if it fails, it returns a CONDITION object -(defun start-swank-listener (&optional (port *default-swank-listener-port*)) - (handler-case - (if (swank-listener-active?) - (log-debug "in start-swank-listener: the swank listener process is already running") - (setq *swank-listener-process* - (process-run-function "Swank Listener" - #'(lambda () - (with-open-socket (sock :type :stream :connect :passive - :local-port port :reuse-address t :auto-close t) - (loop - (let* ((client-sock (accept-connection sock)) - (status (handle-swank-client client-sock))) - (send-swank-response client-sock status)))))))) - (ccl::socket-creation-error (c) (nslog-condition c "Unable to create a socket for the swank-listener: ") c) - (ccl::socket-error (c) (nslog-condition c "Swank-listener failed trying to accept a client connection: ") c) - (serious-condition (c) (nslog-condition c "Error starting in the swank-listener:") c))) - ;;; maybe-start-swank-listener ;;; ----------------------------------------------------------------- @@ -218,5 +108,4 @@ ;;; warranted. (defun maybe-start-swank-listener (&key (override-user-preference nil)) - (unless *ccl-swank-listener-active-p* ;; try to determine the user preferences concerning the ;; swank-listener port number and whether the swank listener @@ -225,27 +114,14 @@ (let* ((start-swank-listener? (or (preference-start-swank-listener?) override-user-preference)) (swank-listener-port (or (preference-swank-listener-port) *default-swank-listener-port*))) - (if (and start-swank-listener? swank-listener-port) - ;; try to start the swank listener - (handler-case (let ((swank-listener (start-swank-listener swank-listener-port))) - (if (typep swank-listener 'process) - (progn - (setf *active-gui-swank-listener-port* swank-listener-port) - (setf *ccl-swank-listener-active-p* t) - swank-listener-port) - (progn - (setf *active-gui-swank-listener-port* nil) - (setf *ccl-swank-listener-active-p* nil) - nil))) - ;; swank listener creation failed - (serious-condition (c) - (setf *active-gui-swank-listener-port* nil) - (setf *ccl-swank-listener-active-p* nil) - (log-debug "~%Error starting swank listener: ~A~%" c) - nil)) - ;; don't try to start the swank listener - (progn - (setf *active-gui-swank-listener-port* nil) - (setf *ccl-swank-listener-active-p* nil) - nil))))) + (unless (and start-swank-listener? + (eql swank-listener-port *active-gui-swank-listener-port*) + ccl::*swank-loader-process* + (not (process-exhausted-p ccl::*swank-loader-process*))) + (ccl::stop-swank-loader) + (setf *active-gui-swank-listener-port* nil) + (when (and start-swank-listener? + swank-listener-port + (ccl::start-swank-loader swank-listener-port)) + (setf *active-gui-swank-listener-port* swank-listener-port))))) (provide :swank-listener) Index: /trunk/source/level-1/l1-boot-2.lisp =================================================================== --- /trunk/source/level-1/l1-boot-2.lisp (revision 15020) +++ /trunk/source/level-1/l1-boot-2.lisp (revision 15021) @@ -353,4 +353,5 @@ (bin-load-provide "CORE-FILES" "core-files") (bin-load-provide "DOMINANCE" "dominance") + (bin-load-provide "REMOTE-LISP" "remote-lisp") (bin-load-provide "MCL-COMPAT" "mcl-compat") (require "LOOP") Index: /trunk/source/lib/compile-ccl.lisp =================================================================== --- /trunk/source/lib/compile-ccl.lisp (revision 15020) +++ /trunk/source/lib/compile-ccl.lisp (revision 15021) @@ -230,4 +230,5 @@ core-files dominance + remote-lisp ;; asdf has peculiar compile-time side-effects ;;asdf Index: /trunk/source/lib/systems.lisp =================================================================== --- /trunk/source/lib/systems.lisp (revision 15020) +++ /trunk/source/lib/systems.lisp (revision 15021) @@ -227,4 +227,5 @@ (core-files "ccl:bin;core-files" ("ccl:library;core-files.lisp")) (dominance "ccl:bin;dominance" ("ccl:library;dominance.lisp")) + (remote-lisp "ccl:bin;remote-lisp" ("ccl:library;remote-lisp.lisp")) (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp")) Index: /trunk/source/library/remote-lisp.lisp =================================================================== --- /trunk/source/library/remote-lisp.lisp (revision 15021) +++ /trunk/source/library/remote-lisp.lisp (revision 15021) @@ -0,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) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Server-side SWANK support +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader)) + +(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-DEDICATED-OUTPUT-STREAM*") + (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*"))) + (globally-redirect-io (swankvar "*GLOBALLY-REDIRECT-IO*")) + (global-debugger (swankvar "*GLOBAL-DEBUGGER*")) + (indentation-updates (swankvar "*CONFIGURE-EMACS-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 specified 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 dedicated-output-port))) + (setf (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*") dedicated-output-port)) + (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 path + +(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-process*) + (unwind-protect + (with-open-socket (socket :connect :passive :local-port port + :reuse-address t) + (signal-semaphore (shiftf sem nil)) + (loop + (let* ((stream (accept-connection socket)) + (line (read-line stream nil))) + (multiple-value-bind (path port) + (parse-emacs-ccl-swank-request line) + (let ((message (handler-case + (if (swank-port-active? port) + (format nil "Swank is already active on port ~s" port) + (progn + (load-swank path) + (start-swank-server :port port) + nil)) + (error (c) (princ-to-string c))))) + (prin1 `(:active (and (swank-port-active? port) t) + :loader ,path + :message ,message + :port ,port) + stream) + (finish-output stream)))))) + (when sem ;; in case exit before finished 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= $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-end t))))) + (values path port))))) + + + +