/[cmucl]/src/motif/lisp/transport.lisp
ViewVC logotype

Contents of /src/motif/lisp/transport.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Feb 15 11:59:24 2000 UTC (14 years, 2 months ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +34 -16 lines
Final installment of support for multi-packet messages and read/write
long strings. Tested using text-get-string and text-set-string. I don't
yet know what other functions may need to use multiple-packet messages.
1 ;;;; -*- Mode: Lisp ; Package: Toolkit-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/motif/lisp/transport.lisp,v 1.4 2000/02/15 11:59:24 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Michael Garland
13 ;;;
14 ;;; Code for transporting packets and messages between the C toolkit server
15 ;;; and the Lisp client.
16 ;;;
17
18 (in-package "TOOLKIT-INTERNALS")
19
20
21
22 ;;;; Data structures
23
24 (defconstant *header-size* 12)
25
26 (defstruct (packet
27 (:print-function print-packet)
28 (:constructor make-packet (head)))
29 (head nil :type system:system-area-pointer)
30 (fill *header-size* :type fixnum)
31 (next nil :type (or null packet)))
32
33 (defstruct (message
34 (:print-function print-message)
35 (:constructor %make-message))
36 (packet-count 0 :type fixnum)
37 (serial (the fixnum 0) :type (unsigned-byte 32))
38 (fill-packet nil :type (or null packet))
39 ;;
40 ;; NOTE: This list contains the constituent packets in REVERSE order
41 ;; while the message is being constructed. When it is finished, the list
42 ;; is reversed.
43 (packet-list nil :type list))
44
45 (defun print-packet (p stream d)
46 (declare (ignore p d))
47 (write-string "#<X Toolkit Packet>" stream))
48
49 (defun print-message (r stream d)
50 (declare (ignore d)
51 (stream stream))
52 (format stream "#<X Toolkit Message - serial ~d>"(message-serial r)))
53
54 (defconstant *packet-size* 4096)
55
56 (deftype packet-index () `(integer 0 ,*packet-size*))
57
58
59
60 ;;;; Memory management and packet accessors
61
62 (defmacro packet-serial (packet)
63 `(the (signed-byte 29) (system:signed-sap-ref-32 (packet-head ,packet) 0)))
64
65 (defmacro packet-sequence-number (packet)
66 `(system:signed-sap-ref-16 (packet-head ,packet) 4))
67
68 (defmacro packet-sequence-length (packet)
69 `(system:signed-sap-ref-16 (packet-head ,packet) 6))
70
71 (defmacro packet-length (packet)
72 `(the packet-index (system:signed-sap-ref-32 (packet-head ,packet) 8)))
73
74
75 ;;; Free-list for keeping empty packet husks around.
76 (defvar *free-packets* nil)
77
78 (defun create-packet ()
79 (if *free-packets*
80 (let ((packet *free-packets*))
81 (setf *free-packets* (packet-next packet))
82 (setf (packet-length packet) *header-size*)
83 (setf (packet-fill packet) *header-size*)
84 packet)
85 (let* ((buffer (system:allocate-system-memory *packet-size*))
86 (packet (make-packet buffer)))
87 (setf (packet-length packet) *header-size*)
88 packet)))
89
90 (defun destroy-packet (packet)
91 (setf (packet-next packet) *free-packets*)
92 (setf *free-packets* packet))
93
94 (declaim (inline make-message))
95 (defun make-message (serial)
96 (declare (type (unsigned-byte 29) serial))
97 (let ((message (%make-message)))
98 (setf (message-serial message) serial)
99 message))
100
101
102
103
104 ;;;; Functions to stuff things into packets
105
106 (macrolet ((def-packet-writer (name size)
107 (let ((sap-ref (ecase size
108 (1 'system:sap-ref-8)
109 (2 'system:sap-ref-16)
110 (4 'system:sap-ref-32)))
111 (bits (* size 8)))
112 `(defun ,name (packet data)
113 (declare (type (or (signed-byte ,bits)
114 (unsigned-byte ,bits)) data))
115 (let ((fill (system:sap+ (packet-head packet)
116 (packet-fill packet))))
117 (setf (,sap-ref fill 0) data)
118 (incf (packet-fill packet) ,size)
119 (incf (packet-length packet) ,size)))))
120 (def-packet-reader (name size)
121 (let ((sap-ref (ecase size
122 (1 'system:sap-ref-8)
123 (2 'system:sap-ref-16)
124 (4 'system:sap-ref-32)))
125 (bits (* size 8)))
126 `(defun ,name (packet)
127 (let* ((fill (system:sap+ (packet-head packet)
128 (packet-fill packet)))
129 (data (,sap-ref fill 0)))
130 (declare (type (or (signed-byte ,bits)
131 (unsigned-byte ,bits)) data))
132 (incf (packet-fill packet) ,size)
133 data)))))
134 (def-packet-writer packet-put-byte 1)
135 (def-packet-writer packet-put-word 2)
136 (def-packet-writer packet-put-dblword 4)
137
138 (def-packet-reader packet-get-byte 1)
139 (def-packet-reader packet-get-word 2)
140 (def-packet-reader packet-get-dblword 4))
141
142
143
144 ;;;; Message management and accessors
145
146 (defun create-message (serial)
147 (let ((message (make-message serial)))
148 (message-add-packet message)
149 message))
150
151 (defun destroy-message (message)
152 (dolist (packet (message-packet-list message))
153 (destroy-packet packet)))
154
155
156 (defun message-add-packet (message)
157 (let ((packet (create-packet)))
158 (push packet (message-packet-list message))
159 (setf (message-fill-packet message) packet)
160 (incf (message-packet-count message))
161 (setf (packet-sequence-number packet) (message-packet-count message))
162 ;; PACKET-SEQUENCE-LENGTH will be set when the message is sent
163 (setf (packet-serial packet) (message-serial message))))
164
165
166 (macrolet ((def-message-writer (name size)
167 (let ((packet-ref (ecase size
168 (1 'packet-put-byte)
169 (2 'packet-put-word)
170 (4 'packet-put-dblword)))
171 (bits (* size 8)))
172 `(defun ,name (message data)
173 (declare (type (signed-byte ,bits) data))
174 (when (> (packet-length (message-fill-packet message))
175 (- *packet-size* ,size 1))
176 (message-add-packet message))
177 (,packet-ref (message-fill-packet message) data))))
178 (def-message-reader (name size)
179 (let ((packet-ref (ecase size
180 (1 'packet-get-byte)
181 (2 'packet-get-word)
182 (4 'packet-get-dblword))))
183 `(defun ,name (message)
184 (unless (< (packet-fill (message-fill-packet message))
185 (- *packet-size* ,size -1))
186 ;;
187 ;; This is REALLY gross
188 (setf (message-fill-packet message)
189 (cadr (member (message-fill-packet message)
190 (message-packet-list message)))))
191 (,packet-ref (message-fill-packet message))))))
192
193 (def-message-writer message-put-byte 1)
194 (def-message-writer message-put-word 2)
195 (def-message-writer message-put-dblword 4)
196
197 ;; These accessors should only be used in deciphering complete messages.
198 ;; Hence, it is assumed that the message IS complete (ie. the packets are
199 ;; in normal order).
200 (def-message-reader message-get-byte 1)
201 (def-message-reader message-get-word 2)
202 (def-message-reader message-get-dblword 4))
203
204
205
206 ;;;; Transmission functions
207
208 (defun read-some-bytes (socket packet count)
209 (declare (type packet-index count))
210 (loop
211 (when (zerop count) (return))
212 (multiple-value-bind
213 (bytes-read errnum)
214 (unix:unix-read socket (system:sap+ (packet-head packet)
215 (packet-fill packet)) count)
216 (declare (type (or null fixnum) bytes-read))
217 (unless bytes-read
218 (toolkit-error "Encountered error reading packet: ~a"
219 (unix:get-unix-error-msg errnum)))
220 (when (zerop bytes-read)
221 (error 'toolkit-eof-error :string "Hit EOF while reading packet"))
222 (decf count (the fixnum bytes-read))
223 (incf (packet-fill packet) (the fixnum bytes-read)))))
224
225 (defun write-some-bytes (socket packet)
226 (let ((fill 0)
227 (count (packet-length packet)))
228 (declare (type packet-index fill count))
229 (loop
230 (when (zerop count) (return))
231 (multiple-value-bind
232 (bytes-sent errnum)
233 (unix:unix-write socket (system:sap+ (packet-head packet) fill)
234 0 count)
235 (declare (type (or null fixnum) bytes-sent))
236 (unless bytes-sent
237 (toolkit-error "Encountered error writing packet: ~a"
238 (unix:get-unix-error-msg errnum)))
239 (when (zerop (the fixnum bytes-sent))
240 (error 'toolkit-eof-error :string "Hit EOF while sending packet."))
241 (decf count (the fixnum bytes-sent))
242 (incf fill (the fixnum bytes-sent))))))
243
244 (defun check-packet-sanity (packet)
245 (format t "Packet serial is ~a~%" (packet-serial packet))
246 (format t "Packet current is ~a~%" (packet-sequence-number packet))
247 (format t "Packet total is ~a~%" (packet-sequence-length packet))
248 (format t "Packet length is ~a~%" (packet-length packet)))
249
250 (declaim (inline transmit-packet receive-packet))
251 (defun transmit-packet (packet socket)
252 (write-some-bytes socket packet ))
253
254 (defun receive-packet (socket)
255 (let ((packet (create-packet)))
256 (setf (packet-fill packet) 0)
257 (read-some-bytes socket packet *header-size*)
258 (read-some-bytes socket packet (- (packet-length packet) *header-size*))
259 (setf (packet-fill packet) *header-size*)
260 packet))
261
262 (defun transmit-message (message socket)
263 ;; First, reverse the packet list so that the packets go out in the right
264 ;; order
265 (setf (message-packet-list message) (nreverse (message-packet-list message)))
266 (let ((packet-count (message-packet-count message)))
267 (dolist (packet (message-packet-list message))
268 (setf (packet-sequence-length packet) packet-count)
269 (transmit-packet packet socket))))
270
271 ;;; An a-list of (serial . incomplete message)
272 (defvar *pending-msgs* nil)
273
274 (defun kill-deferred-message (packet)
275 (declare (ignore packet))
276 (warn "Cannot yet handle killing deferred messages."))
277
278 (defun defer-packet (packet)
279 (let* ((serial (packet-serial packet))
280 (found (assoc serial *pending-msgs*))
281 (message (or (cdr found) (make-message serial))))
282 (push packet (message-packet-list message))
283 (incf (message-packet-count message))
284 (cond ((= (message-packet-count message)(packet-sequence-length packet))
285 (setq *pending-msgs* (delete found *pending-msgs*))
286 (setf (message-packet-list message)
287 ;; this can be nreverse if messages really arrive in order
288 (sort (message-packet-list message) #'<
289 :key (lambda(pkt)(packet-sequence-number pkt))))
290 (setf (message-fill-packet message)
291 (first (message-packet-list message)))
292 message)
293 (t (unless found
294 (setq *pending-msgs* (acons serial message *pending-msgs*)))
295 nil))))
296
297 (defun receive-message (socket)
298 (loop
299 (let* ((first (receive-packet socket))
300 (count (packet-sequence-length first)))
301 (cond
302 ((zerop count) (kill-deferred-message first))
303 ((= count 1)
304 (let ((message (make-message (packet-serial first))))
305 (setf (message-packet-count message) 1)
306 (push first (message-packet-list message))
307 (setf (message-fill-packet message) first)
308 (return message)))
309 (t
310 (let ((message (defer-packet first)))
311 (when message
312 (return message))))))))
313
314
315 ;;;; Functions for handling requests
316
317 (defun create-next-message ()
318 (let ((message (create-message (motif-connection-serial
319 *motif-connection*))))
320 (incf (motif-connection-serial *motif-connection*))
321 message))
322
323 (defun prepare-request (request-op options arg-count)
324 (declare (type (unsigned-byte 16) request-op)
325 (type (unsigned-byte 8) arg-count))
326 (let ((message (create-next-message)))
327 (message-put-word message request-op)
328 (message-put-byte message (if (eq options :confirm) 1 0))
329 (message-put-byte message arg-count)
330 message))

  ViewVC Help
Powered by ViewVC 1.1.5