From 79c30b8d546e6a2b1189b65e1797c6402f2e1e1b Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Fri, 5 Dec 2008 15:17:53 +0100 Subject: [PATCH] Upgraded CLX to the last version of portable CLX --- src/clx/CHANGES | 8 +- src/clx/NEWS | 59 ++- src/clx/README | 12 +- src/clx/attributes.lisp | 21 +- src/clx/buffer.lisp | 826 ++++++++++-------------------------- src/clx/clx.asd | 34 +- src/clx/clx.lisp | 60 +-- src/clx/cmudep.lisp | 2 +- src/clx/demo/clx-demos.lisp | 4 +- src/clx/depdefs.lisp | 28 +- src/clx/dependent.lisp | 236 +++++++---- src/clx/display.lisp | 162 ++++--- src/clx/excldep.lisp | 82 ++-- src/clx/input.lisp | 22 +- src/clx/keysyms.lisp | 25 ++ src/clx/macros.lisp | 6 +- src/clx/manager.lisp | 38 +- src/clx/manual/clx.texinfo | 241 +++++++++-- src/clx/package.lisp | 12 +- src/clx/requests.lisp | 2 +- src/clx/xrender.lisp | 488 ++++++++++++++++----- src/clx/xvidmode.lisp | 2 +- 22 files changed, 1351 insertions(+), 1019 deletions(-) diff --git a/src/clx/CHANGES b/src/clx/CHANGES index 0014c3b3b..f87ce9418 100644 --- a/src/clx/CHANGES +++ b/src/clx/CHANGES @@ -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: diff --git a/src/clx/NEWS b/src/clx/NEWS index 3d142a2fe..73b1ef003 100644 --- a/src/clx/NEWS +++ b/src/clx/NEWS @@ -1,15 +1,68 @@ -*- Text -*- +-- Changes in telent CLX 0.7.3, Tue Mar 28 2006 --- ---- Changes in SBCL CLX 0.5.5, --- +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 --- diff --git a/src/clx/README b/src/clx/README index f23197ebb..7e7dbc0ab 100644 --- a/src/clx/README +++ b/src/clx/README @@ -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 ASDFized version and ongoing by Daniel Barlow -and Christophe Rhodes +and (mostly, these days) Christophe Rhodes diff --git a/src/clx/attributes.lisp b/src/clx/attributes.lisp index 2de4693b5..edb42e40b 100644 --- a/src/clx/attributes.lisp +++ b/src/clx/attributes.lisp @@ -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 diff --git a/src/clx/buffer.lisp b/src/clx/buffer.lisp index 5cfa58623..c48897399 100644 --- a/src/clx/buffer.lisp +++ b/src/clx/buffer.lisp @@ -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)) diff --git a/src/clx/clx.asd b/src/clx/clx.asd index 6c13f472e..e83e6119c 100644 --- a/src/clx/clx.asd +++ b/src/clx/clx.asd @@ -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)))) diff --git a/src/clx/clx.lisp b/src/clx/clx.lisp index f1dbd1163..ce81f6de5 100644 --- a/src/clx/clx.lisp +++ b/src/clx/clx.lisp @@ -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))) diff --git a/src/clx/cmudep.lisp b/src/clx/cmudep.lisp index 993a4ef66..8624a3ee3 100644 --- a/src/clx/cmudep.lisp +++ b/src/clx/cmudep.lisp @@ -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 $") ;;; ;;; ********************************************************************** ;;; diff --git a/src/clx/demo/clx-demos.lisp b/src/clx/demo/clx-demos.lisp index 0fb76068a..06c4fa36d 100644 --- a/src/clx/demo/clx-demos.lisp +++ b/src/clx/demo/clx-demos.lisp @@ -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))) diff --git a/src/clx/depdefs.lisp b/src/clx/depdefs.lisp index 5e4891746..14d97754d 100644 --- a/src/clx/depdefs.lisp +++ b/src/clx/depdefs.lisp @@ -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))) diff --git a/src/clx/dependent.lisp b/src/clx/dependent.lisp index 4b542f16a..55c8bc51a 100644 --- a/src/clx/dependent.lisp +++ b/src/clx/dependent.lisp @@ -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 diff --git a/src/clx/display.lisp b/src/clx/display.lisp index 59d6351af..ae556939d 100644 --- a/src/clx/display.lisp +++ b/src/clx/display.lisp @@ -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)) diff --git a/src/clx/excldep.lisp b/src/clx/excldep.lisp index e6e59d2da..940a70f7c 100644 --- a/src/clx/excldep.lisp +++ b/src/clx/excldep.lisp @@ -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) diff --git a/src/clx/input.lisp b/src/clx/input.lisp index 2fe92b20c..3719c5b0f 100644 --- a/src/clx/input.lisp +++ b/src/clx/input.lisp @@ -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)) diff --git a/src/clx/keysyms.lisp b/src/clx/keysyms.lisp index 4e89f95f4..92fc5ec48 100644 --- a/src/clx/keysyms.lisp +++ b/src/clx/keysyms.lisp @@ -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 diff --git a/src/clx/macros.lisp b/src/clx/macros.lisp index 325ed6bfe..24e1c405a 100644 --- a/src/clx/macros.lisp +++ b/src/clx/macros.lisp @@ -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. diff --git a/src/clx/manager.lisp b/src/clx/manager.lisp index 7d34f0fa3..57aa7b1c1 100644 --- a/src/clx/manager.lisp +++ b/src/clx/manager.lisp @@ -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)) diff --git a/src/clx/manual/clx.texinfo b/src/clx/manual/clx.texinfo index cdd37ddd5..a0b52e7cd 100644 --- a/src/clx/manual/clx.texinfo +++ b/src/clx/manual/clx.texinfo @@ -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):: diff --git a/src/clx/package.lisp b/src/clx/package.lisp index e415bd85d..be7242254 100644 --- a/src/clx/package.lisp +++ b/src/clx/package.lisp @@ -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 diff --git a/src/clx/requests.lisp b/src/clx/requests.lisp index 1602b2d00..745414cd9 100644 --- a/src/clx/requests.lisp +++ b/src/clx/requests.lisp @@ -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 diff --git a/src/clx/xrender.lisp b/src/clx/xrender.lisp index 27d1f2abb..9f6f94e2e 100644 --- a/src/clx/xrender.lisp +++ b/src/clx/xrender.lisp @@ -3,7 +3,7 @@ ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann -;;; $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))) diff --git a/src/clx/xvidmode.lisp b/src/clx/xvidmode.lisp index 602bf5d91..827cd4af0 100644 --- a/src/clx/xvidmode.lisp +++ b/src/clx/xvidmode.lisp @@ -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))