From 5b8bf8182302da984e17fc61dd87d738a50013bc Mon Sep 17 00:00:00 2001 From: Steven Allen Date: Sat, 13 Jan 2024 19:53:54 -0800 Subject: [PATCH 1/6] Implement float & double types The GLX extension needs these types but the issue was hidden by the (now fixed) lax type resolution rules. * xcb-types.el (xcb:-f32, xcb:-f64): Added new types for float32 and float64. (xcb:float, xcb:double): Alias these types to their C type names. (xcb:-f-to-binary, xcb:-binary-to-f): IEEE 754 encoder/decoder. (xcb:-f32-to-binary32, xcb:-binary32-to-f32): 32bit float encoders/decoders. (xcb:-f64-to-binary64, xcb:-binary64-to-f64): 64bit float encoders/decoders. (xcb:-marshal-field, xcb:-unmarshal-field): Support marshaling and unmarshaling to/from floats and doubles. --- xcb-types.el | 80 +++++++++++++++++++++++++++++++++++++++++++ xelb-test.el | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 176 insertions(+) create mode 100644 xelb-test.el diff --git a/xcb-types.el b/xcb-types.el index 5538838..42e6913 100644 --- a/xcb-types.el +++ b/xcb-types.el @@ -346,6 +346,65 @@ FORMAT-STRING is a string specifying the message to output, as in value (- value 4294967296.)))) ;treated as float for 32-bit +(defsubst xcb:-f64-to-binary64 (value) + "Encode a 64-bit float VALUE as a binary64 (IEEE 754)." + (let* ((sigexp (frexp value)) + (exp (+ (cdr sigexp) 1022)) + (frac (abs (car sigexp))) + (isneg (< (copysign 1.0 (car sigexp)) 0)) ; use `copysign' to detect -0.0 + (signmask (if isneg #x8000000000000000 0))) + (+ (cond ((zerop frac) 0) ; 0 + ((isnan frac) #xff0000000000001) ; NaN + ((or (>= exp 2047) (= frac 1e+INF)) #x7ff0000000000000) ; Inf + ((<= exp 0) (ash (round (ldexp frac 52)) exp)) ; Subnormal + (t (+ (ash exp 52) (logand #xfffffffffffff + (round (ldexp frac 53)))))) ; Normal + signmask))) + +(defsubst xcb:-f32-to-binary32 (value) + "Encode a 32-bit float VALUE as a binary32 (IEEE 754)." + (let* ((sigexp (frexp value)) + (exp (+ (cdr sigexp) 126)) + (frac (abs (car sigexp))) + (isneg (< (copysign 1.0 (car sigexp)) 0)) ; use `copysign' to detect -0.0 + (signmask (if isneg #x80000000 0))) + (+ (cond ((zerop frac) 0) ; 0 + ((isnan frac) #x7f800001) ; NaN + ((or (>= exp 255) (= frac 1e+INF)) #x7f800000) ; Inf + ((<= exp 0) (ash (round (ldexp frac 23)) exp)) ; Subnormal + (t (+ (ash exp 23) (logand #x7fffff (round (ldexp frac 24)))))) ; Normal + signmask))) + +(defsubst xcb:-binary64-to-f64 (value) + "Decode binary64 VALUE into a float." + (let ((sign (pcase (ash value -63) + (0 +0.0) + (1 -0.0) + (_ (error "[XCB] Value too large for a float64: %d" value)))) + (exp (logand 2047 (ash value -52))) + (frac (logand #xfffffffffffff value))) + (copysign ; Use copysign, not multiplication, to deal with +/- NAN. + (pcase exp + (2047 (if (zerop frac) 1e+INF 1e+NaN)) ; INF/NAN + (0 (ldexp frac -1074)) ; Subnormal + (_ (ldexp (+ #x10000000000000 frac) (- exp 1075)))) ; Normal + sign))) + +(defsubst xcb:-binary32-to-f32 (value) + "Decode binary32 VALUE into a float." + (let ((sign (pcase (ash value -31) + (0 +0.0) + (1 -0.0) + (_ (error "[XCB] Value too large for a float32: %d" value)))) + (exp (logand 255 (ash value -23))) + (frac (logand #x7fffff value))) + (copysign ; Use copysign, not multiplication, to deal with +/- NAN. + (pcase exp + (255 (if (zerop frac) 1e+INF 1e+NaN)) ; INF/NAN + (0 (ldexp frac -149)) ; Subnormal + (_ (ldexp (+ #x800000 frac) (- exp 150)))) ; Normal + sign))) + (defmacro xcb:-fieldref (field) "Evaluate a field." `(slot-value obj ,field)) @@ -389,6 +448,9 @@ variable property (for internal use only)." (cl-deftype xcb:-u4 () t) ;; 8 B unsigned integer (cl-deftype xcb:-u8 () t) +;; floats & doubles +(cl-deftype xcb:-f32 () t) +(cl-deftype xcb:-f64 () t) ;; (cl-deftype xcb:-pad () t) ;; with align attribute @@ -413,6 +475,8 @@ variable property (for internal use only)." (xcb:deftypealias 'xcb:CARD32 'xcb:-u4) (xcb:deftypealias 'xcb:CARD64 'xcb:-u8) (xcb:deftypealias 'xcb:BOOL 'xcb:-u1) +(xcb:deftypealias 'xcb:float 'xcb:-f32) +(xcb:deftypealias 'xcb:double 'xcb:-f64) ;;;; Struct type @@ -475,6 +539,12 @@ The optional POS argument indicates current byte index of the field (used by (if (slot-value obj '~lsb) (xcb:-pack-i4-lsb value) (xcb:-pack-i4 value))) (`xcb:-u8 (if (slot-value obj '~lsb) (xcb:-pack-u8-lsb value) (xcb:-pack-u8 value))) + (`xcb:-f32 + (let ((value (xcb:-f32-to-binary32 value))) + (if (slot-value obj '~lsb) (xcb:-pack-u4-lsb value) (xcb:-pack-u4 value)))) + (`xcb:-f64 + (let ((value (xcb:-f64-to-binary64 value))) + (if (slot-value obj '~lsb) (xcb:-pack-u8-lsb value) (xcb:-pack-u8 value)))) (`xcb:void (vector value)) (`xcb:-pad (unless (integerp value) @@ -604,6 +674,16 @@ and the second the consumed length." (xcb:-unpack-u8-lsb data offset) (xcb:-unpack-u8 data offset)) 8)) + (`xcb:-f32 (list (xcb:-binary32-to-f32 + (if (slot-value obj '~lsb) + (xcb:-unpack-u4-lsb data offset) + (xcb:-unpack-u4 data offset))) + 4)) + (`xcb:-f64 (list (xcb:-binary64-to-f64 + (if (slot-value obj '~lsb) + (xcb:-unpack-u8-lsb data offset) + (xcb:-unpack-u8 data offset))) + 8)) (`xcb:void (list (aref data offset) 1)) (`xcb:-pad (unless (integerp initform) diff --git a/xelb-test.el b/xelb-test.el new file mode 100644 index 0000000..ed7e6f8 --- /dev/null +++ b/xelb-test.el @@ -0,0 +1,96 @@ +;;; xelb-test.el --- Unit tests for XELB -*- lexical-binding: t -*- +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Steven Allen + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This module contains unit tests for testing XELB. + +;;; Code: + +(require 'ert) +(require 'xcb-types) + +;; https://en.wikipedia.org/wiki/Single-precision_floating-point_format#Notable_single-precision_cases +(defconst xelb-test-binary32-cases + '((#x00000001 . 1.401298464324817e-45) + (#x007fffff . 1.1754942106924411e-38) + (#x00800000 . 1.1754943508222875e-38) + (#x7f7fffff . 3.4028234663852886e38) + (#x3f7fffff . 0.999999940395355225) + (#x3f800000 . 1.0) + (#x3f800001 . 1.00000011920928955) + (#xc0000000 . -2.0) + (#x00000000 . 0.0) + (#x80000000 . -0.0) + (#x7f800000 . 1e+INF) + (#xff800000 . -1e+INF) + (#x40490fdb . 3.14159274101257324) + (#x3eaaaaab . 0.333333343267440796))) + +;; https://en.wikipedia.org/wiki/Double-precision_floating-point_format#Double-precision_examples +(defconst xelb-test-binary64-cases + `((#x3ff0000000000000 . 1.0) + (#x3ff0000000000001 . 1.0000000000000002) + (#x3ff0000000000002 . 1.0000000000000004) + (#x4000000000000000 . 2.0) + (#xc000000000000000 . -2.0) + (#x4008000000000000 . 3.0) + (#x4010000000000000 . 4.0) + (#x4014000000000000 . 5.0) + (#x4018000000000000 . 6.0) + (#x4037000000000000 . 23.0) + (#x3f88000000000000 . 0.01171875) + (#x0000000000000001 . 4.9406564584124654e-324) + (#x000fffffffffffff . 2.2250738585072009e-308) + (#x0010000000000000 . 2.2250738585072014e-308) + (#x7fefffffffffffff . 1.7976931348623157e308) + (#x0000000000000000 . +0.0) + (#x8000000000000000 . -0.0) + (#x7ff0000000000000 . +1e+INF) + (#xfff0000000000000 . -1e+INF) + (#x3fd5555555555555 . ,(/ 1.0 3.0)) + (#x400921fb54442d18 . ,float-pi))) + +(defun xelb-test--test-conversion (a-to-b b-to-a cases) + "Test the bidirectional conversion functions A-TO-B and B-TO-A against CASES. +CASES is an alist of (A . B) pairs." + (pcase-dolist (`(,a . ,b) cases) + (let* ((act-a (funcall b-to-a b)) + (act-b (funcall a-to-b a)) + (round-trip-a (funcall b-to-a act-b)) + (round-trip-b (funcall a-to-b act-a))) + (should (= b act-b round-trip-b)) + (should (= a act-a round-trip-a))))) + +(ert-deftest xelb-test-binary32 () + (xelb-test--test-conversion + #'xcb:-binary32-to-f32 + #'xcb:-f32-to-binary32 + xelb-test-binary32-cases)) + +(ert-deftest xelb-test-binary64 () + (xelb-test--test-conversion + #'xcb:-binary64-to-f64 + #'xcb:-f64-to-binary64 + xelb-test-binary64-cases)) + +(provide 'xelb-test) + +;;; xelb-test.el ends here From 9d8ef737504804ab3d5ee9d2995eab53096f4914 Mon Sep 17 00:00:00 2001 From: Steven Allen Date: Sat, 13 Jan 2024 20:00:27 -0800 Subject: [PATCH 2/6] Improve type-name resolution This patch: 1. Consistently treats names starting with "xproto:" as explicitly referring to "core-protocol" types. This fixes a bug where the screensaver X spec wasn't getting parsed correctly because the `enumref` "xproto:CW" failed to resolve. 2. Always tries to resolve types relative to the current file's imports. 3. Never assumes a type exists (never calls `intern`, always `intern-soft`). This caught the bug fixed in the prior commit where `xcb:float` and `xcb:double` weren't defined. * el_client.el (xelb-xproto-namespace): The default XCB namespace. (xelb-resolve-name): The new function to resolve type names to type symbols. (xelb-node-type): Factored out `xelb-resolve-name'. (xelb-parse-typedef, xelb-parse-eventcopy) (xelb-parse-errorcopy, xelb-parse-enumref): Use `xelb-resolve-name'. --- xelb-gen | 61 +++++++++++++++++++++++--------------------------------- 1 file changed, 25 insertions(+), 36 deletions(-) diff --git a/xelb-gen b/xelb-gen index 6a4779a..9d3c634 100755 --- a/xelb-gen +++ b/xelb-gen @@ -64,6 +64,8 @@ (defvar xelb-request-fields nil "Fields in the current request.") +(defconst xelb-xproto-namespace "xproto:" "The namespace of the core protocol.") + ;;;; Helper functions (defsubst xelb-node-name (node) @@ -74,32 +76,27 @@ "Return the attribute ATTR of node NODE." (cdr (assoc attr (cadr node)))) +(defsubst xelb-resolve-type (name) + "Resolve NAME relative to the current module." + (if (string-prefix-p xelb-xproto-namespace name) + ;; Defined explicitly. + (or (intern-soft (concat "xcb:" (substring name (length xelb-xproto-namespace)))) + (error "Undefined type: %s" name)) + (or + ;; defined by this extension + (intern-soft (concat xelb-prefix name)) + ;; defined by the core protocol + (intern-soft (concat "xcb:" name)) + ;; Defined by an imported extension. + (cl-dolist (i xelb-imports) + (when-let ((type (intern-soft (concat i name)))) + (cl-return type))) + ;; Not defined. + (error "Undefined type: %s" name)))) + (defsubst xelb-node-type (node) "Return the type of node NODE." - (let ((type-name (xelb-node-attr node 'type)) - type) - (if (string-match ":" type-name) - ;; Defined explicitly. - (if (setq type - (intern-soft (concat "xcb:" - (replace-regexp-in-string "^xproto:" "" - type-name)))) - type - (error "Undefined type: %s" type-name)) - (if (setq type (or (intern-soft (concat xelb-prefix type-name)) - (intern-soft (concat "xcb:" type-name)))) - ;; Defined by the core protocol or this extension. - type - (catch 'break - (dolist (i xelb-imports) - (setq type (intern-soft (concat i type-name))) - (when type - (throw 'break type)))) - (if type - ;; Defined by an imported extension. - type - ;; Not defined. - (error "Undefined type: %s" type-name)))))) + (xelb-resolve-type (xelb-node-attr node 'type))) (defsubst xelb-escape-name (name) "Replace underscores in NAME with dashes." @@ -362,9 +359,7 @@ an `xelb-auto-padding' attribute." (defun xelb-parse-typedef (node) "Parse ." (let* ((oldname (xelb-node-attr node 'oldname)) - (oldname (or (intern-soft (concat xelb-prefix oldname)) - (intern-soft (concat "xcb:" oldname)) - (intern (concat xelb-prefix oldname)))) + (oldname (xelb-resolve-type oldname)) (newname (intern (concat xelb-prefix (xelb-node-attr node 'newname))))) `((xcb:deftypealias ',newname ',oldname)))) @@ -464,9 +459,7 @@ The `combine-adjacent' attribute is simply ignored." "Parse ." (let* ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) (refname (xelb-node-attr node 'ref)) - (refname (or (intern-soft (concat xelb-prefix refname)) - (intern-soft (concat "xcb:" refname)) - (intern (concat xelb-prefix refname)))) + (refname (xelb-resolve-type refname)) (xge (child-of-class-p refname 'xcb:-generic-event)) (event-number (string-to-number (xelb-node-attr node 'number)))) (if xge @@ -481,9 +474,7 @@ The `combine-adjacent' attribute is simply ignored." "Parse ." (let* ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) (refname (xelb-node-attr node 'ref)) - (refname (or (intern-soft (concat xelb-prefix refname)) - (intern-soft (concat "xcb:" refname)) - (intern (concat xelb-prefix refname)))) + (refname (xelb-resolve-type refname)) (error-number (string-to-number (xelb-node-attr node 'number)))) (setq xelb-error-alist (nconc xelb-error-alist `((,error-number . ,name)))) `((defclass ,name (xcb:-error ,refname) ;Shadow the method of ref @@ -684,9 +675,7 @@ The `combine-adjacent' attribute is simply ignored." "Parse ." (let ((name (concat (xelb-node-attr node 'ref) ":" (xelb-node-subnode node)))) - (symbol-value (or (intern-soft (concat xelb-prefix name)) - (intern-soft (concat "xcb:" name)) - (intern (concat xelb-prefix name)))))) + (symbol-value (xelb-resolve-type name)))) (defun xelb-parse-unop (node) "Parse ." From c0fee2094a4c4df5991eb22162708ef627d94c72 Mon Sep 17 00:00:00 2001 From: Steven Allen Date: Sat, 13 Jan 2024 20:20:15 -0800 Subject: [PATCH 3/6] Handle elements in XCB specs See https://cgit.freedesktop.org/xcb/proto/tree/doc/xml-xcb.txt, xinput's DeviceClass needed this. * el_client.el (xelb-parse-length): Add a function to handle length nodes. (xelb-parse-structure-content): Use `xelb-parse-length'. --- xcb-types.el | 9 +++++++-- xelb-gen | 6 ++++++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/xcb-types.el b/xcb-types.el index 42e6913..7a9521a 100644 --- a/xcb-types.el +++ b/xcb-types.el @@ -498,7 +498,8 @@ Consider let-bind it rather than change its global value.")) (defclass xcb:-struct (xcb:--struct) ((~lsb :initarg :~lsb :initform (symbol-value 'xcb:lsb) ;see `eieio-default-eval-maybe' - :type xcb:-ignore)) + :type xcb:-ignore) + (~size :initform nil :type xcb:-ignore)) :documentation "Struct type.") (cl-defmethod xcb:marshal ((obj xcb:-struct)) @@ -639,7 +640,11 @@ The optional argument CTX is for ." (setq result (+ result (cadr tmp))) (when (eq type 'xcb:-switch) ;xcb:-switch always finishes a struct (throw 'break 'nil))))) - result)) + (if-let ((size (slot-value obj '~size))) + ;; Let the struct compute it's size if a length field is specified. This lets us skip + ;; unknown fields. + (eval (slot-value obj '~size) `((obj . ,obj))) + result))) (cl-defmethod xcb:-unmarshal-field ((obj xcb:-struct) type data offset initform &optional ctx total-length) diff --git a/xelb-gen b/xelb-gen index 9d3c634..7873d12 100755 --- a/xelb-gen +++ b/xelb-gen @@ -494,6 +494,7 @@ The `combine-adjacent' attribute is simply ignored." (`pad (xelb-parse-pad node)) (`required_start_align (xelb-parse-required_start_align node)) (`field (xelb-parse-field node)) + (`length (xelb-parse-length node)) (`fd (xelb-parse-fd node)) (`list (xelb-parse-list node)) (`exprfield (xelb-parse-exprfield node)) @@ -531,6 +532,11 @@ The `combine-adjacent' attribute is simply ignored." (type (xelb-node-type node))) `((,name :initarg ,(intern (concat ":" (symbol-name name))) :type ,type)))) +(defun xelb-parse-length (node) + "Parse ." + (let ((length (xelb-parse-expression (xelb-node-subnode node)))) + `((~size :initform ',length)))) + (defun xelb-parse-fd (node) "Parse ." (let ((name (intern (xelb-node-attr-escape node 'name)))) From e85f8def5ee0b98d7550ecb7830063ab239cda9b Mon Sep 17 00:00:00 2001 From: Steven Allen Date: Sat, 13 Jan 2024 20:24:27 -0800 Subject: [PATCH 4/6] Switch back to the Emacs 28 pretty-printer function If we're running Emacs 29+, use the pretty-printer function from Emacs 28 for consistency. We can remove this once we can guarantee that all development will happen on Emacs 29+. * el_client.el (xelb-parse): Force emacs-28-style pretty printing. --- xelb-gen | 1 + 1 file changed, 1 insertion(+) diff --git a/xelb-gen b/xelb-gen index 7873d12..476e33e 100755 --- a/xelb-gen +++ b/xelb-gen @@ -179,6 +179,7 @@ an `xelb-auto-padding' attribute." (defun xelb-parse (file) "Parse an XCB protocol description file FILE (XML)." (let ((pp-escape-newlines nil) ;do not escape newlines + (pp-default-function 'pp-28) ;avoid unecessary churn result header) (with-temp-buffer (insert-file-contents file) From 17902c2c2c34fc72ab5e1697bc1684f0133d440e Mon Sep 17 00:00:00 2001 From: Steven Allen Date: Sat, 13 Jan 2024 20:31:46 -0800 Subject: [PATCH 5/6] Update to xcb-proto 1.16.0 * Makefile: Add the dbe (double buffering) extension. * xcb-dbe.el: The new DBE extension. * xcb-dpms.el: * xcb-dri3.el: * xcb-present.el: * xcb-xfixes.el: * xcb-xinput.el: * xcb-xprint: Regenerate from xcb-proto 1.16.0, and with support for floats & doubles. --- Makefile | 2 +- xcb-dbe.el | 162 +++++++++++++++++++++++++++++++++++++++++++++++++ xcb-dpms.el | 26 +++++++- xcb-dri3.el | 9 ++- xcb-glx.el | 6 +- xcb-present.el | 4 +- xcb-xfixes.el | 21 ++++++- xcb-xinput.el | 103 +++++++++++++++++++++++++++++-- xcb-xprint.el | 4 ++ 9 files changed, 324 insertions(+), 13 deletions(-) create mode 100644 xcb-dbe.el diff --git a/Makefile b/Makefile index b86df9d..2d56356 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ PROTO_PATH := /usr/share/xcb -EXTENSIONS := bigreq composite damage dpms dri2 dri3 ge glx present randr \ +EXTENSIONS := bigreq composite damage dbe dpms dri2 dri3 ge glx present randr \ record render res screensaver shape shm sync xc_misc xevie xf86dri \ xf86vidmode xfixes xinerama xinput xkb xprint xselinux xtest xvmc xv diff --git a/xcb-dbe.el b/xcb-dbe.el new file mode 100644 index 0000000..409c37e --- /dev/null +++ b/xcb-dbe.el @@ -0,0 +1,162 @@ +;;; xcb-dbe.el --- X11 Dbe extension -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file was generated by 'el_client.el' from 'dbe.xml', +;; which you can retrieve from . + +;;; Code: + +(require 'xcb-types) + +(defconst xcb:dbe:-extension-xname "DOUBLE-BUFFER") +(defconst xcb:dbe:-extension-name "Dbe") +(defconst xcb:dbe:-major-version 1) +(defconst xcb:dbe:-minor-version 0) + +(require 'xcb-xproto) + +(xcb:deftypealias 'xcb:dbe:BackBuffer 'xcb:DRAWABLE) + +(defconst xcb:dbe:SwapAction:Undefined 0) +(defconst xcb:dbe:SwapAction:Background 1) +(defconst xcb:dbe:SwapAction:Untouched 2) +(defconst xcb:dbe:SwapAction:Copied 3) + +(defclass xcb:dbe:SwapInfo + (xcb:-struct) + ((window :initarg :window :type xcb:WINDOW) + (swap-action :initarg :swap-action :type xcb:CARD8) + (pad~0 :initform 3 :type xcb:-pad))) + +(defclass xcb:dbe:BufferAttributes + (xcb:-struct) + ((window :initarg :window :type xcb:WINDOW))) + +(defclass xcb:dbe:VisualInfo + (xcb:-struct) + ((visual-id :initarg :visual-id :type xcb:VISUALID) + (depth :initarg :depth :type xcb:CARD8) + (perf-level :initarg :perf-level :type xcb:CARD8) + (pad~0 :initform 2 :type xcb:-pad))) + +(defclass xcb:dbe:VisualInfos + (xcb:-struct) + ((n-infos :initarg :n-infos :type xcb:CARD32) + (infos~ :initform + '(name infos type xcb:dbe:VisualInfo size + (xcb:-fieldref 'n-infos)) + :type xcb:-list) + (infos :initarg :infos :type xcb:-ignore))) + +(defclass xcb:dbe:BadBuffer + (xcb:-error) + ((~code :initform 0) + (bad-buffer :initarg :bad-buffer :type xcb:dbe:BackBuffer))) + +(defclass xcb:dbe:QueryVersion + (xcb:-request) + ((~opcode :initform 0 :type xcb:-u1) + (major-version :initarg :major-version :type xcb:CARD8) + (minor-version :initarg :minor-version :type xcb:CARD8) + (pad~0 :initform 2 :type xcb:-pad))) +(defclass xcb:dbe:QueryVersion~reply + (xcb:-reply) + ((pad~0 :initform 1 :type xcb:-pad) + (~sequence :type xcb:CARD16) + (length :type xcb:CARD32) + (major-version :initarg :major-version :type xcb:CARD8) + (minor-version :initarg :minor-version :type xcb:CARD8) + (pad~1 :initform 22 :type xcb:-pad))) + +(defclass xcb:dbe:AllocateBackBuffer + (xcb:-request) + ((~opcode :initform 1 :type xcb:-u1) + (window :initarg :window :type xcb:WINDOW) + (buffer :initarg :buffer :type xcb:dbe:BackBuffer) + (swap-action :initarg :swap-action :type xcb:CARD8) + (pad~0 :initform 3 :type xcb:-pad))) + +(defclass xcb:dbe:DeallocateBackBuffer + (xcb:-request) + ((~opcode :initform 2 :type xcb:-u1) + (buffer :initarg :buffer :type xcb:dbe:BackBuffer))) + +(defclass xcb:dbe:SwapBuffers + (xcb:-request) + ((~opcode :initform 3 :type xcb:-u1) + (n-actions :initarg :n-actions :type xcb:CARD32) + (actions~ :initform + '(name actions type xcb:dbe:SwapInfo size + (xcb:-fieldref 'n-actions)) + :type xcb:-list) + (actions :initarg :actions :type xcb:-ignore))) + +(defclass xcb:dbe:BeginIdiom + (xcb:-request) + ((~opcode :initform 4 :type xcb:-u1))) + +(defclass xcb:dbe:EndIdiom + (xcb:-request) + ((~opcode :initform 5 :type xcb:-u1))) + +(defclass xcb:dbe:GetVisualInfo + (xcb:-request) + ((~opcode :initform 6 :type xcb:-u1) + (n-drawables :initarg :n-drawables :type xcb:CARD32) + (drawables~ :initform + '(name drawables type xcb:DRAWABLE size + (xcb:-fieldref 'n-drawables)) + :type xcb:-list) + (drawables :initarg :drawables :type xcb:-ignore))) +(defclass xcb:dbe:GetVisualInfo~reply + (xcb:-reply) + ((pad~0 :initform 1 :type xcb:-pad) + (~sequence :type xcb:CARD16) + (length :type xcb:CARD32) + (n-supported-visuals :initarg :n-supported-visuals :type xcb:CARD32) + (pad~1 :initform 20 :type xcb:-pad) + (supported-visuals~ :initform + '(name supported-visuals type xcb:dbe:VisualInfos size + (xcb:-fieldref 'n-supported-visuals)) + :type xcb:-list) + (supported-visuals :initarg :supported-visuals :type xcb:-ignore))) + +(defclass xcb:dbe:GetBackBufferAttributes + (xcb:-request) + ((~opcode :initform 7 :type xcb:-u1) + (buffer :initarg :buffer :type xcb:dbe:BackBuffer))) +(defclass xcb:dbe:GetBackBufferAttributes~reply + (xcb:-reply) + ((pad~0 :initform 1 :type xcb:-pad) + (~sequence :type xcb:CARD16) + (length :type xcb:CARD32) + (attributes :initarg :attributes :type xcb:dbe:BufferAttributes) + (pad~1 :initform 20 :type xcb:-pad))) + +(defconst xcb:dbe:error-number-class-alist + '((0 . xcb:dbe:BadBuffer)) + "(error-number . error-class) alist.") + + + +(provide 'xcb-dbe) + +;;; xcb-dbe.el ends here diff --git a/xcb-dpms.el b/xcb-dpms.el index 0e2a166..12f1c15 100644 --- a/xcb-dpms.el +++ b/xcb-dpms.el @@ -28,8 +28,10 @@ (defconst xcb:dpms:-extension-xname "DPMS") (defconst xcb:dpms:-extension-name "DPMS") -(defconst xcb:dpms:-major-version 0) -(defconst xcb:dpms:-minor-version 0) +(defconst xcb:dpms:-major-version 1) +(defconst xcb:dpms:-minor-version 2) + +(require 'xcb-xproto) (defclass xcb:dpms:GetVersion (xcb:-request) @@ -105,6 +107,26 @@ (state :initarg :state :type xcb:BOOL) (pad~1 :initform 21 :type xcb:-pad))) +(defconst xcb:dpms:EventMask:InfoNotify 1) + +(defclass xcb:dpms:SelectInput + (xcb:-request) + ((~opcode :initform 8 :type xcb:-u1) + (event-mask :initarg :event-mask :type xcb:CARD32))) + +(defclass xcb:dpms:InfoNotify + (xcb:-generic-event) + ((~evtype :initform 0) + (pad~0 :initform 2 :type xcb:-pad) + (timestamp :initarg :timestamp :type xcb:TIMESTAMP) + (power-level :initarg :power-level :type xcb:CARD16) + (state :initarg :state :type xcb:BOOL) + (pad~1 :initform 21 :type xcb:-pad))) + +(defconst xcb:dpms:xge-number-class-alist + '((0 . xcb:dpms:InfoNotify)) + "(xge-number . event-class) alist.") + (provide 'xcb-dpms) diff --git a/xcb-dri3.el b/xcb-dri3.el index 2993eb5..3abc664 100644 --- a/xcb-dri3.el +++ b/xcb-dri3.el @@ -29,7 +29,7 @@ (defconst xcb:dri3:-extension-xname "DRI3") (defconst xcb:dri3:-extension-name "DRI3") (defconst xcb:dri3:-major-version 1) -(defconst xcb:dri3:-minor-version 2) +(defconst xcb:dri3:-minor-version 3) (require 'xcb-xproto) @@ -200,6 +200,13 @@ :type xcb:-list) (buffers :initarg :buffers :type xcb:-ignore))) +(defclass xcb:dri3:SetDRMDeviceInUse + (xcb:-request) + ((~opcode :initform 9 :type xcb:-u1) + (window :initarg :window :type xcb:WINDOW) + (drmMajor :initarg :drmMajor :type xcb:CARD32) + (drmMinor :initarg :drmMinor :type xcb:CARD32))) + (provide 'xcb-dri3) diff --git a/xcb-glx.el b/xcb-glx.el index 1a2d829..c04d5e7 100644 --- a/xcb-glx.el +++ b/xcb-glx.el @@ -45,9 +45,9 @@ (xcb:deftypealias 'xcb:glx:DRAWABLE 'xcb:-u4) -(xcb:deftypealias 'xcb:glx:FLOAT32 'xcb:glx:float) +(xcb:deftypealias 'xcb:glx:FLOAT32 'xcb:float) -(xcb:deftypealias 'xcb:glx:FLOAT64 'xcb:glx:double) +(xcb:deftypealias 'xcb:glx:FLOAT64 'xcb:double) (xcb:deftypealias 'xcb:glx:BOOL32 'xcb:CARD32) @@ -575,6 +575,7 @@ (xcb:-fieldref 'gl-str-len)) :type xcb:-list) (gl-extension-string :initarg :gl-extension-string :type xcb:-ignore) + (pad~0 :initform 4 :type xcb:-pad-align) (glx-extension-string~ :initform '(name glx-extension-string type xcb:char size (xcb:-fieldref 'glx-str-len)) @@ -619,6 +620,7 @@ (xcb:-fieldref 'gl-str-len)) :type xcb:-list) (gl-extension-string :initarg :gl-extension-string :type xcb:-ignore) + (pad~0 :initform 4 :type xcb:-pad-align) (glx-extension-string~ :initform '(name glx-extension-string type xcb:char size (xcb:-fieldref 'glx-str-len)) diff --git a/xcb-present.el b/xcb-present.el index 395e8b0..56e1b63 100644 --- a/xcb-present.el +++ b/xcb-present.el @@ -29,7 +29,7 @@ (defconst xcb:present:-extension-xname "Present") (defconst xcb:present:-extension-name "Present") (defconst xcb:present:-major-version 1) -(defconst xcb:present:-minor-version 2) +(defconst xcb:present:-minor-version 3) (require 'xcb-xproto) @@ -55,11 +55,13 @@ (defconst xcb:present:Option:Copy 2) (defconst xcb:present:Option:UST 4) (defconst xcb:present:Option:Suboptimal 8) +(defconst xcb:present:Option:AsyncMayTear 16) (defconst xcb:present:Capability:None 0) (defconst xcb:present:Capability:Async 1) (defconst xcb:present:Capability:Fence 2) (defconst xcb:present:Capability:UST 4) +(defconst xcb:present:Capability:AsyncMayTear 8) (defconst xcb:present:CompleteKind:Pixmap 0) (defconst xcb:present:CompleteKind:NotifyMSC 1) diff --git a/xcb-xfixes.el b/xcb-xfixes.el index 7b52c9f..5b5fdb8 100644 --- a/xcb-xfixes.el +++ b/xcb-xfixes.el @@ -28,7 +28,7 @@ (defconst xcb:xfixes:-extension-xname "XFIXES") (defconst xcb:xfixes:-extension-name "XFixes") -(defconst xcb:xfixes:-major-version 5) +(defconst xcb:xfixes:-major-version 6) (defconst xcb:xfixes:-minor-version 0) (require 'xcb-xproto) @@ -419,6 +419,25 @@ ((~opcode :initform 32 :type xcb:-u1) (barrier :initarg :barrier :type xcb:xfixes:BARRIER))) +(defconst xcb:xfixes:ClientDisconnectFlags:Default 0) +(defconst xcb:xfixes:ClientDisconnectFlags:Terminate 1) + +(defclass xcb:xfixes:SetClientDisconnectMode + (xcb:-request) + ((~opcode :initform 33 :type xcb:-u1) + (disconnect-mode :initarg :disconnect-mode :type xcb:CARD32))) + +(defclass xcb:xfixes:GetClientDisconnectMode + (xcb:-request) + ((~opcode :initform 34 :type xcb:-u1))) +(defclass xcb:xfixes:GetClientDisconnectMode~reply + (xcb:-reply) + ((pad~0 :initform 1 :type xcb:-pad) + (~sequence :type xcb:CARD16) + (length :type xcb:CARD32) + (disconnect-mode :initarg :disconnect-mode :type xcb:CARD32) + (pad~1 :initform 20 :type xcb:-pad))) + (defconst xcb:xfixes:error-number-class-alist '((0 . xcb:xfixes:BadRegion)) "(error-number . error-class) alist.") diff --git a/xcb-xinput.el b/xcb-xinput.el index e35cb0e..7fbb41b 100644 --- a/xcb-xinput.el +++ b/xcb-xinput.el @@ -29,7 +29,7 @@ (defconst xcb:xinput:-extension-xname "XInputExtension") (defconst xcb:xinput:-extension-name "Input") (defconst xcb:xinput:-major-version 2) -(defconst xcb:xinput:-minor-version 3) +(defconst xcb:xinput:-minor-version 4) (require 'xcb-xfixes) @@ -1642,6 +1642,7 @@ (defconst xcb:xinput:DeviceClassType:Valuator 2) (defconst xcb:xinput:DeviceClassType:Scroll 3) (defconst xcb:xinput:DeviceClassType:Touch 8) +(defconst xcb:xinput:DeviceClassType:Gesture 9) (defconst xcb:xinput:DeviceType:MasterPointer 1) (defconst xcb:xinput:DeviceType:MasterKeyboard 2) @@ -1710,6 +1711,14 @@ (mode :initarg :mode :type xcb:CARD8) (num-touches :initarg :num-touches :type xcb:CARD8))) +(defclass xcb:xinput:GestureClass + (xcb:-struct) + ((type :initarg :type :type xcb:CARD16) + (len :initarg :len :type xcb:CARD16) + (sourceid :initarg :sourceid :type xcb:xinput:DeviceId) + (num-touches :initarg :num-touches :type xcb:CARD8) + (pad~0 :initform 1 :type xcb:-pad))) + (defclass xcb:xinput:ValuatorClass (xcb:-struct) ((type :initarg :type :type xcb:CARD16) @@ -1726,7 +1735,11 @@ (defclass xcb:xinput:DeviceClass (xcb:-struct) - ((type :initarg :type :type xcb:CARD16) + ((~size :initform + '(* + (xcb:-fieldref 'len) + 4)) + (type :initarg :type :type xcb:CARD16) (len :initarg :len :type xcb:CARD16) (sourceid :initarg :sourceid :type xcb:xinput:DeviceId) (data :initform @@ -1742,7 +1755,9 @@ ((3) pad~4 number* scroll-type pad~5 flags increment) ((8) - mode* num-touches))) + mode* num-touches) + ((9) + num-touches* pad~6))) :type xcb:-switch) (pad~0 :initform [4 2] @@ -1791,7 +1806,9 @@ (flags :initarg :flags :type xcb:CARD32) (increment :initarg :increment :type xcb:xinput:FP3232) (mode* :initarg :mode* :type xcb:CARD8) - (num-touches :initarg :num-touches :type xcb:CARD8))) + (num-touches :initarg :num-touches :type xcb:CARD8) + (num-touches* :initarg :num-touches* :type xcb:CARD8) + (pad~6 :initform 1 :type xcb:-pad))) (defclass xcb:xinput:XIDeviceInfo (xcb:-struct) @@ -1916,6 +1933,8 @@ (defconst xcb:xinput:GrabType:Enter 2) (defconst xcb:xinput:GrabType:FocusIn 3) (defconst xcb:xinput:GrabType:TouchBegin 4) +(defconst xcb:xinput:GrabType:GesturePinchBegin 5) +(defconst xcb:xinput:GrabType:GestureSwipeBegin 6) (defclass xcb:xinput:GrabModifierInfo (xcb:-struct) @@ -2775,6 +2794,74 @@ (xcb:-event xcb:xinput:BarrierHit) ((~evtype :initform 26))) +(defconst xcb:xinput:GesturePinchEventFlags:GesturePinchCancelled 1) + +(defclass xcb:xinput:GesturePinchBegin + (xcb:-generic-event) + ((~evtype :initform 27) + (deviceid :initarg :deviceid :type xcb:xinput:DeviceId) + (time :initarg :time :type xcb:TIMESTAMP) + (detail :initarg :detail :type xcb:CARD32) + (root :initarg :root :type xcb:WINDOW) + (event :initarg :event :type xcb:WINDOW) + (child :initarg :child :type xcb:WINDOW) + (root-x :initarg :root-x :type xcb:xinput:FP1616) + (root-y :initarg :root-y :type xcb:xinput:FP1616) + (event-x :initarg :event-x :type xcb:xinput:FP1616) + (event-y :initarg :event-y :type xcb:xinput:FP1616) + (delta-x :initarg :delta-x :type xcb:xinput:FP1616) + (delta-y :initarg :delta-y :type xcb:xinput:FP1616) + (delta-unaccel-x :initarg :delta-unaccel-x :type xcb:xinput:FP1616) + (delta-unaccel-y :initarg :delta-unaccel-y :type xcb:xinput:FP1616) + (scale :initarg :scale :type xcb:xinput:FP1616) + (delta-angle :initarg :delta-angle :type xcb:xinput:FP1616) + (sourceid :initarg :sourceid :type xcb:xinput:DeviceId) + (pad~0 :initform 2 :type xcb:-pad) + (mods :initarg :mods :type xcb:xinput:ModifierInfo) + (group :initarg :group :type xcb:xinput:GroupInfo) + (flags :initarg :flags :type xcb:CARD32))) + +(defclass xcb:xinput:GesturePinchUpdate + (xcb:-event xcb:xinput:GesturePinchBegin) + ((~evtype :initform 28))) + +(defclass xcb:xinput:GesturePinchEnd + (xcb:-event xcb:xinput:GesturePinchBegin) + ((~evtype :initform 29))) + +(defconst xcb:xinput:GestureSwipeEventFlags:GestureSwipeCancelled 1) + +(defclass xcb:xinput:GestureSwipeBegin + (xcb:-generic-event) + ((~evtype :initform 30) + (deviceid :initarg :deviceid :type xcb:xinput:DeviceId) + (time :initarg :time :type xcb:TIMESTAMP) + (detail :initarg :detail :type xcb:CARD32) + (root :initarg :root :type xcb:WINDOW) + (event :initarg :event :type xcb:WINDOW) + (child :initarg :child :type xcb:WINDOW) + (root-x :initarg :root-x :type xcb:xinput:FP1616) + (root-y :initarg :root-y :type xcb:xinput:FP1616) + (event-x :initarg :event-x :type xcb:xinput:FP1616) + (event-y :initarg :event-y :type xcb:xinput:FP1616) + (delta-x :initarg :delta-x :type xcb:xinput:FP1616) + (delta-y :initarg :delta-y :type xcb:xinput:FP1616) + (delta-unaccel-x :initarg :delta-unaccel-x :type xcb:xinput:FP1616) + (delta-unaccel-y :initarg :delta-unaccel-y :type xcb:xinput:FP1616) + (sourceid :initarg :sourceid :type xcb:xinput:DeviceId) + (pad~0 :initform 2 :type xcb:-pad) + (mods :initarg :mods :type xcb:xinput:ModifierInfo) + (group :initarg :group :type xcb:xinput:GroupInfo) + (flags :initarg :flags :type xcb:CARD32))) + +(defclass xcb:xinput:GestureSwipeUpdate + (xcb:-event xcb:xinput:GestureSwipeBegin) + ((~evtype :initform 31))) + +(defclass xcb:xinput:GestureSwipeEnd + (xcb:-event xcb:xinput:GestureSwipeBegin) + ((~evtype :initform 32))) + (defclass xcb:xinput:EventForSend (xcb:-event) nil) @@ -2873,7 +2960,13 @@ (23 . xcb:xinput:RawTouchUpdate) (24 . xcb:xinput:RawTouchEnd) (25 . xcb:xinput:BarrierHit) - (26 . xcb:xinput:BarrierLeave)) + (26 . xcb:xinput:BarrierLeave) + (27 . xcb:xinput:GesturePinchBegin) + (28 . xcb:xinput:GesturePinchUpdate) + (29 . xcb:xinput:GesturePinchEnd) + (30 . xcb:xinput:GestureSwipeBegin) + (31 . xcb:xinput:GestureSwipeUpdate) + (32 . xcb:xinput:GestureSwipeEnd)) "(xge-number . event-class) alist.") diff --git a/xcb-xprint.el b/xcb-xprint.el index 6350cc0..9d09d8f 100644 --- a/xcb-xprint.el +++ b/xcb-xprint.el @@ -97,6 +97,7 @@ (xcb:-fieldref 'printerNameLen)) :type xcb:-list) (printer-name :initarg :printer-name :type xcb:-ignore) + (pad~0 :initform 4 :type xcb:-pad-align) (locale~ :initform '(name locale type xcb:xprint:STRING8 size (xcb:-fieldref 'localeLen)) @@ -130,6 +131,7 @@ (xcb:-fieldref 'printerNameLen)) :type xcb:-list) (printerName :initarg :printerName :type xcb:-ignore) + (pad~0 :initform 4 :type xcb:-pad-align) (locale~ :initform '(name locale type xcb:xprint:STRING8 size (xcb:-fieldref 'localeLen)) @@ -198,11 +200,13 @@ (xcb:-fieldref 'len-data)) :type xcb:-list) (data :initarg :data :type xcb:-ignore) + (pad~0 :initform 4 :type xcb:-pad-align) (doc-format~ :initform '(name doc-format type xcb:xprint:STRING8 size (xcb:-fieldref 'len-fmt)) :type xcb:-list) (doc-format :initarg :doc-format :type xcb:-ignore) + (pad~1 :initform 4 :type xcb:-pad-align) (options~ :initform '(name options type xcb:xprint:STRING8 size (xcb:-fieldref 'len-options)) From dd242b5ae2002cb331a26e9bb3d0f5055acab0b0 Mon Sep 17 00:00:00 2001 From: Steven Allen Date: Wed, 17 Jan 2024 11:05:20 -0800 Subject: [PATCH 6/6] Strict (un)marshal size checking * xcb-types.el (xcb:marshal xcb:-struct): Fail encoding if expected size is match the size of the encoded struct. (xcb:unmarshal xcb:-struct): Fail decoding if the expected size is less than the number of bytes read or more than the number of bytes available to read. (xcb:marshal xcb:-union): Fail encoding if the expected size is less than the size of the encoded union. --- xcb-types.el | 34 ++++++++++++++++++++++++++++------ 1 file changed, 28 insertions(+), 6 deletions(-) diff --git a/xcb-types.el b/xcb-types.el index 7a9521a..8bd3a29 100644 --- a/xcb-types.el +++ b/xcb-types.el @@ -519,6 +519,14 @@ Consider let-bind it rather than change its global value.")) (length result)))) (when (eq type 'xcb:-switch) ;xcb:-switch always finishes a struct (throw 'break 'nil))))) + ;; If we specify a size, verify that it matches the actual size. + (when-let* ((size-exp (slot-value obj '~size)) + (size (eval size-exp `((obj . ,obj))))) + (unless (length= result size) + (error "[XCB] Unexpected size for type %s: got %d, expected %d" + (type-of obj) + (length result) + size))) result)) (cl-defmethod xcb:-marshal-field ((obj xcb:-struct) type value &optional pos) @@ -640,11 +648,21 @@ The optional argument CTX is for ." (setq result (+ result (cadr tmp))) (when (eq type 'xcb:-switch) ;xcb:-switch always finishes a struct (throw 'break 'nil))))) - (if-let ((size (slot-value obj '~size))) - ;; Let the struct compute it's size if a length field is specified. This lets us skip - ;; unknown fields. - (eval (slot-value obj '~size) `((obj . ,obj))) - result))) + ;; Let the struct compute it's size if a length field is specified. This lets us skip unknown + ;; fields. + (when-let* ((size-exp (slot-value obj '~size)) + (size (eval size-exp `((obj . ,obj))))) + ;; Make sure the stated size is reasonable. + (cond + ((< size result) + (error "[XCB] Object of type `%s' specified a size (%d) less than the number of bytes read (%d)" + (type-of obj) size result)) + ((length< byte-array (- size result)) + (error "[XCB] Object of type `%s' specified a size (%d) greater than the size of the input (%d)" + (type-of obj) size (+ result (length byte-array))))) + ;; Skip any additional bytes. + (setq result size)) + result)) (cl-defmethod xcb:-unmarshal-field ((obj xcb:-struct) type data offset initform &optional ctx total-length) @@ -868,8 +886,12 @@ This result is converted from the first bounded slot." (slot-value obj name))) (when (> (length tmp) (length result)) (setq result tmp)))) - (when (> size (length result)) + (cond + ((length< result size) (setq result (vconcat result (make-vector (- size (length result)) 0)))) + ((length> result size) + (error "[XCB] Marshaled enum `%s' is larger than its declared size (%d > %d)" + (type-of obj) (length result) size))) result)) ;; (cl-defmethod xcb:unmarshal ((obj xcb:-union) byte-array &optional ctx