162 lines
5.2 KiB
Common Lisp
162 lines
5.2 KiB
Common Lisp
;;; -*- 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*)))
|
||
|
||
|#
|