mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 09:20:23 -07:00
Code Issues Projects Releases Packages Wiki Activity

Upgraded CLX to the last version of portable CLX

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-12-05 15:17:53 +01:00
parent c331bd2630
commit 79c30b8d54
22 changed files with 1351 additions and 1019 deletions
Download patch file Download diff file Expand all files Collapse all files

8
src/clx/CHANGES
View file

@ -1,9 +1,9 @@
Details of changes since R5:
NOTE: this file is not updated any more. Dan's SBCL changes since
checking into CVS can be found from the CVS logs. There may however
be some Dark Ages between when this file was last updated and the
version he started from.
NOTE: this file is not updated any more. Changes since checking into
version control can be found from darcs in some way shape or form.
There may however be some Dark Ages between when this file was last
updated and the version that was the initial version control checkin.
Changes in CLX 5.02:

59
src/clx/NEWS
View file

@ -1,15 +1,68 @@
-*- Text -*-
-- Changes in telent CLX 0.7.3, Tue Mar 28 2006 ---
--- Changes in SBCL CLX 0.5.5, <FILL IN TIMESTAMP> ---
Support for Allegro CL (6.2 and later) (Mikel Evins)
Latin 1 keysyms (Christophe Rhodes)
Some protocol fixes (Douglas Crosher)
Define a RENDER-OP typ (Douglas Crosher)
--- Changes in SBCL CLX 0.7.2, Tue Jan 10 2006 ---
OpenMCL fixes
DPMS extension support
Xauthority ipv6 parsing fixes
Thanks to Bryan O'Connor, Matthew Kennedy, Christophe Rhodes
--- Changes in SBCL CLX 0.7.1, Wed Aug 24 2005 ---
Works in SBCL 0.9.2 and newer.
--- Changes in SBCL CLX 0.7.0, Sun May 1 2005 ---
The SBCL support now depends on version 0.9.0 or greater.
--- Changes in SBCL CLX 0.6.1, Mon Mar 28 2005 ---
experimental GLX extension support (from Janis Dzerins)
The ICCCM-compliant selection handling in demo/clipboard.lisp is now
more ICCCM-compliant.
The implementation of the RENDER client protocol has been
enhanced. (Gilbert Baumann)
Bug fix: CIRCULATE-NOTIFY, CIRCULATE-REQUEST and PROPERTY-NOTIFY input
event descriptions have been fixed.
--- Changes in SBCL CLX 0.6, Tue Nov 16 2004 ---
A port to ECL has been merged (Juan Jose Garcia Ripoll)
With the addition of an implementation of DYNAMIC-EXTENT &REST lists
to SBCL, various functions (e.g. READ-INPUT, QUEUE-EVENT) in CLX
should cons less.
A Texinfo version of the CLX manual as been added.
A Texinfo version of the CLX manual has been added (in manual/), thanks
to the work of Gilbert Baumann and Shawn Betts.
The portable-clx mailing list has been created for development discussion
and bug reports
and bug reports. See
http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
A demonstration of ICCCM-compliant selection handling for select and paste
has been included in demo/clipboard.lisp
Bug fix: change the sizes of certain fields in a WM-SIZE-HINT to be 32
bits wide, as per the ICCCM specifications. Fixes a problem seen with
the MacOS X11 window manger, that uses very large hint values.
(Patch from Eric Marsden)
Bug fix: +POINTER-EVENT-MASK-VECTOR+ is supposed to be a vector of
keywords. It wasn't, but it is now. (Milan Zamazal)
Bug fix: xrender now compiles properly when *DEF-CLX-CLASS-USE-DEFCLASS*
(Milan again)
--- Changes in SBCL CLX 0.5.4, Tue Nov 11 00:02:43 2003 ---

12
src/clx/README
View file

@ -18,7 +18,7 @@ a selection of patches were added from other CLXes around the net.
This CLX distribution is intended to work under the latest released
version of SBCL - please report the bug if it doesn't. It should
usually also work with earlier versions back to 0.8.1, and possibly
usually also work with earlier versions back to 0.9.0, and possibly
earlier still, but may need manual adjustment to the clx.asd file (to
remove use of newly-introduced features).
@ -32,8 +32,12 @@ send mail describing the process so that future versions can incorporate
your instructions.
If you are following SBCL CVS and this CLX does not run in it, please
check the CVS tree for this CLX distribution to see if your bug has
been fixed already. See http://cvs.telent.net/ for details
check the darcs repositor{y,ies} for this CLX distribution to see if
your bug has been fixed already.
darcs get http://verisons.telent.net/clx # version from which releases are made
http://common-lisp.net/~crhodes/clx # patches merged by Christophe
http://monday-monkey.com/repos/clx/ # OpenMCL tree by bryan o'connor?
= Building using asdf-install
@ -105,4 +109,4 @@ Note that your post will be held for approval if you are not subscribed.
--
Heavy lifting by <Raymond.Wiker at fast.no>
ASDFized version and ongoing by Daniel Barlow <dan at metacircles.com>
and Christophe Rhodes <csr21 at cam.ac.uk>
and (mostly, these days) Christophe Rhodes <csr21 at cam.ac.uk>

21
src/clx/attributes.lisp
View file

