/[slime]/slime/cmucl-wire.el
ViewVC logotype

Contents of /slime/cmucl-wire.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sun Sep 14 02:05:43 2003 UTC (10 years, 7 months ago) by lukeg
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +0 -0 lines
FILE REMOVED
Removed.
1 ;;; cmucl-wire.el --- trivial implementation of the CMUCL wire protocol
2
3 ;; Author: Eric Marsden <emarsden@laas.fr>
4 ;; Time-stamp: <2003-08-07 emarsden>
5 ;; Version: 0.1
6 ;; Keywords: comm
7 ;;
8 ;; Copyright (C) 2003 Eric Marsden
9 ;;
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2 of
13 ;; the License, or (at your option) any later version.
14 ;;
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
19 ;;
20 ;; You should have received a copy of the GNU General Public
21 ;; License along with this program; if not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
23 ;; MA 02111-1307, USA.
24 ;;
25 ;; Please send suggestions and bug reports to <emarsden@laas.fr>.
26 ;; The latest version of this package should be available from
27 ;;
28 ;; <URL:http://purl.org/net/emarsden/home/downloads/>
29 ;;
30 ;;
31 ;;; Commentary:
32 ;;
33 ;; Communication with a slave CMUCL using the WIRE protocol. We don't
34 ;; implement the remote-object aspects of the protocol, so the
35 ;; marshaling business is pretty simple.
36 ;;
37 ;; A wire is represented by a buffer, which has an associated network
38 ;; stream with the slave CMUCL. The slave CMUCL has to say
39 ;;
40 ;; (wire:create-request-server port)
41
42
43
44 ;;; Code:
45
46 (require 'cl)
47
48 (defconst +wire-op/funcall+ 6)
49 (defconst +wire-op/number+ 7)
50 (defconst +wire-op/string+ 8)
51 (defconst +wire-op/symbol+ 9)
52 (defconst +wire-op/save+ 10)
53 (defconst +wire-op/lookup+ 11)
54 (defconst +wire-op/cons+ 13)
55
56 (defvar wire-default-package "CL-USER")
57
58 (make-variable-buffer-local
59 (defvar wire-input-marker nil
60 "Marker for the start of unread input."))
61
62 (put 'wire-error
63 'error-conditions
64 '(error wire-error))
65
66 (put 'wire-error 'error-message "Wire error")
67
68 ;; the buffer will contain all wired output from the slave CMUCL
69 (defun wire-connect-to-remote-server (host port success fail)
70 (condition-case nil
71 (let ((process (open-network-stream "CMUCL" nil host port)))
72 (wire-init-process process success fail)
73 process)
74 (file-error
75 (signal 'wire-error (list "Can't connect to wire server")))))
76
77 ;;; building blocks to write "asynchronous" stuff.
78
79 ;; The state of the reader is stored in buffer local variables:
80 ;;
81 ;; - *rstack* ("return stack") contains the functions to be executed.
82 ;; - *stack* stack of argument lists for the functions.
83 ;; - *cont* the next function (to support tail calls)
84 ;; - *args* arguments for *cont*
85 ;; - *success* this function is called when a complete object is read
86 ;; - *fail* called when an errors occurs during reading.
87 ;; - *end-of-file* non-nil when eof was reached (contains condition)
88 ;; - *object-cache*
89 ;;
90 ;; The separation of rstack and stack avoids the creation of closures
91 ;; resp. continuations. The stacks could be implemented as vectors,
92 ;; but are lists for simplicity.
93
94 (defvar *rstack*)
95 (defvar *stack*)
96 (defvar *cont*)
97 (defvar *args*)
98 (defvar *success*)
99 (defvar *fail*)
100 (defvar *end-of-file*)
101 (defvar *object-cache*)
102
103 (defun wire-make-buffer (name)
104 (let ((buffer (generate-new-buffer name)))
105 (with-current-buffer buffer
106 (when (fboundp 'set-buffer-multibyte)
107 (set-buffer-multibyte nil))
108 (buffer-disable-undo))
109 buffer))
110
111 (defun wire-init-process (process success fail)
112 (let ((buffer (wire-make-buffer "*cmucl-wire*")))
113 (set-process-coding-system process 'no-conversion 'no-conversion)
114 (set-process-buffer process buffer)
115 (set-process-filter process 'wire-filter)
116 (set-process-sentinel process 'wire-sentinel)
117 (with-current-buffer buffer
118 (dolist (var '(*rstack*
119 *stack*
120 *cont*
121 *args*
122 *success*
123 *fail*
124 *end-of-file*
125 *object-cache*))
126 (make-local-variable var))
127 (setq *success* success)
128 (setq *fail* fail)
129 (setq *object-cache* (make-hash-table :size 16 :test #'eq))
130 (wire-initialize-stacks))))
131
132 (defun wire-close (wire)
133 (and wire
134 (eq 'open (process-status wire))
135 (kill-buffer (process-buffer wire))))
136
137 (defun wire-filter (wire string)
138 "Insert new data into the wire's buffer *without* moving point."
139 (with-current-buffer (process-buffer wire)
140 (save-excursion
141 (goto-char (point-max))
142 (insert string))
143 (wire-continue)))
144
145 (defun wire-sentinel (process message)
146 (message "wire sentinel: %s" message)
147 (with-current-buffer (process-buffer process)
148 (setq *end-of-file* (list 'wire-error process message))
149 (wire-continue)))
150
151 (defun wire-initialize-stacks ()
152 (setq *rstack* (list 'wire-read-object 'wire-finish))
153 (setq *stack* (list '() '())))
154
155 (defun wire-continue ()
156 (let ((result (wire-read-loop)))
157 (ecase (car result)
158 ((wait quit))
159 (finish
160 (wire-initialize-stacks)
161 (save-current-buffer (funcall *success* (second result)))
162 (wire-continue)))))
163
164 (defun wire-read-loop ()
165 (let ((*cont* (pop *rstack*))
166 (*args* (pop *stack*))
167 (buffer (current-buffer))
168 (error t))
169 (unwind-protect
170 (prog1 (catch 'unloop
171 (while t
172 (apply *cont* *args*)))
173 (setq error nil))
174 (when error
175 (cond ((buffer-live-p buffer)
176 (message "buffer still alive!!"))
177 (t
178 (message "some strange bug")))
179 (debug)))))
180
181 (defun wire-tailcall (fn args)
182 (setq *cont* fn)
183 (setq *args* args))
184
185 (defun wire-bind (producer consumer freevars)
186 (push consumer *rstack*)
187 (push freevars *stack*)
188 (wire-tailcall producer freevars))
189
190 (defun wire-return (arg)
191 (wire-tailcall (pop *rstack*) (cons arg (pop *stack*))))
192
193 (defun wire-finish (value)
194 (assert (null *rstack*))
195 (assert (null *stack*))
196 (throw 'unloop `(finish ,value)))
197
198 (defun wire-cleanup ()
199 (when (get-buffer-process (current-buffer))
200 (delete-process (get-buffer-process (current-buffer))))
201 (kill-buffer (current-buffer))
202 (throw 'unloop '(quit)))
203
204 (defun wire-error (&rest args)
205 (unwind-protect
206 (save-current-buffer
207 (funcall *fail* (etypecase (car args)
208 (string (list 'wire-error (apply #'format args)))
209 (symbol args))))
210 (wire-cleanup)))
211
212 (defun wire-read-byte ()
213 (cond ((eobp)
214 (wire-eat-input)
215 (cond ((and (boundp '*end-of-file*) *end-of-file*)
216 (apply #'wire-error *end-of-file*)
217 (throw 'unloop '(wait)))
218 (t
219 (push #'wire-read-byte *rstack*)
220 (push '() *stack*)
221 (throw 'unloop '(wait)))))
222 (t
223 (forward-char)
224 (wire-return (char-before)))))
225
226 (defun wire-unread-byte (c)
227 (backward-char))
228
229 (defun wire-eat-input ()
230 (unless (bobp)
231 (delete-region (point-min) (1- (point)))))
232
233 (defun wire-expand-bind (v exp body freevars)
234 `(progn
235 (push (lambda (,v ,@freevars)
236 (macrolet ((bind ((v exp) body)
237 (wire-expand-bind
238 v exp body ',(cons v freevars))))
239 ,body))
240 *rstack*)
241 (push (list ,@freevars) *stack*)
242 ,exp))
243
244 ;;; The reader must be carefully written, so that all nececessary
245 ;;; state is saved when the reader "blocks". The macro(let)s below
246 ;;; are intented to simplify this task.
247
248 (defmacro deffn (name args &rest body)
249 `(defun ,name ,args
250 (macrolet ((bind ((v exp) body)
251 (wire-expand-bind v exp body ',args))
252 (call (fn &rest args)
253 `(wire-tailcall ',fn (list ,@args)))
254 (ret (arg)
255 `(wire-return ,arg)))
256 (,@ body))))
257
258 (deffn wire-read-object ()
259 (bind (type (wire-read-byte))
260 (cond ((= type +wire-op/number+)
261 (call wire-read-number))
262 ((= type +wire-op/string+)
263 (call wire-read-string))
264 ((= type +wire-op/symbol+)
265 (call wire-read-symbol))
266 ((= type +wire-op/cons+)
267 (call wire-read-cons))
268 ((= type +wire-op/save+)
269 (call wire-read-save))
270 ((= type +wire-op/lookup+)
271 (call wire-read-lookup))
272 (t
273 (wire-error "Unsupported wire datatype: %S" type)))))
274
275 (deffn wire-read-number ()
276 (bind (b1 (wire-read-byte))
277 (bind (b2-b3-b4 (wire-read-number-aux 2 0))
278 (progn (wire-validate-high-byte b1)
279 (ret (logior (lsh b1 24) b2-b3-b4))))))
280
281 (defun wire-validate-high-byte (byte)
282 (unless (if (zerop (logand byte 128)) ; posivite?
283 (<= byte (eval-when-compile (lsh -1 -25)))
284 (>= byte (eval-when-compile
285 (logand (ash most-negative-fixnum -24)
286 255))))
287 (wire-error "fixnum overlow: %s" byte)))
288
289 (deffn wire-read-number-aux (i accum)
290 (bind (byte (wire-read-byte))
291 (let ((accum (+ (* 256 accum) byte)))
292 (if (zerop i)
293 (ret accum)
294 (call wire-read-number-aux (1- i) accum)))))
295
296 (deffn wire-read-string ()
297 (bind (count (wire-read-number))
298 (call wire-read-string-aux count (make-string count ??))))
299
300 (deffn wire-read-string-aux (remaining string)
301 (if (zerop remaining)
302 (ret string)
303 (bind (char (wire-read-byte))
304 (progn
305 (aset string (- (length string) remaining) char)
306 (call wire-read-string-aux (1- remaining) string)))))
307
308 (deffn wire-read-symbol ()
309 (bind (name (wire-read-string))
310 (bind (package (wire-read-string))
311 (cond ((and (string= name "NIL")
312 (string= package "COMMON-LISP"))
313 (ret 'nil))
314 ((string= package "KEYWORD")
315 (ret (intern (concat ":" name))))
316 (t
317 (ret (intern (format "%s::%s" package name))))))))
318
319 (deffn wire-read-cons ()
320 (bind (car (wire-read-object))
321 (bind (cdr (wire-read-object))
322 (ret (cons car cdr)))))
323
324 (deffn wire-read-save ()
325 (bind (index (wire-read-number))
326 (bind (object (wire-read-object))
327 (progn
328 (setf (gethash index *object-cache*) object)
329 (ret object)))))
330
331 (deffn wire-read-lookup ()
332 (bind (index (wire-read-number))
333 (let ((object (gethash index *object-cache*)))
334 (ret object))))
335
336 ;; === low-level encoding issues ===
337
338 (defun wire-output-byte (wire byte)
339 (process-send-string wire (char-to-string byte)))
340
341 ;; use a separate variable for pos, in case input arrives during
342 ;; the execution of this function
343 (defsubst wire-get-byte (wire)
344 (let ((inhibit-eol-conversion t))
345 (with-current-buffer (process-buffer wire)
346 (goto-char wire-input-marker)
347 (while (eobp)
348 (accept-process-output wire))
349 (forward-char 1)
350 (set-marker wire-input-marker (point))
351 (char-before))))
352
353 (defun wire-output-number (wire number &optional length)
354 (let* ((length (or length 4))
355 (str (make-string length 0))
356 (i (- length 1)))
357 (while (>= i 0)
358 (aset str i (% number 256))
359 (setq number (floor number 256))
360 (decf i))
361 (process-send-string wire str)))
362
363 (defun wire-get-number (wire)
364 (do ((i 4 (- i 1))
365 (accum 0))
366 ((zerop i) accum)
367 (setf accum (+ (* 256 accum) (wire-get-byte wire)))))
368
369 (defun wire-get-symbol (wire)
370 (let ((name (wire-get-string wire))
371 (package (wire-get-string wire)))
372 (intern (format "%s:%s" package name))))
373
374 (defun wire-get-object (wire)
375 (let ((type (wire-get-byte wire)))
376 (cond ((= type +wire-op/number+)
377 (wire-get-number wire))
378 ((= type +wire-op/string+)
379 (wire-get-string wire))
380 ((= type +wire-op/symbol+)
381 (wire-get-symbol wire))
382 (t
383 (error "Unknown wire dataype: %S" type)))))
384
385 ;; Strings are represented by the length as a number, followed by the
386 ;; bytes of the string. Assume that we're dealing with a "simple"
387 ;; string.
388 (defun wire-output-string (wire string)
389 (let ((length (length string)))
390 (wire-output-number wire length)
391 (process-send-string wire string)))
392
393 ;; the first four octets read are the size of the string.
394 (defun wire-get-string (wire)
395 (let ((count (wire-get-number wire)))
396 (when (minusp count)
397 (error "Number overflow in wire-get-string"))
398 (do ((i 0 (+ i 1))
399 (chars (make-string count ?.)))
400 ((= i count) chars)
401 (aset chars i (wire-get-byte wire)))))
402
403 (defun wire-output-object (wire object)
404 (typecase object
405 (integer
406 (wire-output-byte wire +wire-op/number+)
407 (wire-output-number wire object))
408 (string
409 (wire-output-byte wire +wire-op/string+)
410 (wire-output-string wire object))
411 (symbol
412 (wire-output-byte wire +wire-op/symbol+)
413 (wire-output-string wire (wire-symbol-name object))
414 (wire-output-string wire
415 (wire-symbol-package object wire-default-package)))
416 (cons
417 (wire-output-byte wire +wire-op/cons+) ;
418 (wire-output-object wire (car object))
419 (wire-output-object wire (cdr object)))
420 (t
421 (error "Cannot output objects of type %s across a wire."
422 (type-of object))))
423 nil)
424
425 (defun wire-symbol-name (symbol)
426 (let ((n (if (stringp symbol) symbol (symbol-name symbol))))
427 (if (string-match ":\\([^:]*\\)$" n)
428 (match-string 1 n)
429 n)))
430
431 (defun wire-symbol-package (symbol &optional default)
432 (let ((n (if (stringp symbol) symbol (symbol-name symbol))))
433 (if (string-match "^\\([^:]*\\):" n)
434 (match-string 1 n)
435 default)))
436
437 (defun wire-symbol-external-ref-p (symbol)
438 "Does SYMBOL refer to an external symbol?
439 FOO:BAR is an external reference.
440 FOO::BAR is not, and nor is BAR."
441 (let ((name (if (stringp symbol) symbol (symbol-name symbol))))
442 (and (string-match ":" name)
443 (not (string-match "::" name)))))
444
445 ;; send the function and its arguments down the wire as a funcall.
446 (defun wire-output-funcall (wire function &rest args)
447 (let ((num-args (length args)))
448 (wire-output-byte wire +wire-op/funcall+)
449 (wire-output-byte wire num-args)
450 (wire-output-object wire function)
451 (dolist (arg args)
452 (wire-output-object wire arg))
453 nil))
454
455 ;; returns a single value. Note that we send the function name in
456 ;; uppercase, because it doesn't go through the CL reader.
457 (defun wire-remote-eval (wire string package)
458 (wire-output-funcall wire 'SWANK:EVALUATE string package)
459 (let ((status (wire-get-object wire))
460 (condition (wire-get-object wire))
461 (result (wire-get-object wire)))
462 ;; for efficiency, we empty the wire buffer when it gets very large
463 (with-current-buffer (process-buffer wire)
464 (when (> wire-input-marker 100000)
465 (delete-region (point-min) wire-input-marker)))
466 (values status condition result)))
467
468 (provide 'cmucl-wire)
469
470 ;;; cmucl-wire.el ends here

  ViewVC Help
Powered by ViewVC 1.1.5