forked from pallet/ritz
-
Notifications
You must be signed in to change notification settings - Fork 0
/
swank-rpc.lisp
124 lines (102 loc) · 3.93 KB
/
swank-rpc.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
;;; -*- 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.
;;;
(defpackage #:swank-rpc
(:use :cl)
(:export
#:read-message
#:swank-reader-error
#:swank-reader-error.packet
#:swank-reader-error.cause
#:write-message))
(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 (make-condition 'swank-reader-error :packet packet :cause c))))))
;; use peek-char to detect EOF, read-sequence may return 0 instead of
;; signaling a condition.
(defun read-packet (stream)
(peek-char nil stream)
(let* ((header (read-chunk stream 6))
(length (parse-integer header :radix #x10))
(payload (read-chunk stream length)))
payload))
(defun read-chunk (stream length)
(let* ((buffer (make-string length))
(count (read-sequence buffer stream)))
(assert (= count length) () "Short read: length=~D count=~D" length count)
buffer))
;; FIXME: no one ever tested this and will probably not work.
(defparameter *validate-input* nil
"Set to true to require input that 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
(#\" (with-output-to-string (*standard-output*)
(loop for c = (read-char) do
(case c
(#\" (return))
(#\\ (write-char (read-char)))
(t (write-char c))))))
(#\( (loop collect (simple-read)
while (ecase (read-char)
(#\) nil)
(#\space t))))
(#\' `(quote ,(simple-read)))
(t (let ((string (with-output-to-string (*standard-output*)
(loop for ch = c then (read-char nil nil) do
(case ch
((nil) (return))
(#\\ (write-char (read-char)))
((#\space #\)) (unread-char ch)(return))
(t (write-char ch)))))))
(cond ((digit-char-p c) (parse-integer string))
((intern string))))))))
;;;;; Output
(defun write-message (message package stream)
(let* ((string (prin1-to-string-for-emacs message package))
(length (swank-backend:codepoint-length string)))
(let ((*print-pretty* nil))
(format stream "~6,'0x" length))
(write-string string stream)
(finish-output stream)))
(defun prin1-to-string-for-emacs (object package)
(with-standard-io-syntax
(let ((*print-case* :downcase)
(*print-readably* nil)
(*print-pretty* nil)
(*package* package))
(prin1-to-string 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*)))
|#