├── LICENSE ├── README.org ├── cl-gobject-introspection-wrapper.asd ├── desc.lisp ├── macro.lisp ├── package.lisp └── util.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: cl-gobject-introspection-wrapper 2 | This library converts the elements from GObject Introspection into Lisp-style definitions, based on [[https://github.com/andy128k/cl-gobject-introspection][cl-gobject-introspection]]. 3 | * Usage 4 | It's very easy to create a binding to a new GObject-based library via ~cl-gobject-introspection-wrapper~: 5 | 1. Clone this repository into the folder ~local-projects~ under your Quicklisp installation root, then load the library with ~(ql:quickload :cl-gobject-introspection-wrapper)~. 6 | 2. Create a package to store the auto-generated symbols from GIR. To avoid potential symbol conflicts, 7 | we write the ~defpackage~ with an empty ~:use~ clause: 8 | #+BEGIN_SRC lisp 9 | (cl:defpackage gtk (:use)) 10 | #+END_SRC 11 | 3. Use ~gir-wrapper:define-gir-namespace~ to generate all definitions from the GIR namespace: 12 | #+BEGIN_SRC lisp 13 | (gir-wrapper:define-gir-namespace "Gtk") 14 | #+END_SRC 15 | Note that all the definition symbols are exported automatically. 16 | 4. If there exist some definitions whose name is not converted correctly or cause symbol conflicts according to [[Conversion Rules][Conversion Rules]], 17 | you can set up the special variable ~gir-wrapper:*quoted-name-alist*~ to specify the corresponding symbol for a definition. 18 | This could also exclude some definitions by specifying the symbols to ~cl:nil~ so that you can define them by hand later: 19 | #+BEGIN_SRC lisp 20 | (cltl2:compiler-let (gir-wrapper:*quoted-name-alist* 21 | '((("TextBuffer" . "get_insert") . text-buffer-get-insert) ; Specify a symbol for class method 22 | ("CSET_a_2_z" . +cset-a-z-lower-case+) ; Specify a symbol for function, constant, enumeration, class, interface, struct, or function argument. 23 | (("Widget" . "is_sensitive") . cl:nil) ; Exclude a class method. 24 | ("String" . cl:nil))) ; Exclude a function, constant, enumeration, class, struct, or interface. 25 | (gir-wrapper:define-gir-namespace "Gtk" "4.0")) 26 | #+END_SRC 27 | For portability consideration, we set the variable before ~gir-wrapper:define-gir-namespace~, then reset it after that, to avoid using the ~compiler-let~ in CLTL2: 28 | #+BEGIN_SRC lisp 29 | (cl:eval-when (:execute :compile-toplevel :load-toplevel) 30 | (cl:setf gir-wrapper:*quoted-name-alist* '((("TextBuffer" . "get_insert") . text-buffer-get-insert) 31 | ("CSET_a_2_z" . +cset-a-z-lower-case+) 32 | (("Widget" . "is_sensitive") . cl:nil) 33 | ("Widget")))) 34 | 35 | (gir-wrapper:define-gir-namespace "Gtk" "4.0") 36 | 37 | (cl:eval-when (:execute :compile-toplevel :load-toplevel) 38 | (cl:setf gir-wrapper:*quoted-name-alist* '())) 39 | #+END_SRC 40 | * Conversion Rules 41 | In our rule definitions: 42 | - ~*~ is a placeholder that stands for any type. 43 | - ~[]~ denote an optional part of the name. 44 | - ~/~ splits multiple optional words. 45 | ** Class 46 | | GIR definition | Lisp definition | 47 | |----------------+-------------------------------------------------------| 48 | | ~Foo~ | ~(progn (defun foop (instance)) (deftype foo ()))~ | 49 | | ~FOOBar~ | ~(progn (defun foo-bar-p (instance)) (deftype foo-bar ()))~ | 50 | ** Constructor 51 | | GIR definition | Lisp definition | 52 | |-------------------------------------------------------------------------------+---------------------------------------| 53 | | ~Foo new/create[_from/for/with_bar](* arg1, * arg2, ...)~ | ~(defun make-foo (&key arg1 arg2 ...))~ | 54 | | ~Foo new/create_from/for/with_bar(* arg)~ if ~arg~ is used by another constructor | ~(defun make-foo (&key bar))~ | 55 | Note that the constructors with identical name after conversion will be merged into a single Lisp function, 56 | and which constructor to be called is determined by the arguments provided for this function. 57 | ** Function/Method 58 | In class/interface/struct ~Foo~: 59 | | GIR definition | Lisp definition | 60 | |------------------------------------+---------------------------------------------------| 61 | | ~void set_bar(*)~ | ~(defun (setf foo-bar) (value instance))~ | 62 | | ~* get_bar()~ | ~(defun foo-bar (instance)))~ | 63 | | ~* set_bar[_is_baz](boolean)~ | ~(defun (setf foo-bar[-baz]-p) (value instance))~ | 64 | | ~boolean [bar_]is_baz()~ | ~(defun foo[-bar]-baz-p (instance))~ | 65 | | ~boolean get[_bar_is]_baz()~ | ~(defun foo[-bar]-baz-p (instance))~ | 66 | | ~boolean [bar_]has/should/can_baz()~ | ~(defun foo-[bar-]has/should/can-baz-p (instance))~ | 67 | | ~* bar(* arg1, * arg2, ...)~ | ~(defun foo-bar (instance arg1 arg2 ...))~ | 68 | ** Constant 69 | | GIR definition | Lisp definition | 70 | |----------------+----------------------------------------------------------| 71 | | ~FOO_BAR = 123~ | ~(alexandria:define-constant +​foo-bar​+ 123 :test #'equal)~ | 72 | ** Enumeration 73 | | GIR definition | Lisp definition | 74 | |-----------------------+-----------------------------------------------------------------| 75 | | ~Foo { Bar, Baz, ... }~ | ~(progn (defconstant +​foo-bar​+ 0) (defconstant +​foo-baz​+ 1) ...)~ | 76 | -------------------------------------------------------------------------------- /cl-gobject-introspection-wrapper.asd: -------------------------------------------------------------------------------- 1 | (defsystem cl-gobject-introspection-wrapper 2 | :version "1.0.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "lgpl3" 6 | :description "Wrap and call GObject Introspection FFI function in LISP style, based on cl-gobject-introspection." 7 | :homepage "https://github.com/BohongHuang/cl-gobject-introspection-wrapper" 8 | :bug-tracker "https://github.com/BohongHuang/cl-gobject-introspection-wrapper/issues" 9 | :source-control (:git "https://github.com/BohongHuang/cl-gobject-introspection-wrapper.git") 10 | :serial t 11 | :components ((:file "package") 12 | (:file "util") 13 | (:file "desc") 14 | (:file "macro")) 15 | :depends-on (#:alexandria #:cl-gobject-introspection #:cl-ppcre)) 16 | 17 | (uiop:register-image-dump-hook 18 | (lambda () 19 | (setf (symbol-value (find-symbol "*NAMESPACE-CACHE*" :gir)) 20 | (make-hash-table :test #'equal)))) 21 | -------------------------------------------------------------------------------- /desc.lisp: -------------------------------------------------------------------------------- 1 | ;;;; desc.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (in-package #:gir-wrapper) 19 | 20 | (defparameter *namespace* nil) 21 | 22 | (defparameter *class* nil) 23 | 24 | (defparameter *quoted-name-alist* nil) 25 | 26 | (defun quoted-name-symbol (name) 27 | (multiple-value-bind (value exists-p) (assoc-value *quoted-name-alist* name :test #'equal) 28 | (when (and (not value) exists-p) 29 | (throw 'skip nil)) 30 | value)) 31 | 32 | (defun camel-case->lisp-name (phrase) 33 | (string-right-trim "-" (nstring-upcase (cl-ppcre:regex-replace-all "((?lisp-symbol (phrase) 36 | (intern (string-upcase (camel-case->lisp-name phrase)))) 37 | 38 | (defun underscores->lisp-name (phrase) 39 | (substitute #\- #\_ phrase)) 40 | 41 | (defun underscores->lisp-symbol (phrase &optional case-sensitive-p) 42 | (intern (funcall (if case-sensitive-p #'identity #'string-upcase) (underscores->lisp-name phrase)))) 43 | 44 | (defun callable-desc-argument-names (desc) 45 | (let ((argument-name-case-sensitive-p nil)) 46 | (flet ((desc-args () 47 | (mapcar 48 | (lambda (desc) 49 | (let ((name (gir:name-of desc))) 50 | (or (quoted-name-symbol name) (underscores->lisp-symbol name argument-name-case-sensitive-p)))) 51 | (gir:arguments-desc-of desc)))) 52 | (let ((args (desc-args))) 53 | (unless (= (length (remove-duplicates args)) (length args)) 54 | (setf argument-name-case-sensitive-p t 55 | args (desc-args))) 56 | (values args))))) 57 | 58 | (defun transform-class-desc (desc &optional (namespace *namespace*) (class *class*)) 59 | (catch 'skip 60 | (let* ((class-symbol (or (quoted-name-symbol class) (camel-case->lisp-symbol class))) 61 | (pred-symbol (symbolicate class-symbol (if (find #\- (symbol-name class-symbol)) '#:-p '#:p)))) 62 | `((defun ,pred-symbol (instance) 63 | (class-instance-p instance (gir:nget ,namespace ,class))) 64 | (deftype ,class-symbol () 65 | '(satisfies ,pred-symbol)) 66 | (defmethod gir-wrapper:pointer-object (pointer (type (eql ',class-symbol))) 67 | (declare (ignore type)) 68 | (make-instance ',(etypecase desc 69 | (gir::object-class 'gir::object-instance) 70 | (gir::struct-class 'gir::struct-instance)) 71 | :class (gir:nget ,namespace ,class) 72 | :this pointer)))))) 73 | 74 | (defun transform-interface-desc (desc &optional (namespace *namespace*) (class *class*)) 75 | (declare (ignore desc)) 76 | (catch 'skip 77 | (let* ((interface-symbol (or (quoted-name-symbol class) (camel-case->lisp-symbol class))) 78 | (pred-symbol (symbolicate interface-symbol (if (find #\- (symbol-name interface-symbol)) '#:-p '#:p)))) 79 | `((defun ,pred-symbol (instance) 80 | (interface-instance-p instance (gir:nget ,namespace ,class))) 81 | (deftype ,interface-symbol () 82 | '(satisfies ,pred-symbol)))))) 83 | 84 | (defparameter +getter-pattern-1-base+ "(?:(.+?(?=\\bIS\\b))?(?:IS-)?(.+))") ; xxx_is_xxx, xxx 85 | 86 | (defparameter +getter-pattern-1+ (format nil "(?:(.*?(?=\\b(?:GET|IS)\\b))(?:GET-|IS-)~A)" +getter-pattern-1-base+)) ; get_xxx_is_xxx, get_xxx, is_xxx, get_is_xxx 87 | 88 | (defparameter +getter-pattern-2+ "(.*?(?=\\b(?:HAS|SHOULD|CAN)\\b)(?:HAS|SHOULD|CAN)-.+)") ; xxx_should_xxx, xxx_has_xxx, has_xxx, should_xxx 89 | 90 | (defparameter +getter-pattern+ (format nil "(?:~A|~A)" +getter-pattern-1+ +getter-pattern-2+)) 91 | 92 | (defparameter +setter-pattern+ (format nil "(?:SET-(?:~A|~A))" +getter-pattern-1-base+ +getter-pattern-2+)) 93 | 94 | (defparameter +constructor-pattern+ "^(NEW|CREATE)(-WITH|-FROM|-FOR|$)?(-.+|$)") 95 | 96 | (defun scan-to-string (regex target-string) 97 | (multiple-value-bind (match-string groups) (ppcre:scan-to-strings regex target-string) 98 | (when (and match-string (= (length match-string) (length target-string))) 99 | (loop :with string := (make-string (loop :for group :across groups :summing (length group))) 100 | :for i := 0 :then (+ i (length group)) 101 | :for group :across groups 102 | :if group 103 | :do (loop :for char :across group 104 | :for j :from 0 105 | :do (setf (aref string (+ i j)) char)) 106 | :finally (return string))))) 107 | 108 | (defun transform-method-desc (desc &optional (namespace *namespace*) (class *class*)) 109 | (declare (ignore namespace)) 110 | (catch 'skip 111 | (let* ((info (gir::info-of desc)) 112 | (name (nstring-upcase (underscores->lisp-name (gir:info-get-name info)))) 113 | (symbol (intern name)) 114 | (args (callable-desc-argument-names desc)) 115 | (arg-types (mapcar #'gir:type-desc-of (gir:arguments-desc-of desc))) 116 | (ret-types (mapcar #'gir:type-desc-of (gir:returns-desc-of desc))) 117 | (class-name (or (quoted-name-symbol class) (camel-case->lisp-symbol class))) 118 | (proc-arg-fn (loop :for (arg-text arg-len) :on args ; (const char* text, int len, ...) -> (text ... &aux (len (length text))) 119 | :for (arg-text-type arg-len-type) :on arg-types 120 | :for i :from 0 121 | :when (and (eql arg-len-type 'integer) 122 | (eql arg-text-type 'string) 123 | (member (symbol-name arg-len) '("LENGTH" "LEN") :test #'string-equal)) 124 | :return (lambda (args) 125 | (loop :for arg :in args 126 | :for j :from 0 127 | :when (/= (1+ i) j) 128 | :collect arg :into result-args 129 | :finally (return `(,@result-args &aux (,arg-len (length ,arg-text)))))) 130 | :finally (return #'identity))) 131 | (proc-ret-fn (if (and (eq (car ret-types) :void) (cdr ret-types)) 132 | (lambda (body) 133 | (let ((syms (loop :for tpe :in ret-types :collect (gensym)))) 134 | `(multiple-value-bind ,syms ,body 135 | (declare (ignore ,(car syms))) 136 | (values . ,(cdr syms))))) 137 | #'identity))) 138 | (if-let ((name-symbol (quoted-name-symbol (cons class (gir:info-get-name info))))) 139 | `(defun ,name-symbol (instance ,@args) 140 | ,(funcall proc-ret-fn `(gir:invoke (instance ',symbol) ,@args))) 141 | (cond 142 | ((and (not args) 143 | (when-let ((name (scan-to-string +getter-pattern+ name))) 144 | `(defun ,(intern (format nil (if (equal ret-types '(boolean)) "~A-~A-P" "~A-~A") class-name name)) (instance) 145 | ,(funcall proc-ret-fn `(gir:invoke (instance ',symbol))))))) 146 | ((and args 147 | (when-let ((name (scan-to-string +setter-pattern+ name))) 148 | `(defun (setf ,(intern (format nil (if (eql (car arg-types) 'boolean) "~A-~A-P" "~A-~A") class-name name))) (value instance) 149 | (,@(if (cdr args) `(destructuring-bind ,args value) `(symbol-macrolet ((,(car args) value)))) 150 | ,(funcall proc-ret-fn `(gir:invoke (instance ',symbol) ,@args))))))) 151 | (t `(defun ,(intern (format nil "~A-~A" class-name name)) (instance ,@(funcall proc-arg-fn args)) 152 | ,(funcall proc-ret-fn `(gir:invoke (instance ',symbol) ,@args))))))))) 153 | 154 | (defun transform-constructor-desc (desc &optional (namespace *namespace*) (class *class*)) 155 | (catch 'skip 156 | (let* ((info (gir::info-of desc)) 157 | (name (nstring-upcase (underscores->lisp-name (gir:info-get-name info)))) 158 | (symbol (intern name)) 159 | (args (callable-desc-argument-names desc)) 160 | (class-name (or (quoted-name-symbol class) 161 | (camel-case->lisp-symbol class)))) 162 | (let ((body `(gir:invoke (,namespace ,class ',symbol) ,@args))) 163 | (if-let ((name-symbol (quoted-name-symbol (cons class (gir:info-get-name info))))) 164 | (values `(defun ,name-symbol ,args ,body) nil) 165 | (if-let ((method (ppcre:register-groups-bind (verb prep method) (+constructor-pattern+ name) 166 | (declare (ignore verb)) 167 | (if prep (list prep method) (list method))))) 168 | (values `(defun ,(intern (format nil "MAKE~A-~A" 169 | (ecase (length method) 170 | (1 (first method)) 171 | (2 "")) 172 | class-name)) 173 | (&key ,@args) ,body) 174 | (and method 175 | (every (compose #'plusp #'length) method) 176 | (mapcar (lambda (str) (subseq str 1)) method))) 177 | (values `(defun ,(intern (format nil "~A-~A" class-name name)) ,args ,body) nil))))))) 178 | 179 | (defun merge-constructor-forms (forms descs subst-arg-names) 180 | (let ((grouped nil)) 181 | (loop :for (defun-symbol name lambda-list body) :in forms 182 | :for desc :in descs 183 | :for subst-arg-name :in subst-arg-names 184 | :when (eq (car lambda-list) '&key) 185 | :do (pop lambda-list) 186 | :do (push (list desc subst-arg-name body) 187 | (assoc-value (assoc-value grouped name) lambda-list :test #'equal))) 188 | (loop :with unmergeable-constructors 189 | :for (name . arg-groups) :in grouped 190 | :do (setf arg-groups 191 | (mapcan (lambda (arg-group) 192 | (destructuring-bind (args . bodies) arg-group 193 | (if (> (length bodies) 1) 194 | (if (= (length args) 1) 195 | (loop :for (desc subst-arg-name body) :in bodies 196 | :if subst-arg-name 197 | :collect (let ((subst-symbol (intern (lastcar subst-arg-name)))) 198 | `((,subst-symbol) (let ((,(first args) ,subst-symbol)) ,body))) 199 | :into result 200 | :else 201 | :count t :into no-subst-name-count 202 | :and :collect `(,args ,body) :into result 203 | :finally 204 | (assert (<= no-subst-name-count 1)) 205 | (return result)) 206 | (loop :for (desc subst-arg-name body) :in bodies 207 | :if subst-arg-name 208 | :do (let ((*quoted-name-alist* 209 | (cons (let ((name (gir:info-get-name (gir::info-of desc)))) 210 | (cons (cons *class* name) 211 | (intern (format nil "MAKE-~A-~A-~A" 212 | (camel-case->lisp-symbol *class*) 213 | (first subst-arg-name) 214 | (second subst-arg-name))))) 215 | *quoted-name-alist*))) 216 | (push (transform-constructor-desc desc) unmergeable-constructors)) 217 | :else 218 | :collect `(,args ,(third bodies)))) 219 | (mapcar (compose (lambda (body) `(,args ,body)) #'third) bodies)))) 220 | (sort arg-groups #'> :key (compose #'length #'first)))) 221 | :collect `(defun ,name (&key ,@(mapcar (lambda (arg) `(,arg :unspecified)) 222 | (remove-duplicates (loop :for (args body) :in arg-groups 223 | :append args)))) 224 | (cond 225 | ,@(mapcar (lambda (arg-group) 226 | (destructuring-bind (args body) arg-group 227 | `((not (or ,@(mapcar (lambda (arg) `(eql ,arg :unspecified)) args))) ,body))) 228 | arg-groups) 229 | (t (error "Invalid arguments for constructor ~A" ',name)))) 230 | :into merged-constructors 231 | :finally (return (values merged-constructors unmergeable-constructors))))) 232 | 233 | (defun transform-class-function-desc (desc &optional (namespace *namespace*) (class *class*)) 234 | (catch 'skip 235 | (let* ((info (gir::info-of desc)) 236 | (name (nstring-upcase (underscores->lisp-name (gir:info-get-name info)))) 237 | (symbol (intern name)) 238 | (args (callable-desc-argument-names desc)) 239 | (arg-types (mapcar #'gir:type-desc-of (gir:arguments-desc-of desc))) 240 | (ret-types (mapcar #'gir:type-desc-of (gir:returns-desc-of desc))) 241 | (class-name (or (quoted-name-symbol class) 242 | (camel-case->lisp-symbol class))) 243 | (proc-arg-fn (loop :for (arg-text arg-len) :on args ; (const char* text, int len, ...) -> (text ... &aux (len (length text))) 244 | :for (arg-text-type arg-len-type) :on arg-types 245 | :for i :from 0 246 | :when (and (eql arg-len-type 'integer) 247 | (eql arg-text-type 'string) 248 | (member (symbol-name arg-len) '("LENGTH" "LEN") :test #'string-equal)) 249 | :return (lambda (args) 250 | (loop :for arg :in args 251 | :for j :from 0 252 | :when (/= (1+ i) j) 253 | :collect arg :into result-args 254 | :finally (return `(,@result-args &aux (,arg-len (length ,arg-text)))))) 255 | :finally (return #'identity))) 256 | (proc-ret-fn (if (and (eq (car ret-types) :void) (cdr ret-types)) 257 | (lambda (body) 258 | (let ((syms (loop :for tpe :in ret-types :collect (gensym)))) 259 | `(multiple-value-bind ,syms ,body 260 | (declare (ignore ,(car syms))) 261 | (values . ,(cdr syms))))) 262 | #'identity))) 263 | (if-let ((name-symbol (quoted-name-symbol (cons class (gir:info-get-name info))))) 264 | `(defun ,name-symbol ,args 265 | (gir:invoke (,namespace ,class ',symbol) ,@args)) 266 | (cond 267 | ((and (not args) 268 | (when-let ((name (scan-to-string +getter-pattern+ name))) 269 | `(defun ,(intern (format nil (if (equal ret-types '(boolean)) "~A-~A-P" "~A-~A") class-name name)) () 270 | ,(funcall proc-ret-fn `(gir:invoke (,namespace ,class ',symbol))))))) 271 | ((and args 272 | (when-let ((name (scan-to-string +setter-pattern+ name))) 273 | `(defun (setf ,(intern (format nil (if (eql (car arg-types) 'boolean) "~A-~A-P" "~A-~A") class-name name))) (value) 274 | (,@(if (cdr args) `(destructuring-bind ,args value) `(symbol-macrolet ((,(car args) value)))) 275 | ,(funcall proc-ret-fn `(gir:invoke (,namespace ,class ',symbol) ,@args))))))) 276 | (t `(defun ,(intern (format nil "~A-~A" class-name name)) ,(funcall proc-arg-fn args) 277 | ,(funcall proc-ret-fn `(gir:invoke (,namespace ,class ',symbol) ,@args))))))))) 278 | 279 | (defun transform-function-desc (desc &optional (namespace *namespace*) (class *class*)) 280 | (declare (ignore class)) 281 | (catch 'skip 282 | (let* ((info (gir::info-of desc)) 283 | (name (nstring-upcase (underscores->lisp-name (gir:info-get-name info)))) 284 | (symbol (intern name)) 285 | (args (callable-desc-argument-names desc)) 286 | (arg-types (mapcar #'gir:type-desc-of (gir:arguments-desc-of desc))) 287 | (ret-type (gir:type-desc-of (car (gir:returns-desc-of desc))))) 288 | (if-let ((name-symbol (quoted-name-symbol (gir:info-get-name info)))) 289 | `(defun ,name-symbol ,args 290 | (gir:invoke (,namespace ',symbol) ,@args)) 291 | (cond 292 | ((and (not args) 293 | (when-let ((name (scan-to-string +getter-pattern+ name))) 294 | `(defun ,(intern (format nil (if (eql ret-type 'boolean) "~A-P" "~A") name)) () 295 | (gir:invoke (,namespace ',symbol)))))) 296 | ((and args 297 | (when-let ((name (scan-to-string +setter-pattern+ name))) 298 | `(defun (setf ,(intern (format nil (if (eql (car arg-types) 'boolean) "~A-P" "~A") name))) (value) 299 | (,@(if (cdr args) `(destructuring-bind ,args value) `(symbol-macrolet ((,(car args) value)))) 300 | (gir:invoke (,namespace ',symbol) ,@args)))))) 301 | (t `(defun ,(intern (format nil "~A" name)) ,args 302 | (gir:invoke (,namespace ',symbol) ,@args)))))))) 303 | 304 | (defun transform-enum-desc (desc &optional (namespace *namespace*) (class *class*)) 305 | (declare (ignore namespace)) 306 | (catch 'skip 307 | `(defconstant ,(or (quoted-name-symbol (cons class (car desc))) 308 | (intern (format nil "+~A-~A+" 309 | (or (quoted-name-symbol class) 310 | (camel-case->lisp-symbol class)) 311 | (underscores->lisp-symbol (car desc))))) 312 | ,(cdr desc)))) 313 | 314 | (defun transform-constant-desc (desc &optional (namespace *namespace*) (class *class*)) 315 | (declare (ignore class)) 316 | (catch 'skip 317 | `(define-constant ,(or (quoted-name-symbol desc) 318 | (symbolicate '#:+ (underscores->lisp-symbol desc) '#:+)) 319 | (handler-case (gir:nget ,namespace ,desc) 320 | (warning ())) 321 | :test #'equal))) 322 | -------------------------------------------------------------------------------- /macro.lisp: -------------------------------------------------------------------------------- 1 | ;;;; macro.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (in-package #:gir-wrapper) 19 | 20 | (defun defun-form->symbol (form) 21 | (setf form (second form)) 22 | (etypecase form 23 | (list (second form)) 24 | (symbol form))) 25 | 26 | (defmacro define-gir-class (name &optional (namespace *namespace*)) 27 | (let ((desc (gir:nget-desc (eval namespace) name)) 28 | (*namespace* namespace) 29 | (*class* name)) 30 | (let ((class (transform-class-desc desc)) 31 | (constructors (loop :for desc :in (gir:list-constructors-desc desc) 32 | :for (form subst-arg-name) := (multiple-value-list (transform-constructor-desc desc)) 33 | :collect form :into forms 34 | :collect subst-arg-name :into subst-arg-names 35 | :collect desc :into descs 36 | :finally (return (merge-constructor-forms forms descs subst-arg-names)))) 37 | (methods (mapcar #'transform-method-desc (gir:list-methods-desc desc))) 38 | (class-functions (when (typep desc 'gir:object-class) 39 | (mapcar #'transform-class-function-desc (gir:list-class-functions-desc desc))))) 40 | `(progn 41 | ,@class 42 | ,@constructors 43 | ,@methods 44 | ,@class-functions 45 | ,(when-let ((symbols (delete-if #'null (mapcar #'defun-form->symbol (append (remove 'gir-wrapper:pointer-object class :key #'second) constructors methods class-functions))))) 46 | `(export ',symbols)))))) 47 | 48 | (defmacro define-gir-interface (name &optional (namespace *namespace*)) 49 | (let ((desc (gir:nget-desc (eval namespace) name)) 50 | (*namespace* namespace) 51 | (*class* name)) 52 | (let ((interface (transform-interface-desc desc)) 53 | (methods (mapcar #'transform-method-desc (gir:list-methods-desc desc)))) 54 | `(progn 55 | ,@interface 56 | ,@methods 57 | ,(when-let ((symbols (delete-if #'null (mapcar #'defun-form->symbol (append interface methods))))) 58 | `(export ',symbols)))))) 59 | 60 | (defmacro define-gir-constant (name &optional (namespace *namespace*)) 61 | (let ((constant (transform-constant-desc name namespace))) 62 | `(progn 63 | ,constant 64 | ,(when constant 65 | `(export ',(second constant)))))) 66 | 67 | (defmacro define-gir-enum (name &optional (namespace *namespace*)) 68 | (let ((*namespace* namespace) 69 | (*class* name)) 70 | (let ((members (mapcar #'transform-enum-desc (gir:values-of (gir:nget-desc (eval namespace) name))))) 71 | `(progn 72 | ,@members 73 | ,(when members `(export ',(delete-if #'null (mapcar #'second members)))))))) 74 | 75 | (defmacro define-gir-function (name &optional (namespace *namespace*)) 76 | (let ((*namespace* namespace) 77 | (*class* name)) 78 | (let ((function (transform-function-desc (gir:nget-desc (eval namespace) name)))) 79 | `(progn 80 | ,function 81 | ,(when-let ((symbol (defun-form->symbol function))) 82 | `(export ',symbol)))))) 83 | 84 | (defmacro define-gir-namespace (name &optional version repository) 85 | (let ((*namespace* (gir:require-namespace name version)) 86 | (namespace-symbol (intern "*NS*"))) 87 | `(progn 88 | (eval-when (:execute :load-toplevel :compile-toplevel) 89 | (defparameter ,namespace-symbol (gir:require-namespace ,name ,version))) 90 | ,@(mapcar (lambda (info) 91 | (let ((name (gir:info-get-name info)) 92 | (type (gir:info-get-type info))) 93 | (switch (type) 94 | (:object `(define-gir-class ,name ,namespace-symbol)) 95 | (:struct (unless (ppcre:all-matches "Iface$" name) 96 | `(define-gir-class ,name ,namespace-symbol))) 97 | (:function `(define-gir-function ,name ,namespace-symbol)) 98 | (:constant `(define-gir-constant ,name ,namespace-symbol)) 99 | (:enum `(define-gir-enum ,name ,namespace-symbol)) 100 | (:flags `(define-gir-enum ,name ,namespace-symbol)) 101 | (:interface `(define-gir-interface ,name ,namespace-symbol))))) 102 | (gir:repository-get-infos repository name))))) 103 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (defpackage gobject-introspection-wrapper 19 | (:use #:cl #:alexandria) 20 | (:nicknames #:gir-wrapper) 21 | (:export #:*quoted-name-alist* 22 | #:*class* 23 | #:*namespace* 24 | #:define-gir-class 25 | #:define-gir-namespace 26 | #:define-gir-constant 27 | #:define-gir-enum 28 | #:define-gir-function 29 | #:pointer-object 30 | #:object-pointer)) 31 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; util.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (in-package #:gir) 19 | 20 | (defmethod info-of ((desc callable-desc)) 21 | (slot-value desc 'info)) 22 | 23 | (in-package #:gir-wrapper) 24 | 25 | (defgeneric pointer-object (pointer type) 26 | (:documentation "Construct GObject from a CFFI pointer.")) 27 | 28 | (eval-when (:compile-toplevel :load-toplevel :execute) 29 | (setf (fdefinition 'object-pointer) (fdefinition 'gir::this-of))) 30 | 31 | (defun subclassp (class-a class-b) 32 | (loop :for class := class-a :then (gir:parent-of class) 33 | :while class 34 | :thereis (gir:info-equal (gir::info-of class) (gir::info-of class-b)))) 35 | 36 | (defun class-instance-p (instance class) 37 | (subclassp (typecase instance 38 | (gir::object-instance (gir:gir-class-of instance)) 39 | (gir::struct-instance (gir::struct-class-of instance)) 40 | (t (return-from class-instance-p nil))) 41 | class)) 42 | 43 | (defun interface-instance-p (instance interface) 44 | (loop :with interface-info := (gir::info-of interface) 45 | :for info :in (gir::interface-infos-of (typecase instance 46 | (gir::object-instance (gir:gir-class-of instance)) 47 | (gir::struct-instance (gir::struct-class-of instance)) 48 | (t (return-from interface-instance-p nil)))) 49 | :thereis (gir:info-equal info interface-info)) ) 50 | --------------------------------------------------------------------------------