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

Contents of /src/clx/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5