diff options
Diffstat (limited to 'vim/bundle/slimv/slime/swank/rpc.lisp')
-rw-r--r-- | vim/bundle/slimv/slime/swank/rpc.lisp | 162 |
1 files changed, 162 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/swank/rpc.lisp b/vim/bundle/slimv/slime/swank/rpc.lisp new file mode 100644 index 0000000..e30cc2c --- /dev/null +++ b/vim/bundle/slimv/slime/swank/rpc.lisp @@ -0,0 +1,162 @@ +;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- +;;; +;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. +;;; +;;; Created 2010, Terje Norderhaug <terje@in-progress.com> +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package swank/rpc) + + +;;;;; Input + +(define-condition swank-reader-error (reader-error) + ((packet :type string :initarg :packet + :reader swank-reader-error.packet) + (cause :type reader-error :initarg :cause + :reader swank-reader-error.cause))) + +(defun read-message (stream package) + (let ((packet (read-packet stream))) + (handler-case (values (read-form packet package)) + (reader-error (c) + (error 'swank-reader-error + :packet packet :cause c))))) + +(defun read-packet (stream) + (let* ((length (parse-header stream)) + (octets (read-chunk stream length))) + (handler-case (swank/backend:utf8-to-string octets) + (error (c) + (error 'swank-reader-error + :packet (asciify octets) + :cause c))))) + +(defun asciify (packet) + (with-output-to-string (*standard-output*) + (loop for code across (etypecase packet + (string (map 'vector #'char-code packet)) + (vector packet)) + do (cond ((<= code #x7f) (write-char (code-char code))) + (t (format t "\\x~x" code)))))) + +(defun parse-header (stream) + (parse-integer (map 'string #'code-char (read-chunk stream 6)) + :radix 16)) + +(defun read-chunk (stream length) + (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) + (count (read-sequence buffer stream))) + (cond ((= count length) + buffer) + ((zerop count) + (error 'end-of-file :stream stream)) + (t + (error "Short read: length=~D count=~D" length count))))) + +(defparameter *validate-input* nil + "Set to true to require input that more strictly conforms to the protocol") + +(defun read-form (string package) + (with-standard-io-syntax + (let ((*package* package)) + (if *validate-input* + (validating-read string) + (read-from-string string))))) + +(defun validating-read (string) + (with-input-from-string (*standard-input* string) + (simple-read))) + +(defun simple-read () + "Read a form that conforms to the protocol, otherwise signal an error." + (let ((c (read-char))) + (case c + (#\( (loop collect (simple-read) + while (ecase (read-char) + (#\) nil) + (#\space t)))) + (#\' `(quote ,(simple-read))) + (t + (cond + ((digit-char-p c) + (parse-integer + (map 'simple-string #'identity + (loop for ch = c then (read-char nil nil) + while (and ch (digit-char-p ch)) + collect ch + finally (unread-char ch))))) + ((or (member c '(#\: #\")) (alpha-char-p c)) + (unread-char c) + (read-preserving-whitespace)) + (t (error "Invalid character ~:c" c))))))) + + +;;;;; Output + +(defun write-message (message package stream) + (let* ((string (prin1-to-string-for-emacs message package)) + (octets (handler-case (swank/backend:string-to-utf8 string) + (error (c) (encoding-error c string)))) + (length (length octets))) + (write-header stream length) + (write-sequence octets stream) + (finish-output stream))) + +;; FIXME: for now just tell emacs that we and an encoding problem. +(defun encoding-error (condition string) + (swank/backend:string-to-utf8 + (prin1-to-string-for-emacs + `(:reader-error + ,(asciify string) + ,(format nil "Error during string-to-utf8: ~a" + (or (ignore-errors (asciify (princ-to-string condition))) + (asciify (princ-to-string (type-of condition)))))) + (find-package :cl)))) + +(defun write-header (stream length) + (declare (type (unsigned-byte 24) length)) + ;;(format *trace-output* "length: ~d (#x~x)~%" length length) + (loop for c across (format nil "~6,'0x" length) + do (write-byte (char-code c) stream))) + +(defun switch-to-double-floats (x) + (typecase x + (double-float x) + (float (coerce x 'double-float)) + (null x) + (list (loop for (x . cdr) on x + collect (switch-to-double-floats x) into result + until (atom cdr) + finally (return (append result (switch-to-double-floats cdr))))) + (t x))) + +(defun prin1-to-string-for-emacs (object package) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* package) + ;; Emacs has only double floats. + (*read-default-float-format* 'double-float)) + (prin1-to-string (switch-to-double-floats object))))) + + +#| TEST/DEMO: + +(defparameter *transport* + (with-output-to-string (out) + (write-message '(:message (hello "world")) *package* out) + (write-message '(:return 5) *package* out) + (write-message '(:emacs-rex NIL) *package* out))) + +*transport* + +(with-input-from-string (in *transport*) + (loop while (peek-char T in NIL) + collect (read-message in *package*))) + +|# |