@ -66,14 +66,14 @@
(defmacro state-geometry-changes (state) `(fifth ,state))
(defmacro drawable-equal-function ()
(if (member 'drawable +clx-cached-types+)
''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
''drawable-equal))
;; Since drawables are not always cached, we must use drawable-equal
;; to determine equality.
''drawable-equal)
(defmacro window-equal-function ()
(if (member 'window +clx-cached-types+)
''eq
''drawable-equal))
;; Since windows are not always cached, we must use window-equal
;; to determine equality.
''window-equal)
(defmacro with-state ((drawable) &body body)
;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
@ -495,8 +495,13 @@
(declare (clx-values (or null colormap)))
(with-attributes (window :sizes 32)
(let ((id (resource-id-get 28)))
(if (zerop id) nil
(lookup-colormap (window-display window) id)))))
(if (zerop id)
nil
(let ((colormap (lookup-colormap (window-display window) id)))
(unless (colormap-visual-info colormap)
(setf (colormap-visual-info colormap)
(visual-info (window-display window) (resource-id-get 8))))
colormap)))))
(defun set-window-colormap (window colormap)
(change-window-attribute

826
src/clx/buffer.lisp
View file

@ -486,62 +486,58 @@
;;; Reading sequences of chars
(defun read-sequence-char (reply-buffer result-type nitems &optional transform data
(start 0) (index 0))
(declare (type reply-buffer reply-buffer)
(type t result-type) ;; CL type
(type array-index nitems start index)
(type (or null sequence) data))
(declare (type (or null (function (character) t)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(if transform
(flet ((card8->char->transform (v)
(declare (type card8 v))
(funcall transform (card8->char v))))
#+clx-ansi-common-lisp
(declare (dynamic-extent #'card8->char->transform))
(read-sequence-card8
reply-buffer result-type nitems #'card8->char->transform
data start index))
(read-sequence-card8
reply-buffer result-type nitems #'card8->char
data start index)))
(defmacro define-transformed-sequence-reader (name totype transformer reader)
(let ((ntrans (gensym)))
`(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0))
(declare
(type reply-buffer reply-buffer)
(type t result-type)
(type array-index nitems start index)
(type (or null sequence) data)
(type (or null (function (,totype) t)) transform)
#+clx-ansi-common-lisp (dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
(if transform
(flet ((,ntrans (v) (funcall transform (,transformer v))))
#+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans))
(,reader reply-buffer result-type nitems #',ntrans data start index))
(,reader reply-buffer result-type nitems #',transformer data start index)))))
(define-transformed-sequence-reader read-sequence-char character
card8->char read-sequence-card8)
;;; Reading sequences of card8's
(defun read-list-card8 (reply-buffer nitems data start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data))
(with-buffer-input (reply-buffer :sizes (8) :index index)
(do* ((j nitems (index- j 1))
(lst (nthcdr start data) (cdr lst))
(index 0 (index+ index 1)))
((index-zerop j))
(declare (type array-index j index)
(list lst))
(setf (car lst) (read-card8 index)))))
(defmacro define-list-readers ((name tname) type size step reader)
`(progn
(defun ,name (reply-buffer nitems data start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data))
(with-buffer-input (reply-buffer :sizes (,size) :index index)
(do* ((j nitems (index- j 1))
(list (nthcdr start data) (cdr list))
(index 0 (index+ index ,step)))
((index-zerop j))
(declare (type array-index index j) (type list list))
(setf (car list) (,reader index)))))
(defun ,tname (reply-buffer nitems data transform start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data)
(type (function (,type) t) transform)
#+clx-ansi-common-lisp (dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
(with-buffer-input (reply-buffer :sizes (,size) :index index)
(do* ((j nitems (index- j 1))
(list (nthcdr start data) (cdr list))
(index 0 (index+ index ,step)))
((index-zerop j))
(declare (type array-index index j) (type list list))
(setf (car list) (funcall transform (,reader index))))))))
(defun read-list-card8-with-transform (reply-buffer nitems data transform start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data))
(declare (type (function (card8) t) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(with-buffer-input (reply-buffer :sizes (8) :index index)
(do* ((j nitems (index- j 1))
(lst (nthcdr start data) (cdr lst))
(index 0 (index+ index 1)))
((index-zerop j))
(declare (type array-index j index)
(list lst))
(setf (car lst) (funcall transform (read-card8 index))))))
(define-list-readers (read-list-card8 read-list-card8-with-transform) card8
8 1 read-card8)
#-lispm
(defun read-simple-array-card8 (reply-buffer nitems data start index)
@ -604,95 +600,46 @@
(declare (type array-index j end index))
(setf (aref data j) (funcall transform (read-card8 index)))))))
(defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data
(start 0) (index 0))
(declare (type reply-buffer reply-buffer)
(type t result-type) ;; CL type
(type array-index nitems start index)
(type (or null sequence) data))
(declare (type (or null (function (card8) t)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(let ((result (or data (make-sequence result-type nitems))))
(typecase result
(list
(if transform
(read-list-card8-with-transform
reply-buffer nitems result transform start index)
(read-list-card8 reply-buffer nitems result start index)))
#-lispm
((simple-array card8 (*))
(if transform
(read-simple-array-card8-with-transform
reply-buffer nitems result transform start index)
(read-simple-array-card8 reply-buffer nitems result start index)))
(t
(if transform
(read-vector-card8-with-transform
reply-buffer nitems result transform start index)
(read-vector-card8 reply-buffer nitems result start index))))
result))
(defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec))
`(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0))
(declare
(type reply-buffer reply-buffer)
(type t result-type)
(type array-index nitems start index)
(type (or null sequence) data)
(type (or null (function (,type) t)) transform)
#+clx-ansi-common-lisp (dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
(let ((result (or data (make-sequence result-type nitems))))
(typecase result
(list
(if transform
(,tlist reply-buffer nitems result transform start index)
(,list reply-buffer nitems result start index)))
#-lispm
((simple-array ,type (*))
(if transform
(,tsa reply-buffer nitems result transform start index)
(,sa reply-buffer nitems result start index)))
;; FIXME: general sequences
(t
(if transform
(,tvec reply-buffer nitems result transform start index)
(,vec reply-buffer nitems result start index))))
result)))
;;; For now, perhaps performance it isn't worth doing better?
(define-sequence-reader read-sequence-card8 card8
(read-list-card8 read-list-card8-with-transform)
(read-simple-array-card8 read-simple-array-card8-with-transform)
(read-vector-card8 read-vector-card8-with-transform))
(defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data
(start 0) (index 0))
(declare (type reply-buffer reply-buffer)
(type t result-type) ;; CL type
(type array-index nitems start index)
(type (or null sequence) data))
(declare (type (or null (function (int8) t)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(if transform
(flet ((card8->int8->transform (v)
(declare (type card8 v))
(funcall transform (card8->int8 v))))
#+clx-ansi-common-lisp
(declare (dynamic-extent #'card8->int8->transform))
(read-sequence-card8
reply-buffer result-type nitems #'card8->int8->transform
data start index))
(read-sequence-card8
reply-buffer result-type nitems #'card8->int8
data start index)))
(define-transformed-sequence-reader read-sequence-int8 int8
card8->int8 read-sequence-card8)
;;; Reading sequences of card16's
(defun read-list-card16 (reply-buffer nitems data start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data))
(with-buffer-input (reply-buffer :sizes (16) :index index)
(do* ((j nitems (index- j 1))
(lst (nthcdr start data) (cdr lst))
(index 0 (index+ index 2)))
((index-zerop j))
(declare (type array-index j index)
(list lst))
(setf (car lst) (read-card16 index)))))
(defun read-list-card16-with-transform (reply-buffer nitems data transform start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data))
(declare (type (function (card16) t) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(with-buffer-input (reply-buffer :sizes (16) :index index)
(do* ((j nitems (index- j 1))
(lst (nthcdr start data) (cdr lst))
(index 0 (index+ index 2)))
((index-zerop j))
(declare (type array-index j index)
(list lst))
(setf (car lst) (funcall transform (read-card16 index))))))
(define-list-readers (read-list-card16 read-list-card16-with-transform) card16
16 2 read-card16)
#-lispm
(defun read-simple-array-card16 (reply-buffer nitems data start index)
@ -766,94 +713,18 @@
(declare (type array-index j end index))
(setf (aref data j) (funcall transform (read-card16 index)))))))
(defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data
(start 0) (index 0))
(declare (type reply-buffer reply-buffer)
(type t result-type) ;; CL type
(type array-index nitems start index)
(type (or null sequence) data))
(declare (type (or null (function (card16) t)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(let ((result (or data (make-sequence result-type nitems))))
(typecase result
(list
(if transform
(read-list-card16-with-transform reply-buffer nitems result transform start index)
(read-list-card16 reply-buffer nitems result start index)))
#-lispm
((simple-array card16 (*))
(if transform
(read-simple-array-card16-with-transform
reply-buffer nitems result transform start index)
(read-simple-array-card16 reply-buffer nitems result start index)))
(t
(if transform
(read-vector-card16-with-transform
reply-buffer nitems result transform start index)
(read-vector-card16 reply-buffer nitems result start index))))
result))
;;; For now, perhaps performance it isn't worth doing better?
(define-sequence-reader read-sequence-card16 card16
(read-list-card16 read-list-card16-with-transform)
(read-simple-array-card16 read-simple-array-card16-with-transform)
(read-vector-card16 read-vector-card16-with-transform))
(defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data
(start 0) (index 0))
(declare (type reply-buffer reply-buffer)
(type t result-type) ;; CL type
(type array-index nitems start index)
(type (or null sequence) data))
(declare (type (or null (function (int16) t)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(if transform
(flet ((card16->int16->transform (v)
(declare (type card16 v))
(funcall transform (card16->int16 v))))
#+clx-ansi-common-lisp
(declare (dynamic-extent #'card16->int16->transform))
(read-sequence-card16
reply-buffer result-type nitems #'card16->int16->transform
data start index))
(read-sequence-card16
reply-buffer result-type nitems #'card16->int16
data start index)))
(define-transformed-sequence-reader read-sequence-int16 int16
card16->int16 read-sequence-card16)
;;; Reading sequences of card32's
(defun read-list-card32 (reply-buffer nitems data start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data))
(with-buffer-input (reply-buffer :sizes (32) :index index)
(do* ((j nitems (index- j 1))
(lst (nthcdr start data) (cdr lst))
(index 0 (index+ index 4)))
((index-zerop j))
(declare (type array-index j index)
(list lst))
(setf (car lst) (read-card32 index)))))
(defun read-list-card32-with-transform (reply-buffer nitems data transform start index)
(declare (type reply-buffer reply-buffer)
(type array-index nitems start index)
(type list data))
(declare (type (function (card32) t) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(with-buffer-input (reply-buffer :sizes (32) :index index)
(do* ((j nitems (index- j 1))
(lst (nthcdr start data) (cdr lst))
(index 0 (index+ index 4)))
((index-zerop j))
(declare (type array-index j index)
(list lst))
(setf (car lst) (funcall transform (read-card32 index))))))
(define-list-readers (read-list-card32 read-list-card32-with-transform) card32
32 4 read-card32)
#-lispm
(defun read-simple-array-card32 (reply-buffer nitems data start index)
@ -927,115 +798,87 @@
(declare (type array-index j end index))
(setf (aref data j) (funcall transform (read-card32 index)))))))
(defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data
(start 0) (index 0))
(declare (type reply-buffer reply-buffer)
(type t result-type) ;; CL type
(type array-index nitems start index)
(type (or null sequence) data))
(declare (type (or null (function (card32) t)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(let ((result (or data (make-sequence result-type nitems))))
(typecase result
(list
(if transform
(read-list-card32-with-transform reply-buffer nitems result transform start index)
(read-list-card32 reply-buffer nitems result start index)))
#-lispm
((simple-array card32 (*))
(if transform
(read-simple-array-card32-with-transform
reply-buffer nitems result transform start index)
(read-simple-array-card32 reply-buffer nitems result start index)))
(t
(if transform
(read-vector-card32-with-transform
reply-buffer nitems result transform start index)
(read-vector-card32 reply-buffer nitems result start index))))
result))
(define-sequence-reader read-sequence-card32 card32
(read-list-card32 read-list-card32-with-transform)
(read-simple-array-card32 read-simple-array-card32-with-transform)
(read-vector-card32 read-vector-card32-with-transform))
;;; For now, perhaps performance it isn't worth doing better?
(defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data
(start 0) (index 0))
(declare (type reply-buffer reply-buffer)
(type t result-type) ;; CL type
(type array-index nitems start index)
(type (or null sequence) data))
(declare (type (or null (function (int32) t)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(if transform
(flet ((card32->int32->transform (v)
(declare (type card32 v))
(funcall transform (card32->int32 v))))
#+clx-ansi-common-lisp
(declare (dynamic-extent #'card32->int32->transform))
(read-sequence-card32
reply-buffer result-type nitems #'card32->int32->transform
data start index))
(read-sequence-card32
reply-buffer result-type nitems #'card32->int32
data start index)))
(define-transformed-sequence-reader read-sequence-int32 int32
card32->int32 read-sequence-card32)
;;; Writing sequences of chars
(defun write-sequence-char
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) character)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(if transform
(flet ((transform->char->card8 (x)
(char->card8 (the character (funcall transform x)))))
#+clx-ansi-common-lisp
(declare (dynamic-extent #'transform->char->card8))
(write-sequence-card8
buffer boffset data start end #'transform->char->card8))
(write-sequence-card8 buffer boffset data start end #'char->card8)))
(defmacro define-transformed-sequence-writer (name fromtype transformer writer)
(let ((ntrans (gensym)))
`(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform)
(declare
(type buffer buffer)
(type sequence data)
(type array-index boffset start end)
(type (or null (function (t) ,fromtype)) transform)
#+clx-ansi-common-lisp (dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
(if transform
(flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x)))))
#+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans))
(,writer buffer boffset data start end #',ntrans))
(,writer buffer boffset data start end #',transformer)))))
(define-transformed-sequence-writer write-sequence-char character
char->card8 write-sequence-card8)
;;; Writing sequences of card8's
(defun write-list-card8 (buffer boffset data start end)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(writing-buffer-chunks card8
((lst (nthcdr start data)))
((type list lst))
(dotimes (j chunk)
(declare (type array-index j))
#-ti (write-card8 j (pop lst)) ;TI Compiler bug
#+ti (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop lst))
))
nil)
(defmacro define-list-writers ((name tname) type step writer)
`(progn
(defun ,name (buffer boffset data start end)
(declare
(type buffer buffer)
(type list data)
(type array-index boffset start end))
(writing-buffer-chunks ,type
((list (nthcdr start data)))
((type list list))
(do ((j 0 (index+ j ,step)))
((index>= j chunk))
(declare (type array-index j))
(,writer j (pop list)))))
(defun ,tname (buffer boffset data start end transform)
(declare
(type buffer buffer)
(type list data)
(type array-index boffset start end)
(type (function (t) ,type) transform)
#+clx-ansi-common-lisp (dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
(writing-buffer-chunks ,type
((list (nthcdr start data)))
((type list list))
(do ((j 0 (index+ j ,step)))
((index>= j chunk))
(declare (type array-index j))
(,writer j (funcall transform (pop list))))))))
(defun write-list-card8-with-transform (buffer boffset data start end transform)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(declare (type (function (t) card8) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(writing-buffer-chunks card8
((lst (nthcdr start data)))
((type list lst))
(dotimes (j chunk)
(declare (type array-index j))
(write-card8 j (funcall transform (pop lst)))))
nil)
;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8
#+ti
(progn
(defun write-list-card8 (buffer boffset data start end)
(writing-buffer-chunks card8
((list (nthcdr start data)))
((type list list))
(dotimes (j chunk)
(setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list)))))
(defun write-list-card8-with-transform (buffer boffset data start end transform)
(writing-buffer-chunks card8
((list (nthcdr start data)))
((type list lst))
(dotimes (j chunk)
(declare (type array-index j))
(write-card8 j (funcall transform (pop lst)))))))
#-ti
(define-list-writers (write-list-card8 write-list-card8-with-transform) card8
1 write-card8)
;;; Should really write directly from data, instead of into the buffer first
#-lispm
@ -1107,86 +950,42 @@
(setq index (index+ index 1)))))
nil)
(defun write-sequence-card8
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) card8)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(typecase data
(list
(if transform
(write-list-card8-with-transform buffer boffset data start end transform)
(write-list-card8 buffer boffset data start end)))
#-lispm
((simple-array card8 (*))
(if transform
(write-simple-array-card8-with-transform buffer boffset data start end transform)
(write-simple-array-card8 buffer boffset data start end)))
(t
(if transform
(write-vector-card8-with-transform buffer boffset data start end transform)
(write-vector-card8 buffer boffset data start end)))))
(defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec))
`(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform)
(declare
(type buffer buffer)
(type sequence data)
(type array-index boffset start end)
(type (or null (function (t) ,type)) transform)
#+clx-ansi-common-lisp (dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
(typecase data
(list
(if transform
(,tlist buffer boffset data start end transform)
(,list buffer boffset data start end)))
#-lispm
((simple-array ,type (*))
(if transform
(,tsa buffer boffset data start end transform)
(,sa buffer boffset data start end)))
(t ; FIXME: general sequences
(if transform
(,tvec buffer boffset data start end transform)
(,vec buffer boffset data start end))))))
;;; For now, perhaps performance it isn't worth doing better?
(define-sequence-writer write-sequence-card8 card8
(write-list-card8 write-list-card8-with-transform)
(write-simple-array-card8 write-simple-array-card8-with-transform)
(write-vector-card8 write-vector-card8-with-transform))
(defun write-sequence-int8
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) int8)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(if transform
(flet ((transform->int8->card8 (x)
(int8->card8 (the int8 (funcall transform x)))))
#+clx-ansi-common-lisp
(declare (dynamic-extent #'transform->int8->card8))
(write-sequence-card8
buffer boffset data start end #'transform->int8->card8))
(write-sequence-card8 buffer boffset data start end #'int8->card8)))
(define-transformed-sequence-writer write-sequence-int8 int8
int8->card8 write-sequence-card8)
;;; Writing sequences of card16's
(defun write-list-card16 (buffer boffset data start end)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(writing-buffer-chunks card16
((lst (nthcdr start data)))
((type list lst))
;; Depends upon the chunks being an even multiple of card16's big
(do ((j 0 (index+ j 2)))
((index>= j chunk))
(declare (type array-index j))
(write-card16 j (pop lst))))
nil)
(defun write-list-card16-with-transform (buffer boffset data start end transform)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(declare (type (function (t) card16) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(writing-buffer-chunks card16
((lst (nthcdr start data)))
((type list lst))
;; Depends upon the chunks being an even multiple of card16's big
(do ((j 0 (index+ j 2)))
((index>= j chunk))
(declare (type array-index j))
(write-card16 j (funcall transform (pop lst)))))
nil)
(define-list-writers (write-list-card16 write-list-card16-with-transform) card16
2 write-card16)
#-lispm
(defun write-simple-array-card16 (buffer boffset data start end)
@ -1280,65 +1079,15 @@
(setq index (index+ index 1)))))
nil)
(defun write-sequence-card16
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) card16)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(typecase data
(list
(if transform
(write-list-card16-with-transform buffer boffset data start end transform)
(write-list-card16 buffer boffset data start end)))
#-lispm
((simple-array card16 (*))
(if transform
(write-simple-array-card16-with-transform buffer boffset data start end transform)
(write-simple-array-card16 buffer boffset data start end)))
(t
(if transform
(write-vector-card16-with-transform buffer boffset data start end transform)
(write-vector-card16 buffer boffset data start end)))))
(define-sequence-writer write-sequence-card16 card16
(write-list-card16 write-list-card16-with-transform)
(write-simple-array-card16 write-simple-array-card16-with-transform)
(write-vector-card16 write-vector-card16-with-transform))
;;; Writing sequences of int16's
(defun write-list-int16 (buffer boffset data start end)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(writing-buffer-chunks int16
((lst (nthcdr start data)))
((type list lst))
;; Depends upon the chunks being an even multiple of int16's big
(do ((j 0 (index+ j 2)))
((index>= j chunk))
(declare (type array-index j))
(write-int16 j (pop lst))))
nil)
(defun write-list-int16-with-transform (buffer boffset data start end transform)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(declare (type (function (t) int16) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(writing-buffer-chunks int16
((lst (nthcdr start data)))
((type list lst))
;; Depends upon the chunks being an even multiple of int16's big
(do ((j 0 (index+ j 2)))
((index>= j chunk))
(declare (type array-index j))
(write-int16 j (funcall transform (pop lst)))))
nil)
(define-list-writers (write-list-int16 write-list-int16-with-transform) int16
2 write-int16)
#-lispm
(defun write-simple-array-int16 (buffer boffset data start end)
@ -1432,65 +1181,15 @@
(setq index (index+ index 1)))))
nil)
(defun write-sequence-int16
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) int16)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(typecase data
(list
(if transform
(write-list-int16-with-transform buffer boffset data start end transform)
(write-list-int16 buffer boffset data start end)))
#-lispm
((simple-array int16 (*))
(if transform
(write-simple-array-int16-with-transform buffer boffset data start end transform)
(write-simple-array-int16 buffer boffset data start end)))
(t
(if transform
(write-vector-int16-with-transform buffer boffset data start end transform)
(write-vector-int16 buffer boffset data start end)))))
(define-sequence-writer write-sequence-int16 int16
(write-list-int16 write-list-int16-with-transform)
(write-simple-array-int16 write-simple-array-int16-with-transform)
(write-vector-int16 write-vector-int16-with-transform))
;;; Writing sequences of card32's
(defun write-list-card32 (buffer boffset data start end)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(writing-buffer-chunks card32
((lst (nthcdr start data)))
((type list lst))
;; Depends upon the chunks being an even multiple of card32's big
(do ((j 0 (index+ j 4)))
((index>= j chunk))
(declare (type array-index j))
(write-card32 j (pop lst))))
nil)
(defun write-list-card32-with-transform (buffer boffset data start end transform)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(declare (type (function (t) card32) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(writing-buffer-chunks card32
((lst (nthcdr start data)))
((type list lst))
;; Depends upon the chunks being an even multiple of card32's big
(do ((j 0 (index+ j 4)))
((index>= j chunk))
(declare (type array-index j))
(write-card32 j (funcall transform (pop lst)))))
nil)
(define-list-writers (write-list-card32 write-list-card32-with-transform) card32
4 write-card32)
#-lispm
(defun write-simple-array-card32 (buffer boffset data start end)
@ -1584,51 +1283,13 @@
(setq index (index+ index 1)))))
nil)
(defun write-sequence-card32
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) card32)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(typecase data
(list
(if transform
(write-list-card32-with-transform buffer boffset data start end transform)
(write-list-card32 buffer boffset data start end)))
#-lispm
((simple-array card32 (*))
(if transform
(write-simple-array-card32-with-transform buffer boffset data start end transform)
(write-simple-array-card32 buffer boffset data start end)))
(t
(if transform
(write-vector-card32-with-transform buffer boffset data start end transform)
(write-vector-card32 buffer boffset data start end)))))
(define-sequence-writer write-sequence-card32 card32
(write-list-card32 write-list-card32-with-transform)
(write-simple-array-card32 write-simple-array-card32-with-transform)
(write-vector-card32 write-vector-card32-with-transform))
;;; For now, perhaps performance it isn't worth doing better?
(defun write-sequence-int32
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) int32)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(if transform
(flet ((transform->int32->card32 (x)
(int32->card32 (the int32 (funcall transform x)))))
#+clx-ansi-common-lisp
(declare (dynamic-extent #'transform->int32->card32))
(write-sequence-card32
buffer boffset data start end #'transform->int32->card32))
(write-sequence-card32 buffer boffset data start end #'int32->card32)))
(define-transformed-sequence-writer write-sequence-int32 int32
int32->card32 write-sequence-card32)
(defun read-bitvector256 (buffer-bbuf boffset data)
(declare (type buffer-bytes buffer-bbuf)
@ -1673,36 +1334,8 @@
;;; Writing sequences of char2b's
(defun write-list-char2b (buffer boffset data start end)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(writing-buffer-chunks card16
((lst (nthcdr start data)))
((type list lst))
(do ((j 0 (index+ j 2)))
((index>= j (1- chunk)) (setf chunk j))
(declare (type array-index j))
(write-char2b j (pop lst))))
nil)
(defun write-list-char2b-with-transform (buffer boffset data start end transform)
(declare (type buffer buffer)
(type list data)
(type array-index boffset start end))
(declare (type (function (t) card16) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(writing-buffer-chunks card16
((lst (nthcdr start data)))
((type list lst))
(do ((j 0 (index+ j 2)))
((index>= j (1- chunk)) (setf chunk j))
(declare (type array-index j))
(write-char2b j (funcall transform (pop lst)))))
nil)
(define-list-writers (write-list-char2b write-list-char2b-with-transform) card16
2 write-char2b)
#-lispm
(defun write-simple-array-char2b (buffer boffset data start end)
@ -1778,28 +1411,7 @@
(setq index (index+ index 1)))))
nil)
(defun write-sequence-char2b
(buffer boffset data &optional (start 0) (end (length data)) transform)
(declare (type buffer buffer)
(type sequence data)
(type array-index boffset start end))
(declare (type (or null (function (t) card16)) transform)
#+clx-ansi-common-lisp
(dynamic-extent transform)
#+(and lispm (not clx-ansi-common-lisp))
(sys:downward-funarg transform))
(typecase data
(list
(if transform
(write-list-char2b-with-transform buffer boffset data start end transform)
(write-list-char2b buffer boffset data start end)))
#-lispm
((simple-array card16 (*))
(if transform
(write-simple-array-char2b-with-transform buffer boffset data start end transform)
(write-simple-array-char2b buffer boffset data start end)))
(t
(if transform
(write-vector-char2b-with-transform buffer boffset data start end transform)
(write-vector-char2b buffer boffset data start end)))))
(define-sequence-writer write-sequence-char2b card16
(write-list-char2b write-list-char2b-with-transform)
(write-simple-array-char2b write-simple-array-char2b-with-transform)
(write-vector-char2b write-vector-char2b-with-transform))

34
src/clx/clx.asd
View file

@ -35,15 +35,17 @@
(defclass legacy-file (static-file) ())
(defsystem CLX
:depends-on (sb-bsd-sockets)
:version "0.5.4"
:depends-on (#+sbcl sb-bsd-sockets)
:version "0.7.2"
:serial t
:default-component-class clx-source-file
:components
((:file "package")
(:file "depdefs")
(:file "clx")
(:file "dependent")
#-(or openmcl allegro) (:file "dependent")
#+openmcl (:file "dep-openmcl")
#+allegro (:file "dep-allegro")
(:file "macros")
(:file "bufmac")
(:file "buffer")
@ -60,12 +62,19 @@
(:file "manager")
(:file "image")
(:file "resource")
#+allegro
(:file "excldep" :pathname "excldep.lisp")
(:module extensions
:pathname #.(make-pathname :directory '(:relative))
:components
((:file "shape")
(:file "big-requests")
(:file "xvidmode")
(:xrender-source-file "xrender")))
(:xrender-source-file "xrender")
(:file "glx")
(:file "gl" :depends-on ("glx"))
(:file "dpms")
(:file "xtest")))
(:module demo
:default-component-class example-source-file
:components
@ -75,7 +84,9 @@
;; asdf doesn't load example files anyway.
(:file "beziertest")
(:file "clclock")
(:file "clipboard")
(:file "clx-demos")
(:file "gl-test")
;; FIXME: compiling this generates 30-odd spurious code
;; deletion notes. Find out why, and either fix or
;; workaround the problem.
@ -96,7 +107,6 @@
(:legacy-file "exclREADME")
(:legacy-file "exclcmac" :pathname "exclcmac.lisp")
(:legacy-file "excldepc" :pathname "excldep.c")
(:legacy-file "excldep" :pathname "excldep.lisp")
(:legacy-file "sockcl" :pathname "sockcl.lisp")
(:legacy-file "socket" :pathname "socket.c")
(:legacy-file "defsystem" :pathname "defsystem.lisp")
@ -149,14 +159,18 @@
;; use of this does not imply that applications using CLX
;; calls that expand into calls to these accessors will be
;; optimized in the same way).
(let ((sb-ext:*derive-function-types* t))
(let ((sb-ext:*derive-function-types* t)
(sadx (find-symbol "STACK-ALLOCATE-DYNAMIC-EXTENT" :sb-c))
(sadx-var (find-symbol "*STACK-ALLOCATE-DYNAMIC-EXTENT*" :sb-ext)))
;; deeply unportable stuff, this. I will be shot. We
;; want to enable the dynamic-extent declarations in CLX.
(when (sb-c::policy-quality-name-p
'sb-c::stack-allocate-dynamic-extent)
(when (and sadx (sb-c::policy-quality-name-p sadx))
;; no way of setting it back short of yet more yukky stuff
(proclaim '(optimize (sb-c::stack-allocate-dynamic-extent 3))))
(call-next-method)))
(proclaim `(optimize (,sadx 3))))
(if sadx-var
(progv (list sadx-var) (list t)
(call-next-method))
(call-next-method))))
(setf (operation-on-warnings o) on-warnings
(operation-on-failure o) on-failure))))

60
src/clx/clx.lisp
View file

@ -343,6 +343,7 @@
(atom-id-map (make-hash-table :test (resource-id-map-test)
:size *atom-cache-size*)
:type hash-table)
(extended-max-request-length 0 :type card32)
)
(defun print-display-name (display stream)
@ -381,7 +382,7 @@
(print-unreadable-object (drawable stream :type t)
(print-display-name (drawable-display drawable) stream)
(write-string " " stream)
(prin1 (drawable-id drawable) stream)))
(let ((*print-base* 16)) (prin1 (drawable-id drawable) stream))))
(def-clx-class (window (:include drawable) (:copier nil)
(:print-function print-drawable))
@ -580,10 +581,13 @@
'(or mask32 (clx-list event-mask-class)))
(defconstant +pointer-event-mask-vector+
'#(%error %error :button-press :button-release
:enter-window :leave-window :pointer-motion :pointer-motion-hint
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion :keymap-state))
;; the first two elements used to be '%error '%error (i.e. symbols,
;; and not keywords) but the vector is supposed to contain
;; keywords, so I renamed them -dan 2004.11.13
'#(:%error :%error :button-press :button-release
:enter-window :leave-window :pointer-motion :pointer-motion-hint
:button-1-motion :button-2-motion :button-3-motion :button-4-motion
:button-5-motion :button-motion :keymap-state))
(deftype pointer-event-mask-class ()
'(member :button-press :button-release
@ -635,15 +639,16 @@
:arc-mode))
(deftype event-key ()
'(member :key-press :key-release :button-press :button-release :motion-notify
:enter-notify :leave-notify :focus-in :focus-out :keymap-notify
:exposure :graphics-exposure :no-exposure :visibility-notify
:create-notify :destroy-notify :unmap-notify :map-notify :map-request
:reparent-notify :configure-notify :gravity-notify :resize-request
:configure-request :circulate-notify :circulate-request :property-notify
:selection-clear :selection-request :selection-notify
:colormap-notify :client-message :mapping-notify
:shape-notify :xfree86-vidmode-notify))
'(or (member :key-press :key-release :button-press :button-release
:motion-notify :enter-notify :leave-notify :focus-in :focus-out
:keymap-notify :exposure :graphics-exposure :no-exposure
:visibility-notify :create-notify :destroy-notify :unmap-notify
:map-notify :map-request :reparent-notify :configure-notify
:gravity-notify :resize-request :configure-request :circulate-notify
:circulate-request :property-notify :selection-clear
:selection-request :selection-notify :colormap-notify :client-message
:mapping-notify)
(satisfies extension-event-key-p)))
(deftype error-key ()
'(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
@ -821,19 +826,18 @@
(getf (font-properties font) name))
(macrolet ((make-mumble-equal (type)
;; When cached, EQ works fine, otherwise test resource id's and displays
;; Since caching is only done for objects created by the
;; client, we must always compare ID and display for
;; non-identical mumbles.
(let ((predicate (xintern type '-equal))
(id (xintern type '-id))
(dpy (xintern type '-display)))
(if (member type +clx-cached-types+)
`(within-definition (,type make-mumble-equal)
(declaim (inline ,predicate))
(defun ,predicate (a b) (eq a b)))
`(within-definition (,type make-mumble-equal)
(defun ,predicate (a b)
(declare (type ,type a b))
(and (= (,id a) (,id b))
(eq (,dpy a) (,dpy b)))))))))
`(within-definition (,type make-mumble-equal)
(defun ,predicate (a b)
(declare (type ,type a b))
(or (eql a b)
(and (= (,id a) (,id b))
(eq (,dpy a) (,dpy b)))))))))
(make-mumble-equal window)
(make-mumble-equal pixmap)
(make-mumble-equal cursor)
@ -847,10 +851,10 @@
;;; Converts from keyword-lists to integer and back
;;;
(defun encode-mask (key-vector key-list key-type)
;; KEY-VECTOR is a vector containg bit-position keywords. The position of the
;; keyword in the vector indicates its bit position in the resulting mask
;; KEY-LIST is either a mask or a list of KEY-TYPE
;; Returns NIL when KEY-LIST is not a list or mask.
;; KEY-VECTOR is a vector containg bit-position keywords. The
;; position of the keyword in the vector indicates its bit position
;; in the resulting mask. KEY-LIST is either a mask or a list of
;; KEY-TYPE Returns NIL when KEY-LIST is not a list or mask.
(declare (type (simple-array keyword (*)) key-vector)
(type (or mask32 list) key-list))
(declare (clx-values (or mask32 null)))

2
src/clx/cmudep.lisp
View file

@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header$")
"$Header: /loaclhost/usr/local/src/cvs/clx/cmudep.lisp,v 1.1 2000/07/02 19:19:46 dan Exp $")
;;;
;;; **********************************************************************
;;;

4
src/clx/demo/clx-demos.lisp
View file

@ -36,11 +36,11 @@
(unless *display*
#+:cmu
(multiple-value-setq (*display* *screen*) (ext:open-clx-display))
#+(or ecl sbcl)
#+(or sbcl allegro clisp)
(progn
(setf *display* (xlib::open-default-display))
(setf *screen* (xlib:display-default-screen *display*)))
#-(or cmu sbcl ecl)
#-(or cmu sbcl allegro clisp)
(progn
;; Portable method
(setf *display* (xlib:open-display (machine-instance)))

28
src/clx/depdefs.lisp
View file

@ -177,6 +177,10 @@
;;; this to do fast array packing/unpacking when the overlapping-arrays
;;; feature is enabled.
#+clisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless system::*big-endian* (pushnew :clx-little-endian *features*)))
#+(and clx-little-endian lispm)
(eval-when (eval compile load)
(pushnew :clx-overlapping-arrays *features*))
@ -400,10 +404,10 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
;; FIXME: maybe we should reevaluate this?
(defvar *def-clx-class-use-defclass*
#+Genera t
#+(or Genera allegro) t
#+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
#+(and cmu (not pcl)) nil
#-(or Genera cmu) nil
#-(or Genera cmu allegro) nil
"Controls whether DEF-CLX-CLASS uses DEFCLASS.
If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of
@ -667,3 +671,23 @@ used, since NIL is the empty list.")
(:return-type :signed-32bit))
(host :simple-string)
(display :signed-32bit))
;;-----------------------------------------------------------------------------
;; Finding the server socket
;;-----------------------------------------------------------------------------
;; These are here because dep-openmcl.lisp and dependent.lisp both need them
(defconstant +X-unix-socket-path+
"/tmp/.X11-unix/X"
"The location of the X socket")
(defun unix-socket-path-from-host (host display)
"Return the name of the unix domain socket for host and display, or
nil if a network socket should be opened."
(cond ((or (string= host "") (string= host "unix"))
(format nil "~A~D" +X-unix-socket-path+ display))
#+darwin
((and (> (length host) 10) (string= host "tmp/launch" :end1 10))
(format nil "/~A:~D" host display))
(t nil)))

236
src/clx/dependent.lisp
View file

@ -689,7 +689,7 @@
(the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
#+(or cmu sbcl) (progn
#+(or cmu sbcl clisp ecl) (progn
;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI
;;; is irrational, there can't be a precise rational representation. In
@ -863,7 +863,7 @@
;;; MAKE-PROCESS-LOCK: Creating a process lock.
#-(or LispM excl Minima sbcl (and cmu mp))
#-(or LispM excl Minima sbcl (and cmu mp) (and ecl threads))
(defun make-process-lock (name)
(declare (ignore name))
nil)
@ -892,6 +892,10 @@
(defun make-process-lock (name)
(sb-thread:make-mutex :name name))
#+(and ecl threads)
(defun make-lock (name)
(mp:make-lock :name name))
;;; HOLDING-LOCK: Execute a body of code with a lock held.
;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN
@ -900,7 +904,7 @@
;; If you're not sharing DISPLAY objects within a multi-processing
;; shared-memory environment, this is sufficient
#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) )
#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) (and ecl threads))
(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
(declare (ignore locator display whostate timeout))
`(progn ,@body))
@ -935,6 +939,22 @@
`(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
,@body))
#+clisp
(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
&key timeout)
&body body)
(declare (ignore lock display whostate timeout))
`(progn
,@body))
#+(and ecl threads)
(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
&key timeout)
&body body)
(declare (ignore display))
`(progn (mp:get-lock ,lock)
,@body))
#+sbcl
(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
&key timeout)
@ -1102,7 +1122,7 @@
;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
;;; value changes.
#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp))
#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp) (and ecl threads))
(defun process-block (whostate predicate &rest predicate-args)
(declare (ignore whostate))
(or (apply predicate predicate-args)
@ -1168,6 +1188,15 @@
(return))
(yield)))
#+(and ecl threads)
(defun process-block (whostate predicate &rest predicate-args)
(declare (ignore whostate))
(declare (type function predicate))
(loop
(when (apply predicate predicate-args)
(return))
(mp:process-yield)))
;;; FIXME: the below implementation for threaded PROCESS-BLOCK using
;;; queues and condition variables might seem better, but in fact it
;;; turns out to make performance extremely suboptimal, at least as
@ -1203,7 +1232,7 @@
(declaim (inline process-wakeup))
#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp))
#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp) (and ecl threads))
(defun process-wakeup (process)
(declare (ignore process))
nil)
@ -1237,6 +1266,12 @@
(defun process-wakeup (process)
(declare (ignore process))
(yield))
#+(and ecl threads)
(defun process-wakeup (process)
(declare (ignore process))
(mp:process-yield))
#+(or)
(defun process-wakeup (process)
(declare (ignore process))
@ -1255,7 +1290,7 @@
;;; Default return NIL, which is acceptable even if there is a scheduler.
#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp))
#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp) (and ecl threads))
(defun current-process ()
nil)
@ -1282,7 +1317,11 @@
#+sbcl
(defun current-process ()
(sb-thread:current-thread-id))
sb-thread:*current-thread*)
#+(and ecl threads)
(defun current-process ()
(mp:current-process))
;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
@ -1310,6 +1349,13 @@
(defmacro without-interrupts (&body body)
`(system:without-interrupts ,@body))
#+ecl
(defmacro without-interrupts (&body body)
#+threads
`(mp:without-interrupts ,@body)
#-threads
`(let ((ext:*interrupt-enable* nil)) ,@body))
#+sbcl
(defvar *without-interrupts-sic-lock*
(sb-thread:make-mutex :name "lock simulating *without-interrupts*"))
@ -1329,17 +1375,15 @@
(setf ,place ,new-value)
t))))
;;; we only use this queue for the spinlock word, in fact
#+sbcl
(defvar *conditional-store-queue*
(sb-thread:make-waitqueue :name "conditional store"))
#+sbcl
(defmacro conditional-store (place old-value new-value)
`(sb-thread::with-spinlock (*conditional-store-queue*)
(cond ((eq ,place ,old-value)
(setf ,place ,new-value)
t))))
(progn
(defvar *conditional-store-lock*
(sb-thread:make-mutex :name "conditional store"))
(defmacro conditional-store (place old-value new-value)
`(sb-thread:with-mutex (*conditional-store-lock*)
(cond ((eq ,place ,old-value)
(setf ,place ,new-value)
t)))))
;;;----------------------------------------------------------------------------
;;; IO Error Recovery
@ -1403,11 +1447,34 @@
;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
;;; server
#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl)
#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp)
(defun open-x-stream (host display protocol)
host display protocol ;; unused
(error "OPEN-X-STREAM not implemented yet."))
#+clisp
(defun open-x-stream (host display protocol)
(declare (ignore protocol)
(type (integer 0) display))
(let ((socket
;; are we dealing with a localhost?
(when (or (string= host "")
(string= host "unix"))
;; ok, try to connect to a AF_UNIX domain socket
(sys::make-socket-stream "" display))))
(if socket
socket
;; try to connect by hand
(let ((host (host-address host)))
(when host
;; Fixme: get a descent ip standard in CLX: a vector!
(let ((ip (format nil
"~{~D~^.~}"
(rest host))))
(socket:socket-connect (+ 6000 display) ip
:element-type '(unsigned-byte 8))))))))
;;; Genera:
;;; TCP and DNA are both layered products, so try to work with either one.
@ -1512,18 +1579,14 @@
:foreign-port (+ *x-tcp-port* display)))
#+(or sbcl ecl)
(defconstant +X-unix-socket-path+
"/tmp/.X11-unix/X"
"The location of the X socket")
#+sbcl
(defun open-x-stream (host display protocol)
(declare (ignore protocol)
(type (integer 0) display))
(let ((local-socket-path (unix-socket-path-from-host host display)))
(socket-make-stream
(if (or (string= host "") (string= host "unix")) ; AF_LOCAL domain socket
(if local-socket-path
(let ((s (make-instance 'local-socket :type :stream)))
(socket-connect s (format nil "~A~D" +X-unix-socket-path+ display))
(socket-connect s local-socket-path)
s)
(let ((host (car (host-ent-addresses (get-host-by-name host)))))
(when host
@ -1531,17 +1594,7 @@
(socket-connect s host (+ 6000 display))
s))))
:element-type '(unsigned-byte 8)
:input t :output t :buffering :none))
#+ecl
(defun open-x-stream (host display protocol)
(declare (ignore protocol)
(type (integer 0) display))
(let (socket)
(if (or (string= host "") (string= host "unix")) ; AF_UNIX doamin socket
(sys::open-unix-socket-stream
(format nil "~A~D" +X-unix-socket-path+ display))
(si::open-client-stream host (+ 6000 display)))))
:input t :output t :buffering :none)))
;;; BUFFER-READ-DEFAULT - read data from the X stream
@ -1655,7 +1708,7 @@
vector start (- end start))
nil)))
#+ecl
#+(or ecl clisp)
(defun buffer-read-default (display vector start end timeout)
(declare (type display display)
(type buffer-bytes vector)
@ -1677,7 +1730,7 @@
;;; receiving all data from the X Window System server.
;;; You are encouraged to write a specialized version of
;;; buffer-read-default that does block transfers.
#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl)
#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl clisp)
(defun buffer-read-default (display vector start end timeout)
(declare (type display display)
(type buffer-bytes vector)
@ -1759,25 +1812,13 @@
(system:output-raw-bytes (display-output-stream display) vector start end)
nil)
#+sbcl
#+(or sbcl ecl clisp)
(defun buffer-write-default (vector display start end)
(declare (type buffer-bytes vector)
(type display display)
(type array-index start end))
#.(declare-buffun)
(sb-impl::output-raw-bytes (display-output-stream display) vector start end)
nil)
#+ecl
(defun buffer-write-default (vector display start end)
(declare (type buffer-bytes vector)
(type display display)
(type array-index start end))
#.(declare-buffun)
(write-sequence vector
(display-output-stream display)
:start start
:end end)
(write-sequence vector (display-output-stream display) :start start :end end)
nil)
;;; WARNING:
@ -1786,7 +1827,7 @@
;;; You are STRONGLY encouraged to write a specialized version
;;; of buffer-write-default that does block transfers.
#-(or Genera explorer excl lcl3.0 Minima CMU sbcl)
#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp)
(defun buffer-write-default (vector display start end)
;; The default buffer write function for use with common-lisp streams
(declare (type buffer-bytes vector)
@ -1849,7 +1890,7 @@
#-(or Genera explorer excl lcl3.0 CMU sbcl)
(defparameter *buffer-read-polling-time* 0.5)
#-(or Genera explorer excl lcl3.0 CMU sbcl)
#-(or Genera explorer excl lcl3.0 CMU sbcl clisp)
(defun buffer-input-wait-default (display timeout)
(declare (type display display)
(type (or null (real 0 *)) timeout))
@ -1873,7 +1914,7 @@
(return-from buffer-input-wait-default nil)))
:timeout)))))
#+(or CMU sbcl)
#+(or CMU sbcl clisp)
(defun buffer-input-wait-default (display timeout)
(declare (type display display)
(type (or null number) timeout))
@ -1887,7 +1928,10 @@
:input timeout)
#+mp (mp:process-wait-until-fd-usable
(system:fd-stream-fd stream) :input timeout)
#-(or sbcl mp) (system:wait-until-fd-usable
#+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
(ext:socket-status stream (and timeout sec)
(round usec 1d-6)))
#-(or sbcl mp clisp) (system:wait-until-fd-usable
(system:fd-stream-fd stream) :input timeout)
nil
:timeout)))))
@ -2254,9 +2298,9 @@
;; dispatching, not just type checking. -- Ram.
(defmacro type? (object type)
#+(or cmu sbcl)
#+(or cmu sbcl clisp)
`(typep ,object ,type)
#-(or cmu sbcl)
#-(or cmu sbcl clisp)
(if (not (constantp type))
`(typep ,object ,type)
(progn
@ -2327,12 +2371,12 @@
(declare (dbg:error-reporter))
(apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp))
#+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp))
(defun x-error (condition &rest keyargs)
(declare (dynamic-extent keyargs))
(apply #'error condition keyargs))
#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp)
(defun x-cerror (proceed-format-string condition &rest keyargs)
(declare (dynamic-extent keyargs))
(apply #'cerror proceed-format-string condition keyargs))
@ -2355,12 +2399,12 @@
(ext::disable-clx-event-handling disp)))
(error condx)))
#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl)
#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun x-error (condition &rest keyargs)
(error "X-Error: ~a"
(princ-to-string (apply #'make-condition condition keyargs))))
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun x-cerror (proceed-format-string condition &rest keyargs)
(cerror proceed-format-string "X-Error: ~a"
(princ-to-string (apply #'make-condition condition keyargs))))
@ -2453,7 +2497,7 @@
(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
(format stream continue-format-string))
#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(define-condition x-error (error) ())
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
@ -2497,7 +2541,7 @@
,condition))
',name))))
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun condition-print (condition stream depth)
(declare (type x-error condition)
(type stream stream)
@ -2507,14 +2551,14 @@
(funcall (x-error-report-function condition) condition stream))
condition)
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun make-condition (type &rest slot-initializations)
(declare (dynamic-extent slot-initializations))
(let ((make-function (intern (concatenate 'string (string 'make-) (string type))
(symbol-package type))))
(apply make-function slot-initializations)))
#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(define-condition type-error (x-error)
((datum :reader type-error-datum :initarg :datum)
(expected-type :reader type-error-expected-type :initarg :expected-type))
@ -2529,7 +2573,7 @@
;; HOST hacking
;;-----------------------------------------------------------------------------
#-(or explorer Genera Minima Allegro CMU sbcl ecl)
#-(or explorer Genera Minima Allegro CMU sbcl ecl clisp)
(defun host-address (host &optional (family :internet))
;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
;; and cdr is a list of network address bytes.
@ -2539,6 +2583,45 @@
host family
(error "HOST-ADDRESS not implemented yet."))
#+clisp
(defun host-address (host &optional (family :internet))
"Return a list whose car is the family keyword (:internet :DECnet :Chaos)
and cdr is a list of network address bytes."
(declare (type stringable host)
(type (or null (member :internet :decnet :chaos) card8) family))
(declare (clx-values list))
(labels ((no-host-error ()
(error "Unknown host ~S" host))
(no-address-error ()
(error "Host ~S has no ~S address" host family)))
(let ((hostent (posix::resolve-host-ipaddr (string host))))
(when (not (posix::hostent-addr-list hostent))
(no-host-error))
(ecase family
((:internet nil 0)
(unless (= (posix::hostent-addrtype hostent) 2)
(no-address-error))
(let ((addr (first (posix::hostent-addr-list hostent))))
(etypecase addr
(integer
(list :internet
(ldb (byte 8 24) addr)
(ldb (byte 8 16) addr)
(ldb (byte 8 8) addr)
(ldb (byte 8 0) addr)))
(string
(let ((parts (read-from-string
(nsubstitute #\Space #\. (ext:string-concat
"(" addr ")")))))
(check-type parts (cons (unsigned-byte 8)
(cons (unsigned-byte 8)
(cons (unsigned-byte 8)
(cons (unsigned-byte 8)
NULL)))))
(cons :internet parts))))))))))
#+explorer
(defun host-address (host &optional (family :internet))
;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
@ -2810,7 +2893,8 @@
#+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
#+sbcl (sb-ext:posix-getenv name)
#+ecl (si:getenv name)
#-(or sbcl excl lcl3.0 CMU ecl) (progn name nil))
#+clisp (ext:getenv name)
#-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil))
(defun get-host-name ()
"Return the same hostname as gethostname(3) would"
@ -2820,7 +2904,8 @@
;; resources-pathname was using short-site-name for this purpose
#+excl (short-site-name)
#+ecl (si:getenv "HOST")
#-(or excl cmu sbcl ecl) (error "get-host-name not implemented"))
#+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s)))
#-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented"))
(defun homedir-file-pathname (name)
(and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
@ -2850,6 +2935,10 @@
(pathname xauthority)))
(homedir-file-pathname ".Xauthority")))
#+ecl
(eval-when (:load-toplevel :execute :compile-toplevel)
(pushnew :unix *features*))
;;; this particular defaulting behaviour is typical to most Unices, I think
#+unix
(defun get-default-display (&optional display-name)
@ -2894,11 +2983,6 @@ Returns a list of (host display-number screen protocol)."
(t :internet))))
(list host (or display 0) (or screen 0) protocol)))
#+win32
(defun get-default-display (&optional display-name)
(declare (ignore display-name))
(list "127.0.0.1" 0 0 :internet))
;;-----------------------------------------------------------------------------
;; GC stuff
@ -2993,7 +3077,7 @@ Returns a list of (host display-number screen protocol)."
(setf (char-bit object :hyper) 1)))
object)
#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp)
(defun default-keysym-translate (display state object)
(declare (type display display)
(type card16 state)
@ -3550,7 +3634,7 @@ Returns a list of (host display-number screen protocol)."
(count height (1- count)))
((zerop count))
(declare (type array-index src-idx dest-idx count))
(sb-kernel:bit-bash-copy sdata src-idx ddata dest-idx width)))))
(sb-kernel:ub1-bash-copy sdata src-idx ddata dest-idx width)))))
#+(or CMU sbcl)
(defun fast-read-pixarray-using-bitblt

162
src/clx/display.lisp
View file

@ -41,35 +41,48 @@
(defun read-xauth-entry (stream)
(labels ((read-short (stream &optional (eof-errorp t))
(let ((high-byte (read-byte stream eof-errorp)))
(and high-byte
(dpb high-byte (byte 8 8) (read-byte stream)))))
(read-short-length-string (stream)
(let ((length (read-short stream)))
(let ((string (make-string length)))
(dotimes (k length)
(setf (schar string k) (card8->char (read-byte stream))))
string)))
(read-short-length-vector (stream)
(let ((length (read-short stream)))
(let ((vector (make-array length :element-type '(unsigned-byte 8))))
(dotimes (k length)
(setf (aref vector k) (read-byte stream)))
vector))))
(let ((family (read-short stream nil)))
(if (null family)
(list nil nil nil nil nil)
(let* ((address (read-short-length-vector stream))
(number (parse-integer (read-short-length-string stream)))
(name (read-short-length-string stream))
(data (read-short-length-vector stream))
(family (or (car (rassoc family *protocol-families*)) family)))
(list
family
(ecase family
(:local (map 'string #'code-char address))
(:internet (coerce address 'list)))
number name data))))))
(let ((high-byte (read-byte stream eof-errorp)))
(and high-byte
(dpb high-byte (byte 8 8) (read-byte stream)))))
(read-short-length-string (stream)
(let ((length (read-short stream)))
(let ((string (make-string length)))
(dotimes (k length)
(setf (schar string k) (card8->char (read-byte stream))))
string)))
(read-short-length-vector (stream)
(let ((length (read-short stream)))
(let ((vector (make-array length
:element-type '(unsigned-byte 8))))
(dotimes (k length)
(setf (aref vector k) (read-byte stream)))
vector))))
(let ((family-id (read-short stream nil)))
(if (null family-id)
(list nil nil nil nil nil)
(let* ((address-data (read-short-length-vector stream))
(number (parse-integer (read-short-length-string stream)))
(name (read-short-length-string stream))
(data (read-short-length-vector stream))
(family (car (rassoc family-id *protocol-families*))))
(unless family
(return-from read-xauth-entry
;; we return FAMILY-ID to signal to
;; GET-BEST-AUTHORIZATION that we haven't finished
;; with the stream.
(list family-id nil nil nil nil)))
(let ((address
(case family
(:local (map 'string #'code-char address-data))
(:internet (coerce address-data 'list))
;; FIXME: we can probably afford not to support
;; :DECNET or :CHAOSNET in this modern age, but
;; :INTERNET6 probably deserve support. -- CSR,
;; 2005-08-07
(t nil))))
;; if ADDRESS is NIL by this time, we will never match
;; the address of DISPLAY.
(list family address number name data)))))))
(defun get-best-authorization (host display protocol)
;; parse .Xauthority, extract the cookie for DISPLAY on HOST.
@ -117,6 +130,24 @@
(values best-name best-data)))))))
(values "" "")))
(defmacro with-display ((display &key timeout inline)
&body body)
;; This macro is for use in a multi-process environment. It
;; provides exclusive access to the local display object for
;; multiple request generation. It need not provide immediate
;; exclusive access for replies; that is, if another process is
;; waiting for a reply (while not in a with-display), then
;; synchronization need not (but can) occur immediately. Except
;; where noted, all routines effectively contain an implicit
;; with-display where needed, so that correct synchronization is
;; always provided at the interface level on a per-call basis.
;; Nested uses of this macro will work correctly. This macro does
;; not prevent concurrent event processing; see with-event-queue.
`(with-buffer (,display
,@(and timeout `(:timeout ,timeout))
,@(and inline `(:inline ,inline)))
,@body))
;;
;; Resource id management
;;
@ -133,40 +164,59 @@
(type mask32 mask))))))
(defun resourcealloc (display)
;; Allocate a resource-id for in DISPLAY
;; Allocate a resource-id for use in DISPLAY
(declare (type display display))
(declare (clx-values resource-id))
(dpb (incf (display-resource-id-count display))
(display-resource-id-byte display)
(display-resource-id-base display)))
(loop for next-count upfrom (1+ (display-resource-id-count display))
repeat (1+ (display-resource-id-mask display))
as id = (dpb next-count
(display-resource-id-byte display)
(display-resource-id-base display))
unless (nth-value 1 (gethash id (display-resource-id-map display)))
do (setf (display-resource-id-count display) next-count)
(setf (gethash id (display-resource-id-map display)) t)
(return-from resourcealloc id))
;; internal consistency check
(assert (= (hash-table-count (display-resource-id-map display))
(1+ (display-resource-id-mask display))))
;; tell the user what's gone wrong
(error 'resource-ids-exhausted))
(defmacro allocate-resource-id (display object type)
;; Allocate a resource-id for OBJECT in DISPLAY
(if (member (eval type) +clx-cached-types+)
`(let ((id (funcall (display-xid ,display) ,display)))
(save-id ,display id ,object)
id)
`(funcall (display-xid ,display) ,display)))
`(with-display (,display)
,(if (member (eval type) +clx-cached-types+)
`(let ((id (funcall (display-xid ,display) ,display)))
(save-id ,display id ,object)
id)
`(funcall (display-xid ,display) ,display))))
(defmacro deallocate-resource-id (display id type)
(declare (ignore type))
;; Deallocate a resource-id for OBJECT in DISPLAY
(when (member (eval type) +clx-cached-types+)
`(deallocate-resource-id-internal ,display ,id)))
`(deallocate-resource-id-internal ,display ,id))
(defun deallocate-resource-id-internal (display id)
(remhash id (display-resource-id-map display)))
(with-display (display)
(remhash id (display-resource-id-map display))))
(defun lookup-resource-id (display id)
;; Find the object associated with resource ID
(gethash id (display-resource-id-map display)))
(defun save-id (display id object)
;; Register a resource-id from another display.
;; cache the object associated with ID for this display.
(declare (type display display)
(type integer id)
(type t object))
(declare (clx-values object))
(setf (gethash id (display-resource-id-map display)) object))
;; we can't cache objects from other clients, because they may
;; become invalid without us being told about that.
(let ((base (display-resource-id-base display))
(mask (display-resource-id-mask display)))
(when (= (logandc2 id mask) base)
(setf (gethash id (display-resource-id-map display)) object))
object))
;; Define functions to find the CLX data types given a display and resource-id
;; If the data type is being cached, look there first.
@ -263,24 +313,6 @@
;;
;; Display functions
;;
(defmacro with-display ((display &key timeout inline)
&body body)
;; This macro is for use in a multi-process environment. It
;; provides exclusive access to the local display object for
;; multiple request generation. It need not provide immediate
;; exclusive access for replies; that is, if another process is
;; waiting for a reply (while not in a with-display), then
;; synchronization need not (but can) occur immediately. Except
;; where noted, all routines effectively contain an implicit
;; with-display where needed, so that correct synchronization is
;; always provided at the interface level on a per-call basis.
;; Nested uses of this macro will work correctly. This macro does
;; not prevent concurrent event processing; see with-event-queue.
`(with-buffer (,display
,@(and timeout `(:timeout ,timeout))
,@(and inline `(:inline ,inline)))
,@body))
(defmacro with-event-queue ((display &key timeout inline)
&body body &environment env)
;; exclusive access to event queue
@ -337,8 +369,9 @@ authority data for the local machine's actual hostname - as returned by
gethostname(3) - is used instead."
(destructuring-bind (host display screen protocol)
(get-default-display display-name)
(declare (ignore screen))
(open-display host :display display :protocol protocol)))
(let ((display (open-display host :display display :protocol protocol)))
(setf (display-default-screen display) (nth screen (display-roots display)))
display)))
(defun open-display (host &key (display 0) protocol authorization-name authorization-data)
;; Implementation specific routine to setup the buffer for a
@ -378,6 +411,9 @@ gethostname(3) - is used instead."
(initialize-resource-allocator disp)
(initialize-predefined-atoms disp)
(initialize-extensions disp)
(when (assoc "BIG-REQUESTS" (display-extension-alist disp)
:test #'string=)
(enable-big-requests disp))
(setq ok-p t))
(unless ok-p (close-display disp :abort t)))
disp))

82
src/clx/excldep.lisp
View file

@ -30,7 +30,7 @@
(eval-when (eval compile load)
(let ((x '#(1)))
(if (not (eq 0 (sys::memref x
#.(comp::mdparam 'comp::md-svector-data0-adj)
#.(sys::mdparam 'comp::md-lvector-data0-norm)
0 :unsigned-byte)))
(pushnew :little-endian *features*)
(pushnew :big-endian *features*))))
@ -184,6 +184,10 @@
;; Return t if there is a character available for reading or on error,
;; otherwise return nil.
#-(version>= 6 0)
(progn
#-(or (version>= 4 2) mswindows)
(defun fd-char-avail-p (fd)
(multiple-value-bind (available-p errcode)
(comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
@ -191,6 +195,19 @@
then t
else available-p)))
#+(and (version>= 4 2) (not mswindows))
(defun fd-char-avail-p (fd)
(excl::filesys-character-available-p fd))
#+mswindows
(defun fd-char-avail-p (socket-stream)
(listen socket-stream))
)
#+(version>= 6 0)
(defun fd-char-avail-p (socket-stream)
(excl::read-no-hang-p socket-stream))
(defmacro with-interrupt-checking-on (&body body)
`(locally (declare (optimize (safety 1)))
,@body))
@ -199,54 +216,23 @@
;; Start storing at index 'start-index' and read exactly 'length' bytes.
;; Return t if an error or eof occurred, nil otherwise.
(defun fd-read-bytes (fd vector start-index length)
(declare (fixnum fd start-index length)
(type (simple-array (unsigned-byte 8) (*)) vector))
;; Read from the given stream fd into 'vector', which has element type card8.
;; Start storing at index 'start-index' and read exactly 'length' bytes.
;; Return t if an error or eof occurred, nil otherwise.
(declare (fixnum next-index start-index length))
(with-interrupt-checking-on
(do ((rest length))
((eq 0 rest) nil)
(declare (fixnum rest))
(multiple-value-bind (numread errcode)
(comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector
start-index rest)
(declare (fixnum numread))
(excl:if* errcode
then (if (not (eq errcode
excl::*error-code-interrupted-system-call*))
(return t))
elseif (eq 0 numread)
then (return t)
else (decf rest numread)
(incf start-index numread))))))
(when (plusp (ff:get-entry-points
(make-array 1 :initial-contents
(list (ff:convert-to-lang "fd_wait_for_input")))
(make-array 1 :element-type '(unsigned-byte 32))))
(ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input"))
(load "excldep.o"))
(when (plusp (ff:get-entry-points
(make-array 1 :initial-contents
(list (ff:convert-to-lang "connect_to_server")))
(make-array 1 :element-type '(unsigned-byte 32))))
(ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c))
(load "socket.o"))
(ff:defforeign-list `((connect-to-server
:entry-point
,(ff:convert-to-lang "connect_to_server")
:return-type :fixnum
:arg-checking nil
:arguments (string fixnum))
(fd-wait-for-input
:entry-point ,(ff:convert-to-lang "fd_wait_for_input")
:return-type :fixnum
:arg-checking nil
:call-direct t
:callback nil
:allow-other-keys t
:arguments (fixnum fixnum))))
(let ((end-index (+ start-index length)))
(loop
(let ((next-index (excl:read-vector vector fd
:start start-index
:end end-index)))
(excl:if* (eq next-index start-index)
then ; end of file before was all filled up
(return t)
elseif (eq next-index end-index)
then ; we're all done
(return nil)
else (setq start-index next-index)))))))
;; special patch for CLX (various process fixes)

22
src/clx/input.lisp
View file

@ -106,6 +106,11 @@
(declare (clx-values event-key))
(kintern event)))
(defun extension-event-key-p (key)
(dolist (extension *extensions* nil)
(when (member key (second extension))
(return t))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun allocate-extension-event-code (name)
;; Allocate an event-code for an extension. This is executed at
@ -117,9 +122,7 @@
(declare (type (or null card8) event-code))
(unless event-code
;; First ensure the name is for a declared extension
(unless (dolist (extension *extensions*)
(when (member name (second extension))
(return t)))
(unless (extension-event-key-p name)
(x-type-error name 'event-key))
(setq event-code (position nil *event-key-vector*
:start *first-extension-event-code*))
@ -936,20 +939,20 @@
(declare-event :circulate-notify
(card16 sequence)
(window event-window window parent)
((member16 :top :bottom) place))
((member8 :top :bottom) place))
(declare-event :circulate-request
(card16 sequence)
(window (parent event-window) window)
(pad16 1 2)
((member16 :top :bottom) place))
((member8 :top :bottom) place))
(declare-event :property-notify
(card16 sequence)
(window (window event-window))
(keyword atom) ;; keyword
((or null card32) time)
((member16 :new-value :deleted) state))
((member8 :new-value :deleted) state))
(declare-event :selection-clear
(card16 sequence)
@ -1774,6 +1777,13 @@
(format stream "inconsistent-parameters:~{ ~s~}"
(inconsistent-parameters-parameters condition)))))
(define-condition resource-ids-exhausted (x-error)
()
(:report
(lambda (condition stream)
(declare (ignore condition))
(format stream "All X resource IDs are in use."))))
(defun get-error-key (display error-code)
(declare (type display display)
(type array-index error-code))

25
src/clx/keysyms.lisp
View file

@ -33,6 +33,16 @@
(define-keysym-set :publish (keysym 10 0) (keysym 10 255))
(define-keysym-set :apl (keysym 11 0) (keysym 11 255))
(define-keysym-set :hebrew (keysym 12 0) (keysym 12 255))
(define-keysym-set :thai (keysym 13 0) (keysym 13 255))
(define-keysym-set :korean (keysym 14 0) (keysym 14 255))
(define-keysym-set :latin-5 (keysym 15 0) (keysym 15 255))
(define-keysym-set :latin-6 (keysym 16 0) (keysym 16 255))
(define-keysym-set :latin-7 (keysym 17 0) (keysym 17 255))
(define-keysym-set :latin-8 (keysym 18 0) (keysym 18 255))
(define-keysym-set :latin-9 (keysym 19 0) (keysym 19 255))
(define-keysym-set :currency (keysym 32 0) (keysym 32 255))
(define-keysym-set :|3270| (keysym 253 0) (keysym 253 255))
(define-keysym-set :xkb (keysym 254 0) (keysym 254 255))
(define-keysym-set :keyboard (keysym 255 0) (keysym 255 255))
(define-keysym :character-set-switch character-set-switch-keysym)
@ -156,6 +166,21 @@
(define-keysym #\backspace (keysym 255 008)) ; :tty
)
;;; these keysym definitions are only correct if the underlying lisp's
;;; definition of characters between 160 and 255 match latin1 exactly.
;;; If the characters are in some way locale-dependent (as, I believe,
;;; in Allegro8) or are treated as opaque without any notions of
;;; graphicness or case (as in cmucl and openmcl) then defining these
;;; keysyms is either not useful or wrong. -- CSR, 2006-03-14
#+sbcl
(progn
(do ((i 160 (+ i 1)))
((>= i 256))
(if (or (<= #xc0 i #xd6)
(<= #xd8 i #xde))
(define-keysym (code-char i) i :lowercase (+ i 32))
(define-keysym (code-char i) i))))
#+(or lispm excl)
(progn ;; Nonstandard characters
(define-keysym #\escape (keysym 255 027)) ; :tty

6
src/clx/macros.lisp
View file

@ -16,7 +16,7 @@
;;; express or implied warranty.
;;;
;;; CLX basicly implements a very low overhead remote procedure call
;;; CLX basically implements a very low overhead remote procedure call
;;; to the server. This file contains macros which generate the code
;;; for both the client AND the server, given a specification of the
;;; interface. This was done to eliminate errors that may occur because
@ -334,6 +334,10 @@
((index) (declare (ignore index)) nil)
((index value) (declare (ignore index value)) nil))
(define-accessor pad32 (32)
((index) (declare (ignore index)) nil)
((index value) (declare (ignore index value)) nil))
(define-accessor bit-vector256 (256)
;; used for key-maps
;; REAL-INDEX parameter provided so the default index can be over-ridden.

38
src/clx/manager.lisp
View file

@ -61,7 +61,10 @@
(when value
(let* ((name-len (position 0 (the (vector card8) value)))
(name (subseq (the (vector card8) value) 0 name-len))
(class (subseq (the (vector card8) value) (1+ name-len) (1- (length value)))))
(class
(when name-len
(subseq (the (vector card8) value) (1+ name-len)
(position 0 (the (vector card8) value) :start (1+ name-len))))))
(values (and (plusp (length name)) (map 'string #'card8->char name))
(and (plusp (length class)) (map 'string #'card8->char class)))))))
@ -233,20 +236,23 @@
(def-clx-class (wm-size-hints)
(user-specified-position-p nil :type generalized-boolean) ;; True when user specified x y
(user-specified-size-p nil :type generalized-boolean) ;; True when user specified width height
(x nil :type (or null int16)) ;; Obsolete
(y nil :type (or null int16)) ;; Obsolete
(width nil :type (or null card16)) ;; Obsolete
(height nil :type (or null card16)) ;; Obsolete
(min-width nil :type (or null card16))
(min-height nil :type (or null card16))
(max-width nil :type (or null card16))
(max-height nil :type (or null card16))
(width-inc nil :type (or null card16))
(height-inc nil :type (or null card16))
;; the next four fields are obsolete when using a modern window manager
;; (that will use min-width and friends instead), but they should be set by
;; clients in case an old window manager is used
(x nil :type (or null int32))
(y nil :type (or null int32))
(width nil :type (or null card32))
(height nil :type (or null card32))
(min-width nil :type (or null card32))
(min-height nil :type (or null card32))
(max-width nil :type (or null card32))
(max-height nil :type (or null card32))
(width-inc nil :type (or null card32))
(height-inc nil :type (or null card32))
(min-aspect nil :type (or null number))
(max-aspect nil :type (or null number))
(base-width nil :type (or null card16))
(base-height nil :type (or null card16))
(base-width nil :type (or null card32))
(base-height nil :type (or null card32))
(win-gravity nil :type (or null win-gravity))
(program-specified-position-p nil :type generalized-boolean) ;; True when program specified x y
(program-specified-size-p nil :type generalized-boolean) ;; True when program specified width height
@ -496,15 +502,15 @@
(type (or null wm-size-hints) normal-hints zoom-hints)
(type generalized-boolean user-specified-position-p user-specified-size-p)
(type generalized-boolean program-specified-position-p program-specified-size-p)
(type (or null int16) x y)
(type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
(type (or null int32) x y)
(type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
(type (or null win-gravity) win-gravity)
(type (or null number) min-aspect max-aspect)
(type (or null (member :off :on)) input)
(type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
(type (or null pixmap) icon-pixmap icon-mask)
(type (or null window) icon-window)
(type (or null card16) icon-x icon-y)
(type (or null card32) icon-x icon-y)
(type (or null resource-id) window-group)
(dynamic-extent options))
(when name (setf (wm-name window) name))

241
src/clx/manual/clx.texinfo
View file

@ -1,23 +1,17 @@
\input texinfo @c -*-texinfo-*-
@c $Id$
@c $Id: clx.texinfo,v 1.3 2004/11/18 12:01:48 dan Exp $
@c %**start of header
@setfilename clx.info
@settitle Common LISP X Interface
@setchapternewpage odd
@c %**end of header
@dircategory Lisp Programming
@dircategory lisp
@direntry
* CLX: (clx). Common LISP X Interface
* CLX: (clx). Common LISP X Interface
@end direntry
@titlepage
@title The Common Lisp X Interface (CLX)
@page
@vskip 0pt plus 1filll
@c @copying
@copying
The Common LISP X Interface (CLX)
Copyright @copyright{} 1988, 1989 Texas Instruments Incorporated
@ -32,7 +26,14 @@ described herein for any purpose. It is provided "as is" without
express or implied warranty.
@end quotation
@c @end copying
@end copying
@titlepage
@title The Common Lisp X Interface (CLX)
@page
@vskip 0pt plus 1filll
@insertcopying
@end titlepage
@contents
@ -41,22 +42,7 @@ express or implied warranty.
@node Top, Acknowledgments, (dir), (dir)
@top The Common LISP X Interface (CLX)
@c @copying
The Common LISP X Interface (CLX)
Copyright @copyright{} 1988, 1989 Texas Instruments Incorporated
@quotation
Permission is granted to any individual or institution to use, copy,
modify and distribute this document, provided that this complete
copyright and permission notice is maintained, intact, in all copies
and supporting documentation. Texas Instruments Incorporated makes no
representations about the suitability of this document or the software
described herein for any purpose. It is provided "as is" without
express or implied warranty.
@end quotation
@c @end copying
@insertcopying
@end ifnottex
@menu
@ -254,6 +240,8 @@ Extensions
* Extensions (Extensions)::
* SHAPE - The X11 Nonrectangular Window Shape Extension::
* RENDER - A new rendering system for X11::
* DPMS - The X11 Display Power Management Signaling Extension::
* BIG-REQUESTS - Big Requests Extension::
RENDER - A new rendering system for X11
@ -2121,8 +2109,13 @@ return information about the display. This section discusses how to:
@section Opening the Display
The @var{open-display} function is used to open a connection to an X
server.
The @var{open-display} and @var{open-default-display} functions are
used to open a connection to an X server. @var{open-default-display}
is an extension that is not present in the MIT CLX tree, but is
preferred where available as it uses the same rules for display
defaulting as the C Xlib bindings, and tends to get authorization
right more often than @var{open-display} (particularly on
ssh-forwarded connections)
@defun open-display host &key :display :protocol
@ -2161,6 +2154,49 @@ Type @var{display}.
@end defun
@defun open-default-display &optional display-name
@table @var
@item display-name
The display to connect to. Display names have the format
@verbatim
[protocol/] [hostname] : [:] displaynumber [.screennumber]
@end verbatim
There are two special cases in parsing, to match that done in the Xlib
C language bindings
@itemize @bullet
@item If the hostname is @code{unix} or the empty string, any supplied
protocol is ignored and a connection is made using the @code{local} transport.
@item If a double colon separates @var{hostname} from @var{displaynumber}, the
protocol is assumed to be @code{decnet}.
@end itemize
If @var{display-name} is not supplied, a default will be provided
appropriate for the local environment: on a POSIX system - the only
kind this CLX port runs on - the default display is taken from the
environment variable @env{DISPLAY}. See also the section ``DISPLAY
NAMES'' in X(7)
@end table
Open a connection to @var{display-name} or to the appropriate
default display.
@code{open-display-name} always attempts to do display authorization,
following complicated rules that closely match the ones that the C
Xlib bindings use. Briefly: the hostname is resolved to an address,
then authorization data for the (protocol, host-address,
displaynumber) triple is looked up in the file given by the
environment variable @env{AUTHORITY_PATHNAME} (typically
@file{$HOME/.Xauthority}). If the protocol is @code{:local}, or if
the hostname resolves to the local host, authority data for the local
machine's actual hostname - as returned by gethostname(3) - is used
instead.
@end defun
@node Display Attributes, Managing the Output Buffer, Opening the Display, Displays
@section Display Attributes
@ -15654,9 +15690,11 @@ of zero is a hint that no repetition should occur.
@node Extensions, Errors, Control Functions, Top
@chapter Extensions
@menu
* Extensions (Extensions)::
* SHAPE - The X11 Nonrectangular Window Shape Extension::
* RENDER - A new rendering system for X11::
* Extensions (Extensions)::
* SHAPE - The X11 Nonrectangular Window Shape Extension::
* RENDER - A new rendering system for X11::
* DPMS - The X11 Display Power Management Signaling Extension::
* BIG-REQUESTS - Big Requests Extension::
@end menu
@node Extensions (Extensions), SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions, Extensions
@ -15744,7 +15782,7 @@ Type @var{card8} or @var{null}.
This documentation is yet to be written.
@node RENDER - A new rendering system for X11, , SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions
@node RENDER - A new rendering system for X11, DPMS - The X11 Display Power Management Signaling Extension, SHAPE - The X11 Nonrectangular Window Shape Extension, Extensions
@section RENDER - A new rendering system for X11
@ -16082,8 +16120,143 @@ Requests the sequence of glyphs to be drawn with the glyph-set.
What new errors Xrender defines...
@node Errors, Undocumented, Extensions, Top
@node DPMS - The X11 Display Power Management Signaling Extension, BIG-REQUESTS - Big Requests Extension, RENDER - A new rendering system for X11, Extensions
@section DPMS - The X11 Display Power Management Signaling Extension
@defun dpms-get-version display &optional (major-version 1) (minor-version 1)
@table @var
@item display
@var{display}
@item major-version
@var{card16}
@item minor-version
@var{card16}
@end table
Return two values: the major and minor version of the DPMS
implementation the server supports.
If supplied, the @var{major-version} and @var{minor-version}
indicate what version of the protocol the client wants the server to
implement.
@end defun
@defun dpms-capable display
@table @var
@item display
@var{display}
@end table
True if the currently running server's devices are capable of DPMS
operations.
The truth value of this request is implementation defined, but is
generally based on the capabilities of the graphic card and monitor
combination. Also, the return value in the case of heterogeneous
multi-head servers is implementation defined.
@end defun
@defun dpms-get-timeouts display
@table @var
@item display
@var{display}
@end table
Return three values: the current values of the DPMS timeout values.
The timeout values are (in order returned): standby, suspend and off.
All values are in units of seconds. A value of zero for any timeout
value indicates that the mode is disabled.
@end defun
@defun dpms-set-timeouts display standby suspend off
@table @var
@item display
@var{display}
@item standby
@var{card16}
@item suspend
@var{card16}
@item off
@var{card16}
@end table
Set the values of the DPMS timeouts. All values are in units of
seconds. A value of zero for any timeout value disables that mode.
@end defun
@defun dpms-enable display
@table @var
@item display
@var{display}
@end table
Enable the DPMS characteristics of the server using the server's
currently stored timeouts. If DPMS is already enabled, no change is
affected.
@end defun
@defun dpms-disable display
@table @var
@item display
@var{display}
@end table
Disable the DPMS characteristics of the server. It does not affect
the core or extension screen savers. If DPMS is already disabled, no
change is effected.
This request is provided so that DPMS may be disabled without damaging
the server's stored timeout values.
@end defun
@defun dpms-force-level display power-level
@table @var
@item display
@var{display}
@item power-level
(member :dpms-mode-on :dpms-mode-standby :dpms-mode-suspend :dpms-mode-off)
@end table
Forces a specific DPMS level on the server.
@end defun
@defun dpms-info display
@table @var
@item display
@var{display}
@end table
Returns two values: the DPMS power-level and state value for the
display.
State is one of the keywords DPMS-ENABLED or DPMS-DISABLED.
If state is DPMS-ENABLED, then power-level is returned as one of the
keywords DPMS-MODE-ON, DPMS-MODE-STANDBY, DPMS-MODE-SUSPEND or
DPMS-MODE-OFF. If state is DPMS-DISABLED, then power-level is
undefined and returned as NIL.
@end defun
@node BIG-REQUESTS - Big Requests Extension, , DPMS - The X11 Display Power Management Signaling Extension, Extensions
@section BIG-REQUESTS - Big Requests Extension
@defun display-extended-max-request-length display
@end defun
@defun enable-big-requests display
@end defun
@chapter Errors
@node Errors, Undocumented, Extensions, Top
@menu
* Introduction (Errors)::

12
src/clx/package.lisp
View file

@ -98,7 +98,8 @@
device-event-mask-class discard-current-event discard-font-info display
display-after-function display-authorization-data display-authorization-name
display-bitmap-format display-byte-order display-default-screen
display-display display-error-handler display-finish-output
display-display display-error-handler
display-extended-max-request-length display-finish-output
display-force-output display-host display-image-lsb-first-p
display-invoke-after-function display-keycode-range display-max-keycode
display-max-request-length display-min-keycode display-motion-buffer-size
@ -226,6 +227,10 @@
#+clx-ansi-common-lisp
(common-lisp:in-package :common-lisp-user)
#+ecl
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sockets))
#+clx-ansi-common-lisp
(defpackage xlib
(:use common-lisp)
@ -238,7 +243,7 @@
#+lcl3.0 (:import-from lcl arglist)
#+lispm (:import-from lisp char-bit)
#+lispm (:import-from sys arglist with-stack-list with-stack-list*)
#+sbcl (:use sb-bsd-sockets)
#+(or sbcl ecl) (:use sb-bsd-sockets)
(:export
*version* access-control access-error access-hosts
activate-screen-saver add-access-host add-resource add-to-save-set
@ -268,7 +273,8 @@
device-event-mask-class discard-current-event discard-font-info display
display-after-function display-authorization-data display-authorization-name
display-bitmap-format display-byte-order display-default-screen
display-display display-error-handler display-finish-output
display-display display-error-handler
display-extended-max-request-length display-finish-output
display-force-output display-host display-image-lsb-first-p
display-invoke-after-function display-keycode-range display-max-keycode
display-max-request-length display-min-keycode display-motion-buffer-size

2
src/clx/requests.lisp
View file

@ -1258,7 +1258,7 @@
(card16-get 16)
(card32-get 8)
(member8-get 1 :off :on)
(bit-vector256-get 32))))
(bit-vector256-get 20))))
;; The base volume should
;; be considered to be the "desired" volume in the normal case; that is, a

488
src/clx/xrender.lisp
View file

@ -3,7 +3,7 @@
;;; Title: The X Render Extension
;;; Created: 2002-08-03
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; $Id$
;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $
;;; ---------------------------------------------------------------------------
;;;
;;; (c) copyright 2002, 2003 by Gilbert Baumann
@ -47,6 +47,38 @@
;; - Write tests.
;;;; API issues
;; - On one hand we want convenience functions like RENDER-TRIANGLE or
;; WITH-UNIFORM-COLOR-PICTURE. On the other hand if you are up to
;; write a full rasterization library you obviously want high
;; performance entry points as RENDER-TRIANGLES-1.
;; - We want to extend XLIB:COLOR into something with alpha channel.
;; How to name it?
;; - WITH-UNIFORM-COLOR-PICTURE (var picture r g b &optional alpha) &body body
;;
;; Example:
;; (WITH-UNIFORM-COLOR-PICTURE (color dest 1.0 1.0 0.0)
;; (RENDER-TRIANGLE dest color ...))
;; - Pose the filter and the transform slots of a picture.
;; - Also introduce a PICTURE-DEFAULT-MASK-FORMAT?
;; - COPY-PICTURE?
;; - WITH-PICTURE-OPTIONS ?
;;
;; (WITH-PICTURE-OPTIONS (pic :repeat :on) ...)
;; - WITH-PICTURE ?
;;
;; (WITH-PICTURE (picture drawable ...) ...)
;;
(in-package :xlib)
;; Beginning to collect the external interface for documentation.
@ -101,44 +133,62 @@
render-composite-glyphs
render-add-glyph
render-add-glyph-from-picture
render-free-glyphs
render-combine
))
render-free-glyphs))
(pushnew :clx-ext-render *features*)
(define-extension "RENDER")
(progn
(defconstant +X-RenderQueryVersion+ 0) ;done
(defconstant +X-RenderQueryPictFormats+ 1)
(defconstant +X-RenderQueryPictIndexValues+ 2)
(defconstant +X-RenderQueryDithers+ 3)
(defconstant +X-RenderCreatePicture+ 4) ;done
(defconstant +X-RenderChangePicture+ 5) ;done
(defconstant +X-RenderSetPictureClipRectangles+ 6) ;done
(defconstant +X-RenderFreePicture+ 7) ;done
(defconstant +X-RenderComposite+ 8) ;we need better arglist
(defconstant +X-RenderScale+ 9)
(defconstant +X-RenderTrapezoids+ 10)
(defconstant +X-RenderTriangles+ 11)
(defconstant +X-RenderTriStrip+ 12)
(defconstant +X-RenderTriFan+ 13)
(defconstant +X-RenderColorTrapezoids+ 14)
(defconstant +X-RenderColorTriangles+ 15)
(defconstant +X-RenderTransform+ 16)
(defconstant +X-RenderCreateGlyphSet+ 17) ;done
(defconstant +X-RenderReferenceGlyphSet+ 18) ;done
(defconstant +X-RenderFreeGlyphSet+ 19) ;done
(defconstant +X-RenderAddGlyphs+ 20)
(defconstant +X-RenderAddGlyphsFromPicture+ 21)
(defconstant +X-RenderFreeGlyphs+ 22)
(defconstant +X-RenderCompositeGlyphs8+ 23) ;done
(defconstant +X-RenderCompositeGlyphs16+ 24)
(defconstant +X-RenderCompositeGlyphs32+ 25)
(defconstant +X-RenderFillRectangles+ 26))
;;;; Request constants
;; Note: Although version numbers are given render.h where the request
;; numbers are defined, render-query-version returns 0.0 all displays
;; i tested. --GB 2004-07-21
(defconstant +X-RenderQueryVersion+ 0) ;done
(defconstant +X-RenderQueryPictFormats+ 1)
(defconstant +X-RenderQueryPictIndexValues+ 2) ;0.7
(defconstant +X-RenderQueryDithers+ 3)
(defconstant +X-RenderCreatePicture+ 4) ;done
(defconstant +X-RenderChangePicture+ 5) ;done
(defconstant +X-RenderSetPictureClipRectangles+ 6) ;done
(defconstant +X-RenderFreePicture+ 7) ;done
(defconstant +X-RenderComposite+ 8) ;we need better arglist
(defconstant +X-RenderScale+ 9)
(defconstant +X-RenderTrapezoids+ 10) ;low-level done
(defconstant +X-RenderTriangles+ 11) ;low-level done
(defconstant +X-RenderTriStrip+ 12)
(defconstant +X-RenderTriFan+ 13)
(defconstant +X-RenderColorTrapezoids+ 14) ;nyi in X server, not mentioned in renderproto.h
(defconstant +X-RenderColorTriangles+ 15) ;nyi in X server, not mentioned in renderproto.h
(defconstant +X-RenderTransform+ 16) ;commented out in render.h
(defconstant +X-RenderCreateGlyphSet+ 17) ;done
(defconstant +X-RenderReferenceGlyphSet+ 18) ;done
(defconstant +X-RenderFreeGlyphSet+ 19) ;done
(defconstant +X-RenderAddGlyphs+ 20) ;done, untested
(defconstant +X-RenderAddGlyphsFromPicture+ 21) ;done, untested
(defconstant +X-RenderFreeGlyphs+ 22) ;done, untested
(defconstant +X-RenderCompositeGlyphs8+ 23) ;done
(defconstant +X-RenderCompositeGlyphs16+ 24) ;done
(defconstant +X-RenderCompositeGlyphs32+ 25) ;done
;; >= 0.1
(defconstant +X-RenderFillRectangles+ 26) ;single rectangle version done
;; >= 0.5
(defconstant +X-RenderCreateCursor+ 27)
;; >= 0.6
(defconstant +X-RenderSetPictureTransform+ 28) ;I don't understand what this one should do.
(defconstant +X-RenderQueryFilters+ 29) ;seems to be there on server side
; some guts of its implementation there.
(defconstant +X-RenderSetPictureFilter+ 30)
(defconstant +X-RenderCreateAnimCursor+ 31) ;What has render to do with cursors?
;;;;
;; Sanity measures:
@ -215,8 +265,7 @@ by every function, which attempts to generate RENDER requests."
(defun find-window-picture-format (window)
"Find the picture format which matches the given window."
(let* ((cm (window-colormap window))
(vi (colormap-visual-info cm))
(let* ((vi (window-visual-info window))
(display (window-display window)))
(ensure-render-initialized display)
(case (visual-info-class vi)
@ -224,6 +273,7 @@ by every function, which attempts to generate RENDER requests."
(maphash (lambda (k f)
(declare (ignore k))
(when (and (eql (picture-format-type f) :direct)
(eql (picture-format-depth f) (drawable-depth window))
(eql (dpb -1 (picture-format-red-byte f) 0)
(visual-info-red-mask vi))
(eql (dpb -1 (picture-format-green-byte f) 0)
@ -272,8 +322,10 @@ by every function, which attempts to generate RENDER requests."
(unless (zerop (byte-size (cdr k)))
(format bag " ~A~D" (car k) (byte-size (cdr k)))))))))
(print-unreadable-object (object stream :type t :identity nil)
(format stream "~D ~S~A"
(format stream "~D ~S ~S ~S~A"
(picture-format-id object)
(picture-format-colormap object)
(picture-format-depth object)
(picture-format-type object) abbrev))))
(eval-when (:compile-toplevel :load-toplevel :execute)
@ -284,26 +336,58 @@ by every function, which attempts to generate RENDER requests."
(define-accessor render-op (8)
((index) `(member8-get ,index
:clear :src :dst :over :over-reverse :in :in-reverse
:out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum))
:out :out-reverse :atop :atop-reverse :xor :add :saturate
'#:undefined-pict-op-Eh '#:undefined-pict-op-Fh
:disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
:disjoint-over-reverse :disjoint-in :disjoint-in-reverse
:disjoint-out :disjoint-out-reverse :disjoint-atop
:disjoint-atop-reverse :disjoint-xor
'#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh
'#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh
:conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
:conjoint-over-reverse :conjoint-in :conjoint-in-reverse
:conjoint-out :conjoint-out-reverse :conjoint-atop
:conjoint-atop-reverse :conjoint-xor))
((index thing) `(member8-put ,index ,thing
:clear :src :dst :over :over-reverse :in :in-reverse
:out :out-reverse :atop :atop-reverse :xor :add :saturate :maximum))))
:out :out-reverse :atop :atop-reverse :xor :add :saturate
'#:undefined-pict-op-Eh '#:undefined-pict-op-Fh
:disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
:disjoint-over-reverse :disjoint-in :disjoint-in-reverse
:disjoint-out :disjoint-out-reverse :disjoint-atop
:disjoint-atop-reverse :disjoint-xor
'#:undefined-pict-op-1Ch '#:undefined-pict-op-1Dh
'#:undefined-pict-op-1Eh '#:undefined-pict-op-1Fh
:conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
:conjoint-over-reverse :conjoint-in :conjoint-in-reverse
:conjoint-out :conjoint-out-reverse :conjoint-atop
:conjoint-atop-reverse :conjoint-xor)))
(deftype render-op ()
'(member :clear :src :dst :over :over-reverse :in :in-reverse
:out :out-reverse :atop :atop-reverse :xor :add :saturate
:disjoint-clear :disjoint-src :disjoint-dst :disjoint-over
:disjoint-over-reverse :disjoint-in :disjoint-in-reverse
:disjoint-out :disjoint-out-reverse :disjoint-atop
:disjoint-atop-reverse :disjoint-xor
:conjoint-clear :conjoint-src :conjoint-dst :conjoint-over
:conjoint-over-reverse :conjoint-in :conjoint-in-reverse
:conjoint-out :conjoint-out-reverse :conjoint-atop
:conjoint-atop-reverse :conjoint-xor)))
;; Now these pictures objects are like graphics contexts. I was about
;; to introduce a synchronous mode, realizing that the RENDER protocol
;; provides no provision to actually query a picture object's values.
;; *sigh*
(def-clx-class (picture (:copier nil)
)
(def-clx-class (picture (:copier nil))
(id 0 :type resource-id)
(display nil :type (or null display))
(plist nil :type list) ; Extension hook
format
%changed-p
%server-values
%values
%drawable)
(format)
(%changed-p)
(%server-values)
(%values)
(%drawable))
(defun picture-drawable (picture)
(picture-%drawable picture))
@ -361,9 +445,9 @@ by every function, which attempts to generate RENDER requests."
,index))
(%render-change-picture-clip-rectangles
picture (aref (picture-%values picture) ,index))
(setf (aref (picture-%values picture) ,index)
(aref (picture-%server-values picture)
,index))))
(setf (aref (picture-%server-values picture) ,index)
(aref (picture-%values picture) ,index))))
(setf (picture-%changed-p picture) nil)))
(defun render-create-picture
@ -446,17 +530,18 @@ by every function, which attempts to generate RENDER requests."
(card32 0)
(card32 1))
(values
(card16-get 8)
(card16-get 10)
)))
(card32-get 8)
(card32-get 12) )))
(defun render-query-picture-formats (display)
(with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
((data +X-RenderQueryPictFormats+))
(let ((n-picture-formats (card32-get 8))
(n-screens (card32-get 12))
(off 32))
(declare (ignore n-screens off))
(n-depths (card32-get 16))
(n-visuals (card32-get 20))
(n-subpixel (card32-get 24)))
(declare (ignore n-screens n-depths n-visuals n-subpixel))
(loop for i below n-picture-formats
collect
(let ((off (+ (* 8 4)
@ -493,6 +578,152 @@ by every function, which attempts to generate RENDER requests."
;; fill rectangles, colors.
(defun render-triangles-1 (picture op source src-x src-y format coord-sequence)
;; For performance reasons we do a special typecase on (simple-array
;; (unsigned-byte 32) (*)), so that it'll be possible to have high
;; performance rasters.
(macrolet ((guts ()
'(let ((display (picture-display picture)))
(synchronise-picture-state picture)
(synchronise-picture-state source)
(with-buffer-request (display (extension-opcode display "RENDER"))
(data +X-RenderTriangles+)
(render-op op) ;op
(card8 0) ;pad
(card16 0) ;pad
(resource-id (picture-id source))
(resource-id (picture-id picture))
(picture-format format)
(int16 src-x)
(int16 src-y)
((sequence :format int32) coord-sequence) ))))
(typecase coord-sequence
((simple-array (unsigned-byte 32) (*))
(locally
(declare (type (simple-array (unsigned-byte 32) (*)) coord-sequence))
(guts)))
(t
(guts)))))
#||
(defun render-set-picture-transform (picture mxx mxy dx mxy myy dy &optional (mwx 0) (mwy 0) (dw 1))
...)
||#
(defun render-set-picture-transform (picture a b c d e f p q r)
(let ((display (picture-display picture)))
(ensure-render-initialized display)
(synchronise-picture-state picture)
(with-buffer-request (display (extension-opcode display "RENDER"))
(data +X-RenderSetPictureTransform+)
#|
(card8 0) ;; render-op op) ;op
(card8 0) ;pad
(card16 0) ;pad
|#
(resource-id (picture-id picture))
(card32 a)
(card32 b)
(card32 c)
(card32 d)
(card32 e)
(card32 f)
(card32 p)
(card32 q)
(card32 r))))
(defun render-query-filters (drawable)
(let ((display (drawable-display drawable)))
(with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil)
((data +X-RenderQueryFilters+)
(drawable drawable))
(let* ((len (card32-get 4))
(n-aliases (card32-get 8))
(n-filters (card32-get 12))
(off (+ (* 8 4) (* 4 (ceiling (* 2 n-aliases) 4)))))
(print (list :aliases
(loop for i below n-aliases collect (card16-get (+ (* 8 4) (* i 2))))))
(print (list :foo len n-aliases n-filters
(loop for i below len
collect (card8-get (+ off 0 (* 4 i)))
collect (card8-get (+ off 1 (* 4 i)))
collect (card8-get (+ off 2 (* 4 i)))
collect (card8-get (+ off 3 (* 4 i))))))
(print
(labels ((grab-string (j)
(let ((n (card8-get j)))
(incf j)
(values
(map 'string #'code-char (loop repeat n collect (card8-get j) do (incf j)))
j))))
(loop repeat n-filters collect
(multiple-value-bind (s j) (grab-string off)
(setf off j)
(intern (string-upcase s) :keyword)))))
#+NIL
(loop for i below n-picture-formats
collect
(let ((off (+ (* 8 4)
(* i 28)))) ;size of picture-format-info
(make-picture-format
:display display
:id (card32-get (+ off 0))
:type (member8-get (+ off 4) :indexed :direct)
:depth (card8-get (+ off 5))
:red-byte (byte (integer-length (card16-get (+ off 10)))
(card16-get (+ off 8)))
:green-byte (byte (integer-length (card16-get (+ off 14)))
(card16-get (+ off 12)))
:blue-byte (byte (integer-length (card16-get (+ off 18)))
(card16-get (+ off 16)))
:alpha-byte (byte (integer-length (card16-get (+ off 22)))
(card16-get (+ off 20)))
:colormap (let ((cmid (card32-get (+ off 24))))
(unless (zerop cmid)
(lookup-colormap display cmid))))))))))
(defun render-set-filter (picture filter)
(let ((display (picture-display picture)))
(ensure-render-initialized display)
(synchronise-picture-state picture)
(with-buffer-request (display (extension-opcode display "RENDER"))
(data +X-RenderSetPictureFilter+)
(resource-id (picture-id picture))
(card16 (length filter))
(card16 0) ;pad
((sequence :format card8) (map 'vector #'char-code filter)))))
#||
(defun render-triangle (destination source x1 y1 x2 y2 x3 y3 &key (src-x 0) (src-y 0) (format nil) (op :over))
(render-triangles-1 destination op source ...)
)
||#
(defun render-trapezoids-1 (picture op source src-x src-y format coord-sequence)
;; coord-sequence is top bottom
;; line-1-x1 line-1-y1 line-1-x2 line-1-y2
;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ...
;;
(let ((display (picture-display picture)))
(synchronise-picture-state picture)
(synchronise-picture-state source)
(with-buffer-request (display (extension-opcode display "RENDER"))
(data +X-RenderTrapezoids+)
(render-op op) ;op
(card8 0) ;pad
(card16 0) ;pad
(resource-id (picture-id source))
(resource-id (picture-id picture))
(picture-format format)
(int16 src-x)
(int16 src-y)
((sequence :format int32) coord-sequence) )))
(defun render-composite (op
source mask dest
src-x src-y mask-x mask-y dst-x dst-y
@ -509,12 +740,12 @@ by every function, which attempts to generate RENDER requests."
(resource-id (picture-id source))
(resource-id (if mask (picture-id mask) 0))
(resource-id (picture-id dest))
(card16 src-x)
(card16 src-y)
(card16 mask-x)
(card16 mask-y)
(card16 dst-x)
(card16 dst-y)
(int16 src-x)
(int16 src-y)
(int16 mask-x)
(int16 mask-y)
(int16 dst-x)
(int16 dst-y)
(card16 width)
(card16 height))))
@ -523,7 +754,7 @@ by every function, which attempts to generate RENDER requests."
(id 0 :type resource-id)
(display nil :type (or null display))
(plist nil :type list) ; Extension hook
format)
(format))
(defun render-create-glyph-set (format &key glyph-set)
(let ((display (picture-format-display format)))
@ -579,25 +810,63 @@ by every function, which attempts to generate RENDER requests."
(int16 src-x) (int16 src-y)
(card8 (- end start)) ;length of glyph elt
(card8 0) (card16 0) ;padding
(card16 dest-x) (card16 dest-y) ;dx, dy
(int16 dest-x) (int16 dest-y) ;dx, dy
((sequence :format card8) sequence))))
(defmacro %render-composite-glyphs
(opcode type transform
display dest glyph-set source dest-x dest-y sequence alu src-x src-y mask-format start end)
`(with-buffer-request (,display (extension-opcode ,display "RENDER"))
(data ,opcode)
(render-op ,alu)
(card8 0) (card16 0) ;padding
(picture ,source)
(picture ,dest)
((or (member :none) picture-format) ,mask-format)
(glyph-set ,glyph-set)
(int16 ,src-x) (int16 ,src-y)
(card8 (- ,end ,start)) ;length of glyph elt
(card8 0) (card16 0) ;padding? really?
(card16 ,dest-x) (card16 ,dest-y) ;dx, dy
((sequence :format ,type :start ,start :end ,end :transform ,transform) ,sequence)))
(opcode type transform display dest glyph-set source dest-x dest-y sequence
alu src-x src-y mask-format start end)
(let ((size (ecase type (card8 1) (card16 2) (card32 4)))
;; FIXME: the last chunk for CARD8 can be 254.
(chunksize (ecase type (card8 252) (card16 254) (card32 254))))
`(multiple-value-bind (nchunks leftover)
(floor (- end start) ,chunksize)
(let* ((payloadsize (+ (* nchunks (+ 8 (* ,chunksize ,size)))
(if (> leftover 0)
(+ 8 (* 4 (ceiling (* leftover ,size) 4)))
0)))
(request-length (+ 7 (/ payloadsize 4))))
(declare (integer request-length))
(with-buffer-request (,display (extension-opcode ,display "RENDER") :length (* 4 request-length))
(data ,opcode)
(length request-length)
(render-op ,alu)
(card8 0) (card16 0) ;padding
(picture ,source)
(picture ,dest)
((or (member :none) picture-format) ,mask-format)
(glyph-set ,glyph-set)
(int16 ,src-x) (int16 ,src-y)
(progn
(let ((boffset (+ buffer-boffset 28))
(start ,start)
(end ,end)
(dest-x ,dest-x)
(dest-y ,dest-y))
(dotimes (i nchunks)
(set-buffer-offset boffset)
(put-items (0)
(card8 ,chunksize)
(card8 0)
(card16 0)
(int16 dest-x)
(int16 dest-y)
((sequence :start start :end (+ start ,chunksize) :format ,type :transform ,transform :appending t) ,sequence))
(setq dest-x 0 dest-y 0)
(incf boffset (+ 8 (* ,chunksize ,size)))
(incf start ,chunksize))
(when (> leftover 0)
(set-buffer-offset boffset)
(put-items (0)
(card8 leftover)
(card8 0)
(card16 0)
(int16 dest-x)
(int16 dest-y)
((sequence :start start :end end :format ,type :transform ,transform :appending t) ,sequence))
;; padding?
(incf boffset (+ 8 (* 4 (ceiling (* leftover ,size) 4)))))
(setf (buffer-boffset ,display) boffset))))))))
(defun render-composite-glyphs (dest glyph-set source dest-x dest-y sequence
&key (op :over)
@ -795,17 +1064,17 @@ by every function, which attempts to generate RENDER requests."
(render-fill-rectangle px.pic :src
(list #x8000 #x0000 #x8000 #xFFFF)
0 0 256 256)
;; render-combine simply does not work
(render-combine :src pic pic px.pic
350 350 350 350 0 0 256 256)
(render-composite :src pic pic px.pic
350 350 350 350 0 0 256 256)
;;
(render-fill-rectangle px.pic :over
(list #x8000 #x8000 #x8000 #x8000)
0 0 100 100)
(render-combine :src
px.pic px.pic pic
0 0 0 0 350 350
256 256)
(render-composite :src
px.pic px.pic pic
0 0 0 0 350 350
256 256)
(render-fill-rectangle pic op (list #x0 #x0 #x0 #x8000) 200 200 800 800)
(display-finish-output dpy))
(close-display dpy))))
@ -834,23 +1103,22 @@ by every function, which attempts to generate RENDER requests."
(xlib:draw-point px px.gc x y)
))
(xlib:clear-area win)
(let ((q(render-create-picture px
:format
(first (find-matching-picture-formats
dpy
:depth 32
:alpha 8 :red 8 :green 8 :blue 8))
:component-alpha :on
:repeat :off
)))
(render-combine op
q
q
pic
0 0
0 0
100 100
400 400))
(let ((q (render-create-picture px
:format
(first (find-matching-picture-formats
dpy
:depth 32
:alpha 8 :red 8 :green 8 :blue 8))
:component-alpha :on
:repeat :off)))
(render-composite op
q
q
pic
0 0
0 0
100 100
400 400))
(let ()
;;(render-fill-rectangle pic op (list 255 255 255 255) 100 100 200 200)
(display-finish-output dpy)))
@ -866,3 +1134,21 @@ by every function, which attempts to generate RENDER requests."
(display-finish-output dpy)
(close-display dpy)))
||#
;;;; Cursors
(defun render-create-cursor (picture &optional (x 0) (y 0))
(let ((display (picture-display picture)))
(ensure-render-initialized display)
(synchronise-picture-state picture)
(let* ((cursor (make-cursor :display display))
(cid (allocate-resource-id display cursor 'cursor)))
(setf (cursor-id cursor) cid)
(with-buffer-request (display (extension-opcode display "RENDER"))
(data +X-RenderCreateCursor+)
(resource-id cid)
(resource-id (picture-id picture))
(card16 x)
(card16 y))
cursor)))

2
src/clx/xvidmode.lisp
View file

@ -436,7 +436,7 @@ invalid."
(defun xfree86-vidmode-set-gamma (dpy scr &key (red 1.0) (green 1.0) (blue 1.0))
(declare (type display dpy)
(type screen scr)
(type (single-float 0.100 10.000) red green blue))
(type (single-float 0.100f0 10.000f0) red green blue))
(with-buffer-request (dpy (vidmode-opcode dpy))
(data +set-gamma+)
(card16 (screen-position scr dpy))