Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/lib/protocol/xrequest.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/lib/protocol/xrequest.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1862 - (view) (download)

1 : monnier 2 (* xrequest.sml
2 :     *
3 :     * COPYRIGHT (c) 1990,1991 by John H. Reppy. See COPYRIGHT file for details.
4 :     *
5 :     * Functions for encoding X11 protocol request messages.
6 :     *
7 :     * TODO
8 :     * - encodeAllocColorCells
9 :     * - encodeAllocColorPlanes
10 :     * - encodeChangeKeyboardMapping
11 :     * - encodeSetPointerMapping
12 :     * - encodeGetPointerMapping
13 :     * - encodeSetModifierMapping
14 :     *)
15 :    
16 :     structure XRequest =
17 :     struct
18 :     local
19 :     structure G = Geometry
20 :     structure XTy = XProtTypes
21 :    
22 :     structure W8A = Word8Array
23 :     structure W8V = Word8Vector
24 :    
25 :     (* we need to treat requests as arrays for initialization purposes, but
26 :     * we don't want them to be modifiable afterwords.
27 :     *)
28 :     val v2a : Word8Vector.vector -> Word8Array.array = Unsafe.cast
29 :    
30 :     fun pad n = if (Word.andb(Word.fromInt n, 0w3) <> 0w0)
31 :     then pad(n+1)
32 :     else n
33 :    
34 :     fun mkReqBuf sz = Unsafe.Word8Vector.create sz
35 :    
36 :     fun put8 (buf, i, w)= W8A.update(v2a buf, i, w)
37 :     fun putWord8 (buf, i, x) =
38 :     put8(buf, i, Word8.fromLargeWord(Word.toLargeWord x))
39 :     fun putSigned8 (buf, i, x) = put8(buf, i, Word8.fromInt x)
40 :    
41 : mblume 1856 fun put16 (buf, i, x) = PackWord16Big.update(v2a buf, i div 2, x)
42 : monnier 2 fun putWord16 (buf, i, x) = put16(buf, i, Word.toLargeWord x)
43 :     fun putSigned16 (buf, i, x) = put16(buf, i, LargeWord.fromInt x)
44 :    
45 : mblume 1856 fun put32 (buf, i, x) = PackWord32Big.update(v2a buf, i div 4, x)
46 : monnier 2 fun putWord32 (buf, i, x) = put32(buf, i, Word.toLargeWord x)
47 :     fun putSigned32 (buf, i, x) = put32(buf, i, LargeWord.fromInt x)
48 :    
49 : mblume 1862 fun putString (buf, i, s) = Byte.packString(v2a buf, i, Substring.full s)
50 : monnier 2 fun putData (buf, i, bv) = W8A.copyVec{
51 : mblume 1350 dst=v2a buf, di=i, src=bv
52 : monnier 2 }
53 :    
54 :     fun putBool (buf, i, false) = put8 (buf, i, 0w0)
55 :     | putBool (buf, i, true) = put8 (buf, i, 0w1)
56 :    
57 :     fun putXId (buf, i, XTy.XID n) = putWord32 (buf, i, n)
58 :     fun putXIdOption (buf, i, NONE) = putWord32 (buf, i, 0w0)
59 :     | putXIdOption (buf, i, SOME(XTy.XID n)) = putWord32 (buf, i, n)
60 :    
61 :     fun putAtom (buf, i, XTy.XAtom n) = putWord32 (buf, i, n)
62 :     fun putAtomOption (buf, i, NONE) = putWord32 (buf, i, 0w0)
63 :     | putAtomOption (buf, i, SOME(XTy.XAtom n)) = putWord32 (buf, i, n)
64 :    
65 :     fun putPixel (buf, i, XTy.PIXEL n) = putSigned32(buf, i, n)
66 :     fun putPlaneMask (buf, i, XTy.PLANEMASK n) = putWord32(buf, i, n)
67 :     fun putEventMask (buf, i, XTy.XEVTMASK m) = putWord32(buf, i, m)
68 :     fun putPtrEventMask (buf, i, XTy.XEVTMASK m) = putWord16(buf, i, m)
69 :    
70 :     fun putPt (buf, i, G.PT{x, y}) = (
71 :     putSigned16(buf, i, x); putSigned16(buf, i+2, y))
72 :     fun putSize (buf, i, G.SIZE{wid, ht}) = (
73 :     putSigned16(buf, i, wid); putSigned16(buf, i+2, ht))
74 :     fun putRect (buf, i, G.RECT{x, y, wid, ht}) = (
75 :     putSigned16(buf, i, x); putSigned16(buf, i+2, y);
76 :     putSigned16(buf, i+4, wid); putSigned16(buf, i+6, ht))
77 :     fun putArc (buf, i, G.ARC{x, y, wid, ht, angle1, angle2}) = (
78 :     putSigned16(buf, i, x); putSigned16(buf, i+2, y);
79 :     putSigned16(buf, i+4, wid); putSigned16(buf, i+6, ht);
80 :     putSigned16(buf, i+8, angle1); putSigned16(buf, i+10, angle2))
81 :     fun putWGeom (buf, i, G.WGEOM{pos, sz, border}) = (
82 :     putPt(buf, i, pos);
83 :     putSize(buf, i+4, sz);
84 :     putSigned16(buf, i+8, border))
85 :    
86 :     fun putTS (buf, i, XTy.CurrentTime) = put32(buf, i, 0w0)
87 :     | putTS (buf, i, XTy.TimeStamp(XTime.XT t)) = put32(buf, i, t)
88 :    
89 :     fun putRGB (buf, i, XTy.RGB{red, green, blue}) = (
90 :     putWord16(buf, i, red);
91 :     putWord16(buf, i+2, green);
92 :     putWord16(buf, i+4, blue))
93 :    
94 :     fun putGrabMode(buf, i, XTy.SynchronousGrab) = put8(buf, i, 0w0)
95 :     | putGrabMode(buf, i, XTy.AsynchronousGrab) = put8(buf, i, 0w1)
96 :    
97 :     fun putList (f, sz : int) (buf, base, list) = let
98 :     fun put (_, []) = ()
99 :     | put (i, x::r) = (f(buf, i, x); put(i+sz, r))
100 :     in
101 :     put (base, list)
102 :     end
103 :    
104 :     val putPts = putList (putPt, 4)
105 :     val putRects = putList (putRect, 8)
106 :     val putPixels = putList (putPixel, 4)
107 :    
108 :     (* build a value list and mask from a value option array *)
109 :     fun mkValList (XTy.VALS arr) = let
110 :     fun f (~1, n, m, l) = (n, XTy.VALMASK m, l)
111 :     | f (i, n, m, l) = (case Array.sub(arr, i)
112 :     of (SOME x) => f(i-1, n+1, Word.orb(m, Word.<<(0w1, Word.fromInt i)), x::l)
113 :     | NONE => f(i-1, n, m, l)
114 :     (* end case *))
115 :     in
116 :     f ((Array.length arr)-1, 0, 0w0, [])
117 :     end
118 :    
119 :     (* Put value masks and lists *)
120 :     local
121 :     val putVals = putList (putWord32, 4)
122 :     in
123 :     fun putValList (buf, i, XTy.VALMASK m, vals) = (
124 :     putWord32(buf, i, m);
125 :     putVals(buf, i+4, vals))
126 :     fun putValList16 (buf, i, XTy.VALMASK m, vals) = (
127 :     putWord16(buf, i, m);
128 :     putVals(buf, i+4, vals))
129 :     end (* local *)
130 :    
131 :     (** X11 protocol request codes and sizes (from "Xproto.h") **)
132 :     type reqinfo = {code : Word8.word, size : int}
133 :     val reqCreateWindow = {code = 0w1, size = 8} : reqinfo
134 :     val reqChangeWindowAttributes = {code = 0w2, size = 3} : reqinfo
135 :     val reqGetWindowAttributes = {code = 0w3, size = 2} : reqinfo
136 :     val reqDestroyWindow = {code = 0w4, size = 2} : reqinfo
137 :     val reqDestroySubwindows = {code = 0w5, size = 2} : reqinfo
138 :     val reqChangeSaveSet = {code = 0w6, size = 2} : reqinfo
139 :     val reqReparentWindow = {code = 0w7, size = 4} : reqinfo
140 :     val reqMapWindow = {code = 0w8, size = 2} : reqinfo
141 :     val reqMapSubwindows = {code = 0w9, size = 2} : reqinfo
142 :     val reqUnmapWindow = {code = 0w10, size = 2} : reqinfo
143 :     val reqUnmapSubwindows = {code = 0w11, size = 2} : reqinfo
144 :     val reqConfigureWindow = {code = 0w12, size = 3} : reqinfo
145 :     val reqCirculateWindow = {code = 0w13, size = 2} : reqinfo
146 :     val reqGetGeometry = {code = 0w14, size = 2} : reqinfo
147 :     val reqQueryTree = {code = 0w15, size = 2} : reqinfo
148 :     val reqInternAtom = {code = 0w16, size = 2} : reqinfo
149 :     val reqGetAtomName = {code = 0w17, size = 2} : reqinfo
150 :     val reqChangeProperty = {code = 0w18, size = 6} : reqinfo
151 :     val reqDeleteProperty = {code = 0w19, size = 3} : reqinfo
152 :     val reqGetProperty = {code = 0w20, size = 6} : reqinfo
153 :     val reqListProperties = {code = 0w21, size = 2} : reqinfo
154 :     val reqSetSelectionOwner = {code = 0w22, size = 4} : reqinfo
155 :     val reqGetSelectionOwner = {code = 0w23, size = 2} : reqinfo
156 :     val reqConvertSelection = {code = 0w24, size = 6} : reqinfo
157 :     val reqSendEvent = {code = 0w25, size = 11} : reqinfo
158 :     val reqGrabPointer = {code = 0w26, size = 6} : reqinfo
159 :     val reqUngrabPointer = {code = 0w27, size = 2} : reqinfo
160 :     val reqGrabButton = {code = 0w28, size = 6} : reqinfo
161 :     val reqUngrabButton = {code = 0w29, size = 3} : reqinfo
162 :     val reqChangeActivePointerGrab = {code = 0w30, size = 4} : reqinfo
163 :     val reqGrabKeyboard = {code = 0w31, size = 4} : reqinfo
164 :     val reqUngrabKeyboard = {code = 0w32, size = 2} : reqinfo
165 :     val reqGrabKey = {code = 0w33, size = 4} : reqinfo
166 :     val reqUngrabKey = {code = 0w34, size = 3} : reqinfo
167 :     val reqAllowEvents = {code = 0w35, size = 2} : reqinfo
168 :     val reqGrabServer = {code = 0w36, size = 1} : reqinfo
169 :     val reqUngrabServer = {code = 0w37, size = 1} : reqinfo
170 :     val reqQueryPointer = {code = 0w38, size = 2} : reqinfo
171 :     val reqGetMotionEvents = {code = 0w39, size = 4} : reqinfo
172 :     val reqTranslateCoords = {code = 0w40, size = 4} : reqinfo
173 :     val reqWarpPointer = {code = 0w41, size = 6} : reqinfo
174 :     val reqSetInputFocus = {code = 0w42, size = 3} : reqinfo
175 :     val reqGetInputFocus = {code = 0w43, size = 1} : reqinfo
176 :     val reqQueryKeymap = {code = 0w44, size = 1} : reqinfo
177 :     val reqOpenFont = {code = 0w45, size = 3} : reqinfo
178 :     val reqCloseFont = {code = 0w46, size = 2} : reqinfo
179 :     val reqQueryFont = {code = 0w47, size = 2} : reqinfo
180 :     val reqQueryTextExtents = {code = 0w48, size = 2} : reqinfo
181 :     val reqListFonts = {code = 0w49, size = 2} : reqinfo
182 :     val reqListFontsWithInfo = {code = 0w50, size = 2} : reqinfo
183 :     val reqSetFontPath = {code = 0w51, size = 2} : reqinfo
184 :     val reqGetFontPath = {code = 0w52, size = 1} : reqinfo
185 :     val reqCreatePixmap = {code = 0w53, size = 4} : reqinfo
186 :     val reqFreePixmap = {code = 0w54, size = 2} : reqinfo
187 :     val reqCreateGC = {code = 0w55, size = 4} : reqinfo
188 :     val reqChangeGC = {code = 0w56, size = 3} : reqinfo
189 :     val reqCopyGC = {code = 0w57, size = 4} : reqinfo
190 :     val reqSetDashes = {code = 0w58, size = 3} : reqinfo
191 :     val reqSetClipRectangles = {code = 0w59, size = 3} : reqinfo
192 :     val reqFreeGC = {code = 0w60, size = 2} : reqinfo
193 :     val reqClearArea = {code = 0w61, size = 4} : reqinfo
194 :     val reqCopyArea = {code = 0w62, size = 7} : reqinfo
195 :     val reqCopyPlane = {code = 0w63, size = 8} : reqinfo
196 :     val reqPolyPoint = {code = 0w64, size = 3} : reqinfo
197 :     val reqPolyLine = {code = 0w65, size = 3} : reqinfo
198 :     val reqPolySegment = {code = 0w66, size = 3} : reqinfo
199 :     val reqPolyRectangle = {code = 0w67, size = 3} : reqinfo
200 :     val reqPolyArc = {code = 0w68, size = 3} : reqinfo
201 :     val reqFillPoly = {code = 0w69, size = 4} : reqinfo
202 :     val reqPolyFillRectangle = {code = 0w70, size = 3} : reqinfo
203 :     val reqPolyFillArc = {code = 0w71, size = 3} : reqinfo
204 :     val reqPutImage = {code = 0w72, size = 6} : reqinfo
205 :     val reqGetImage = {code = 0w73, size = 5} : reqinfo
206 :     val reqPolyText8 = {code = 0w74, size = 4} : reqinfo
207 :     val reqPolyText16 = {code = 0w75, size = 4} : reqinfo
208 :     val reqImageText8 = {code = 0w76, size = 4} : reqinfo
209 :     val reqImageText16 = {code = 0w77, size = 4} : reqinfo
210 :     val reqCreateColormap = {code = 0w78, size = 4} : reqinfo
211 :     val reqFreeColormap = {code = 0w79, size = 2} : reqinfo
212 :     val reqCopyColormapAndFree = {code = 0w80, size = 3} : reqinfo
213 :     val reqInstallColormap = {code = 0w81, size = 2} : reqinfo
214 :     val reqUninstallColormap = {code = 0w82, size = 2} : reqinfo
215 :     val reqListInstalledColormaps = {code = 0w83, size = 2} : reqinfo
216 :     val reqAllocColor = {code = 0w84, size = 4} : reqinfo
217 :     val reqAllocNamedColor = {code = 0w85, size = 3} : reqinfo
218 :     val reqAllocColorCells = {code = 0w86, size = 3} : reqinfo
219 :     val reqAllocColorPlanes = {code = 0w87, size = 4} : reqinfo
220 :     val reqFreeColors = {code = 0w88, size = 3} : reqinfo
221 :     val reqStoreColors = {code = 0w89, size = 2} : reqinfo
222 :     val reqStoreNamedColor = {code = 0w90, size = 4} : reqinfo
223 :     val reqQueryColors = {code = 0w91, size = 2} : reqinfo
224 :     val reqLookupColor = {code = 0w92, size = 3} : reqinfo
225 :     val reqCreateCursor = {code = 0w93, size = 8} : reqinfo
226 :     val reqCreateGlyphCursor = {code = 0w94, size = 8} : reqinfo
227 :     val reqFreeCursor = {code = 0w95, size = 2} : reqinfo
228 :     val reqRecolorCursor = {code = 0w96, size = 5} : reqinfo
229 :     val reqQueryBestSize = {code = 0w97, size = 3} : reqinfo
230 :     val reqQueryExtension = {code = 0w98, size = 2} : reqinfo
231 :     val reqListExtensions = {code = 0w99, size = 1} : reqinfo
232 :     val reqChangeKeyboardMapping = {code = 0w100, size = 2} : reqinfo
233 :     val reqGetKeyboardMapping = {code = 0w101, size = 2} : reqinfo
234 :     val reqChangeKeyboardControl = {code = 0w102, size = 2} : reqinfo
235 :     val reqGetKeyboardControl = {code = 0w103, size = 1} : reqinfo
236 :     val reqBell = {code = 0w104, size = 1} : reqinfo
237 :     val reqChangePointerControl = {code = 0w105, size = 3} : reqinfo
238 :     val reqGetPointerControl = {code = 0w106, size = 1} : reqinfo
239 :     val reqSetScreenSaver = {code = 0w107, size = 3} : reqinfo
240 :     val reqGetScreenSaver = {code = 0w108, size = 1} : reqinfo
241 :     val reqChangeHosts = {code = 0w109, size = 2} : reqinfo
242 :     val reqListHosts = {code = 0w110, size = 1} : reqinfo
243 :     val reqSetAccessControl = {code = 0w111, size = 1} : reqinfo
244 :     val reqSetCloseDownMode = {code = 0w112, size = 1} : reqinfo
245 :     val reqKillClient = {code = 0w113, size = 2} : reqinfo
246 :     val reqRotateProperties = {code = 0w114, size = 3} : reqinfo
247 :     val reqForceScreenSaver = {code = 0w115, size = 1} : reqinfo
248 :     val reqSetPointerMapping = {code = 0w116, size = 1} : reqinfo
249 :     val reqGetPointerMapping = {code = 0w117, size = 1} : reqinfo
250 :     val reqSetModifierMapping = {code = 0w118, size = 1} : reqinfo
251 :     val reqGetModifierMapping = {code = 0w119, size = 1} : reqinfo
252 :     val reqNoOperation = {code = 0w127, size = 1} : reqinfo
253 :    
254 :     (* Allocate a buffer for a fixed-sized message and initialize the
255 :     * code and size fields. Return the buffer.
256 :     *)
257 :     fun mkReq ({code, size} : reqinfo) = let
258 :     val buf = mkReqBuf(4*size)
259 :     in
260 :     put8 (buf, 0, code); (* request opcode *)
261 :     putSigned16 (buf, 2, size); (* request size (in words) *)
262 :     buf
263 :     end
264 :    
265 :     (* Allocate a buffer for a fixed-sized message that contains an xid
266 :     * in its first field, and initialize the code and size fields. Return
267 :     * the buffer.
268 :     *)
269 :     fun mkResourceReq (info, xid) = let
270 :     val buf = mkReq info
271 :     in
272 :     putXId (buf, 4, xid); (* resource id *)
273 :     buf
274 :     end
275 :    
276 :     (* Allocate and initialize a buffer for a variable-sized request.
277 :     * Return the new buffer.
278 :     *)
279 :     fun mkExtraReq ({code, size}, extra) = let
280 :     val sz = size+extra
281 :     val buf = mkReqBuf (4*sz)
282 :     in
283 :     put8 (buf, 0, code); (* request opcode *)
284 :     putSigned16 (buf, 2, sz); (* request size (in words) *)
285 :     buf
286 :     end
287 :    
288 :     (* Allocate and initialize a buffer for a variable-sized request. Only allocate
289 :     * space for the header. Return the new buffer.
290 :     *)
291 :     fun mkVarReq ({code, size}, extra) = let
292 :     val sz = size+extra
293 :     val buf = mkReqBuf (4*size)
294 :     in
295 :     put8 (buf, 0, code); (* request opcode *)
296 :     putSigned16 (buf, 2, size+extra); (* request size (in words) *)
297 :     buf
298 :     end
299 :    
300 :     in
301 :    
302 :     (* encode the connection request message. This consists of the byte-order,
303 :     * protocol version, and optional authentication data.
304 :     *)
305 :     fun encodeConnectionReq { minorVersion, auth } = let
306 :     fun setPrefix sz = let
307 :     val buf = W8V.tabulate(sz, fn _ => 0w0)
308 :     in
309 :     put8(buf, 0, Byte.charToByte #"B"); (* byte order: MSB *)
310 :     put8(buf, 3, 0w11); (* major version: 11 *)
311 :     put8(buf, 5, Word8.fromInt minorVersion);
312 :     buf
313 :     end
314 :     in
315 :     case auth
316 :     of NONE => setPrefix 12
317 :     | (SOME(XTy.AUTH{name, data, ...})) => let
318 :     val authNameLen = pad(size name)
319 :     val authDataLen = pad(Word8Vector.length data)
320 :     val prefix = setPrefix (12 + authNameLen + authDataLen)
321 :     in
322 :     putSigned16 (prefix, 6, size name);
323 :     putSigned16 (prefix, 8, Word8Vector.length data);
324 :     putString (prefix, 12, name);
325 :     putData (prefix, 12 + authNameLen, data);
326 :     prefix
327 :     end
328 :     (* end case *)
329 :     end
330 :    
331 :     fun encodeCreateWindow { win, parent, input_only, depth, visual, geom, vals } = let
332 :     val (nvals, mask, vals) = mkValList vals
333 :     val msg = mkExtraReq (reqCreateWindow, nvals)
334 :     in
335 :     putSigned8(msg, 1, depth);
336 :     putXId(msg, 4, win);
337 :     putXId(msg, 8, parent);
338 :     putWGeom(msg, 12, geom);
339 :     put16(msg, 22, case input_only
340 :     of NONE => 0w0
341 :     | (SOME false) => 0w1
342 :     | (SOME true) => 0w2);
343 :     putWord32(msg, 24, case visual
344 :     of NONE => 0w0
345 :     | SOME(XTy.VISUALID id) => id
346 :     (* end case *));
347 :     putValList (msg, 28, mask, vals);
348 :     msg
349 :     end
350 :    
351 :     fun encodeChangeWindowAttributes { win, vals } = let
352 :     val (nvals, mask, vals) = mkValList vals
353 :     val msg = mkExtraReq (reqChangeWindowAttributes, nvals)
354 :     in
355 :     putXId(msg, 4, win);
356 :     putValList (msg, 8, mask, vals);
357 :     msg
358 :     end
359 :    
360 :     fun encodeGetWindowAttributes { win } = mkResourceReq (reqGetWindowAttributes, win)
361 :    
362 :     fun encodeDestroyWindow { win } = mkResourceReq (reqDestroyWindow, win)
363 :     fun encodeDestroySubwindows { win } = mkResourceReq (reqDestroySubwindows, win)
364 :    
365 :     fun encodeChangeSaveSet { insert, win } = let
366 :     val msg = mkReq (reqChangeSaveSet)
367 :     in
368 :     putBool(msg, 1, insert);
369 :     putXId(msg, 4, win);
370 :     msg
371 :     end
372 :    
373 :     fun encodeReparentWindow { win, parent, pos } = let
374 :     val msg = mkResourceReq (reqReparentWindow, win)
375 :     in
376 :     putXId (msg, 8, parent);
377 :     putPt (msg, 12, pos);
378 :     msg
379 :     end
380 :    
381 :     fun encodeMapWindow { win } = mkResourceReq (reqMapWindow, win)
382 :     fun encodeMapSubwindows { win } = mkResourceReq (reqMapSubwindows, win)
383 :     fun encodeUnmapWindow { win } = mkResourceReq (reqUnmapWindow, win)
384 :     fun encodeUnmapSubwindows { win } = mkResourceReq (reqUnmapSubwindows, win)
385 :    
386 :     fun encodeConfigureWindow { win, vals } = let
387 :     val (nvals, mask, vals) = mkValList vals
388 :     val msg = mkExtraReq (reqConfigureWindow, nvals)
389 :     in
390 :     putXId(msg, 4, win);
391 :     putValList16 (msg, 8, mask, vals);
392 :     msg
393 :     end
394 :    
395 :     fun encodeCirculateWindow { parent, win, place } = let
396 :     val msg = mkReq (reqCirculateWindow)
397 :     in
398 :     putXId(msg, 4, parent);
399 :     putXId(msg, 8, win);
400 :     put8(msg, 12, case place
401 :     of XTy.PlaceOnTop => 0w0
402 :     | XTy.PlaceOnBottom => 0w1
403 :     (* end case *));
404 :     msg
405 :     end
406 :    
407 :     fun encodeGetGeometry { drawable } = mkResourceReq (reqGetGeometry, drawable)
408 :    
409 :     fun encodeQueryTree { win } = mkResourceReq (reqQueryTree, win)
410 :    
411 :     fun encodeInternAtom { name, only_if_exists } = let
412 :     val n = String.size name
413 :     val msg = mkExtraReq (reqInternAtom, (pad n) div 4)
414 :     in
415 :     putBool (msg, 1, only_if_exists);
416 :     putSigned16 (msg, 4, n);
417 :     putString (msg, 8, name);
418 :     msg
419 :     end
420 :    
421 :     fun encodeGetAtomName { atom = (XTy.XAtom id) } =
422 :     mkResourceReq (reqGetAtomName, XTy.XID id)
423 :    
424 :     fun encodeChangeProperty {win, name, prop, mode} = let
425 :     val XTy.PROP_VAL{typ, value = XTy.RAW_DATA{format, data}} = prop
426 :     val nbytes = Word8Vector.length data
427 :     val msg = mkExtraReq (reqChangeProperty, (pad nbytes) div 4)
428 :     val (nitems, fmt) = case format
429 :     of XTy.Raw8 => (nbytes, 0w8)
430 :     | XTy.Raw16 => (nbytes div 2, 0w16)
431 :     | XTy.Raw32 => (nbytes div 4, 0w32)
432 :     in
433 :     put8(msg, 1, case mode
434 :     of XTy.ReplaceProp => 0w0
435 :     | XTy.PrependProp => 0w1
436 :     | XTy.AppendProp => 0w2
437 :     (* end case *));
438 :     putXId(msg, 4, win);
439 :     putAtom(msg, 8, name);
440 :     putAtom(msg, 12, typ);
441 :     put8(msg, 16, fmt);
442 :     putSigned32(msg, 20, nitems);
443 :     putData(msg, 24, data);
444 :     msg
445 :     end
446 :    
447 :     fun encodeDeleteProperty { win, prop } = let
448 :     val msg = mkReq reqDeleteProperty
449 :     in
450 :     putXId(msg, 4, win);
451 :     putAtom(msg, 8, prop);
452 :     msg
453 :     end
454 :    
455 :     fun encodeGetProperty { win, prop, typ, offset, len, delete } = let
456 :     val msg = mkReq (reqGetProperty)
457 :     in
458 :     putBool(msg, 1, delete);
459 :     putXId(msg, 4, win);
460 :     putAtom(msg, 8, prop);
461 :     putAtomOption(msg, 12, typ);
462 :     putSigned32(msg, 16, offset);
463 :     putSigned32(msg, 20, len);
464 :     msg
465 :     end
466 :    
467 :     fun encodeListProperties { win } = mkResourceReq (reqListProperties, win)
468 :    
469 :     fun encodeSetSelectionOwner { win, selection, timestamp } = let
470 :     val msg = mkReq reqSetSelectionOwner
471 :     in
472 :     putXIdOption(msg, 4, win);
473 :     putAtom(msg, 8, selection);
474 :     putTS(msg, 12, timestamp);
475 :     msg
476 :     end
477 :    
478 :     fun encodeGetSelectionOwner { selection = (XTy.XAtom x) } =
479 :     mkResourceReq (reqGetSelectionOwner, XTy.XID x)
480 :    
481 :     fun encodeConvertSelection
482 :     { selection, target, property, requestor, timestamp } = let
483 :     val msg = mkReq reqConvertSelection
484 :     in
485 :     putXId(msg, 4, requestor);
486 :     putAtom(msg, 8, selection);
487 :     putAtom(msg, 12, target);
488 :     putAtomOption(msg, 16, property);
489 :     putTS(msg, 20, timestamp);
490 :     msg
491 :     end
492 :    
493 :     (* NOTE: this just encodes the header info; the encoding of the event
494 :     * message is handled by the routines in XSendEvent.
495 :     *)
496 :     fun encodeSendEvent { dst, propagate, evt_mask } = let
497 :     val msg = mkReq (reqSendEvent)
498 :     in
499 :     putBool (msg, 1, propagate);
500 :     case dst
501 :     of XTy.SendEvtTo_PointerWindow => put32(msg, 4, 0w0)
502 :     | XTy.SendEvtTo_InputFocus => put32(msg, 4, 0w1)
503 :     | (XTy.SendEvtTo_Window wid) => putXId(msg, 4, wid)
504 :     (* end case *);
505 :     putEventMask (msg, 8, evt_mask);
506 :     msg
507 :     end
508 :    
509 :     fun encodeGrabPointer
510 :     { win, owner_evts, evt_mask, ptr_mode, kbd_mode, confine_to, cursor, time } = let
511 :     val msg = mkReq (reqGrabPointer)
512 :     in
513 :     putBool (msg, 1, owner_evts);
514 :     putXId (msg, 4, win);
515 :     putPtrEventMask (msg, 8, evt_mask);
516 :     putGrabMode (msg, 10, ptr_mode);
517 :     putGrabMode (msg, 11, kbd_mode);
518 :     putXIdOption (msg, 12, confine_to);
519 :     putXIdOption (msg, 16, cursor);
520 :     putTS (msg, 20, time);
521 :     msg
522 :     end
523 :    
524 :     fun encodeGrabKeyboard
525 :     { win, owner_evts, ptr_mode, kbd_mode, time } = let
526 :     val msg = mkReq (reqGrabKeyboard)
527 :     in
528 :     putBool(msg, 1, owner_evts);
529 :     putXId(msg, 4, win);
530 :     putTS(msg, 8, time);
531 :     putGrabMode(msg, 12, ptr_mode);
532 :     putGrabMode(msg, 13, kbd_mode);
533 :     msg
534 :     end
535 :    
536 :     local
537 :     fun ungrab info { time } = let
538 :     val msg = mkReq (info)
539 :     in
540 :     putTS(msg, 4, time);
541 :     msg
542 :     end
543 :     in
544 :     val encodeUngrabPointer = ungrab reqUngrabPointer
545 :     val encodeUngrabKeyboard = ungrab reqUngrabKeyboard
546 :     end
547 :    
548 :     fun encodeChangeActivePointerGrab { evt_mask, cursor, time } = let
549 :     val msg = mkReq (reqChangeActivePointerGrab)
550 :     in
551 :     putXIdOption(msg, 4, cursor);
552 :     putTS(msg, 8, time);
553 :     putPtrEventMask(msg, 12, evt_mask);
554 :     msg
555 :     end
556 :    
557 :     local
558 :     fun putModifiers(buf, i, mset) = let
559 :     val m = case (KeyBut.mkModState mset)
560 :     of XTy.AnyModKey => 0wx8000
561 :     | (XTy.MKState m) => m
562 :     in
563 :     putWord16(buf, i, m)
564 :     end
565 :     fun putButton(buf, i, SOME(XTy.MButton b)) = putSigned8(buf, i, b)
566 :     | putButton(buf, i, NONE) = put8(buf, i, 0w0)
567 :     fun putKeyCode(buf, i, XTy.KEYCODE k) = putSigned8(buf, i, k)
568 :     in
569 :     fun encodeGrabButton
570 :     { button, modifiers, win, owner_evts, evt_mask, ptr_mode, kbd_mode,
571 :     confine_to, cursor } = let
572 :     val msg = mkReq reqGrabButton
573 :     in
574 :     putBool(msg, 1, owner_evts);
575 :     putXId(msg, 4, win);
576 :     putPtrEventMask(msg, 8, evt_mask);
577 :     putGrabMode(msg, 10, ptr_mode);
578 :     putGrabMode(msg, 11, kbd_mode);
579 :     putXIdOption(msg, 12, confine_to);
580 :     putXIdOption(msg, 16, cursor);
581 :     putButton(msg, 18, button);
582 :     putModifiers(msg, 20, modifiers);
583 :     msg
584 :     end
585 :    
586 :     fun encodeGrabKey { key, modifiers, win, owner_evts, ptr_mode, kbd_mode } = let
587 :     val msg = mkReq reqGrabKey
588 :     in
589 :     putBool(msg, 1, owner_evts);
590 :     putXId(msg, 4, win);
591 :     putModifiers(msg, 8, modifiers);
592 :     putKeyCode(msg, 10, key);
593 :     putGrabMode(msg, 11, ptr_mode);
594 :     putGrabMode(msg, 12, kbd_mode);
595 :     msg
596 :     end
597 :    
598 :     fun encodeUngrabButton { button, modifiers, win } = let
599 :     val msg = mkReq (reqUngrabButton)
600 :     in
601 :     putButton(msg, 1, button);
602 :     putXId(msg, 4, win);
603 :     putModifiers(msg, 8, modifiers);
604 :     msg
605 :     end
606 :    
607 :     fun encodeUngrabKey { key, modifiers, win } = let
608 :     val msg = mkReq (reqUngrabKey)
609 :     in
610 :     putKeyCode(msg, 1, key);
611 :     putXId(msg, 4, win);
612 :     putModifiers(msg, 8, modifiers);
613 :     msg
614 :     end
615 :     end (* local *)
616 :    
617 :     fun encodeAllowEvents { mode, time } = let
618 :     val msg = mkReq (reqAllowEvents)
619 :     in
620 :     put8(msg, 1, case mode
621 :     of XTy.AsyncPointer => 0w0 | XTy.SyncPointer => 0w1
622 :     | XTy.ReplayPointer => 0w2 | XTy.AsyncKeyboard => 0w3
623 :     | XTy.SyncKeyboard => 0w4 | XTy.ReplayKeyboard => 0w5
624 :     | XTy.AsyncBoth => 0w6 | XTy.SyncBoth => 0w7
625 :     (* end case *));
626 :     putTS(msg, 4, time);
627 :     msg
628 :     end
629 :    
630 :     fun encodeQueryPointer { win } = mkResourceReq (reqQueryPointer, win)
631 :    
632 :     fun encodeGetMotionEvents { win, start, stop } = let
633 :     val msg = mkReq (reqGetMotionEvents)
634 :     in
635 :     putXId(msg, 4, win);
636 :     putTS(msg, 8, start);
637 :     putTS(msg, 12, stop);
638 :     msg
639 :     end
640 :    
641 :     fun encodeTranslateCoords { src_win, dst_win, src_pt } = let
642 :     val msg = mkResourceReq (reqTranslateCoords, src_win)
643 :     in
644 :     putXId (msg, 8, dst_win);
645 :     putPt (msg, 12, src_pt);
646 :     msg
647 :     end
648 :    
649 :     fun encodeWarpPointer { src, dst, src_rect, dst_pt } = let
650 :     val msg = mkReq reqWarpPointer
651 :     in
652 :     putXIdOption(msg, 4, src);
653 :     putXIdOption(msg, 8, dst);
654 :     putRect(msg, 12, src_rect);
655 :     putPt(msg, 20, dst_pt);
656 :     msg
657 :     end
658 :    
659 :     fun encodeSetInputFocus { focus, revert_to, timestamp } = let
660 :     val msg = mkReq reqSetInputFocus
661 :     in
662 :     put8(msg, 1, case revert_to
663 :     of XTy.RevertToNone => 0w0
664 :     | XTy.RevertToPointerRoot => 0w1
665 :     | XTy.RevertToParent => 0w2
666 :     (* end case *));
667 :     putXId(msg, 4, case focus
668 :     of XTy.InputFocus_None => (XTy.XID 0w0)
669 :     | XTy.InputFocus_PointerRoot => (XTy.XID 0w1)
670 :     | (XTy.InputFocus_Window w) => w
671 :     (* end case *));
672 :     putTS (msg, 8, timestamp);
673 :     msg
674 :     end
675 :    
676 :     fun encodeOpenFont { font, name } = let
677 :     val n = String.size name
678 :     val msg = mkExtraReq (reqOpenFont, (pad n) div 4)
679 :     in
680 :     putXId (msg, 4, font);
681 :     putSigned16 (msg, 8, n);
682 :     putString (msg, 12, name);
683 :     msg
684 :     end
685 :    
686 :     fun encodeCloseFont { font } = mkResourceReq (reqCloseFont, font)
687 :    
688 :     fun encodeQueryFont { font } = mkResourceReq (reqQueryFont, font)
689 :    
690 :     fun encodeQueryTextExtents { font, str } = let
691 :     val len = String.size str
692 :     val p = pad len
693 :     val msg = mkExtraReq(reqQueryTextExtents, p div 4)
694 :     in
695 :     putBool(msg, 1, ((len - p) = 2));
696 :     putXId(msg, 4, font);
697 :     putString(msg, 8, str);
698 :     msg
699 :     end
700 :    
701 :     local
702 :     fun encode info { pattern, max } = let
703 :     val len = String.size pattern
704 :     val msg = mkExtraReq (info, (pad len) div 4)
705 :     in
706 :     putSigned16(msg, 4, max);
707 :     putSigned16(msg, 6, len);
708 :     putString(msg, 8, pattern);
709 :     msg
710 :     end
711 :     in
712 :     val encodeListFonts = encode reqListFonts
713 :     val encodeListFontsWithInfo = encode reqListFontsWithInfo
714 :     end (* local *)
715 :    
716 :     fun encodeSetFontPath { path } = let
717 :     fun f ([], n, l) = (n, String.concat(List.rev l))
718 :     | f (s::r, n, l) = let val len = String.size s
719 :     in
720 :     (** should check that len <= 255 **)
721 :     f(r, n+1, s :: String.str(Char.chr len) :: l)
722 :     end
723 :     val (nstrs, data) = f(path, 0, [])
724 :     val len = String.size data
725 :     val msg = mkExtraReq (reqSetFontPath, (pad len) div 4)
726 :     in
727 :     putSigned16(msg, 4, nstrs);
728 :     putString(msg, 8, data);
729 :     msg
730 :     end
731 :    
732 :     fun encodeCreatePixmap { pixmap, drawable, depth, size } = let
733 :     val msg = mkResourceReq (reqCreatePixmap, pixmap)
734 :     in
735 :     putSigned8 (msg, 1, depth);
736 :     putXId (msg, 8, drawable);
737 :     putSize (msg, 12, size);
738 :     msg
739 :     end
740 :    
741 :     fun encodeFreePixmap { pixmap } = mkResourceReq (reqFreePixmap, pixmap)
742 :    
743 :     fun encodeCreateGC { gc, drawable, vals } = let
744 :     val (nvals, mask, vals) = mkValList vals
745 :     val msg = mkExtraReq (reqCreateGC, nvals)
746 :     in
747 :     putXId(msg, 4, gc);
748 :     putXId(msg, 8, drawable);
749 :     putValList (msg, 12, mask, vals);
750 :     msg
751 :     end
752 :    
753 :     fun encodeChangeGC { gc, vals } = let
754 :     val (nvals, mask, vals) = mkValList vals
755 :     val msg = mkExtraReq (reqChangeGC, nvals)
756 :     in
757 :     putXId(msg, 4, gc);
758 :     putValList (msg, 8, mask, vals);
759 :     msg
760 :     end
761 :    
762 :     fun encodeCopyGC { src, dst, mask = XTy.VALMASK m } = let
763 :     val msg = mkReq (reqCopyGC)
764 :     in
765 :     putXId(msg, 4, src);
766 :     putXId(msg, 8, dst);
767 :     putWord32(msg, 12, m);
768 :     msg
769 :     end
770 :    
771 :     fun encodeSetDashes { gc, dash_offset, dashes } = let
772 :     val n = List.length dashes
773 :     val msg = mkExtraReq (reqSetDashes, (pad n) div 4)
774 :     in
775 :     putXId(msg, 4, gc);
776 :     putSigned16(msg, 8, dash_offset);
777 :     putSigned16(msg, 10, n);
778 :     putList (putSigned8, 1) (msg, 12, dashes);
779 :     msg
780 :     end
781 :    
782 :     fun encodeSetClipRectangles { gc, clip_origin, ordering, rects } = let
783 :     val msg = mkExtraReq (reqSetClipRectangles, 2 * (List.length rects))
784 :     in
785 :     put8(msg, 1, case ordering
786 :     of XTy.UnsortedOrder => 0w0 | XTy.YSortedOrder => 0w1
787 :     | XTy.YXSortedOrder => 0w2 | XTy.YXBandedOrder => 0w3
788 :     (* end case *));
789 :     putXId(msg, 4, gc);
790 :     putPt(msg, 8, clip_origin);
791 :     putRects(msg, 12, rects);
792 :     msg
793 :     end
794 :    
795 :     fun encodeFreeGC { gc } = mkResourceReq (reqFreeGC, gc)
796 :    
797 :     fun encodeClearArea { win, rect, exposures } = let
798 :     val msg = mkResourceReq (reqClearArea, win)
799 :     in
800 :     putBool (msg, 1, exposures);
801 :     putRect (msg, 8, rect);
802 :     msg
803 :     end
804 :    
805 :     fun encodeCopyArea { gc, src, dst, src_pt, size, dst_pt } = let
806 :     val msg = mkResourceReq (reqCopyArea, src)
807 :     in
808 :     putXId (msg, 8, dst);
809 :     putXId (msg, 12, gc);
810 :     putPt (msg, 16, src_pt);
811 :     putPt (msg, 20, dst_pt);
812 :     putSize (msg, 24, size);
813 :     msg
814 :     end
815 :    
816 :     fun encodeCopyPlane { gc, src, dst, src_pt, size, dst_pt, plane } = let
817 :     val msg = mkResourceReq (reqCopyPlane, src)
818 :     in
819 :     putXId (msg, 8, dst);
820 :     putXId (msg, 12, gc);
821 :     putPt (msg, 16, src_pt);
822 :     putPt (msg, 20, dst_pt);
823 :     putSize (msg, 24, size);
824 :     put32 (msg, 28, LargeWord.<<(0w1, Word.fromInt plane));
825 :     msg
826 :     end
827 :    
828 :    
829 :     local
830 :     fun encodePoly req_info { drawable, gc, relative, items } = let
831 :     val msg = mkExtraReq (req_info, List.length items)
832 :     in
833 :     putBool(msg, 1, relative);
834 :     putXId(msg, 4, drawable);
835 :     putXId(msg, 8, gc);
836 :     putPts (msg, 12, items);
837 :     msg
838 :     end
839 :     in
840 :     val encodePolyPoint = encodePoly reqPolyPoint
841 :     val encodePolyLine = encodePoly reqPolyLine
842 :     end
843 :    
844 :    
845 :     local
846 :     fun encode (info, putItems, sz) { drawable, gc, items } = let
847 :     val msg = mkExtraReq (info, sz*(List.length items))
848 :     in
849 :     putXId(msg, 4, drawable);
850 :     putXId(msg, 8, gc);
851 :     putItems (msg, 12, items);
852 :     msg
853 :     end
854 :     val putSegs = putList
855 :     (fn (buf, i, G.LINE(p1, p2)) => (putPt(buf, i, p1); putPt(buf, i+4, p2)), 8)
856 :     val putArcs = putList (putArc, 12)
857 :     in
858 :     val encodePolySegment = encode (reqPolySegment, putSegs, 2)
859 :     val encodePolyRectangle = encode (reqPolyRectangle, putRects, 2)
860 :     val encodePolyFillRectangle = encode (reqPolyFillRectangle, putRects, 2)
861 :     val encodePolyArc = encode (reqPolyArc, putArcs, 3)
862 :     val encodePolyFillArc = encode (reqPolyFillArc, putArcs, 3)
863 :     end (* local *)
864 :    
865 :     fun encodeFillPoly { drawable, gc, shape, relative, pts } = let
866 :     val msg = mkExtraReq (reqFillPoly, List.length pts)
867 :     in
868 :     putXId(msg, 4, drawable);
869 :     putXId(msg, 8, gc);
870 :     put8(msg, 12, case shape
871 :     of XTy.ComplexShape => 0w0
872 :     | XTy.NonconvexShape => 0w1
873 :     | XTy.ConvexShape => 0w2
874 :     (* end case *));
875 :     putBool(msg, 13, relative);
876 :     putPts (msg, 16, pts);
877 :     msg
878 :     end
879 :    
880 :     local
881 :     fun putImageFormat (buf, i, XTy.XYBitmap) = put8(buf, i, 0w0)
882 :     | putImageFormat (buf, i, XTy.XYPixmap) = put8(buf, i, 0w1)
883 :     | putImageFormat (buf, i, XTy.ZPixmap) = put8(buf, i, 0w2)
884 :     in
885 :     fun encodePutImage { drawable, gc, depth, size, dst, lpad, format, data } = let
886 :     val n = W8V.length data
887 :     val msg = mkExtraReq (reqPutImage, (pad n) div 4)
888 :     in
889 :     putImageFormat(msg, 1, format);
890 :     putXId(msg, 4, drawable);
891 :     putXId(msg, 8, gc);
892 :     putSize(msg, 12, size);
893 :     putPt(msg, 16, dst);
894 :     putSigned8(msg, 20, lpad);
895 :     putSigned8(msg, 21, depth);
896 :     putData(msg, 24, data);
897 :     msg
898 :     end
899 :     fun encodeGetImage { drawable, rect, plane_mask, format } = let
900 :     val msg = mkResourceReq (reqGetImage, drawable)
901 :     in
902 :     putImageFormat(msg, 1, format);
903 :     putRect(msg, 8, rect);
904 :     putPlaneMask(msg, 16, plane_mask);
905 :     msg
906 :     end
907 :     end (* local *)
908 :    
909 :     local
910 :     fun textlen (nil, n) = n
911 :     | textlen ((XTy.FontItem _)::r, n) = textlen(r, n+5)
912 :     | textlen ((XTy.TextItem(_, s))::r, n) = textlen(r, n+2+(String.size s))
913 :     fun encode (itemlen, req_info) { drawable, gc, pt, items } = let
914 :     fun put (msg, i, []) = ()
915 :     | put (msg, i, (XTy.FontItem(XTy.XID fid)) :: r) = (
916 :     put8(msg, i, 0w255);
917 :     (* NOTE: this is unaligned, so we have to do it byte-by-byte *)
918 :     putWord8 (msg, i+1, Word.>>(fid, 0w24));
919 :     putWord8 (msg, i+2, Word.>>(fid, 0w16));
920 :     putWord8 (msg, i+3, Word.>>(fid, 0w8));
921 :     putWord8 (msg, i+4, fid);
922 :     put (msg, i+5, r))
923 :     | put (msg, i, (XTy.TextItem(delta, s)) :: r) = let
924 :     val n = itemlen s
925 :     in
926 :     if (n > 254)
927 :     then MLXError.impossible "excessive string in PolyText"
928 :     else ();
929 :     putSigned8(msg, i, n);
930 :     putSigned8(msg, i+1, delta);
931 :     putString(msg, i+2, s);
932 :     put (msg, i+2+(String.size s), r)
933 :     end
934 :     val l = textlen (items, 0)
935 :     val p = pad l
936 :     val msg = mkExtraReq (req_info, p div 4)
937 :     in
938 :     if (p = l) then () else put8(msg, 16+l, 0w0); (* Xlib does this *)
939 :     putXId(msg, 4, drawable);
940 :     putXId(msg, 8, gc);
941 :     putPt(msg, 12, pt);
942 :     put(msg, 16, items);
943 :     msg
944 :     end
945 :     in
946 :     val encodePolyText8 = encode (String.size, reqPolyText8)
947 :     val encodePolyText16 = encode (fn s => ((String.size s) div 2), reqPolyText16)
948 :     end (* local *)
949 :    
950 :     local
951 :     fun encode (textlen, req_info) { drawable, gc, pt, str } = let
952 :     val len = String.size str
953 :     val msg = mkExtraReq (req_info, (pad len) div 4)
954 :     in
955 :     putSigned8(msg, 1, textlen str);
956 :     putXId(msg, 4, drawable);
957 :     putXId(msg, 8, gc);
958 :     putPt(msg, 12, pt);
959 :     putString(msg, 16, str);
960 :     msg
961 :     end
962 :     in
963 :     val encodeImageText8 = encode (String.size, reqImageText8)
964 :     val encodeImageText16 = encode (fn s => ((String.size s) div 2), reqImageText16)
965 :     end (* local *)
966 :    
967 :     fun encodeCreateColormap { cmap, win, visual, all_writable } = let
968 :     val msg = mkReq reqCreateColormap
969 :     in
970 :     putBool(msg, 1, all_writable);
971 :     putXId(msg, 4, cmap);
972 :     putXId(msg, 8, win);
973 :     putXId(msg, 12, visual);
974 :     msg
975 :     end
976 :    
977 :     fun encodeFreeColormap { cmap } = mkResourceReq (reqFreeColormap, cmap)
978 :    
979 :     fun encodeCopyColormapAndFree { src, dst } = let
980 :     val msg = mkReq reqCopyColormapAndFree
981 :     in
982 :     putXId(msg, 4, dst);
983 :     putXId(msg, 8, src);
984 :     msg
985 :     end
986 :    
987 :     fun encodeInstallColormap { cmap } = mkResourceReq (reqInstallColormap, cmap)
988 :     fun encodeUninstallColormap { cmap } = mkResourceReq (reqUninstallColormap, cmap)
989 :    
990 :     fun encodeListInstalledColormaps { win } =
991 :     mkResourceReq (reqListInstalledColormaps, win)
992 :    
993 :     fun encodeAllocColor { cmap, color } = let
994 :     val msg = mkReq (reqAllocColor)
995 :     in
996 :     putXId(msg, 4, cmap);
997 :     putRGB(msg, 8, color);
998 :     msg
999 :     end
1000 :    
1001 :     fun encodeAllocNamedColor { cmap, name } = let
1002 :     val n = String.size name
1003 :     val msg = mkExtraReq (reqAllocNamedColor, (pad n) div 4)
1004 :     in
1005 :     putXId(msg, 4, cmap);
1006 :     putSigned16(msg, 8, n);
1007 :     putString (msg, 12, name);
1008 :     msg
1009 :     end
1010 :    
1011 :     (**************************************************************************************
1012 :     fun encodeAllocColorCells = let
1013 :     val msg = mkReq (reqAllocColorCells)
1014 :     in
1015 :     raise XERROR "unimplemented" (*** FIX ***)
1016 :     end
1017 :     fun encodeAllocColorPlanes = let
1018 :     val msg = mkReq (reqAllocColorPlanes)
1019 :     in
1020 :     raise XERROR "unimplemented" (*** FIX ***)
1021 :     end
1022 :     **************************************************************************************)
1023 :    
1024 :     fun encodeFreeColors { cmap, plane_mask, pixels } = let
1025 :     val msg = mkExtraReq (reqFreeColors, List.length pixels)
1026 :     in
1027 :     putXId(msg, 4, cmap);
1028 :     putPlaneMask(msg, 8, plane_mask);
1029 :     putPixels (msg, 12, pixels);
1030 :     msg
1031 :     end
1032 :    
1033 :     local
1034 :     fun putColorItem (buf, i, XTy.COLORITEM{pixel, red, green, blue}) = let
1035 :     val rmask = (case red
1036 :     of NONE => 0w0
1037 :     | (SOME x) => (putWord16(buf, i+4, x); 0w1)
1038 :     (* end case *))
1039 :     val gmask = (case green
1040 :     of NONE => 0w0
1041 :     | (SOME x) => (putWord16(buf, i+6, x); 0w2)
1042 :     (* end case *))
1043 :     val bmask = (case blue
1044 :     of NONE => 0w0
1045 :     | (SOME x) => (putWord16(buf, i+8, x); 0w4)
1046 :     (* end case *))
1047 :     in
1048 :     putPixel(buf, i, pixel);
1049 :     put8(buf, i+10, Word8.orb(rmask, Word8.orb(gmask, bmask)))
1050 :     end
1051 :     val putColorItemList = putList (putColorItem, 12)
1052 :     in
1053 :     fun encodeStoreColors { cmap, items } = let
1054 :     val msg = mkExtraReq (reqStoreColors, 3*(List.length items))
1055 :     in
1056 :     putXId(msg, 4, cmap);
1057 :     putColorItemList(msg, 8, items);
1058 :     msg
1059 :     end
1060 :     end (* local *)
1061 :    
1062 :     fun encodeStoreNamedColor
1063 :     { cmap, name, pixel, do_red, do_green, do_blue } = let
1064 :     val n = String.size name
1065 :     val msg = mkExtraReq (reqStoreNamedColor, (pad n) div 4)
1066 :     val mask = Word8.orb(
1067 :     if do_red then 0w1 else 0w0,
1068 :     Word8.orb(
1069 :     if do_green then 0w2 else 0w0,
1070 :     if do_blue then 0w4 else 0w0))
1071 :     in
1072 :     put8(msg, 1, mask);
1073 :     putXId(msg, 4, cmap);
1074 :     putPixel(msg, 8, pixel);
1075 :     putString (msg, 12, name);
1076 :     msg
1077 :     end
1078 :    
1079 :     fun encodeQueryColors { cmap, pixels } = let
1080 :     val msg = mkExtraReq (reqQueryColors, List.length pixels)
1081 :     in
1082 :     putXId(msg, 4, cmap);
1083 :     putPixels (msg, 8, pixels);
1084 :     msg
1085 :     end
1086 :    
1087 :     fun encodeLookupColor { cmap, name } = let
1088 :     val n = String.size name
1089 :     val msg = mkExtraReq (reqLookupColor, (pad n) div 4)
1090 :     in
1091 :     putXId(msg, 4, cmap);
1092 :     putSigned16(msg, 8, n);
1093 :     putString(msg, 12, name);
1094 :     msg
1095 :     end
1096 :    
1097 :     fun encodeCreateCursor { cursor, src, mask, fore_rgb, back_rgb, hot_spot} = let
1098 :     val msg = mkReq (reqCreateCursor)
1099 :     in
1100 :     putXId(msg, 4, cursor);
1101 :     putXId(msg, 8, src);
1102 :     putXIdOption(msg, 12, mask);
1103 :     putRGB(msg, 16, fore_rgb);
1104 :     putRGB(msg, 22, back_rgb);
1105 :     putPt(msg, 24, hot_spot);
1106 :     msg
1107 :     end
1108 :    
1109 :     fun encodeCreateGlyphCursor
1110 :     { cursor, src_font, mask_font, src_chr, mask_chr, fore_rgb, back_rgb } = let
1111 :     val msg = mkReq (reqCreateGlyphCursor)
1112 :     in
1113 :     putXId(msg, 4, cursor);
1114 :     putXId(msg, 8, src_font);
1115 :     putXIdOption(msg, 12, mask_font);
1116 :     putSigned16(msg, 16, src_chr);
1117 :     putSigned16(msg, 18, mask_chr);
1118 :     putRGB(msg, 20, fore_rgb);
1119 :     putRGB(msg, 26, back_rgb);
1120 :     msg
1121 :     end
1122 :    
1123 :     fun encodeFreeCursor { cursor } = mkResourceReq (reqFreeCursor, cursor)
1124 :    
1125 :     fun encodeRecolorCursor { cursor, fore_color, back_color } = let
1126 :     val msg = mkReq reqRecolorCursor
1127 :     in
1128 :     putXId(msg, 4, cursor);
1129 :     putRGB(msg, 8, fore_color);
1130 :     putRGB(msg, 14, back_color);
1131 :     msg
1132 :     end
1133 :    
1134 :     fun encodeQueryBestSize { class, drawable, size } = let
1135 :     val msg = mkReq reqQueryBestSize
1136 :     in
1137 :     put8(msg, 1, case class
1138 :     of XTy.CursorShape => 0w0
1139 :     | XTy.TileShape => 0w1
1140 :     | XTy.StippleShape => 0w2
1141 :     (* end case *));
1142 :     putXId(msg, 4, drawable);
1143 :     putSize(msg, 8, size);
1144 :     msg
1145 :     end
1146 :    
1147 :     fun encodeQueryExtension name = let
1148 :     val n = String.size name
1149 :     val msg = mkExtraReq (reqQueryExtension, (pad n) div 4)
1150 :     in
1151 :     putSigned16(msg, 4, n);
1152 :     putString(msg, 8, name);
1153 :     msg
1154 :     end
1155 :    
1156 :     (**************************************************************************************
1157 :     fun encodeChangeKeyboardMapping = let
1158 :     val msg = mkReq (reqChangeKeyboardMapping)
1159 :     in
1160 :     raise XERROR "unimplemented" (*** FIX ***)
1161 :     end
1162 :     **************************************************************************************)
1163 :    
1164 :     fun encodeGetKeyboardMapping {first=(XTy.KEYCODE k), count} = let
1165 :     val msg = mkReq reqGetKeyboardMapping
1166 :     in
1167 :     putSigned8(msg, 4, k);
1168 :     putSigned8(msg, 5, count);
1169 :     msg
1170 :     end
1171 :    
1172 :     fun encodeChangeKeyboardControl { vals } = let
1173 :     val (nvals, mask, vals) = mkValList vals
1174 :     val msg = mkExtraReq (reqChangeKeyboardControl, nvals)
1175 :     in
1176 :     putValList(msg, 4, mask, vals);
1177 :     msg
1178 :     end
1179 :    
1180 :     fun encodeBell { percent } = let
1181 :     val msg = mkReq reqBell
1182 :     in
1183 :     putSigned8(msg, 1, percent);
1184 :     msg
1185 :     end
1186 :    
1187 :     fun encodeChangePointerControl { acceleration, threshold } = let
1188 :     val msg = mkReq reqChangePointerControl
1189 :     in
1190 :     case acceleration
1191 :     of NONE => putBool(msg, 10, false)
1192 :     | (SOME{numerator, denominator}) => (
1193 :     putBool(msg, 10, true);
1194 :     putSigned16(msg, 4, numerator);
1195 :     putSigned16(msg, 6, denominator));
1196 :     case threshold
1197 :     of NONE => putBool(msg, 11, false)
1198 :     | (SOME threshold) => (
1199 :     putBool(msg, 11, false);
1200 :     putSigned16(msg, 8, threshold));
1201 :     msg
1202 :     end
1203 :    
1204 :     fun encodeSetScreenSaver
1205 :     { timeout, interval, prefer_blanking, allow_exposures } = let
1206 :     val msg = mkReq reqSetScreenSaver
1207 :     fun put (i, NONE) = put8(msg, i, 0w2)
1208 :     | put (i, SOME b) = putBool(msg, i, b)
1209 :     in
1210 :     putSigned16(msg, 4, timeout);
1211 :     putSigned16(msg, 6, interval);
1212 :     put(8, prefer_blanking);
1213 :     put(9, allow_exposures);
1214 :     msg
1215 :     end
1216 :    
1217 :     fun encodeChangeHosts { host, remove } = let
1218 :     val (family, addr) = case host
1219 :     of (XTy.InternetHost s) => (0w0, s)
1220 :     | (XTy.DECnetHost s) => (0w1, s)
1221 :     | (XTy.ChaosHost s) => (0w2, s)
1222 :     val len = String.size addr
1223 :     val msg = mkExtraReq (reqChangeHosts, (pad len) div 4)
1224 :     in
1225 :     putBool(msg, 1, remove);
1226 :     put8(msg, 4, family);
1227 :     putSigned16(msg, 6, len);
1228 :     putString(msg, 8, addr);
1229 :     msg
1230 :     end
1231 :    
1232 :     fun encodeSetAccessControl { enable } = let
1233 :     val msg = mkReq (reqSetAccessControl)
1234 :     in
1235 :     putBool(msg, 1, enable);
1236 :     msg
1237 :     end
1238 :    
1239 :     fun encodeSetCloseDownMode { mode } = let
1240 :     val msg = mkReq (reqSetCloseDownMode)
1241 :     in
1242 :     put8(msg, 1, case mode
1243 :     of XTy.DestroyAll => 0w0
1244 :     | XTy.RetainPermanent => 0w1
1245 :     | XTy.RetainTemporary => 0w2
1246 :     (* end case *));
1247 :     msg
1248 :     end
1249 :    
1250 :     fun encodeKillClient { resource } = let
1251 :     val rid = case resource of NONE => (XTy.XID 0w0) | (SOME x) => x
1252 :     in
1253 :     mkResourceReq (reqKillClient, rid)
1254 :     end
1255 :    
1256 :     fun encodeRotateProperties { win, delta, properties } = let
1257 :     val n = List.length properties
1258 :     val msg = mkExtraReq (reqRotateProperties, n)
1259 :     in
1260 :     putXId(msg, 4, win);
1261 :     putSigned16(msg, 8, n);
1262 :     putSigned16(msg, 10, delta);
1263 :     putList (putAtom, 4) (msg, 12, properties);
1264 :     msg
1265 :     end
1266 :    
1267 :     fun encodeForceScreenSaver { activate } = let
1268 :     val msg = mkReq (reqForceScreenSaver)
1269 :     in
1270 :     putBool(msg, 1, activate);
1271 :     msg
1272 :     end
1273 :    
1274 :     (**************************************************************************************
1275 :     fun encodeSetPointerMapping = let
1276 :     val msg = mkReq (reqSetPointerMapping)
1277 :     in
1278 :     raise XERROR "unimplemented" (*** FIX ***)
1279 :     end
1280 :     fun encodeGetPointerMapping = let
1281 :     val msg = mkReq (reqGetPointerMapping)
1282 :     in
1283 :     raise XERROR "unimplemented" (*** FIX ***)
1284 :     end
1285 :     fun encodeSetModifierMapping = let
1286 :     val msg = mkExtraReq (reqSetModifierMapping, ?)
1287 :     in
1288 :     raise XERROR "unimplemented" (*** FIX ***)
1289 :     end
1290 :     **************************************************************************************)
1291 :    
1292 :     (* Fixed requests *)
1293 :     val requestNoOperation = mkReq reqNoOperation
1294 :     val requestGetInputFocus = mkReq reqGetInputFocus
1295 :     val requestQueryKeymap = mkReq reqQueryKeymap
1296 :     val requestGrabServer = mkReq reqGrabServer
1297 :     val requestUngrabServer = mkReq reqUngrabServer
1298 :     val requestGetFontPath = mkReq reqGetFontPath
1299 :     val requestListExtensions = mkReq reqListExtensions
1300 :     val requestGetKeyboardControl = mkReq reqGetKeyboardControl
1301 :     val requestGetPointerControl = mkReq reqGetPointerControl
1302 :     val requestGetScreenSaver = mkReq reqGetScreenSaver
1303 :     val requestListHosts = mkReq reqListHosts
1304 :     val requestGetModifierMapping = mkReq reqGetModifierMapping
1305 :    
1306 :     end (* local open ... *)
1307 :    
1308 :     end (* XRequests *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0