diff options
Diffstat (limited to 'elpa/xelb-0.20/xelb-gen')
| -rwxr-xr-x | elpa/xelb-0.20/xelb-gen | 726 |
1 files changed, 726 insertions, 0 deletions
diff --git a/elpa/xelb-0.20/xelb-gen b/elpa/xelb-0.20/xelb-gen new file mode 100755 index 0000000..daff68c --- /dev/null +++ b/elpa/xelb-0.20/xelb-gen @@ -0,0 +1,726 @@ +#!/usr/bin/env -S emacs -Q --script +;;; xelb-gen --- XELB Code Generator -*- lexical-binding: t; no-byte-compile: t -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Chris Feng <chris.w.feng@gmail.com> + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; 'xelb-gen' is responsible for converting XCB XML description files into +;; Elisp libraries. Here are a few design guidelines: +;; + The generated codes should be human-readable and conform to the Elisp +;; coding conventions. Names mentioned in X specifications are preferred. +;; + Deprecated features such as <valueparam> should be dropped, for +;; - they would generate incompatible codes, and +;; - they are probably already dropped upstream. +;; + All documentations (within <doc> tags) and comments should be stripped +;; out to reduce the overall amount of code. XELB application developers are +;; then encouraged to refer to the corresponding specifications to get an +;; authoritative explanation. + +;; This file is only intended to be run as a script. + +;; References: +;; + xcb/proto (git://anongit.freedesktop.org/xcb/proto) + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'pp) + +;; Only used to eliminate compile warnings when distributed. +(require 'xcb-types nil t) + +;;;; Variables + +(defvar xelb-prefix "xcb:" "Namespace of this module.") + +(defvar xelb-error-alist nil "Record X errors in this module.") + +(defvar xelb-event-alist nil "Record X events in this module.") + +(defvar xelb-xge-alist nil "Record X generic events in this module.") + +(defvar xelb-imports nil "Record imported libraries.") + +(defvar xelb-pad-count -1 "<pad> node counter.") + +(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) + "Return the tag name of node NODE." + (car node)) + +(defsubst xelb-node-attr (node attr) + "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." + (xelb-resolve-type (xelb-node-attr node 'type))) + +(defsubst xelb-escape-name (name) + "Replace underscores in NAME with dashes." + (replace-regexp-in-string "_" "-" name)) + +(defsubst xelb-node-name-escape (node) + "Return the tag name of node NODE and escape it." + (xelb-escape-name (xelb-node-name node))) + +(defsubst xelb-node-attr-escape (node attr) + "Return the attribute ATTR of node NODE and escape it." + (xelb-escape-name (xelb-node-attr node attr))) + +(defsubst xelb-node-subnodes (node &optional mark-auto-padding) + "Return all the subnodes of node NODE as a list. + +If MARK-AUTO-PADDING is non-nil, all <list>'s fitting for padding will include +an `xelb-auto-padding' attribute." + (let ((subnodes (cddr node))) + (when mark-auto-padding + ;; Remove all <comment>'s and <doc>'s + (setq subnodes + (cl-delete-if (lambda (i) (or (eq 'comment (car i)) (eq 'doc (car i)))) + subnodes)) + (dotimes (i (1- (length subnodes))) + (when (and (eq 'list (xelb-node-name (elt subnodes i))) + (pcase (xelb-node-name (elt subnodes (1+ i))) + ((or `reply `pad)) + (_ t))) + (setf (cadr (elt subnodes i)) + (nconc (cadr (elt subnodes i)) `((xelb-auto-padding . t))))))) + subnodes)) + +(defsubst xelb-node-subnode (node) + "Return the (only) subnode of node NODE with useless contents skipped." + (let ((result (xelb-node-subnodes node))) + (catch 'break + (dolist (i result) + (unless (and (listp i) + (or (eq (xelb-node-name i) 'comment) + (eq (xelb-node-name i) 'doc))) + (throw 'break i)))))) + +(defun xelb-node-size (node) + "Return the size of NODE in bytes." + (pcase (xelb-node-name node) + (`pad (xelb-node-attr node 'bytes)) + (`field (xelb-type-size (xelb-node-type node))) + (`list (* (xelb-type-size (xelb-node-type node)) + (xelb-parse-expression (xelb-node-subnode node)))) + ((or `comment `doc) 0) + (x (error "Unexpected element: <%s>" x)))) + +(defun xelb-type-size (type &optional slot) + "Return size of TYPE in bytes." + (pcase (or (get type 'xcb--typealias) type) + (`xcb:-ignore 0) + ((or `xcb:-u1 `xcb:-i1 `xcb:void) 1) + ((or `xcb:-u2 `xcb:-i2) 2) + ((or `xcb:-u4 `xcb:-i4) 4) + (`xcb:-u8 8) + (`xcb:-pad (cl--slot-descriptor-initform slot)) + (`xcb:-list + (let ((initform (cadr (cl--slot-descriptor-initform slot)))) + (* (plist-get initform 'size) + (xelb-type-size (plist-get initform 'type))))) + ((and x (guard (child-of-class-p x 'xcb:-struct))) + (apply #'+ + (mapcar (lambda (slot) + (xelb-type-size (cl--slot-descriptor-type slot) slot)) + (eieio-class-slots x)))) + (x (error "Unknown size of type: %s" x)))) + +(defsubst xelb-generate-pad-name () + "Generate a new slot name for <pad>." + (make-symbol (format "pad~%d" (cl-incf xelb-pad-count)))) + +;;;; Entry & root element + +(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) + (setq result (libxml-parse-xml-region (point-min) (point-max))) + (unless (eq 'xcb (xelb-node-name result)) + ;; There's an extra comment. + (setq result (xelb-node-subnode result))) + (cl-assert (eq 'xcb (xelb-node-name result))) + (setq header (xelb-node-attr result 'header)) + (unless (string= header "xproto") + (setq xelb-prefix (concat xelb-prefix header ":"))) + ;; Print header + (princ (format "\ +;;; xcb-%s.el --- X11 %s -*- 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file was generated by 'xelb-gen' from '%s', +;; which you can retrieve from <git://anongit.freedesktop.org/xcb/proto>. + +;;; Code: + +\(require 'xcb-types) + +" + header + (let ((extension-name (xelb-node-attr result + 'extension-name))) + (if extension-name + (concat extension-name " extension") + "core protocol")) + (file-name-nondirectory file))) + ;; Print extension info (if any) + (let ((extension-xname (xelb-node-attr result 'extension-xname)) + (extension-name (xelb-node-attr result 'extension-name)) + (major-version (xelb-node-attr result 'major-version)) + (minor-version (xelb-node-attr result 'minor-version))) + (when extension-xname + (pp `(defconst ,(intern (concat xelb-prefix "-extension-xname")) + ,extension-xname))) + (when extension-name + (pp `(defconst ,(intern (concat xelb-prefix "-extension-name")) + ,extension-name))) + (when major-version + (pp `(defconst ,(intern (concat xelb-prefix "-major-version")) + ,(string-to-number major-version)))) + (when minor-version + (pp `(defconst ,(intern (concat xelb-prefix "-minor-version")) + ,(string-to-number minor-version)))) + (when (or extension-xname extension-name major-version minor-version) + (princ "\n"))) + ;; Print contents + (dolist (i (xelb-node-subnodes result)) + (let ((result (xelb-parse-top-level-element i))) + (when result ;skip <doc>, comments, etc + (dolist (j result) + (eval j) ;Make it immediately available. + (pp j)) + (princ "\n")))) + ;; Print error/event alists + (when xelb-error-alist + (pp + `(defconst ,(intern (concat xelb-prefix "error-number-class-alist")) + ',xelb-error-alist "(error-number . error-class) alist.")) + (princ "\n")) + (when xelb-event-alist + (pp + `(defconst ,(intern (concat xelb-prefix "event-number-class-alist")) + ',xelb-event-alist "(event-number . event-class) alist.")) + (princ "\n")) + (when xelb-xge-alist + (pp + `(defconst ,(intern (concat xelb-prefix "xge-number-class-alist")) + ',xelb-xge-alist "(xge-number . event-class) alist.")) + (princ "\n")) + ;; Print footer + (princ (format "\ + + +(provide 'xcb-%s) + +;;; xcb-%s.el ends here +" header header))))) + +;;;; XCB: top-level elements + +(defun xelb-parse-top-level-element (node) + "Parse a top-level node NODE." + (setq xelb-pad-count -1) + (pcase (xelb-node-name node) + (`import (xelb-parse-import node)) + (`struct (xelb-parse-struct node)) + (`union (xelb-parse-union node)) + ((or `xidtype `xidunion) + (xelb-parse-xidtype node)) ;they are basically the same + (`enum (xelb-parse-enum node)) + (`typedef (xelb-parse-typedef node)) + (`request (xelb-parse-request node)) + (`event (xelb-parse-event node)) + (`error (xelb-parse-error node)) + (`eventcopy (xelb-parse-eventcopy node)) + (`errorcopy (xelb-parse-errorcopy node)) + (`eventstruct (xelb-parse-eventstruct node)) + ((or `comment `doc)) ;ignored + (x (error "Unsupported top-level element: <%s>" x)))) + +(defun xelb-parse-import (node) + "Parse <import>." + (let* ((name (xelb-node-subnode node)) + (header (intern (concat "xcb-" name)))) + (require header) + (push (concat "xcb:" name ":") xelb-imports) + `((require ',header)))) + +(defun xelb-parse-struct (node) + "Parse <struct>." + (let ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) + (contents (xelb-node-subnodes node t))) + `((defclass ,name (xcb:-struct) + ,(apply #'nconc (mapcar #'xelb-parse-structure-content contents)))))) + +(defun xelb-parse-union (node) + "Parse <union>." + (let ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) + (contents (xelb-node-subnodes node))) + `((defclass ,name (xcb:-union) + ,(apply #'nconc + `((~size :initform + ,(apply #'max (mapcar #'xelb-node-size contents)))) + (mapcar #'xelb-parse-structure-content contents)))))) + +(defun xelb-parse-xidtype (node) + "Parse <xidtype>." + (let ((name (intern (concat xelb-prefix (xelb-node-attr node 'name))))) + `((xcb:deftypealias ',name 'xcb:-u4)))) + +(defun xelb-parse-enum (node) + "Parse <enum>." + (let ((name-prefix (concat xelb-prefix (xelb-node-attr node 'name) ":")) + (items (xelb-node-subnodes node)) + (value 0)) + (delq nil ;remove nil's produced by tags like <doc> + (mapcar (lambda (i) + (when (eq (xelb-node-name i) 'item) + ;; Only handle <item> tags + (let* ((name (xelb-node-attr i 'name)) + (name (intern (concat name-prefix name))) + (expression (xelb-node-subnode i))) + (if expression + (setq value (xelb-parse-expression expression)) + (cl-incf value)) + ;; Omit the rare enums that do not fit in a fixnum in + ;; 32-bit Emacs, so that the resulting .el and .elc + ;; files are portable to 32-bit Emacs. Admittedly + ;; this is a kludge. + (unless (and (integerp value) + (not (<= -536870912 value 536870911))) + `(defconst ,name ,value))))) + items)))) + +(defun xelb-parse-typedef (node) + "Parse <typedef>." + (let* ((oldname (xelb-node-attr node 'oldname)) + (oldname (xelb-resolve-type oldname)) + (newname (intern (concat xelb-prefix + (xelb-node-attr node 'newname))))) + `((xcb:deftypealias ',newname ',oldname)))) + +(defun xelb-parse-request (node) + "Parse <request>. + +The `combine-adjacent' attribute is simply ignored." + (let* ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) + (opcode (string-to-number (xelb-node-attr node 'opcode))) + (contents `((~opcode :initform ,opcode :type xcb:-u1))) + (subnodes (xelb-node-subnodes node t)) + expressions + result reply-name reply-contents) + ;; Fill `xelb-request-fields'. + (setq xelb-request-fields nil) + (dolist (i subnodes) + (unless (eq (xelb-node-name i) 'reply) + (let ((name (xelb-node-attr i 'name))) + (when name + (push (intern (xelb-escape-name name)) xelb-request-fields))))) + (dolist (i subnodes) + (if (not (eq (xelb-node-name i) 'reply)) + (progn + (setq result (xelb-parse-structure-content i)) + (if (eq 'exprfield (xelb-node-name i)) + ;; Split into field and expression + (setq contents (nconc contents (list (car result))) + expressions (nconc expressions (list (cadr result)))) + (setq contents (nconc contents result)))) + ;; Parse <reply> + (setq xelb-pad-count -1) ;reset padding counter + (setq xelb-request-fields nil) ;Clear `xelb-request-fields'. + (setq reply-name + (intern (concat xelb-prefix (xelb-node-attr node 'name) + "~reply"))) + (setq reply-contents (xelb-node-subnodes i t)) + (setq reply-contents + (apply #'nconc + (mapcar #'xelb-parse-structure-content reply-contents))))) + (setq xelb-request-fields nil) ;Clear `xelb-request-fields'. + (delq nil contents) + (delq nil + `((defclass ,name (xcb:-request) ,contents) + ;; The optional expressions + ,(when expressions + `(cl-defmethod xcb:marshal ((obj ,name)) nil + ,@expressions + (cl-call-next-method obj))) + ;; The optional reply body + ,(when reply-name + (delq nil reply-contents) + ;; Insert slots for sequence number and reply length. + (setcdr reply-contents (append '((~sequence :type xcb:CARD16) + (length :type xcb:CARD32)) + (cdr reply-contents))) + `(defclass ,reply-name (xcb:-reply) ,reply-contents)))))) + +(defun xelb-parse-event (node) + "Parse <event>." + (let ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) + (event-number (string-to-number (xelb-node-attr node 'number))) + (no-sequence-number (xelb-node-attr node 'no-sequence-number)) + (xge (xelb-node-attr node 'xge)) + (contents (xelb-node-subnodes node t)) + xge-extension) + (setq xge-extension (and xge (not (eq name 'xcb:GeGeneric)))) + (setq contents + (apply #'nconc (mapcar #'xelb-parse-structure-content contents))) + (unless (or no-sequence-number xge) + (setcdr contents (append '((~sequence :type xcb:CARD16)) + (cdr contents)))) + ;; Add the event code. + (unless (and xge (not xge-extension)) + (push `(,(if xge '~evtype '~code) :initform ,event-number) contents)) + (if xge-extension + (setq xelb-xge-alist + (nconc xelb-xge-alist `((,event-number . ,name)))) + (setq xelb-event-alist + (nconc xelb-event-alist `((,event-number . ,name))))) + `((defclass ,name (,(if xge 'xcb:-generic-event 'xcb:-event)) ,contents)))) + +(defun xelb-parse-error (node) + "Parse <error>." + (let ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) + (error-number (string-to-number (xelb-node-attr node 'number))) + (contents (xelb-node-subnodes node t))) + (setq xelb-error-alist (nconc xelb-error-alist `((,error-number . ,name)))) + `((defclass ,name (xcb:-error) + ,(append + ;; The error code. + `((~code :initform ,error-number)) + ;; The contents. + (apply #'nconc (mapcar #'xelb-parse-structure-content contents))))))) + +(defun xelb-parse-eventcopy (node) + "Parse <eventcopy>." + (let* ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) + (refname (xelb-node-attr node 'ref)) + (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 + (setq xelb-xge-alist + (nconc xelb-xge-alist `((,event-number . ,name)))) + (setq xelb-event-alist + (nconc xelb-event-alist `((,event-number . ,name))))) + `((defclass ,name (,refname) ;Shadow the method of ref. + ((,(if xge '~evtype '~code) :initform ,event-number)))))) + +(defun xelb-parse-errorcopy (node) + "Parse <errorcopy>." + (let* ((name (intern (concat xelb-prefix (xelb-node-attr node 'name)))) + (refname (xelb-node-attr node 'ref)) + (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 + ((~code :initform ,error-number)))))) + +(defun xelb-parse-eventstruct (node) + "Parse <eventstruct>." + (let ((name (intern (concat xelb-prefix (xelb-node-attr node 'name))))) + ;; Only conventional events are supported (and we don't check opcode). + `((defclass ,name (xcb:-event) nil)))) + +;;;; XCB: structure contents + +(defun xelb-parse-structure-content (node) + "Parse a structure content node NODE." + (pcase (xelb-node-name node) + (`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)) + (`switch (xelb-parse-switch node)) + ((or `comment `doc)) ;simply ignored + (x (error "Unsupported structure content: <%s>" x)))) + +;; The car of the result shall be renamed to prevent duplication of slot names +(defun xelb-parse-pad (node) + "Parse <pad>." + (let ((bytes (xelb-node-attr node 'bytes)) + (align (xelb-node-attr node 'align))) + (if bytes + `((,(xelb-generate-pad-name) + :initform ,(string-to-number bytes) :type xcb:-pad)) + (if align + `((,(xelb-generate-pad-name) + :initform ,(string-to-number align) :type xcb:-pad-align)) + (error "Invalid <pad> field"))))) + +(defun xelb-parse-required_start_align (node) + "Parse <required_start_align>." + (let ((align (xelb-node-attr node 'align)) + (offset (xelb-node-attr node 'offset))) + `((,(xelb-generate-pad-name) + :initform ,(if offset + (vector (string-to-number align) + (string-to-number offset)) + (string-to-number align)) + :type xcb:-pad-align)))) + +(defun xelb-parse-field (node) + "Parse <field>." + (let* ((name (intern (xelb-node-attr-escape node 'name))) + (type (xelb-node-type node))) + `((,name :initarg ,(intern (concat ":" (symbol-name name))) :type ,type)))) + +(defun xelb-parse-length (node) + "Parse <length>." + (let ((length (xelb-parse-expression (xelb-node-subnode node)))) + `((~size :initform ',length)))) + +(defun xelb-parse-fd (node) + "Parse <fd>." + (let ((name (intern (xelb-node-attr-escape node 'name)))) + `((,name :type xcb:fd)))) + +(defun xelb-parse-list (node) + "Parse <list>." + (let* ((name (intern (xelb-node-attr-escape node 'name))) + (name-alt (intern (concat (xelb-node-attr-escape node 'name) "~"))) + (type (xelb-node-type node)) + (size (xelb-parse-expression (xelb-node-subnode node)))) + `((,name-alt :initform '(name ,name type ,type size ,size) + :type xcb:-list) + (,name :initarg ,(intern (concat ":" (symbol-name name))) + :type xcb:-ignore)))) + +;; The car of result is the field declaration, and the cadr is the expression +;; to be evaluated. +(defun xelb-parse-exprfield (node) + "Parse <exprfield>." + (let* ((name (intern (xelb-node-attr-escape node 'name))) + (type (xelb-node-type node)) + (value (xelb-parse-expression (xelb-node-subnode node)))) + `((,name :type ,type) + (setf (slot-value obj ',name) ,value)))) + +;; The only difference between <bitcase> and <case> is whether the `condition' +;; is a list +;; The name attribute of <bitcase> and <case> seems not useful here. +(defun xelb-parse-switch (node) + "Parse <switch>." + (let ((name (intern (xelb-node-attr-escape node 'name))) + (expression (xelb-parse-expression (car (xelb-node-subnodes node)))) + ;; <case> and <bitcase> only + (cases (cl-remove-if-not (lambda (i) + (memq (xelb-node-name i) '(case bitcase))) + (xelb-node-subnodes node))) + fields) + ;; Avoid duplicated slot names by appending "*" if necessary + (let (names name) + (dolist (case cases) + (pcase (xelb-node-name case) + ((or `bitcase `case) + (dolist (field (xelb-node-subnodes case)) + (pcase (xelb-node-name field) + ((or `enumref `pad `doc `comment `required_start_align)) + (_ + (setq name (xelb-node-attr field 'name)) + (when (member name names) + (while (member name names) + (setq name (concat name "*"))) + (setcdr (assoc 'name (cadr field)) name)) + (cl-pushnew name names :test #'equal)))))))) + (setq cases + (mapcar (lambda (i) + (let ((case-name (xelb-node-name i)) + condition name-list tmp) + (when (or (eq case-name 'bitcase) (eq case-name 'case)) + (dolist (j (xelb-node-subnodes i t)) + (pcase (xelb-node-name j) + (`enumref + (setq condition + (nconc condition + (list (xelb-parse-enumref j))))) + (_ + (setq tmp (xelb-parse-structure-content j)) + (setq fields (nconc fields tmp)) + (setq name-list + (nconc name-list (list (caar tmp))))))) + (when (eq case-name 'bitcase) + (setq condition (if (= 1 (length condition)) + ;; Flatten 1-element list. + (car condition) + (if (cl-every #'integerp condition) + (apply #'logior condition) + `(logior ,@condition)))))) + `(,condition ,@name-list))) + cases)) + `((,name :initform '(expression ,expression cases ,cases) + :type xcb:-switch) + ,@fields))) + +;;;; XCB: expressions + +(defun xelb-parse-expression (node) + "Parse an expression node NODE." + (when node + (pcase (xelb-node-name node) + (`op (xelb-parse-op node)) + (`fieldref (xelb-parse-fieldref node)) + (`paramref (xelb-parse-paramref node)) + (`value (xelb-parse-value node)) + (`bit (xelb-parse-bit node)) + (`enumref (xelb-parse-enumref node)) + (`unop (xelb-parse-unop node)) + (`sumof (xelb-parse-sumof node)) + (`popcount (xelb-parse-popcount node)) + (`listelement-ref (xelb-parse-listelement-ref node)) + ((or `comment `doc)) ;simply ignored + (x (error "Unsupported expression: <%s>" x))))) + +(defun xelb-parse-op (node) + "Parse <op>." + (let* ((subnodes (xelb-node-subnodes node)) + (x (xelb-parse-expression (car subnodes))) + (y (xelb-parse-expression (cadr subnodes)))) + (pcase (xelb-node-attr node 'op) + ("+" `(+ ,x ,y)) + ("-" `(- ,x ,y)) + ("*" `(* ,x ,y)) + ("/" `(/ ,x ,y)) + ("&" `(logand ,x ,y)) + ("<<" `(ash ,x ,y)) + (x (error "Unsupported operator: `%s'" x))))) + +(defun xelb-parse-fieldref (node) + "Parse <fieldref>." + (let ((name (intern (xelb-escape-name (xelb-node-subnode node))))) + (if (or (not xelb-request-fields) ;Probably not a request. + (memq name xelb-request-fields) + (not (string-suffix-p "-len" (symbol-name name)))) + `(xcb:-fieldref ',name) + `(length + (xcb:-fieldref ',(intern (substring (symbol-name name) 0 -4))))))) + +(defun xelb-parse-paramref (node) + "Parse <paramref>." + `(xcb:-paramref ',(intern (xelb-escape-name (xelb-node-subnode node))))) + +(defun xelb-parse-value (node) + "Parse <value>." + (string-to-number + (replace-regexp-in-string "^0x" "#x" (xelb-node-subnode node)))) + +(defun xelb-parse-bit (node) + "Parse <bit>." + (let ((bit (string-to-number (xelb-node-subnode node)))) + (cl-assert (<= 0 bit 31)) + (ash 1 bit))) + +(defun xelb-parse-enumref (node) + "Parse <enumref>." + (let ((name (concat (xelb-node-attr node 'ref) ":" + (xelb-node-subnode node)))) + (symbol-value (xelb-resolve-type name)))) + +(defun xelb-parse-unop (node) + "Parse <unop>." + (cl-assert (string= "~" (xelb-node-attr node 'op))) + `(lognot ,(xelb-parse-expression (xelb-node-subnode node)))) + +(defun xelb-parse-sumof (node) + "Parse <sumof>." + (let* ((ref (intern (xelb-node-attr-escape node 'ref))) + (expression (xelb-node-subnode node)) + (list-data `(slot-value obj ',ref))) + (if (not expression) + `(apply #'+ ,list-data) + (setq expression (xelb-parse-expression expression)) + `(apply #'+ (mapcar (lambda (i) + (eval ',expression (list (nconc '(obj) i)))) + ,list-data))))) + +(defun xelb-parse-popcount (node) + "Parse <popcount>." + (let ((expression (xelb-parse-expression (xelb-node-subnode node)))) + `(logcount ,expression))) + +(defun xelb-parse-listelement-ref (_node) + "Parse <listelement-ref>." + 'obj) ;a list element is internally named 'obj' + +;;;; The entry + +(setq debug-on-error t) +(setq edebug-all-forms t) + +(if (not argv) + (error "Usage: xelb-gen <protocol.xml> [additional_load_paths]") + (add-to-list 'load-path default-directory) + (dolist (i (cdr argv)) + (add-to-list 'load-path i)) + (require 'xcb-types) + (xelb-parse (car argv))) + +;;; xelb-gen ends here |