/[cmucl]/src/clx/macros.lisp
ViewVC logotype

Contents of /src/clx/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Tue Aug 21 15:49:28 2007 UTC (6 years, 7 months ago) by fgilham
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, sse2-base, sse2-packed-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, release-19e, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, unicode-utf16-sync-2008-11, release-19e-pre1, release-19e-pre2, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, unicode-utf16-extfmt-2009-06-11, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, portable-clx-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, sse2-packed-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, unicode-utf16-extfmt-branch
Changes since 1.6: +169 -149 lines
Telent CLX import
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;;
4 ;;; TEXAS INSTRUMENTS INCORPORATED
5 ;;; P.O. BOX 2909
6 ;;; AUSTIN, TEXAS 78769
7 ;;;
8 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
9 ;;;
10 ;;; Permission is granted to any individual or institution to use, copy, modify,
11 ;;; and distribute this software, provided that this complete copyright and
12 ;;; permission notice is maintained, intact, in all copies and supporting
13 ;;; documentation.
14 ;;;
15 ;;; Texas Instruments Incorporated provides this software "as is" without
16 ;;; express or implied warranty.
17 ;;;
18
19 ;;; CLX basically implements a very low overhead remote procedure call
20 ;;; to the server. This file contains macros which generate the code
21 ;;; for both the client AND the server, given a specification of the
22 ;;; interface. This was done to eliminate errors that may occur because
23 ;;; the client and server code get/put bytes in different places, and
24 ;;; it makes it easier to extend the protocol.
25
26 ;;; This is built on top of BUFFER
27
28 #+cmu
29 (ext:file-comment "$Id: macros.lisp,v 1.7 2007/08/21 15:49:28 fgilham Exp $")
30
31 (in-package :xlib)
32
33 (defmacro type-check (value type)
34 value type
35 (when +type-check?+
36 `(unless (type? ,value ,type)
37 (x-type-error ,value ,type))))
38
39 ;;; This variable is used by the required-arg macro just to satisfy compilers.
40 (defvar *required-arg-dummy*)
41
42 ;;; An error signalling macro use to specify that keyword arguments are required.
43 (defmacro required-arg (name)
44 `(progn (x-error 'missing-parameter :parameter ',name)
45 *required-arg-dummy*))
46
47 (defmacro lround (index)
48 ;; Round up to the next 32 bit boundary
49 `(the array-index (logand (index+ ,index 3) -4)))
50
51 (defmacro wround (index)
52 ;; Round up to the next 16 bit boundary
53 `(the array-index (logand (index+ ,index 1) -2)))
54
55 ;;
56 ;; Data-type accessor functions
57 ;;
58 ;; These functions translate between lisp data-types and the byte,
59 ;; half-word or word that gets transmitted across the client/server
60 ;; connection
61
62 (defun index-increment (type)
63 ;; Given a type, return its field width in bytes
64 (let* ((name (if (consp type) (car type) type))
65 (increment (get name 'byte-width :not-found)))
66 (when (eq increment :not-found)
67 ;; Check for TYPE in a different package
68 (when (not (eq (symbol-package name) *xlib-package*))
69 (setq name (xintern name))
70 (setq increment (get name 'byte-width :not-found)))
71 (when (eq increment :not-found)
72 (error "~s isn't a known field accessor" name)))
73 increment))
74
75 (eval-when (:compile-toplevel :load-toplevel :execute)
76 (defun getify (name)
77 (xintern name '-get))
78
79 (defun putify (name &optional predicate-p)
80 (xintern name '-put (if predicate-p '-predicating "")))
81
82 ;;; Use &body so zmacs indents properly
83 (defmacro define-accessor (name (width) &body get-put-macros)
84 ;; The first body form defines the get macro
85 ;; The second body form defines the put macro
86 ;; The third body form is optional, and defines a put macro that does
87 ;; type checking and does a put when ok, else NIL when the type is incorrect.
88 ;; If no third body form is present, then these macros assume that
89 ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated.
90 ;; these predicating puts are used by the OR accessor.
91 (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro))
92 (when (cdddr get-put-macros)
93 (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros)))
94 (let ((get-macro (or (first get-put-macros) (error "No GET macro form for ~s" name)))
95 (put-macro (or (second get-put-macros) (error "No PUT macro form for ~s" name))))
96 `(within-definition (,name define-accessor)
97 (setf (get ',name 'byte-width) ,(and width (floor width 8)))
98 (defmacro ,(getify name) ,(car get-macro)
99 ,@(cdr get-macro))
100 (defmacro ,(putify name) ,(car put-macro)
101 ,@(cdr put-macro))
102 ,@(when +type-check?+
103 (let ((predicating-put (third get-put-macros)))
104 (when predicating-put
105 `((setf (get ',name 'predicating-put) t)
106 (defmacro ,(putify name t) ,(car predicating-put)
107 ,@(cdr predicating-put)))))))))
108 ) ;; End eval-when
109
110 (define-accessor card32 (32)
111 ((index) `(read-card32 ,index))
112 ((index thing) `(write-card32 ,index ,thing)))
113
114 (define-accessor card29 (32)
115 ((index) `(read-card29 ,index))
116 ((index thing) `(write-card29 ,index ,thing)))
117
118 (define-accessor card16 (16)
119 ((index) `(read-card16 ,index))
120 ((index thing) `(write-card16 ,index ,thing)))
121
122 (define-accessor card8 (8)
123 ((index) `(read-card8 ,index))
124 ((index thing) `(write-card8 ,index ,thing)))
125
126 (define-accessor integer (32)
127 ((index) `(read-int32 ,index))
128 ((index thing) `(write-int32 ,index ,thing)))
129
130 (define-accessor int16 (16)
131 ((index) `(read-int16 ,index))
132 ((index thing) `(write-int16 ,index ,thing)))
133
134 (define-accessor rgb-val (16)
135 ;; Used for color's
136 ((index) `(card16->rgb-val (read-card16 ,index)))
137 ((index thing) `(write-card16 ,index (rgb-val->card16 ,thing))))
138
139 (define-accessor angle (16)
140 ;; Used for drawing arcs
141 ((index) `(int16->radians (read-int16 ,index)))
142 ((index thing) `(write-int16 ,index (radians->int16 ,thing))))
143
144 (define-accessor bit (0)
145 ;; Like BOOLEAN, but tests bits
146 ;; only used by declare-event (:enter-notify :leave-notify)
147 ((index bit)
148 `(logbitp ,bit (read-card8 ,index)))
149 ((index thing bit)
150 (if (zerop bit)
151 `(write-card8 ,index (if ,thing 1 0))
152 `(write-card8 ,index (dpb (if ,thing 1 0) (byte 1 ,bit) (read-card8 ,index))))))
153
154 (define-accessor boolean (8)
155 ((index)
156 `(plusp (read-card8 ,index)))
157 ((index thing) `(write-card8 ,index (if ,thing 1 0))))
158
159 (define-accessor drawable (32)
160 ((index &optional (buffer '%buffer))
161 `(lookup-drawable ,buffer (read-card29 ,index)))
162 ((index thing) `(write-card29 ,index (drawable-id ,thing))))
163
164 (define-accessor window (32)
165 ((index &optional (buffer '%buffer))
166 `(lookup-window ,buffer (read-card29 ,index)))
167 ((index thing) `(write-card29 ,index (window-id ,thing))))
168
169 (define-accessor pixmap (32)
170 ((index &optional (buffer '%buffer))
171 `(lookup-pixmap ,buffer (read-card29 ,index)))
172 ((index thing) `(write-card29 ,index (pixmap-id ,thing))))
173
174 (define-accessor gcontext (32)
175 ((index &optional (buffer '%buffer))
176 `(lookup-gcontext ,buffer (read-card29 ,index)))
177 ((index thing) `(write-card29 ,index (gcontext-id ,thing))))
178
179 (define-accessor cursor (32)
180 ((index &optional (buffer '%buffer))
181 `(lookup-cursor ,buffer (read-card29 ,index)))
182 ((index thing) `(write-card29 ,index (cursor-id ,thing))))
183
184 (define-accessor colormap (32)
185 ((index &optional (buffer '%buffer))
186 `(lookup-colormap ,buffer (read-card29 ,index)))
187 ((index thing) `(write-card29 ,index (colormap-id ,thing))))
188
189 (define-accessor font (32)
190 ((index &optional (buffer '%buffer))
191 `(lookup-font ,buffer (read-card29 ,index)))
192 ;; The FONT-ID accessor may make a OpenFont request. Since we don't support recursive
193 ;; with-buffer-request, issue a compile time error, rather than barf at run-time.
194 ((index thing)
195 (declare (ignore index thing))
196 (error "FONT-ID must be called OUTSIDE with-buffer-request. Use RESOURCE-ID instead.")))
197
198 ;; Needed to get and put xatom's in events
199 (define-accessor keyword (32)
200 ((index &optional (buffer '%buffer))
201 `(atom-name ,buffer (read-card29 ,index)))
202 ((index thing &key (buffer '%buffer))
203 `(write-card29 ,index (or (atom-id ,thing ,buffer)
204 (error "CLX implementation error in KEYWORD-PUT")))))
205
206 (define-accessor resource-id (32)
207 ((index) `(read-card29 ,index))
208 ((index thing) `(write-card29 ,index ,thing)))
209
210 (define-accessor resource-id-or-nil (32)
211 ((index) (let ((id (gensym)))
212 `(let ((,id (read-card29 ,index)))
213 (and (plusp ,id) ,id))))
214 ((index thing) `(write-card29 ,index (or ,thing 0))))
215
216 (defmacro char-info-get (index)
217 `(make-char-info
218 :left-bearing (int16-get ,index)
219 :right-bearing (int16-get ,(+ index 2))
220 :width (int16-get ,(+ index 4))
221 :ascent (int16-get ,(+ index 6))
222 :descent (int16-get ,(+ index 8))
223 :attributes (card16-get ,(+ index 10))))
224
225 (define-accessor member8 (8)
226 ((index &rest keywords)
227 (let ((value (gensym)))
228 `(let ((,value (read-card8 ,index)))
229 (declare (type (integer 0 (,(length keywords))) ,value))
230 (type-check ,value '(integer 0 (,(length keywords))))
231 (svref ',(apply #'vector keywords) ,value))))
232 ((index thing &rest keywords)
233 `(write-card8 ,index (position ,thing
234 #+lispm ',keywords ;; Lispm's prefer lists
235 #-lispm (the simple-vector ',(apply #'vector keywords))
236 :test #'eq)))
237 ((index thing &rest keywords)
238 (let ((value (gensym)))
239 `(let ((,value (position ,thing
240 #+lispm ',keywords
241 #-lispm (the simple-vector ',(apply #'vector keywords))
242 :test #'eq)))
243 (and ,value (write-card8 ,index ,value))))))
244
245 (define-accessor member16 (16)
246 ((index &rest keywords)
247 (let ((value (gensym)))
248 `(let ((,value (read-card16 ,index)))
249 (declare (type (integer 0 (,(length keywords))) ,value))
250 (type-check ,value '(integer 0 (,(length keywords))))
251 (svref ',(apply #'vector keywords) ,value))))
252 ((index thing &rest keywords)
253 `(write-card16 ,index (position ,thing
254 #+lispm ',keywords ;; Lispm's prefer lists
255 #-lispm (the simple-vector ',(apply #'vector keywords))
256 :test #'eq)))
257 ((index thing &rest keywords)
258 (let ((value (gensym)))
259 `(let ((,value (position ,thing
260 #+lispm ',keywords
261 #-lispm (the simple-vector ',(apply #'vector keywords))
262 :test #'eq)))
263 (and ,value (write-card16 ,index ,value))))))
264
265 (define-accessor member (32)
266 ((index &rest keywords)
267 (let ((value (gensym)))
268 `(let ((,value (read-card29 ,index)))
269 (declare (type (integer 0 (,(length keywords))) ,value))
270 (type-check ,value '(integer 0 (,(length keywords))))
271 (svref ',(apply #'vector keywords) ,value))))
272 ((index thing &rest keywords)
273 `(write-card29 ,index (position ,thing
274 #+lispm ',keywords ;; Lispm's prefer lists
275 #-lispm (the simple-vector ',(apply #'vector keywords))
276 :test #'eq)))
277 ((index thing &rest keywords)
278 (if (cdr keywords) ;; IF more than one
279 (let ((value (gensym)))
280 `(let ((,value (position ,thing
281 #+lispm ',keywords
282 #-lispm (the simple-vector ',(apply #'vector keywords))
283 :test #'eq)))
284 (and ,value (write-card29 ,index ,value))))
285 `(and (eq ,thing ,(car keywords)) (write-card29 ,index 0)))))
286
287 (deftype member-vector (vector) `(member ,@(coerce (symbol-value vector) 'list)))
288
289 (define-accessor member-vector (32)
290 ((index membership-vector)
291 `(member-get ,index ,@(coerce (eval membership-vector) 'list)))
292 ((index thing membership-vector)
293 `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
294 ((index thing membership-vector)
295 `(member-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
296
297 (define-accessor member16-vector (16)
298 ((index membership-vector)
299 `(member16-get ,index ,@(coerce (eval membership-vector) 'list)))
300 ((index thing membership-vector)
301 `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
302 ((index thing membership-vector)
303 `(member16-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
304
305 (define-accessor member8-vector (8)
306 ((index membership-vector)
307 `(member8-get ,index ,@(coerce (eval membership-vector) 'list)))
308 ((index thing membership-vector)
309 `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list)))
310 ((index thing membership-vector)
311 `(member8-put ,index ,thing ,@(coerce (eval membership-vector) 'list))))
312
313 (define-accessor boole-constant (32)
314 ;; this isn't member-vector because we need eql instead of eq
315 ((index)
316 (let ((value (gensym)))
317 `(let ((,value (read-card29 ,index)))
318 (declare (type (integer 0 (,(length +boole-vector+))) ,value))
319 (type-check ,value '(integer 0 (,(length +boole-vector+))))
320 (svref +boole-vector+ ,value))))
321 ((index thing)
322 `(write-card29 ,index (position ,thing (the simple-vector +boole-vector+))))
323 ((index thing)
324 (let ((value (gensym)))
325 `(let ((,value (position ,thing (the simple-vector +boole-vector+))))
326 (and ,value (write-card29 ,index ,value))))))
327
328 (define-accessor null (32)
329 ((index) `(if (zerop (read-card32 ,index)) nil (read-card32 ,index)))
330 ((index value) (declare (ignore value)) `(write-card32 ,index 0)))
331
332 (define-accessor pad8 (8)
333 ((index) (declare (ignore index)) nil)
334 ((index value) (declare (ignore index value)) nil))
335
336 (define-accessor pad16 (16)
337 ((index) (declare (ignore index)) nil)
338 ((index value) (declare (ignore index value)) nil))
339
340 (define-accessor bit-vector256 (256)
341 ;; used for key-maps
342 ;; REAL-INDEX parameter provided so the default index can be over-ridden.
343 ;; This is needed for the :keymap-notify event where the keymap overlaps
344 ;; the window id.
345 ((index &optional (real-index index) data)
346 `(read-bitvector256 buffer-bbuf ,real-index ,data))
347 ((index map &optional (real-index index) (buffer '%buffer))
348 `(write-bitvector256 ,buffer (index+ buffer-boffset ,real-index) ,map)))
349
350 (define-accessor string (nil)
351 ((length index &key reply-buffer)
352 `(read-sequence-char
353 ,(or reply-buffer '%reply-buffer) 'string ,length nil nil 0 ,index))
354 ((index string &key buffer (start 0) end header-length appending)
355 (unless buffer (setq buffer '%buffer))
356 (unless header-length (setq header-length (lround index)))
357 (let* ((real-end (if appending (or end `(length ,string)) (gensym)))
358 (form `(write-sequence-char ,buffer (index+ buffer-boffset ,header-length)
359 ,string ,start ,real-end)))
360 (if appending
361 form
362 `(let ((,real-end ,(or end `(length ,string))))
363 (write-card16 2 (index-ceiling (index+ (index- ,real-end ,start) ,header-length) 4))
364 ,form)))))
365
366 (define-accessor sequence (nil)
367 ((&key length (format 'card32) result-type transform reply-buffer data index start)
368 `(,(ecase format
369 (card8 'read-sequence-card8)
370 (int8 'read-sequence-int8)
371 (card16 'read-sequence-card16)
372 (int16 'read-sequence-int16)
373 (card32 'read-sequence-card32)
374 (int32 'read-sequence-int32))
375 ,(or reply-buffer '%reply-buffer)
376 ,result-type ,length ,transform ,data
377 ,@(when (or start index) `(,(or start 0)))
378 ,@(when index `(,index))))
379 ((index data &key (format 'card32) (start 0) end transform buffer appending)
380 (unless buffer (setq buffer '%buffer))
381 (let* ((real-end (if appending (or end `(length ,data)) (gensym)))
382 (writer (xintern 'write-sequence- format))
383 (form `(,writer ,buffer (index+ buffer-boffset ,(lround index))
384 ,data ,start ,real-end ,transform)))
385 (flet ((maker (size)
386 (if appending
387 form
388 (let ((idx `(index- ,real-end ,start)))
389 (unless (= size 1)
390 (setq idx `(index-ceiling ,idx ,size)))
391 `(let ((,real-end ,(or end `(length ,data))))
392 (write-card16 2 (index+ ,idx ,(index-ceiling index 4)))
393 ,form)))))
394 (ecase format
395 ((card8 int8)
396 (maker 4))
397 ((card16 int16 char2b)
398 (maker 2))
399 ((card32 int32)
400 (maker 1)))))))
401
402 (defmacro client-message-event-get-sequence ()
403 '(let* ((format (read-card8 1))
404 (sequence (make-array (ceiling 160 format)
405 :element-type `(unsigned-byte ,format))))
406 (declare (type (member 8 16 32) format))
407 (do ((i 12)
408 (j 0 (index1+ j)))
409 ((>= i 32))
410 (case format
411 (8 (setf (aref sequence j) (read-card8 i))
412 (index-incf i))
413 (16 (setf (aref sequence j) (read-card16 i))
414 (index-incf i 2))
415 (32 (setf (aref sequence j) (read-card32 i))
416 (index-incf i 4))))
417 sequence))
418
419 (defmacro client-message-event-put-sequence (format sequence)
420 `(ecase ,format
421 (8 (sequence-put 12 ,sequence
422 :format card8
423 :end (min (length ,sequence) 20)
424 :appending t))
425 (16 (sequence-put 12 ,sequence
426 :format card16
427 :end (min (length ,sequence) 10)
428 :appending t))
429 (32 (sequence-put 12 ,sequence
430 :format card32
431 :end (min (length ,sequence) 5)
432 :appending t))))
433
434 ;; Used only in declare-event
435 (define-accessor client-message-sequence (160)
436 ((index format) (declare (ignore index format)) `(client-message-event-get-sequence))
437 ((index value format) (declare (ignore index))
438 `(client-message-event-put-sequence ,format ,value)))
439
440
441 ;;;
442 ;;; Compound accessors
443 ;;; Accessors that take other accessors as parameters
444 ;;;
445 (define-accessor code (0)
446 ((index) (declare (ignore index)) '(read-card8 0))
447 ((index value) (declare (ignore index)) `(write-card8 0 ,value))
448 ((index value) (declare (ignore index)) `(write-card8 0 ,value)))
449
450 (define-accessor length (0)
451 ((index) (declare (ignore index)) '(read-card16 2))
452 ((index value) (declare (ignore index)) `(write-card16 2 ,value))
453 ((index value) (declare (ignore index)) `(write-card16 2 ,value)))
454
455 (deftype data () 'card8)
456
457 (define-accessor data (0)
458 ;; Put data in byte 1 of the reqeust
459 ((index &optional stuff) (declare (ignore index))
460 (if stuff
461 (if (consp stuff)
462 `(,(getify (car stuff)) 1 ,@(cdr stuff))
463 `(,(getify stuff) 1))
464 `(read-card8 1)))
465 ((index thing &optional stuff)
466 (if stuff
467 (if (consp stuff)
468 `(macrolet ((write-card32 (index value) index value))
469 (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
470 `(,(putify stuff) 1 ,thing))
471 `(write-card8 1 ,thing)))
472 ((index thing &optional stuff)
473 (if stuff
474 `(and (type? ,thing ',stuff)
475 ,(if (consp stuff)
476 `(macrolet ((write-card32 (index value) index value))
477 (write-card8 1 (,(putify (car stuff)) ,index ,thing ,@(cdr stuff))))
478 `(,(putify stuff) 1 ,thing)))
479 `(and (type? ,thing 'card8) (write-card8 1 ,thing)))))
480
481 ;; Macroexpand the result of OR-GET to allow the macros file to not be loaded
482 ;; when using event-case. This is pretty gross.
483
484 (defmacro or-expand (&rest forms &environment environment)
485 `(cond ,@(mapcar #'(lambda (forms)
486 (mapcar #'(lambda (form)
487 (clx-macroexpand form environment))
488 forms))
489 forms)))
490
491 ;;
492 ;; the OR type
493 ;;
494 (define-accessor or (32)
495 ;; Select from among several types (usually NULL and something else)
496 ((index &rest type-list &environment environment)
497 (do ((types type-list (cdr types))
498 (value (gensym))
499 (result))
500 ((endp types)
501 `(let ((,value (read-card32 ,index)))
502 (macrolet ((read-card32 (index) index ',value)
503 (read-card29 (index) index ',value))
504 ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment))))
505 (let ((item (car types))
506 (args nil))
507 (when (consp item)
508 (setq args (cdr item)
509 item (car item)))
510 (if (eq item 'null) ;; Special case for NULL
511 (push `((zerop ,value) nil) result)
512 (push
513 `((,(getify item) ,index ,@args))
514 result)))))
515
516 ((index value &rest type-list)
517 (do ((types type-list (cdr types))
518 (result))
519 ((endp types)
520 `(cond ,@(nreverse result)
521 ,@(when +type-check?+
522 `((t (x-type-error ,value '(or ,@type-list)))))))
523 (let* ((type (car types))
524 (type-name type)
525 (args nil))
526 (when (consp type)
527 (setq args (cdr type)
528 type-name (car type)))
529 (push
530 `(,@(cond ((get type-name 'predicating-put) nil)
531 ((or +type-check?+ (cdr types)) `((type? ,value ',type)))
532 (t '(t)))
533 (,(putify type-name (get type-name 'predicating-put)) ,index ,value ,@args))
534 result)))))
535
536 ;;
537 ;; the MASK type...
538 ;; is used to specify a subset of a collection of "optional" arguments.
539 ;; A mask type consists of a 32 bit mask word followed by a word for each one-bit
540 ;; in the mask. The MASK type is ALWAYS the LAST item in a request.
541 ;;
542 (setf (get 'mask 'byte-width) nil)
543
544 (defun mask-get (index type-values body-function)
545 (declare (type function body-function)
546 #+clx-ansi-common-lisp
547 (dynamic-extent body-function)
548 #+(and lispm (not clx-ansi-common-lisp))
549 (sys:downward-funarg body-function))
550 ;; This is a function, because it must return more than one form (called by get-put-items)
551 ;; Functions that use this must have a binding for %MASK
552 (let* ((bit 0)
553 (result
554 (mapcar
555 #'(lambda (form)
556 (if (atom form)
557 form ;; Hack to allow BODY-FUNCTION to return keyword/value pairs
558 (prog1
559 `(when (logbitp ,bit %mask)
560 ;; Execute form when bit is set
561 ,form)
562 (incf bit))))
563 (get-put-items
564 (+ index 4) type-values nil
565 #'(lambda (type index item args)
566 (declare (ignore index))
567 (funcall body-function type '(* (incf %index) 4) item args))))))
568 ;; First form must load %MASK
569 `(,@(when (atom (car result))
570 (list (pop result)))
571 (progn (setq %mask (read-card32 ,index))
572 (setq %index ,(ceiling index 4))
573 ,(car result))
574 ,@(cdr result))))
575
576 ;; MASK-PUT
577
578 (defun mask-put (index type-values body-function)
579 (declare (type function body-function)
580 #+clx-ansi-common-lisp
581 (dynamic-extent body-function)
582 #+(and lispm (not clx-ansi-common-lisp))
583 (sys:downward-funarg body-function))
584 ;; The MASK type writes a 32 bit mask with 1 bits for each non-nil value in TYPE-VALUES
585 ;; A 32 bit value follows for each non-nil value.
586 `((let ((%mask 0)
587 (%index ,index))
588 ,@(let ((bit 1))
589 (get-put-items
590 index type-values t
591 #'(lambda (type index item args)
592 (declare (ignore index))
593 (if (or (symbolp item) (constantp item))
594 `((unless (null ,item)
595 (setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
596 ,@(funcall body-function type
597 `(index-incf %index 4) item args)))
598 `((let ((.item. ,item))
599 (unless (null .item.)
600 (setq %mask (logior %mask ,(shiftf bit (ash bit 1))))
601 ,@(funcall body-function type
602 `(index-incf %index 4) '.item. args))))))))
603 (write-card32 ,index %mask)
604 (write-card16 2 (index-ceiling (index-incf %index 4) 4))
605 (incf (buffer-boffset %buffer) %index))))
606
607 (define-accessor progn (nil)
608 ;; Catch-all for inserting random code
609 ;; Note that code using this is then responsible for setting the request length
610 ((index statement) (declare (ignore index)) statement)
611 ((index statement) (declare (ignore index)) statement))
612
613
614 ;
615 ; Wrapper macros, for use around the above
616 ;
617
618 ;;; type-check was here, and has been moved up
619
620 (defmacro check-put (index value type &rest args &environment env)
621 (let* ((var (if (or (symbolp value) (constantp value)) value '.value.))
622 (body
623 (if (or (null (macroexpand `(type-check ,var ',type) env))
624 (member type '(or progn pad8 pad16))
625 (constantp value))
626 `(,(putify type) ,index ,var ,@args)
627 ;; Do type checking
628 (if (get type 'predicating-put)
629 `(or (,(putify type t) ,index ,var ,@args)
630 (x-type-error ,var ',(if args `(,type ,@args) type)))
631 `(if (type? ,var ',type)
632 (,(putify type) ,index ,var ,@args)
633 (x-type-error ,var ',(if args `(,type ,@args) type)))))))
634 (if (eq var value)
635 body
636 `(let ((,var ,value))
637 ,body))))
638
639 (defun get-put-items (index type-args putp &optional body-function)
640 (declare (type (or null function) body-function)
641 #+clx-ansi-common-lisp
642 (dynamic-extent body-function)
643 #+(and lispm (not clx-ansi-common-lisp))
644 (sys:downward-funarg body-function))
645 ;; Given a lists of the form (type item item ... item)
646 ;; Calls body-function with four arguments, a function name,
647 ;; index, item name, and optional arguments.
648 ;; The results are appended together and retured.
649 (unless body-function
650 (setq body-function
651 #'(lambda (type index item args)
652 `((check-put ,index ,item ,type ,@args)))))
653 (do* ((items type-args (cdr items))
654 (type (caar items) (caar items))
655 (args nil nil)
656 (result nil)
657 (sizes nil))
658 ((endp items) (values result index sizes))
659 (when (consp type)
660 (setq args (cdr type)
661 type (car type)))
662 (cond ((member type '(return buffer)))
663 ((eq type 'mask) ;; Hack to enable mask-get/put to return multiple values
664 (setq result
665 (append result (if putp
666 (mask-put index (cdar items) body-function)
667 (mask-get index (cdar items) body-function)))
668 index nil))
669 (t (do* ((item (cdar items) (cdr item))
670 (increment (index-increment type)))
671 ((endp item))
672 (when (constantp index)
673 (case increment ;Round up index when needed
674 (2 (setq index (wround index)))
675 (4 (setq index (lround index)))))
676 (setq result
677 (append result (funcall body-function type index (car item) args)))
678 (when (constantp index)
679 ;; Variable length requests have null length increment.
680 ;; Variable length requests set the request size
681 ;; & maintain buffer pointers
682 (if (null increment)
683 (setq index nil)
684 (progn
685 (incf index increment)
686 (when (and increment (zerop increment)) (setq increment 1))
687 (pushnew (* increment 8) sizes)))))))))
688
689 (defmacro with-buffer-request-internal
690 ((buffer opcode &key length sizes &allow-other-keys)
691 &body type-args)
692 (multiple-value-bind (code index item-sizes)
693 (get-put-items 4 type-args t)
694 (let ((length (if length `(index+ ,length +requestsize+) '+requestsize+))
695 (sizes (remove-duplicates (append '(8 16) item-sizes sizes))))
696 `(with-buffer-output (,buffer :length ,length :sizes ,sizes)
697 (setf (buffer-last-request ,buffer) buffer-boffset)
698 (write-card8 0 ,opcode) ;; Stick in the opcode
699 ,@code
700 ,@(when index
701 (setq index (lround index))
702 `((write-card16 2 ,(ceiling index 4))
703 (setf (buffer-boffset ,buffer) (index+ buffer-boffset ,index))))
704 (buffer-new-request-number ,buffer)))))
705
706 (defmacro with-buffer-request
707 ((buffer opcode &rest options &key inline gc-force &allow-other-keys)
708 &body type-args &environment env)
709 (if (and (null inline) (macroexpand '(use-closures) env))
710 `(flet ((.request-body. (.display.)
711 (declare (type display .display.))
712 (with-buffer-request-internal (.display. ,opcode ,@options)
713 ,@type-args)))
714 #+clx-ansi-common-lisp
715 (declare (dynamic-extent #'.request-body.))
716 (,(if (eq (car (macroexpand '(with-buffer (buffer)) env)) 'progn)
717 'with-buffer-request-function-nolock
718 'with-buffer-request-function)
719 ,buffer ,gc-force #'.request-body.))
720 `(let ((.display. ,buffer))
721 (declare (type display .display.))
722 (with-buffer (.display.)
723 ,@(when gc-force `((force-gcontext-changes-internal ,gc-force)))
724 (multiple-value-prog1
725 (without-aborts
726 (with-buffer-request-internal (.display. ,opcode ,@options)
727 ,@type-args))
728 (display-invoke-after-function .display.))))))
729
730 (defmacro with-buffer-request-and-reply
731 ((buffer opcode reply-size &key sizes multiple-reply inline)
732 type-args &body reply-forms &environment env)
733 (declare (indentation 0 4 1 4 2 1))
734 (let* ((inner-reply-body
735 `(with-buffer-input (.reply-buffer. :display .display.
736 ,@(and sizes (list :sizes sizes)))
737 nil ,@reply-forms))
738 (reply-body
739 (if (or (not (symbolp reply-size)) (constantp reply-size))
740 inner-reply-body
741 `(let ((,reply-size (reply-data-size (the reply-buffer .reply-buffer.))))
742 (declare (type array-index ,reply-size))
743 ,inner-reply-body))))
744 (if (and (null inline) (macroexpand '(use-closures) env))
745 `(flet ((.request-body. (.display.)
746 (declare (type display .display.))
747 (with-buffer-request-internal (.display. ,opcode)
748 ,@type-args))
749 (.reply-body. (.display. .reply-buffer.)
750 (declare (type display .display.)
751 (type reply-buffer .reply-buffer.))
752 (progn .display. .reply-buffer. nil)
753 ,reply-body))
754 #+clx-ansi-common-lisp
755 (declare (dynamic-extent #'.request-body. #'.reply-body.))
756 (with-buffer-request-and-reply-function
757 ,buffer ,multiple-reply #'.request-body. #'.reply-body.))
758 `(let ((.display. ,buffer)
759 (.pending-command. nil)
760 (.reply-buffer. nil))
761 (declare (type display .display.)
762 (type (or null pending-command) .pending-command.)
763 (type (or null reply-buffer) .reply-buffer.))
764 (unwind-protect
765 (progn
766 (with-buffer (.display.)
767 (setq .pending-command. (start-pending-command .display.))
768 (without-aborts
769 (with-buffer-request-internal (.display. ,opcode)
770 ,@type-args))
771 (buffer-force-output .display.)
772 (display-invoke-after-function .display.))
773 ,@(if multiple-reply
774 `((loop
775 (setq .reply-buffer. (read-reply .display. .pending-command.))
776 (when ,reply-body (return nil))
777 (deallocate-reply-buffer (shiftf .reply-buffer. nil))))
778 `((setq .reply-buffer. (read-reply .display. .pending-command.))
779 ,reply-body)))
780 (when .reply-buffer.
781 (deallocate-reply-buffer .reply-buffer.))
782 (when .pending-command.
783 (stop-pending-command .display. .pending-command.)))))))
784
785 (defmacro compare-request ((index) &body body)
786 `(macrolet ((write-card32 (index item) `(= ,item (read-card32 ,index)))
787 (write-int32 (index item) `(= ,item (read-int32 ,index)))
788 (write-card29 (index item) `(= ,item (read-card29 ,index)))
789 (write-int29 (index item) `(= ,item (read-int29 ,index)))
790 (write-card16 (index item) `(= ,item (read-card16 ,index)))
791 (write-int16 (index item) `(= ,item (read-int16 ,index)))
792 (write-card8 (index item) `(= ,item (read-card8 ,index)))
793 (write-int8 (index item) `(= ,item (read-int8 ,index))))
794 (macrolet ((type-check (value type) value type nil))
795 (and ,@(get-put-items index body t)))))
796
797 (defmacro put-items ((index) &body body)
798 `(progn ,@(get-put-items index body t)))
799
800 (defmacro decode-type (type value)
801 ;; Given an integer and type, return the value
802 (let ((args nil))
803 (when (consp type)
804 (setq args (cdr type)
805 type (car type)))
806 `(macrolet ((read-card29 (value) value)
807 (read-card32 (value) value)
808 (read-int32 (value) `(card32->int32 ,value))
809 (read-card16 (value) value)
810 (read-int16 (value) `(card16->int16 ,value))
811 (read-card8 (value) value)
812 (read-int8 (value) `(int8->card8 ,value)))
813 (,(getify type) ,value ,@args))))
814
815 (defmacro encode-type (type value)
816 ;; Given a value and type, return an integer
817 ;; When check-p, do type checking on value
818 (let ((args nil))
819 (when (consp type)
820 (setq args (cdr type)
821 type (car type)))
822 `(macrolet ((write-card29 (index value) index value)
823 (write-card32 (index value) index value)
824 (write-int32 (index value) index `(int32->card32 ,value))
825 (write-card16 (index value) index value)
826 (write-int16 (index value) index `(int16->card16 ,value))
827 (write-card8 (index value) index value)
828 (write-int8 (index value) index `(int8->card8 ,value)))
829 (check-put 0 ,value ,type ,@args))))
830
831 (defmacro set-decode-type (type accessor value)
832 `(setf ,accessor (encode-type ,type ,value)))
833 (defsetf decode-type set-decode-type)
834
835
836 ;;;
837 ;;; Request codes
838 ;;;
839
840 (defconstant +x-createwindow+ 1)
841 (defconstant +x-changewindowattributes+ 2)
842 (defconstant +x-getwindowattributes+ 3)
843 (defconstant +x-destroywindow+ 4)
844 (defconstant +x-destroysubwindows+ 5)
845 (defconstant +x-changesaveset+ 6)
846 (defconstant +x-reparentwindow+ 7)
847 (defconstant +x-mapwindow+ 8)
848 (defconstant +x-mapsubwindows+ 9)
849 (defconstant +x-unmapwindow+ 10)
850 (defconstant +x-unmapsubwindows+ 11)
851 (defconstant +x-configurewindow+ 12)
852 (defconstant +x-circulatewindow+ 13)
853 (defconstant +x-getgeometry+ 14)
854 (defconstant +x-querytree+ 15)
855 (defconstant +x-internatom+ 16)
856 (defconstant +x-getatomname+ 17)
857 (defconstant +x-changeproperty+ 18)
858 (defconstant +x-deleteproperty+ 19)
859 (defconstant +x-getproperty+ 20)
860 (defconstant +x-listproperties+ 21)
861 (defconstant +x-setselectionowner+ 22)
862 (defconstant +x-getselectionowner+ 23)
863 (defconstant +x-convertselection+ 24)
864 (defconstant +x-sendevent+ 25)
865 (defconstant +x-grabpointer+ 26)
866 (defconstant +x-ungrabpointer+ 27)
867 (defconstant +x-grabbutton+ 28)
868 (defconstant +x-ungrabbutton+ 29)
869 (defconstant +x-changeactivepointergrab+ 30)
870 (defconstant +x-grabkeyboard+ 31)
871 (defconstant +x-ungrabkeyboard+ 32)
872 (defconstant +x-grabkey+ 33)
873 (defconstant +x-ungrabkey+ 34)
874 (defconstant +x-allowevents+ 35)
875 (defconstant +x-grabserver+ 36)
876 (defconstant +x-ungrabserver+ 37)
877 (defconstant +x-querypointer+ 38)
878 (defconstant +x-getmotionevents+ 39)
879 (defconstant +x-translatecoords+ 40)
880 (defconstant +x-warppointer+ 41)
881 (defconstant +x-setinputfocus+ 42)
882 (defconstant +x-getinputfocus+ 43)
883 (defconstant +x-querykeymap+ 44)
884 (defconstant +x-openfont+ 45)
885 (defconstant +x-closefont+ 46)
886 (defconstant +x-queryfont+ 47)
887 (defconstant +x-querytextextents+ 48)
888 (defconstant +x-listfonts+ 49)
889 (defconstant +x-listfontswithinfo+ 50)
890 (defconstant +x-setfontpath+ 51)
891 (defconstant +x-getfontpath+ 52)
892 (defconstant +x-createpixmap+ 53)
893 (defconstant +x-freepixmap+ 54)
894 (defconstant +x-creategc+ 55)
895 (defconstant +x-changegc+ 56)
896 (defconstant +x-copygc+ 57)
897 (defconstant +x-setdashes+ 58)
898 (defconstant +x-setcliprectangles+ 59)
899 (defconstant +x-freegc+ 60)
900 (defconstant +x-cleartobackground+ 61)
901 (defconstant +x-copyarea+ 62)
902 (defconstant +x-copyplane+ 63)
903 (defconstant +x-polypoint+ 64)
904 (defconstant +x-polyline+ 65)
905 (defconstant +x-polysegment+ 66)
906 (defconstant +x-polyrectangle+ 67)
907 (defconstant +x-polyarc+ 68)
908 (defconstant +x-fillpoly+ 69)
909 (defconstant +x-polyfillrectangle+ 70)
910 (defconstant +x-polyfillarc+ 71)
911 (defconstant +x-putimage+ 72)
912 (defconstant +x-getimage+ 73)
913 (defconstant +x-polytext8+ 74)
914 (defconstant +x-polytext16+ 75)
915 (defconstant +x-imagetext8+ 76)
916 (defconstant +x-imagetext16+ 77)
917 (defconstant +x-createcolormap+ 78)
918 (defconstant +x-freecolormap+ 79)
919 (defconstant +x-copycolormapandfree+ 80)
920 (defconstant +x-installcolormap+ 81)
921 (defconstant +x-uninstallcolormap+ 82)
922 (defconstant +x-listinstalledcolormaps+ 83)
923 (defconstant +x-alloccolor+ 84)
924 (defconstant +x-allocnamedcolor+ 85)
925 (defconstant +x-alloccolorcells+ 86)
926 (defconstant +x-alloccolorplanes+ 87)
927 (defconstant +x-freecolors+ 88)
928 (defconstant +x-storecolors+ 89)
929 (defconstant +x-storenamedcolor+ 90)
930 (defconstant +x-querycolors+ 91)
931 (defconstant +x-lookupcolor+ 92)
932 (defconstant +x-createcursor+ 93)
933 (defconstant +x-createglyphcursor+ 94)
934 (defconstant +x-freecursor+ 95)
935 (defconstant +x-recolorcursor+ 96)
936 (defconstant +x-querybestsize+ 97)
937 (defconstant +x-queryextension+ 98)
938 (defconstant +x-listextensions+ 99)
939 (defconstant +x-setkeyboardmapping+ 100)
940 (defconstant +x-getkeyboardmapping+ 101)
941 (defconstant +x-changekeyboardcontrol+ 102)
942 (defconstant +x-getkeyboardcontrol+ 103)
943 (defconstant +x-bell+ 104)
944 (defconstant +x-changepointercontrol+ 105)
945 (defconstant +x-getpointercontrol+ 106)
946 (defconstant +x-setscreensaver+ 107)
947 (defconstant +x-getscreensaver+ 108)
948 (defconstant +x-changehosts+ 109)
949 (defconstant +x-listhosts+ 110)
950 (defconstant +x-changeaccesscontrol+ 111)
951 (defconstant +x-changeclosedownmode+ 112)
952 (defconstant +x-killclient+ 113)
953 (defconstant +x-rotateproperties+ 114)
954 (defconstant +x-forcescreensaver+ 115)
955 (defconstant +x-setpointermapping+ 116)
956 (defconstant +x-getpointermapping+ 117)
957 (defconstant +x-setmodifiermapping+ 118)
958 (defconstant +x-getmodifiermapping+ 119)
959 (defconstant +x-nooperation+ 127)
960
961 ;;; Some macros for threaded lists
962
963 (defmacro threaded-atomic-push (item list next type)
964 (let ((x (gensym))
965 (y (gensym)))
966 `(let ((,x ,item))
967 (declare (type ,type ,x))
968 (loop
969 (let ((,y ,list))
970 (declare (type (or null ,type) ,y)
971 (optimize (speed 3) (safety 0)))
972 (setf (,next ,x) ,y)
973 (when (conditional-store ,list ,y ,x)
974 (return ,x)))))))
975
976 (defmacro threaded-atomic-pop (list next type)
977 (let ((y (gensym)))
978 `(loop
979 (let ((,y ,list))
980 (declare (type (or null ,type) ,y)
981 (optimize (speed 3) (safety 0)))
982 (if (null ,y)
983 (return nil)
984 (when (conditional-store ,list ,y (,next (the ,type ,y)))
985 (setf (,next (the ,type ,y)) nil)
986 (return ,y)))))))
987
988 (defmacro threaded-nconc (item list next type)
989 (let ((first (gensym))
990 (x (gensym))
991 (y (gensym))
992 (z (gensym)))
993 `(let ((,z ,item)
994 (,first ,list))
995 (declare (type ,type ,z)
996 (type (or null ,type) ,first)
997 (optimize (speed 3) (safety 0)))
998 (if (null ,first)
999 (setf ,list ,z)
1000 (do* ((,x ,first ,y)
1001 (,y (,next ,x) (,next ,x)))
1002 ((null ,y)
1003 (setf (,next ,x) ,z)
1004 ,first)
1005 (declare (type ,type ,x)
1006 (type (or null ,type) ,y)))))))
1007
1008 (defmacro threaded-push (item list next type)
1009 (let ((x (gensym)))
1010 `(let ((,x ,item))
1011 (declare (type ,type ,x)
1012 (optimize (speed 3) (safety 0)))
1013 (shiftf (,next ,x) ,list ,x)
1014 ,x)))
1015
1016 (defmacro threaded-pop (list next type)
1017 (let ((x (gensym)))
1018 `(let ((,x ,list))
1019 (declare (type (or null ,type) ,x)
1020 (optimize (speed 3) (safety 0)))
1021 (when ,x
1022 (shiftf ,list (,next (the ,type ,x)) nil))
1023 ,x)))
1024
1025 (defmacro threaded-enqueue (item head tail next type)
1026 (let ((x (gensym)))
1027 `(let ((,x ,item))
1028 (declare (type ,type ,x)
1029 (optimize (speed 3) (safety 0)))
1030 (if (null ,tail)
1031 (threaded-nconc ,x ,head ,next ,type)
1032 (threaded-nconc ,x (,next (the ,type ,tail)) ,next ,type))
1033 (setf ,tail ,x))))
1034
1035 (defmacro threaded-dequeue (head tail next type)
1036 (let ((x (gensym)))
1037 `(let ((,x ,head))
1038 (declare (type (or null ,type) ,x)
1039 (optimize (speed 3) (safety 0)))
1040 (when ,x
1041 (when (eq ,x ,tail)
1042 (setf ,tail (,next (the ,type ,x))))
1043 (setf ,head (,next (the ,type ,x))))
1044 ,x)))
1045
1046 (defmacro threaded-requeue (item head tail next type)
1047 (let ((x (gensym)))
1048 `(let ((,x ,item))
1049 (declare (type ,type ,x)
1050 (optimize (speed 3) (safety 0)))
1051 (if (null ,tail)
1052 (setf ,tail (setf ,head ,x))
1053 (shiftf (,next ,x) ,head ,x))
1054 ,x)))
1055
1056 (defmacro threaded-dolist ((variable list next type) &body body)
1057 `(block nil
1058 (do* ((,variable ,list (,next (the ,type ,variable))))
1059 ((null ,variable))
1060 (declare (type (or null ,type) ,variable))
1061 ,@body)))
1062
1063 (defmacro threaded-delete (item list next type)
1064 (let ((x (gensym))
1065 (y (gensym))
1066 (z (gensym))
1067 (first (gensym)))
1068 `(let ((,x ,item)
1069 (,first ,list))
1070 (declare (type ,type ,x)
1071 (type (or null ,type) ,first)
1072 (optimize (speed 3) (safety 0)))
1073 (when ,first
1074 (if (eq ,first ,x)
1075 (setf ,first (setf ,list (,next ,x)))
1076 (do* ((,y ,first ,z)
1077 (,z (,next ,y) (,next ,y)))
1078 ((or (null ,z) (eq ,z ,x))
1079 (when (eq ,z ,x)
1080 (setf (,next ,y) (,next ,x))))
1081 (declare (type ,type ,y))
1082 (declare (type (or null ,type) ,z)))))
1083 (setf (,next ,x) nil)
1084 ,first)))
1085
1086 (defmacro threaded-length (list next type)
1087 (let ((x (gensym))
1088 (count (gensym)))
1089 `(do ((,x ,list (,next (the ,type ,x)))
1090 (,count 0 (index1+ ,count)))
1091 ((null ,x)
1092 ,count)
1093 (declare (type (or null ,type) ,x)
1094 (type array-index ,count)
1095 (optimize (speed 3) (safety 0))))))
1096

  ViewVC Help
Powered by ViewVC 1.1.5