ultimate-vim/sources_non_forked/slimv/slime/swank/rpc.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*)))

|#