;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;;; ;;; Touched: Sun Aug 21 10:49:13 2005 +0530 ;;; Time-stamp: <06/01/08 22:49:06 madhu> ;;; Bugs-To: ;;; ;;; CMUCL client for the swank protocol in slime 050819 ;;; (C) 2005 Madhu ALL RIGHTS ~RESEDA~ ;;; ;;; WARNING: meanings of symbols are are different from the `slime.el' ;;; file from which this file is derived. ;;; (defpackage :swank-client (:use :cl)) (in-package :swank-client) (defvar slime-dispatching-connection nil "Network process currently executing. This is dynamically bound while handling messages from Lisp; it overrides `slime-default-connection'.") (defvar slime-default-connection nil "Network connection to use by default. Used for all Lisp communication, except when overridden by `slime-dispatching-connection'") (defvar slime-net-processes nil "List of processes (sockets) connected to Lisps.") (defvar slime-net-coding-system nil ; bogus "*Coding system used for network connections. See also `slime-net-valid-coding-systems'.") (defvar slime-net-valid-coding-systems ; bogus '((iso-latin-1-unix nil :iso-latin-1-unix) (iso-8859-1-unix nil :iso-latin-1-unix) (binary nil :iso-latin-1-unix) (utf-8-unix t :utf-8-unix) (emacs-mule-unix t :emacs-mule-unix)) "A list of valid coding systems. Each element is of the form: (NAME MULTIBYTEP CL-NAME)") (defun slime-secret (&optional (file #p"home:slime-secret") ) ;; broken in cmucl 19c -- touch the file first, madhu 060108 "Finds the magic secret from the user's home directory. Returns nil if the file doesn't exist or is empty; otherwise the first line of the file." (with-open-file (stream file :if-does-not-exist nil) (when stream (read-line stream nil nil)))) ;;; TODO integrate challenge authentication from auth2; crypticl; ;;; ---------------------------------------------------------------------- ;;; ;;; start the server with, say: (swank 9006) ;;; (defun swank (&optional (port 4005) (style nil)) ;;(and style (ecase style ((:fd-handler :sigio :spawn)))) (progn (cl:require 'swank #p"home:/elisp/pkg/slime/swank-loader") (provide 'swank)) #+nil ; damn defsystem require 050312 (cl:load ($p "home:/elisp/pkg/slime/swank-loader")) ;; madhu 050826 (set (cl:find-symbol "*USE-DEDICATED-OUTPUT-STREAM*" :swank) nil) (set (cl:find-symbol "*LOG-EVENTS*" :SWANK) t) (set (cl:find-symbol "*GLOBAL-DEBUGGER*" :SWANK) nil) (set (cl:find-symbol "*GLOBALLY-REDIRECT-IO*" :SWANK) nil) (set (cl:find-symbol "*CONFIGURE-EMACS-INDENTATION*" :SWANK) nil) (unwind-protect (funcall (cl:find-symbol "SETUP-SERVER" :swank) port (lambda (x) (print x) (terpri) (warn "set up ~a" x) (force-output)) style nil ; more crap. :iso-latin-1-unix) (setf *debugger-hook* nil))) ;;; ;;; ;;; (require 'simple-streams) (defun %open-network-connection (host port) "returns a socket simple stream";;; madhu 050826 (make-instance 'stream::socket-simple-stream :remote-host host :remote-port port :direction :io)) ;;; Interface (defun slime-net-connect (host port &optional (set-default-p t)) "Establish a connection with a CL." (let ((socket (%open-network-connection host port) #+nil(ext:connect-to-inet-socket host port :stream))) #+todo (let ((fd (stream::stream-input-handle socket))) (when fd (unix:unix-fcntl fd unix:f-setfl unix:fndelay)) (let ((ofd (stream::stream-output-handle socket))) (when (and ofd (not (= ofd fd))) (unix:unix-fcntl ofd unix:f-setfl unix:fndelay)))) (when set-default-p (setq slime-default-connection socket)) (push socket slime-net-processes) (let ((secret (slime-secret))) (when secret (slime-net-send secret socket) #+ignore (write-line secret socket))) socket)) #+nil (setq $a (slime-net-connect "localhost" 9066)) ;;; Event logging ;;; (defvar slime-log-events t "Log protocol events") (defun slime-log-event (event) "Record the fact that EVENT occurred." (when slime-log-events (warn "log-event: ~S" event))) ;;; ;;; (defun slime-net-encode-length (n) "Encode an integer into a 24-bit hex string." (format nil "~6,'0,X" n)) (defun slime-safe-encoding-p (coding-system string) ; bogus (declare (ignore coding-system string)) t) ;;; dummy package for sending package qualified sexps from LISP ;;; (defvar +null-package+ (let ((package (make-package :null-package :use nil))) package)) ;;; ;;; Interface (defun slime-net-send (sexp proc) "Send a SEXP to Lisp over the socket PROC. This is the lowest level of communication. The sexp will be READ and EVAL'd by Lisp." (let* ((msg (concatenate 'string (let ((*package* +null-package+)) (cl:prin1-to-string sexp)) #+nil (string #\Return))) (string (concatenate 'string (slime-net-encode-length (length msg)) msg)) (coding-system ; XXX (STREAM::STREAM-EXTERNAL-FORMAT proc))) (slime-log-event sexp) (cond ((slime-safe-encoding-p coding-system string) (write-sequence string proc)) (t (error "Coding system ~s not suitable for ~S" coding-system string))))) (defun slime-net-close (process) ;; (when (open-stream-p process) ;XXX (close process :abort t);;) (setq slime-net-processes (remove process slime-net-processes)) (when (eq process slime-default-connection) (setq slime-default-connection nil))) (let* ((max 10240) ; XXX "resourced via closure vars" (seq (make-array 6 :element-type 'character)) (buf (make-array max :element-type 'character :fill-pointer t))) (defun slime-net-read (stream) "Read a message from the network buffer." (read-sequence seq stream) (let ((len (parse-integer seq :radix 16))) (assert (< len max)) (setf (fill-pointer buf) len) (read-sequence buf stream) (let (*read-eval*) (read-from-string buf))))) ;;; Connection environment. values are plists ;;; ;;; (defvar *connection-environment* (make-hash-table :test #'eq)) (defmacro slime-def-connection-var (varname &rest initial-value-and-doc) "Define a connection-local variable. The value of the variable can be read by calling the function of the same name (it must not be accessed directly). The accessor function is setf-able. The actual variable bindings are stored per connection in `*connection-environment*'. The accessor function refers to the binding for `slime-connection'." `(progn ;; Variable (defvar ,varname ,@initial-value-and-doc) ; holds the default! ;; Accessor (defun ,varname (&optional (process slime-dispatching-connection)) (assert process) (getf (gethash process *connection-environment*) ',varname ,varname)) (defsetf ,varname (&optional (process 'slime-dispatching-connection)) (store) `(progn (assert ,process) (setf (getf (gethash ,process *connection-environment*) ',',varname) ,store))) '(,varname))) (slime-def-connection-var slime-connection-number nil "Serial number of a connection. Bound in the connection's process-buffer.") (slime-def-connection-var slime-lisp-features '() "The symbol-names of Lisp's *FEATURES*. This is automatically synchronized from Lisp.") (slime-def-connection-var slime-lisp-package "COMMON-LISP-USER" "The current package name of the Superior lisp. This is automatically synchronized from Lisp.") (slime-def-connection-var slime-lisp-package-prompt-string "CL-USER" "The current package name of the Superior lisp. This is automatically synchronized from Lisp.") (slime-def-connection-var slime-pid nil "The process id of the Lisp process.") (slime-def-connection-var slime-lisp-implementation-type nil "The implementation type of the Lisp process.") (slime-def-connection-var slime-lisp-implementation-version nil "The implementation type of the Lisp process.") (slime-def-connection-var slime-lisp-implementation-type-name nil "The short name for the implementation type of the Lisp process.") (slime-def-connection-var slime-connection-name nil "The short name for connection.") (slime-def-connection-var slime-symbolic-lisp-name nil "The symbolic name passed to slime when starting connection.") (slime-def-connection-var slime-inferior-process nil "The inferior process for the connection if any.") (slime-def-connection-var slime-communication-style nil "The communication style.") (slime-def-connection-var slime-machine-instance nil "The name of the (remote) machine running the Lisp process.") ;;; Connection setup ;;; ;;; (defvar slime-connection-counter 0 "The number of SLIME connections made. For generating serial numbers.") (defun slime-generate-connection-name (lisp-name) (loop for i from 1 for name = lisp-name then (format nil "~a<~d>" lisp-name i) while (find name slime-net-processes :key #'slime-connection-name :test #'equal) finally (return name))) (defun slime-generate-symbolic-lisp-name (lisp-name) (if lisp-name (loop for i from 1 for name = lisp-name then (format nil "~a<~d>" lisp-name i) while (find name slime-net-processes :key #'slime-symbolic-lisp-name :test #'equal) finally (return name)))) (defun slime-set-connection-info (connection info) "Initialize CONNECTION with INFO received from Lisp." (destructuring-bind (pid type name features style version host) info (setf (slime-pid) pid (slime-lisp-implementation-type) type (slime-lisp-implementation-type-name) name (slime-connection-name) (slime-generate-connection-name name) (slime-lisp-features) features (slime-communication-style) style (slime-lisp-implementation-version) version (slime-machine-instance) host)) (warn "Connected. ~S: ~S" connection info)) ;;; Evaluation bits (defmacro destructure-case (value &rest patterns) "Dispatch VALUE to one of PATTERNS. A cross between `case' and `destructuring-bind'. The pattern syntax is: ((HEAD . ARGS) . BODY) The list of patterns is searched for a HEAD `eq' to the car of VALUE. If one is found, the BODY is executed with ARGS bound to the corresponding values in the CDR of VALUE." (let ((operator (gensym "op-")) (operands (gensym "rand-")) (tmp (gensym "tmp-"))) `(let* ((,tmp ,value) (,operator (car ,tmp)) (,operands (cdr ,tmp))) (case ,operator ,@(mapcar (lambda (clause) (if (eq (car clause) t) `(t ,@(cdr clause)) (destructuring-bind ((op &rest rands) &rest body) clause `(,op (destructuring-bind ,rands ,operands . ,body))))) patterns) ,@(if (eq (caar (last patterns)) t) '() `((t (error "destructure-case failed: ~S" ,tmp)))))))) ;; ;; (defun dummy-warn (&rest rest) (format t "~a" rest)) (defun slime-connection () "Return the connection to use for Lisp interaction. Signal an error if there's no connection." (or slime-dispatching-connection slime-default-connection (error "No default connection selected."))) (defun slime-send (sexp) "Send SEXP directly over the wire on the current connection." (slime-net-send sexp (slime-connection)) ; XXX (force-output (slime-connection))) ;;; ;;; ;;; (slime-def-connection-var slime-rex-continuations '() "List of (ID . FUNCTION) continuations waiting for RPC results.") (slime-def-connection-var slime-continuation-counter 0 "Continuation serial number counter.") ;;; XXX Modified slime-current-package and slime-current-thread semantics (slime-def-connection-var slime-current-package "COMMON-LISP-USER" "The Lisp package associated with the current buffer. This is set only in buffers bound to specific packages.") ; XXX (slime-def-connection-var slime-current-thread t "The id of the current thread on the Lisp side. t means the \"current\" thread;") ; XXX (defvar slime-current-output-id nil "The id of the current repl output. This variable is rebound by the :RETURN event handler and used by slime-repl-insert-prompt.") ;;;;; Protocol event handler (the guts) (defun slime-dispatch-event (event &optional process) (let ((slime-dispatching-connection (or process (slime-connection)))) (assert slime-dispatching-connection) (destructure-case event ((:write-string output) (dummy-warn 'slime-write-string output)) ((:read-output output) (dummy-warn 'slime-output-string output)) ((:presentation-start id) (dummy-warn 'slime-mark-presentation-start id)) ((:presentation-end id) (dummy-warn 'slime-mark-presentation-end id)) ;; ((:emacs-rex form package thread continuation) (dummy-warn 'slime-set-state "|eval...") #+todo (when (and (slime-use-sigint-for-interrupt) (slime-busy-p)) (message "; pipelined request... %S" form)) (let ((id (incf (slime-continuation-counter)))) (push (cons id continuation) (slime-rex-continuations)) (slime-send `(:emacs-rex ,form ,package ,thread ,id)))) ((:return value id) (let ((rec (assoc id (slime-rex-continuations) :test #'eq))) (cond (rec (setf (slime-rex-continuations ) (remove rec (slime-rex-continuations))) (when (null (slime-rex-continuations)) ;; eval done ) (let ((slime-current-output-id id)) ;; this is not very ;; elegant but it avoids changing the protocol #+NIL(warn "TODO: (FUNCALL (CDR REC) VALUE) ~&(funcall ~a ~a)" (cdr rec) value) (funcall (cdr rec) value))) (t (error "Unexpected reply: ~S ~S" id value))))) ((:debug-activate thread level) (assert thread) (dummy-warn 'sldb-activate thread level)) ((:debug thread level condition restarts frames conts) (assert thread) (dummy-warn 'sldb-setup thread level condition restarts frames conts)) ((:debug-return thread level &optional stepping) (assert thread) (dummy-warn 'sldb-exit thread level stepping)) ((:emacs-interrupt thread) (cond #+todo((slime-use-sigint-for-interrupt) (slime-send-sigint)) (t (slime-send `(:emacs-interrupt ,thread))))) ((:read-string thread tag) (assert thread) (dummy-warn 'slime-repl-read-string thread tag)) ((:evaluate-in-emacs string thread tag) (assert thread) (dummy-warn 'evaluate-in-emacs (car (read-from-string string)) thread tag)) ((:read-aborted thread tag) (assert thread) (dummy-warn 'slime-repl-abort-read thread tag)) ((:emacs-return-string thread tag string) (slime-send `(:emacs-return-string ,thread ,tag ,string))) ;; ((:new-package package prompt-string) (setf (slime-lisp-package) package) (setf (slime-lisp-package-prompt-string) prompt-string)) ((:new-features features) (setf (slime-lisp-features) features)) ((:indentation-update info) (dummy-warn 'slime-handle-indentation-update info)) ((:open-dedicated-output-stream port) (dummy-warn 'slime-open-stream-to-lisp port)) ((:eval-no-wait fun args) (dummy-warn ':eval-no-wait fun args) #+nil (apply (intern fun) args)) ((:eval thread tag fun args) (dummy-warn 'slime-eval-for-lisp thread tag (intern fun) args)) ((:emacs-return thread tag value) (slime-send `(:emacs-return ,thread ,tag ,value))) ((:ed what) (dummy-warn 'slime-ed what)) ((:debug-condition thread message) (assert thread) (warn "debug-condition: (thread ~a) ~a" thread message))))) ;;; XXX cannot trace! #+nil (untrace slime-dispatch-event) (defmacro slime-rex ((&rest saved-vars) (sexp &optional (package '(slime-current-package (slime-connection))) (thread '(slime-current-thread (slime-connection))) ) &rest continuations) "(slime-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) Remote EXecute SEXP. VARs are a list of saved variables visible in the other forms. Each VAR is either a symbol or a list (VAR INIT-VALUE). SEXP is evaluated and the princed version is sent to Lisp. PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. The default value is (slime-current-package). CONTINUATIONS are a list of patterns with same syntax as `destructure-case'. The result of the evaluation is dispatched on CLAUSES. The result is either a sexp of the form (:ok VALUE) or (:abort). CONTINUATIONS are executed asynchronously. ;;;Note: don't use backquote syntax for SEXP, because Emacs20 cannot ;;;deal with that." (let ((result (gensym))) `(let ,(loop for var in saved-vars collect (etypecase var (symbol (list var var)) (cons var))) (slime-dispatch-event (list :emacs-rex ,sexp ,package ,thread (lambda (,result) (destructure-case ,result ,@continuations))))))) (defun slime-eval-async (sexp &optional cont package) "Evaluate SEXP on the superior Lisp and call CONT with the result." (slime-rex (cont) (sexp (or package (slime-current-package (slime-connection)))) ((:ok result) (when cont (funcall cont result))) ((:abort) (warn "Evaluation aborted.")))) (defun %process-available-input-1 (stream) (when (listen stream) (let ((event (slime-net-read stream))) (values (slime-dispatch-event event stream) t)))) (defun %process-available-input (stream) ; blocking (let ((event (slime-net-read stream))) (values (slime-dispatch-event event stream) t))) ;; back to connections ;; (defun slime-init-connection-state (proc symbolic-lisp-name) "Initialize connection state in the process-buffer of PROC." ;; To make life simpler for the user: if this is the only open ;; connection then reset the connection counter. (when (equal slime-net-processes (list proc)) (setq slime-connection-counter 0)) (setf (slime-connection-number proc) (incf slime-connection-counter)) (setf (slime-symbolic-lisp-name proc) (slime-generate-symbolic-lisp-name symbolic-lisp-name)) ;; We do our initialization asynchronously. The current function may ;; be called from a timer, and if we setup the REPL from a timer ;; then it mysteriously uses the wrong keymap for the first command. (slime-eval-async '(swank:connection-info) (lambda (info) (slime-set-connection-info proc info)))) ;;; Interface (defun slime-setup-connection (process symbolic-lisp-name) "Make a connection out of PROCESS." (let ((slime-dispatching-connection process)) (slime-init-connection-state process symbolic-lisp-name) process)) ;;; Synchronous requests are implemented in terms of asynchronous ;;; ones. We make an asynchronous request with a continuation function ;;; that `throw's its result up to a `catch' and then enter a loop of ;;; handling I/O until that happens. (defvar slime-stack-eval-tags nil "List of stack-tags of continuations waiting on the stack.") (defun slime-eval (sexp &optional package) "Evaluate SEXP on the superior Lisp and return the result." (when (null package) (setq package (slime-current-package (slime-connection)))) (let* ((tag (gensym "slime-result-")) (slime-stack-eval-tags (cons tag slime-stack-eval-tags)) (goose (catch tag (slime-rex (tag sexp) (sexp package) ((:ok value) (unless (member tag slime-stack-eval-tags) (error "tag = ~S eval-tags = ~S sexp = ~S" tag slime-stack-eval-tags sexp)) (throw tag (list #'identity value))) ((:abort) (throw tag (list #'error "Synchronous Lisp Evaluation aborted.")))) (loop ;; block, discarding results (%process-available-input (slime-connection)))))) (assert goose) (apply #'funcall goose))) (defun slime-reset (&optional (slime-dispatching-connection ; XXX (slime-connection))) "Clear all pending continuations." (setf (slime-rex-continuations) '())) (defun slime-quit-lisp () "Quit lisp, kill the inferior process and associated buffers." (slime-eval-async '(swank:quit-lisp))) (defun sldb-quit () "Quit to toplevel." (slime-eval-async '(swank:throw-to-toplevel) (lambda (_) (declare (ignore _)) (error "sldb-quit returned")))) (defun slime-disconnect () "Disconnect all connections." (mapcar #'slime-net-close slime-net-processes)) (defun slime-interrupt () "Interrupt Lisp." (slime-dispatch-event `(:emacs-interrupt ,(slime-current-thread (slime-connection))))) (defun slime-ping () "Check that communication works." (format t "~s" (slime-eval "PONG"))) #|| SYNOPSIS ;; on one lisp (%open-swank-server 9006) ;; on the other this our lisp (setq $a (slime-net-connect "localhost" 9006)) ; sets default (slime-eval '(cl:+ 2 3)) ;;etc. (slime-interrupt) ;; sink (loop for (last-gander last-gander-p) = (list nil nil) then (list gander gander-p) for (gander gander-p) = (multiple-value-list (%process-available-input-1 (slime-connection))) unless gander-p return last-gander) (sldb-quit) (mapcar #'finish-output slime-net-processes) (stream:stream-input-handle $a) (slime-eval-async '(cl:+ 2 3) #'identity) (slime-disconnect) (cons 'trace (loop for x being the external-symbols of :swank-backend if (fboundp x) collect x)) ||# ;;; Still doesnt work with CLISP running the server. SWANK SUCKS for ;;; all the trouble in `portability's name. ;;; ;;; Elisp: ;;; (put 'slime-def-connection-var 'lisp-indent-function 2) ;;; (put 'destructure-case 'lisp-indent-function 1)