/[slime]/slime/swank-rpc.lisp
ViewVC logotype

Contents of /slime/swank-rpc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sat Oct 9 23:02:33 2010 UTC (3 years, 6 months ago) by rtoy
Branch: MAIN
CVS Tags: SLIME-2-3, FAIRLY-STABLE, byte-stream, SLIME-2-2
Changes since 1.6: +1 -1 lines
Add CODEPOINT-LENGTH function to return the number of codepoints in a
string.  Needed to make sure that Emacs and Lisp agree on the length
of a string.  Emacs wants codepoints and some lisps give code units.
1 ;;; -*- indent-tabs-mode:nil coding:latin-1-unix -*-
2 ;;;
3 ;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems.
4 ;;;
5 ;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
11 (defpackage #:swank-rpc
12 (:use :cl)
13 (:export
14 #:read-message
15 #:swank-reader-error
16 #:swank-reader-error.packet
17 #:swank-reader-error.cause
18 #:write-message))
19
20 (in-package :swank-rpc)
21
22
23 ;;;;; Input
24
25 (define-condition swank-reader-error (reader-error)
26 ((packet :type string :initarg :packet :reader swank-reader-error.packet)
27 (cause :type reader-error :initarg :cause :reader swank-reader-error.cause)))
28
29 (defun read-message (stream package)
30 (let ((packet (read-packet stream)))
31 (handler-case (values (read-form packet package))
32 (reader-error (c)
33 (error (make-condition 'swank-reader-error :packet packet :cause c))))))
34
35 ;; use peek-char to detect EOF, read-sequence may return 0 instead of
36 ;; signaling a condition.
37 (defun read-packet (stream)
38 (peek-char nil stream)
39 (let* ((header (read-chunk stream 6))
40 (length (parse-integer header :radix #x10))
41 (payload (read-chunk stream length)))
42 payload))
43
44 (defun read-chunk (stream length)
45 (let* ((buffer (make-string length))
46 (count (read-sequence buffer stream)))
47 (assert (= count length) () "Short read: length=~D count=~D" length count)
48 buffer))
49
50 ;; FIXME: no one ever tested this and will probably not work.
51 (defparameter *validate-input* nil
52 "Set to true to require input that strictly conforms to the protocol")
53
54 (defun read-form (string package)
55 (with-standard-io-syntax
56 (let ((*package* package))
57 (if *validate-input*
58 (validating-read string)
59 (read-from-string string)))))
60
61 (defun validating-read (string)
62 (with-input-from-string (*standard-input* string)
63 (simple-read)))
64
65 (defun simple-read ()
66 "Read a form that conforms to the protocol, otherwise signal an error."
67 (let ((c (read-char)))
68 (case c
69 (#\" (with-output-to-string (*standard-output*)
70 (loop for c = (read-char) do
71 (case c
72 (#\" (return))
73 (#\\ (write-char (read-char)))
74 (t (write-char c))))))
75 (#\( (loop collect (simple-read)
76 while (ecase (read-char)
77 (#\) nil)
78 (#\space t))))
79 (#\' `(quote ,(simple-read)))
80 (t (let ((string (with-output-to-string (*standard-output*)
81 (loop for ch = c then (read-char nil nil) do
82 (case ch
83 ((nil) (return))
84 (#\\ (write-char (read-char)))
85 ((#\space #\)) (unread-char ch)(return))
86 (t (write-char ch)))))))
87 (cond ((digit-char-p c) (parse-integer string))
88 ((intern string))))))))
89
90
91 ;;;;; Output
92
93 (defun write-message (message package stream)
94 (let* ((string (prin1-to-string-for-emacs message package))
95 (length (swank-backend:codepoint-length string)))
96 (let ((*print-pretty* nil))
97 (format stream "~6,'0x" length))
98 (write-string string stream)
99 (finish-output stream)))
100
101 (defun prin1-to-string-for-emacs (object package)
102 (with-standard-io-syntax
103 (let ((*print-case* :downcase)
104 (*print-readably* nil)
105 (*print-pretty* nil)
106 (*package* package))
107 (prin1-to-string object))))
108
109
110 #| TEST/DEMO:
111
112 (defparameter *transport*
113 (with-output-to-string (out)
114 (write-message '(:message (hello "world")) *package* out)
115 (write-message '(:return 5) *package* out)
116 (write-message '(:emacs-rex NIL) *package* out)))
117
118 *transport*
119
120 (with-input-from-string (in *transport*)
121 (loop while (peek-char T in NIL)
122 collect (read-message in *package*)))
123
124 |#

  ViewVC Help
Powered by ViewVC 1.1.5