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

Contents of /src/clx/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5