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

Contents of /src/clx/glx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.1: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 #+cmu
2 (ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $")
3
4 (defpackage :glx
5 (:use :common-lisp :xlib)
6 (:import-from :xlib
7 "DEFINE-ACCESSOR"
8 "DEF-CLX-CLASS"
9 "DECLARE-EVENT"
10 "ALLOCATE-RESOURCE-ID"
11 "DEALLOCATE-RESOURCE-ID"
12 "PRINT-DISPLAY-NAME"
13 "WITH-BUFFER-REQUEST"
14 "WITH-BUFFER-REQUEST-AND-REPLY"
15 "READ-CARD32"
16 "WRITE-CARD32"
17 "CARD32-GET"
18 "CARD8-GET"
19 "SEQUENCE-GET"
20 "SEQUENCE-PUT"
21 "DATA"
22
23 ;; Types
24 "ARRAY-INDEX"
25 "BUFFER-BYTES"
26
27 "WITH-DISPLAY"
28 "BUFFER-FLUSH"
29 "BUFFER-WRITE"
30 "BUFFER-FORCE-OUTPUT"
31 "ASET-CARD8"
32 "ASET-CARD16"
33 "ASET-CARD32"
34 )
35 (:export ;; Constants
36 "+VENDOR+"
37 "+VERSION+"
38 "+EXTENSIONS+"
39
40 ;; Conditions
41 "BAD-CONTEXT"
42 "BAD-CONTEXT-STATE"
43 "BAD-DRAWABLE"
44 "BAD-PIXMAP"
45 "BAD-CONTEXT-TAG"
46 "BAD-CURRENT-WINDOW"
47 "BAD-RENDER-REQUEST"
48 "BAD-LARGE-REQUEST"
49 "UNSUPPORTED-PRIVATE-REQUEST"
50 "BAD-FB-CONFIG"
51 "BAD-PBUFFER"
52 "BAD-CURRENT-DRAWABLE"
53 "BAD-WINDOW"
54
55 ;; Requests
56 "QUERY-VERSION"
57 "QUERY-SERVER-STRING"
58 "CREATE-CONTEXT"
59 "DESTROY-CONTEXT"
60 "IS-DIRECT"
61 "QUERY-CONTEXT"
62 "GET-DRAWABLE-ATTRIBUTES"
63 "MAKE-CURRENT"
64 ;;"GET-VISUAL-CONFIGS"
65 "CHOOSE-VISUAL"
66 "VISUAL-ATTRIBUTE"
67 "VISUAL-ID"
68 "RENDER"
69 "SWAP-BUFFERS"
70 "WAIT-GL"
71 "WAIT-X"
72 ))
73
74
75 (in-package :glx)
76
77
78 (declaim (optimize (debug 3) (safety 3)))
79
80
81 (define-extension "GLX"
82 :events (:glx-pbuffer-clobber)
83 :errors (bad-context
84 bad-context-state
85 bad-drawable
86 bad-pixmap
87 bad-context-tag
88 bad-current-window
89 bad-render-request
90 bad-large-request
91 unsupported-private-request
92 bad-fb-config
93 bad-pbuffer
94 bad-current-drawable
95 bad-window))
96
97
98 ;;; Opcodes.
99
100 (eval-when (:compile-toplevel :load-toplevel :execute)
101 (defconstant +render+ 1)
102 (defconstant +create-context+ 3)
103 (defconstant +destroy-context+ 4)
104 (defconstant +make-current+ 5)
105 (defconstant +is-direct+ 6)
106 (defconstant +query-version+ 7)
107 (defconstant +wait-gl+ 8)
108 (defconstant +wait-x+ 9)
109 (defconstant +copy-context+ 10)
110 (defconstant +swap-buffers+ 11)
111 (defconstant +get-visual-configs+ 14)
112 (defconstant +destroy-glx-pixmap+ 15)
113 (defconstant +query-server-string+ 19)
114 (defconstant +client-info+ 20)
115 (defconstant +get-fb-configs+ 21)
116 (defconstant +query-context+ 25)
117 (defconstant +get-drawable-attributes+ 29)
118 )
119
120
121 ;;; Constants
122
123 (eval-when (:compile-toplevel :load-toplevel :execute)
124 (defconstant +vendor+ 1)
125 (defconstant +version+ 2)
126 (defconstant +extensions+ 3)
127 )
128
129
130 ;;; Types
131
132 ;;; FIXME:
133 ;;; - Are all the 32-bit values unsigned? Do we care?
134 ;;; - These are not used much, yet.
135 (progn
136 (deftype attribute-pair ())
137 (deftype bitfield () 'mask32)
138 (deftype bool32 () 'card32) ; 1 for true and 0 for false
139 (deftype enum () 'card32)
140 (deftype fbconfigid () 'card32)
141 ;; FIXME: How to define these two?
142 (deftype float32 () 'single-float)
143 (deftype float64 () 'double-float)
144 ;;(deftype glx-context () 'card32)
145 (deftype context-tag () 'card32)
146 ;;(deftype glx-drawable () 'card32)
147 (deftype glx-pixmap () 'card32)
148 (deftype glx-pbuffer () 'card32)
149 (deftype glx-render-command () #|TODO|#)
150 (deftype glx-window () 'card32)
151 #-(and)
152 (deftype visual-property ()
153 "An ordered list of 32-bit property values followed by unordered pairs of
154 property types and property values."
155 ;; FIXME: maybe CLX-LIST or even just LIST?
156 'clx-sequence))
157
158
159 ;;; FIXME: DEFINE-ACCESSOR interns getter and setter in XLIB package
160 ;;; (using XINTERN). Therefore the accessors defined below can only
161 ;;; be accessed using double-colon, which is a bad style. Or these
162 ;;; forms must be taken to another file so the accessors exist before
163 ;;; we get to this file.
164
165 #-(and)
166 (define-accessor glx-context-tag (32)
167 ((index) `(read-card32 ,index))
168 ((index thing) `(write-card32 ,index ,thing)))
169
170 #-(and)
171 (define-accessor glx-enum (32)
172 ((index) `(read-card32 ,index))
173 ((index thing) `(write-card32 ,index ,thing)))
174
175
176 ;;; FIXME: I'm just not sure we need a seperate accessors for what
177 ;;; essentially are aliases for other types. Maybe use compiler
178 ;;; macros?
179 ;;;
180 ;;; This trick won't do because CLX wants e.g. CONTEXT-TAG to be a
181 ;;; known accessor. The only trick left I think is to change the
182 ;;; XINTERN function to intern the new symbols in the same package as
183 ;;; he symbol part of it comes from. Don't know if it would break
184 ;;; anything, thought. (I would be quite surprised if it did -- there
185 ;;; is only one package in CLX after all: XLIB.)
186 ;;;
187 ;;; I also found the origin of the error (about symbol not being a
188 ;;; known accessor): INDEX-INCREMENT function. Looks like all we have
189 ;;; to do is to add an XLIB::BYTE-WIDTH property to the type symbol
190 ;;; plist. But accessors are macros, not functions, anyway.
191
192 #-(and)
193 (progn
194 (declaim (inline context-tag-get context-tag-put enum-get enum-put))
195 (defun context-tag-get (index) (card32-get index))
196 (defun context-tag-put (index thing) (card32-put index thing))
197 (defun enum-get (index) (card32-get index))
198 (defun enum-put (index thing) (card32-put index thing))
199 )
200
201
202 ;;; Structures
203
204
205 (def-clx-class (context (:constructor %make-context)
206 (:print-function print-context)
207 (:copier nil))
208 (id 0 :type resource-id)
209 (display nil :type (or null display))
210 (tag 0 :type card32)
211 (drawable nil :type (or null drawable))
212 ;; TODO: There can only be one current context (as far as I
213 ;; understand). If so, we'd need only one buffer (otherwise it's a
214 ;; big waste to have a quarter megabyte buffer for each context; or
215 ;; we could allocate/grow the buffer on demand).
216 ;;
217 ;; 256k buffer for Render command. Big requests are served with
218 ;; RenderLarge command. First 8 octets are Render request fields.
219 ;;
220 (rbuf (make-array (+ 8 (* 256 1024)) :element-type '(unsigned-byte 8)) :type buffer-bytes)
221 ;; Index into RBUF where the next rendering command should be inserted.
222 (index 8 :type array-index))
223
224
225 (defun print-context (ctx stream depth)
226 (declare (type context ctx)
227 (ignore depth))
228 (print-unreadable-object (ctx stream :type t)
229 (print-display-name (context-display ctx) stream)
230 (write-string " " stream)
231 (princ (context-id ctx) stream)))
232
233
234 (def-clx-class (visual (:constructor %make-visual)
235 (:print-function print-visual)
236 (:copier nil))
237 (id 0 :type resource-id)
238 (attributes nil :type list))
239
240
241 (defun print-visual (visual stream depth)
242 (declare (type visual visual)
243 (ignore depth))
244 (print-unreadable-object (visual stream :type t)
245 (write-string "ID: " stream)
246 (princ (visual-id visual) stream)
247 (write-string " " stream)
248 (princ (visual-attributes visual) stream)))
249
250
251
252 ;;; Events.
253
254 (defconstant +damaged+ #x8017)
255 (defconstant +saved+ #x8018)
256 (defconstant +window+ #x8019)
257 (defconstant +pbuffer+ #x801a)
258
259
260 (declare-event :glx-pbuffer-clobber
261 (card16 sequence)
262 (card16 event-type) ;; +DAMAGED+ or +SAVED+
263 (card16 draw-type) ;; +WINDOW+ or +PBUFFER+
264 (resource-id drawable)
265 ;; FIXME: (bitfield buffer-mask)
266 (card32 buffer-mask)
267 (card16 aux-buffer)
268 (card16 x y width height count))
269
270
271
272 ;;; Errors.
273
274 (define-condition bad-context (request-error) ())
275 (define-condition bad-context-state (request-error) ())
276 (define-condition bad-drawable (request-error) ())
277 (define-condition bad-pixmap (request-error) ())
278 (define-condition bad-context-tag (request-error) ())
279 (define-condition bad-current-window (request-error) ())
280 (define-condition bad-render-request (request-error) ())
281 (define-condition bad-large-request (request-error) ())
282 (define-condition unsupported-private-request (request-error) ())
283 (define-condition bad-fb-config (request-error) ())
284 (define-condition bad-pbuffer (request-error) ())
285 (define-condition bad-current-drawable (request-error) ())
286 (define-condition bad-window (request-error) ())
287
288 (define-error bad-context decode-core-error)
289 (define-error bad-context-state decode-core-error)
290 (define-error bad-drawable decode-core-error)
291 (define-error bad-pixmap decode-core-error)
292 (define-error bad-context-tag decode-core-error)
293 (define-error bad-current-window decode-core-error)
294 (define-error bad-render-request decode-core-error)
295 (define-error bad-large-request decode-core-error)
296 (define-error unsupported-private-request decode-core-error)
297 (define-error bad-fb-config decode-core-error)
298 (define-error bad-pbuffer decode-core-error)
299 (define-error bad-current-drawable decode-core-error)
300 (define-error bad-window decode-core-error)
301
302
303
304 ;;; Requests.
305
306
307 (defun query-version (display)
308 (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
309 ((data +query-version+)
310 (card32 1)
311 (card32 3))
312 (values
313 (card32-get 8)
314 (card32-get 12))))
315
316
317 (defun query-server-string (display screen name)
318 "NAME is one of +VENDOR+, +VERSION+ or +EXTENSIONS+"
319 (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
320 ((data +query-server-string+)
321 (card32 (or (position screen (display-roots display) :test #'eq) 0))
322 (card32 name))
323 (let* ((length (card32-get 12))
324 (bytes (sequence-get :format card8
325 :result-type '(simple-array card8 (*))
326 :index 32
327 :length length)))
328 (declare (type (simple-array card8 (*)) bytes)
329 (type fixnum length))
330 (map-into (make-string (1- length)) #'code-char bytes))))
331
332
333 (defun client-info (display)
334 ;; TODO: This should be invoked automatically when using this
335 ;; library in initialization stage.
336 ;;
337 ;; TODO: No extensions supported yet.
338 ;;
339 ;; *** Maybe the LENGTH field must be filled in some special way
340 ;; (similar to data)?
341 (with-buffer-request (display (extension-opcode display "GLX"))
342 (data +client-info+)
343 (card32 4) ; length of the request
344 (card32 1) ; major
345 (card32 3) ; minor
346 (card32 0) ; n
347 ))
348
349
350 ;;; XXX: This looks like an internal thing. Should name appropriately.
351 (defun make-context (display)
352 (let ((ctx (%make-context :display display)))
353 (setf (context-id ctx)
354 (allocate-resource-id display ctx 'context))
355 ;; Prepare render request buffer.
356 ctx))
357
358
359 (defun create-context (screen visual
360 &optional
361 (share-list 0)
362 (is-direct nil))
363 "Do NOT use the direct mode, yet!"
364 (let* ((root (screen-root screen))
365 (display (drawable-display root))
366 (ctx (make-context display)))
367 (with-buffer-request (display (extension-opcode display "GLX"))
368 (data +create-context+)
369 (resource-id (context-id ctx))
370 (resource-id visual)
371 (card32 (or (position screen (display-roots display) :test #'eq) 0))
372 (resource-id share-list)
373 (boolean is-direct))
374 ctx))
375
376
377 ;;; TODO: Maybe make this var private to GLX-MAKE-CURRENT and GLX-GET-CURRENT-CONTEXT only?
378 ;;;
379 (defvar *current-context* nil)
380
381
382 (defun destroy-context (ctx)
383 (let ((id (context-id ctx))
384 (display (context-display ctx)))
385 (with-buffer-request (display (extension-opcode display "GLX"))
386 (data +destroy-context+)
387 (resource-id id))
388 (deallocate-resource-id display id 'context)
389 (setf (context-id ctx) 0)
390 (when (eq ctx *current-context*)
391 (setf *current-context* nil))))
392
393
394 (defun is-direct (ctx)
395 (let ((display (context-display ctx)))
396 (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
397 ((data +is-direct+)
398 (resource-id (context-id ctx)))
399 (card8-get 8))))
400
401
402 (defun query-context (ctx)
403 ;; TODO: What are the attribute types?
404 (let ((display (context-display ctx)))
405 (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
406 ((data +query-context+)
407 (resource-id (context-id ctx)))
408 (let ((num-attributes (card32-get 8)))
409 ;; FIXME: Is this really so?
410 (declare (type fixnum num-attributes))
411 (loop
412 repeat num-attributes
413 for i fixnum upfrom 32 by 8
414 collecting (cons (card32-get i)
415 (card32-get (+ i 4))))))))
416
417
418 (defun get-drawable-attributes (drawable)
419 (let ((display (drawable-display drawable)))
420 (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
421 ((data +get-drawable-attributes+)
422 (drawable drawable))
423 (let ((num-attributes (card32-get 8)))
424 ;; FIXME: Is this really so?
425 (declare (type fixnum num-attributes))
426 (loop
427 repeat num-attributes
428 for i fixnum upfrom 32 by 8
429 collecting (cons (card32-get i)
430 (card32-get (+ i 4))))))))
431
432
433 ;;; TODO: What is the idea behind passing drawable to this function?
434 ;;; Can a context be made current for different drawables at different
435 ;;; times? (Man page on glXMakeCurrent says that context's viewport
436 ;;; is set to the size of drawable when creating; it does not change
437 ;;; afterwards.)
438 ;;;
439 (defun make-current (drawable ctx)
440 (let ((display (drawable-display drawable))
441 (old-tag (if *current-context* (context-tag *current-context*) 0)))
442 (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
443 ((data +make-current+)
444 (resource-id (drawable-id drawable))
445 (resource-id (context-id ctx))
446 ;; *** CARD32 is really a CONTEXT-TAG
447 (card32 old-tag))
448 (let ((new-tag (card32-get 8)))
449 (setf (context-tag ctx) new-tag
450 (context-drawable ctx) drawable
451 (context-display ctx) display
452 *current-context* ctx)))))
453
454
455 ;;; FIXME: Decide how to represent and use these.
456 (eval-when (:load-toplevel :compile-toplevel :execute)
457 (macrolet ((generate-config-properties ()
458 (let ((list '((:glx-visual visual-id)
459 (:glx-class card32)
460 (:glx-rgba bool32)
461 (:glx-red-size card32)
462 (:glx-green-size card32)
463 (:glx-blue-size card32)
464 (:glx-alpha-size card32)
465 (:glx-accum-red-size card32)
466 (:glx-accum-green-size card32)
467 (:glx-accum-blue-size card32)
468 (:glx-accum-alpha-size card32)
469 (:glx-double-buffer bool32)
470 (:glx-stereo bool32)
471 (:glx-buffer-size card32)
472 (:glx-depth-size card32)
473 (:glx-stencil-size card32)
474 (:glx-aux-buffers card32)
475 (:glx-level int32))))
476 `(progn
477 ,@(loop for (symbol type) in list
478 collect `(setf (get ',symbol 'visual-config-property-type) ',type))
479 (defparameter *visual-config-properties*
480 (map 'vector #'car ',list))
481 (declaim (type simple-vector *visual-config-properties*))
482 (deftype visual-config-property ()
483 '(member ,@(mapcar #'car list)))))))
484 (generate-config-properties)))
485
486
487 (defun make-visual (attributes)
488 (let ((id-cons (first attributes)))
489 (assert (eq :glx-visual (car id-cons))
490 (id-cons)
491 "GLX visual id must be first in attributes list!")
492 (%make-visual :id (cdr id-cons)
493 :attributes (rest attributes))))
494
495
496 (defun visual-attribute (visual attribute)
497 (assert (or (numberp attribute)
498 (find attribute *visual-config-properties*))
499 (attribute)
500 "~S is not a known GLX visual attribute." attribute)
501 (cdr (assoc attribute (visual-attributes visual))))
502
503
504 ;;; TODO: Make this return nice structured objects with field values of correct type.
505 ;;; FIXME: Looks like every other result is corrupted.
506 (defun get-visual-configs (screen)
507 (let ((display (drawable-display (screen-root screen))))
508 (with-buffer-request-and-reply (display (extension-opcode display "GLX") nil)
509 ((data +get-visual-configs+)
510 (card32 (or (position screen (display-roots display) :test #'eq) 0)))
511 (let* ((num-visuals (card32-get 8))
512 (num-properties (card32-get 12))
513 (num-ordered (length *visual-config-properties*)))
514 ;; FIXME: Is this really so?
515 (declare (type fixnum num-ordered num-visuals num-properties))
516 (loop
517 with index fixnum = 28
518 repeat num-visuals
519 collecting (make-visual
520 (nconc (when (<= num-ordered num-properties)
521 (map 'list #'(lambda (property)
522 (cons property (card32-get (incf index 4))))
523 *visual-config-properties*))
524 (when (< num-ordered num-properties)
525 (loop repeat (/ (- num-properties num-ordered) 2)
526 collecting (cons (card32-get (incf index 4))
527 (card32-get (incf index 4))))))))))))
528
529
530 (defun choose-visual (screen attributes)
531 "ATTRIBUTES is a list of desired attributes for a visual. The elements may be
532 either a symbol, which means that the boolean attribute with that name must be true; or
533 it can be a list of the form: (attribute-name value &optional (test '<=)) which means that
534 the attribute named attribute-name must satisfy the test when applied to the given value and
535 attribute's value in visual.
536 Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)."
537 ;; TODO: Add type checks
538 ;;
539 ;; TODO: This function checks only supplied attributes; should check
540 ;; all attributes, with default for boolean type being false, and
541 ;; for number types zero.
542 ;;
543 ;; TODO: Make this smarter, like the docstring says, instead of
544 ;; parrotting the inflexible C API.
545 ;;
546 (flet ((visual-matches-p (visual attributes)
547 (dolist (attribute attributes t)
548 (etypecase attribute
549 (symbol (not (null (visual-attribute visual attribute))))
550 (cons (<= (second attribute) (visual-attribute visual (car attribute))))))))
551 (let* ((visuals (get-visual-configs screen))
552 (candidates (loop
553 for visual in visuals
554 when (visual-matches-p visual attributes)
555 collect visual))
556 (result (first candidates)))
557
558 (dolist (candidate (rest candidates))
559 ;; Visuals with glx-class 3 (pseudo-color) and 4 (true-color)
560 ;; are preferred over glx-class 2 (static-color) and 5 (direct-color).
561 (let ((class (visual-attribute candidate :glx-class)))
562 (when (or (= class 3)
563 (= class 4))
564 (setf result candidate))))
565 result)))
566
567
568 (defun render ()
569 (declare (optimize (debug 3)))
570 (assert (context-p *current-context*)
571 (*current-context*)
572 "~S is not a context." *current-context*)
573 (let* ((ctx *current-context*)
574 (display (context-display ctx))
575 (rbuf (context-rbuf ctx))
576 (index (context-index ctx)))
577 (declare (type buffer-bytes rbuf)
578 (type array-index index))
579 (when (< 8 index)
580 (with-display (display)
581 ;; Flush display's buffer first so we don't get messed up with X requests.
582 (buffer-flush display)
583 ;; First, update the Render request fields.
584 (aset-card8 (extension-opcode display "GLX") rbuf 0)
585 (aset-card8 1 rbuf 1)
586 (aset-card16 (ceiling index 4) rbuf 2)
587 (aset-card32 (context-tag ctx) rbuf 4)
588 ;; Then send the request.
589 (buffer-write rbuf display 0 (context-index ctx))
590 ;; Start filling from the beginning
591 (setf (context-index ctx) 8)))
592 (values)))
593
594
595 (defun swap-buffers ()
596 (assert (context-p *current-context*)
597 (*current-context*)
598 "~S is not a context." *current-context*)
599 (let* ((ctx *current-context*)
600 (display (context-display ctx)))
601 ;; Make sure all rendering commands are sent away.
602 (glx:render)
603 (with-buffer-request (display (extension-opcode display "GLX"))
604 (data +swap-buffers+)
605 ;; *** GLX_CONTEXT_TAG
606 (card32 (context-tag ctx))
607 (resource-id (drawable-id (context-drawable ctx))))
608 (display-force-output display)))
609
610
611 ;;; FIXME: These two are more complicated than sending messages. As I
612 ;;; understand it, wait-gl should inhibit any X requests until all GL
613 ;;; requests are sent...
614 (defun wait-gl ()
615 (assert (context-p *current-context*)
616 (*current-context*)
617 "~S is not a context." *current-context*)
618 (let* ((ctx *current-context*)
619 (display (context-display ctx)))
620 (with-buffer-request (display (extension-opcode display "GLX"))
621 (data +wait-gl+)
622 ;; *** GLX_CONTEXT_TAG
623 (card32 (context-tag ctx)))))
624
625
626 (defun wait-x ()
627 (assert (context-p *current-context*)
628 (*current-context*)
629 "~S is not a context." *current-context*)
630 (let* ((ctx *current-context*)
631 (display (context-display ctx)))
632 (with-buffer-request (display (extension-opcode display "GLX"))
633 (data +wait-x+)
634 ;; *** GLX_CONTEXT_TAG
635 (card32 (context-tag ctx)))))

  ViewVC Help
Powered by ViewVC 1.1.5