├── LICENSE ├── README.org ├── allocator-ecl.lisp ├── allocator.lisp ├── array.lisp ├── cffi-object.asd ├── cffi-object.ops.asd ├── defcfun.lisp ├── definition.lisp ├── global.lisp ├── libc.lisp ├── macros.lisp ├── object.lisp ├── ops.lisp ├── package.lisp ├── pointer.lisp ├── test └── package.lisp └── type.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright 2023 Bohong Huang 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: cffi-object 2 | Fast and convenient foreign object interoperation via CFFI. 3 | * Introduction 4 | When developing projects that heavily use CFFI, interfacing with foreign libraries and managing memory are unavoidable issues. 5 | The following are three commonly used approaches: 6 | 1. Expose raw pointers to the high level code. \\ 7 | This approach is very lightweight and efficient, but it requires programmers to manually manage memory. 8 | Even if macros that expand to ~unwind-protect~ can be used to manage resources with dynamic extent, 9 | it can sometimes make the code style unnatural under some scenarios that don't require deterministic time for resource acquisition and release. 10 | 2. Provide high-level wrapper classes or structs (all the fields are of Lisp's native types) with ~cffi:translate-from/to-foreign~ or ~cffi:expand-from/to-foreign~ defined. \\ 11 | This hands over the memory management to Lisp's GC and makes it more natural when operating data received from or passed to the foreign. 12 | However, for foreign functions that directly accept structs by value, it requires ~cffi-libffi~, which [[https://www.reddit.com/r/lisp/comments/ygebes/passing_c_struct_by_value_cffilibffi_is_250x/][has significant overhead]] under frequent invocations. 13 | CFFI does not automatically call the translation mechanism mentioned above for foreign functions that accept struct pointers as parameters, 14 | so users or library developers need to first allocate memory on the stack using ~with-foreign-object(s)~ (if the Lisp implementation does not support it, it may be allocated on the heap), 15 | and CFFI will perform the conversion with ~cffi:translate-from/to-foreign~ at runtime or ~cffi:expand-from/to-foreign~ at compile-time. 16 | The overhead involved in this process is not negligible for large structs, especially for real-time media processing, gaming, and other CPU intensive applications. 17 | 3. Define structs for each CFFI type, wrap a pointer inside, and selectively use ~trivial-garbage~ to manage the memory. \\ 18 | This approach seems to combine the advantages of the above two methods. In most cases, programmers don't need to concern themselves with memory. 19 | Except for making the timing of resource release uncertain and putting some potential pressure on the GC, 20 | it has good performance because many implementations (such as SBCL and ECL) operate foreign memory efficiently. 21 | Additionally, this approach does not have the overhead brought by ~cffi:translate-from/to-foreign~ or ~cffi:expand-from/to-foreign~, 22 | making it ideal for applications that require frequent calls to foreign functions, 23 | such as calling foreign functions for SIMD-accelerated matrix calculations or outputting audio buffers to audio devices. 24 | 25 | ~cffi-object~ adopts the third approach above and provides a uniform way to directly convert existing CFFI type definitions (which can be generated by autowrapping tools like [[https://github.com/borodust/claw][claw]]) 26 | into Lisp's struct and function definitions, allowing you to operate on foreign data types as if they were native types in Lisp, without having to write glue code by hand. 27 | 28 | ~cffi-object~ should run on any implementation that supports [[https://github.com/cffi/cffi][CFFI]] and [[https://github.com/trivial-garbage/trivial-garbage][trivial-garbage]]. 29 | To test the system, simply eval ~(asdf:test-system :cffi-object)~ in the REPL. 30 | * Features 31 | - *Generate CLOS classes for foreign types and use them as if they are native Lisp types* \\ 32 | You can generate the structure definition for a existing CFFI type: 33 | 34 | #+BEGIN_SRC lisp 35 | (cffi:defcstruct vector2 36 | (x :float) 37 | (y :float)) 38 | 39 | (cobj:define-cobject-class (vector2 (:struct vector2))) 40 | #+END_SRC 41 | 42 | Or you can generate structure definitions for all the CFFI types declared in a package. 43 | This can be useful if you have an existing library that already defined those CFFI types: 44 | 45 | #+BEGIN_SRC lisp 46 | (cl:defpackage #:mylib 47 | (:use #:cl)) 48 | 49 | (cl:in-package #:mylib) 50 | 51 | (cffi:defcstruct vector2 52 | (x :float) 53 | (y :float)) 54 | 55 | (cffi:defcstruct camera-2d 56 | (offset (:struct vector2)) 57 | (target (:struct vector2)) 58 | (rotation :float) 59 | (zoom :float)) 60 | 61 | (cobj:define-cobject-class #:mylib) 62 | #+END_SRC 63 | 64 | Then you can create or modify objects of these types just like using structs defined with ~defstruct~: 65 | 66 | #+BEGIN_SRC lisp 67 | MYLIB> (make-vector2) 68 | # 69 | MYLIB> ; The memory is unintialized by default 70 | ; No values 71 | MYLIB> (make-vector2 :x 1.0 :y 2.0) 72 | # 73 | MYLIB> (make-camera-2d :offset * :target * :rotation 0.0 :zoom 1.0) 74 | # 76 | :TARGET # 77 | :ROTATION 0.0 78 | :ZOOM 1.0 79 | @0x00007F3C840011B0> 80 | MYLIB> (camera-2d-offset *) 81 | # 82 | MYLIB> (copy-vector2 *) 83 | # 84 | MYLIB> (setf (vector2-x *) 2.0) 85 | 2.0 86 | MYLIB> (copy-vector2 ** ***) ; In-place copy 87 | # 88 | MYLIB> (vector2-equal * ***) 89 | T 90 | #+END_SRC 91 | 92 | You can also define generic methods specialized for these foreign types: 93 | 94 | #+BEGIN_SRC lisp 95 | MYLIB> (defmethod position2 ((camera camera-2d)) (camera-2d-offset camera)) 96 | # 97 | MYLIB> (defmethod position2 ((vector vector2)) vector) 98 | # 99 | MYLIB> (position2 (make-camera-2d)) 100 | # 101 | MYLIB> (position2 (make-vector2)) 102 | # 103 | #+END_SRC 104 | - *Low overhead when interfacing with foreign functions* \\ 105 | All the objects created with ~cffi-object~ are fixed in memory and have the same memory representation as C, 106 | which means that structures can be passed directly to C functions or objects can be created directly 107 | by returning a pointer to a structure from a C function without conversion needed. 108 | 109 | #+BEGIN_SRC lisp 110 | (cl:in-package #:mylib) 111 | 112 | (declaim (inline vector2-add)) 113 | (cffi:defcfun ("__claw_Vector2Add" vector2-add) (:pointer (:struct vector2)) 114 | (%%claw-result- (:pointer (:struct vector2))) 115 | (v1 (:pointer (:struct vector2))) 116 | (v2 (:pointer (:struct vector2)))) 117 | 118 | (let ((v1 (make-vector2 :x 1.0 :y 2.0)) 119 | (v2 (make-vector2 :x 3.0 :y 4.0))) 120 | (vector2-add (cobj:cobject-pointer v1) 121 | (cobj:cobject-pointer v1) 122 | (cobj:cobject-pointer v2)) 123 | v1) ; => # 124 | #+END_SRC 125 | - *Automatic and safe memory management* \\ 126 | All objects created by Lisp are automatically managed by the GC (Garbage Collector), 127 | and any reference to an object or its fields will prevent the memory of that object from being released: 128 | 129 | #+BEGIN_SRC lisp 130 | (let* ((cam (make-camera-2d)) 131 | (vec (camera-2d-offset cam))) 132 | ;; VEC is a reference to the OFFSET field of CAMERA-2D, 133 | ;; which will share memory in a certain region. 134 | vec) ; => # 135 | ;; This is safe because VEC holds a reference to CAM, 136 | ;; which will prevent both GC from collecting CAM and 137 | ;; releasing the corresponding memory. 138 | #+END_SRC 139 | 140 | Exchanging object ownership with C functions is convenient: 141 | 142 | #+BEGIN_SRC lisp 143 | (cl:in-package #:mylib) 144 | 145 | (declaim (inline malloc)) 146 | (cffi:defcfun malloc :pointer ; cffi:foreign-alloc 147 | (size :size)) 148 | 149 | (declaim (inline free)) 150 | (cffi:defcfun free :void ; cffi:foreign-free 151 | (size :pointer)) 152 | 153 | (let* ((vec1 (cobj:manage-cobject ; Take ownership of the object from foreign and responsible for freeing the memory. 154 | (cobj:pointer-cobject 155 | (malloc (cffi:foreign-type-size 156 | '(:struct vector2))) 157 | 'vector2))) 158 | (vec2 (cobj:pointer-cobject ; Share the memory of this object with foreign and not responsible for freeing the memory. 159 | (cobj:cobject-pointer vec1) 160 | 'vector2))) 161 | (assert (vector2-equal vec1 vec2)) 162 | (free (cobj:unmanage-cobject vec1))) ; Transfer ownership of the object to foreign and no longer responsible for freeing its memory. 163 | #+END_SRC 164 | 165 | But when you transfer the deallocation of memory to foreign code, you should be aware that the memory of this object may become invalid at any time 166 | if it is deallocated by the foreign. 167 | - *Bring unboxed struct/array and by-value assignment to Common Lisp* \\ 168 | ~cffi-object~ is capable of creating unboxed structs or arrays, which are fully compatible with C, 169 | so pointers can be directly passed to foreign: 170 | 171 | #+BEGIN_SRC lisp 172 | (cl:in-package #:mylib) 173 | 174 | (cffi:defcstruct named-vector2-buffer 175 | (name :string) 176 | (buffer (:array (:struct vector2) 64)) 177 | (size :size)) 178 | 179 | (cobj:define-cobject-class (:struct named-vector2-buffer)) 180 | #+END_SRC 181 | 182 | #+BEGIN_SRC lisp 183 | MYLIB> (cffi:foreign-type-size '(:struct named-vector2-buffer)) 184 | 528 185 | MYLIB> (make-named-vector2-buffer :name "DEFAULT" :size 0) 186 | # 189 | # 190 | # 191 | # 192 | # 193 | # 194 | # 195 | # 196 | # 197 | # ... [54 elements elided]> 198 | :SIZE 0 199 | @0x00007F3C8400FCC0> 200 | MYLIB> (cobj:cfill (named-vector2-buffer-buffer *) (make-vector2 :x 1.0 :y 2.0)) 201 | #<# 202 | # 203 | # 204 | # 205 | # 206 | # 207 | # 208 | # 209 | # 210 | # ... [54 elements elided]> 211 | MYLIB> (cobj:make-carray 5 :element-type 'vector2 212 | :initial-contents (loop :for i :below 5 213 | :collect (make-vector2 :x (coerce i 'single-float) 214 | :y (coerce i 'single-float)))) 215 | #<# 216 | # 217 | # 218 | # 219 | #> 220 | MYLIB> (cobj:creplace ** *) 221 | #<# 222 | # 223 | # 224 | # 225 | # 226 | # 227 | # 228 | # 229 | # 230 | # ... [54 elements elided]> 231 | #+END_SRC 232 | * Related Projects 233 | - [[https://github.com/digikar99/unboxables][unboxables]] \\ 234 | ~unboxables~ can provide unboxed struct/array features for Common Lisp too, 235 | and it uses a more compact memory layout, which can potentially have lower memory consumption, 236 | while ~cffi-object~ , by default, uses the C memory representation which may have padding between fields, 237 | allowing you to pass pointers to foreign functions directly. 238 | Currently, ~cffi-cobject~ may not have the high-performance array operations that ~unboxables~ provides. 239 | It is more focused on interoperation with foreign anyway. 240 | - [[https://github.com/bohonghuang/cffi-ops][cffi-ops]] \\ 241 | ~cffi-ops~ provides some macros expanded at compile-time, so it doesn't cons and can be used in performance-sensitive functions, 242 | which allows you to implement GC-free and high performance algorithms. 243 | System ~cffi-object.ops~ provides ~cffi-object~ the integration with ~cffi-ops~, which can be enabled by ~(cobj.ops:enable-cobject-ops)~ at compile-time: 244 | 245 | #+BEGIN_SRC lisp 246 | (cl:in-package #:mylib) 247 | 248 | (eval-when (:compile-toplevel :load-toplevel :execute) 249 | (cobj.ops:enable-cobject-ops)) 250 | 251 | (let ((vec1 (make-vector2 :x 1.0 :y 2.0)) 252 | (vec2 (make-vector2 :x 3.0 :y 4.0))) 253 | (clocally (declare (ctype (:object (:struct vector2)) vec1 vec2)) 254 | (vector2-add (& vec1) (& vec1) (& vec2)) 255 | (assert (= (-> vec1 x) 4.0)) 256 | (assert (= (-> (& vec1) y) 6.0)))) 257 | #+END_SRC 258 | -------------------------------------------------------------------------------- /allocator-ecl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defun foreign-alloc/ecl (type) 4 | (ext:with-backend 5 | :bytecodes (si:allocate-foreign-data :void (cffi:foreign-type-size type)) 6 | :c/c++ (ffi:c-inline 7 | (type (cffi:foreign-type-size type)) (:object :fixnum) :object 8 | "ecl_allocate_foreign_data(#0, #1)" 9 | :one-liner t :side-effects t))) 10 | 11 | (defun foreign-free/ecl (ptr) 12 | (declare (ignorable ptr)) 13 | (ext:with-backend :bytecodes (cffi:foreign-free ptr) :c/c++ (progn))) 14 | 15 | (defun setup-ecl-allocator () 16 | (setf *default-cobject-allocator* 17 | (make-cobject-allocator 18 | :allocator #'foreign-alloc/ecl 19 | :deallocator #'foreign-free/ecl) 20 | *cobject-allocator* *default-cobject-allocator* 21 | (fdefinition 'manage-cobject) 22 | (let ((manage-cobject (fdefinition 'manage-cobject))) 23 | (named-lambda manage-cobject/ecl (cobject) 24 | (ext:with-backend 25 | :bytecodes (funcall manage-cobject cobject) 26 | :c/c++ (if (eq (cobject-allocator-deallocator *cobject-allocator*) #'foreign-free/ecl) 27 | cobject (funcall manage-cobject cobject))))) 28 | (fdefinition 'unmanage-cobject) 29 | (let ((unmanage-cobject (fdefinition 'unmanage-cobject))) 30 | (named-lambda unmanage-cobject/ecl (cobject) 31 | (if (ext:get-finalizer cobject) 32 | (funcall unmanage-cobject cobject) 33 | (warn "Object ~A has no finalizer, so its memory cannot be unmanaged." cobject)) 34 | (cobject-pointer cobject))))) 35 | 36 | (setup-ecl-allocator) 37 | -------------------------------------------------------------------------------- /allocator.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (declaim (inline make-cobject-allocator)) 4 | (defstruct cobject-allocator 5 | (allocator (constantly (cffi:null-pointer)) :type (function (cffi::foreign-type) (values cffi:foreign-pointer))) 6 | (deallocator #'values :type (function (cffi:foreign-pointer)))) 7 | 8 | (declaim (type cobject-allocator *default-cobject-allocator*)) 9 | (defparameter *default-cobject-allocator* (make-cobject-allocator 10 | :allocator (lambda (type) (cffi-sys:%foreign-alloc (cffi:foreign-type-size type))) 11 | :deallocator #'cffi-sys:foreign-free)) 12 | 13 | (declaim (type cobject-allocator *cobject-allocator*)) 14 | (defparameter *cobject-allocator* *default-cobject-allocator*) 15 | 16 | (declaim (inline make-leaky-allocator)) 17 | (defun make-leaky-allocator (&key (allocator (cobject-allocator-allocator *cobject-allocator*)) (deallocator #'values)) 18 | (make-cobject-allocator :allocator allocator :deallocator deallocator)) 19 | 20 | (defmacro with-leaky-allocator (&body body) 21 | (with-gensyms (allocator) 22 | `(let ((,allocator (make-leaky-allocator))) 23 | (declare (dynamic-extent ,allocator)) 24 | (let ((*cobject-allocator* ,allocator)) . ,body)))) 25 | 26 | (declaim (inline %make-sized-monotonic-buffer-allocator)) 27 | (defstruct (sized-monotonic-buffer-allocator (:include cobject-allocator) (:constructor %make-sized-monotonic-buffer-allocator)) 28 | (pointer (cffi:null-pointer) :type cffi:foreign-pointer) 29 | (size 0 :type non-negative-fixnum) 30 | (offset 0 :type non-negative-fixnum)) 31 | 32 | (declaim (inline make-sized-monotonic-buffer-allocator)) 33 | (defun make-sized-monotonic-buffer-allocator (&key (pointer (cffi:null-pointer)) (size 0) (upstream *cobject-allocator*)) 34 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) 35 | (let* ((allocator-1 nil) 36 | (allocator-2 (%make-sized-monotonic-buffer-allocator :allocator (lambda (type &aux (size (cffi:foreign-type-size type)) (align (cffi:foreign-type-alignment type))) 37 | (declare (type non-negative-fixnum size align)) 38 | (with-accessors ((offset sized-monotonic-buffer-allocator-offset) 39 | (buffer-size sized-monotonic-buffer-allocator-size) 40 | (pointer sized-monotonic-buffer-allocator-pointer) 41 | (allocator sized-monotonic-buffer-allocator-allocator) 42 | (deallocator sized-monotonic-buffer-allocator-deallocator)) 43 | allocator-1 44 | (let ((align-offset (mod (- align offset) align))) 45 | (if (<= (+ offset align-offset size) buffer-size) 46 | (prog1 (cffi:inc-pointer pointer (incf offset align-offset)) 47 | (incf offset size)) 48 | (if upstream 49 | (prog1 (funcall (cobject-allocator-allocator upstream) type) 50 | (setf offset buffer-size) 51 | (setf deallocator (cobject-allocator-deallocator upstream))) 52 | (error "Cannot allocate a space of ~D byte~:P with allocator ~A." size allocator-1)))))) 53 | :deallocator #'values :size size :pointer pointer))) 54 | (setf allocator-1 allocator-2) 55 | allocator-2)) 56 | 57 | (defmacro with-monotonic-buffer-allocator ((&key 58 | buffer pointer 59 | (size (if buffer `(length ,buffer) 128)) 60 | (upstream '*cobject-allocator*) 61 | (values '#'values)) 62 | &body body) 63 | (with-gensyms (buffer-var pointer-var size-var allocator) 64 | (flet ((wrap-with-buffer-var (form) 65 | (cond 66 | (buffer `(let ((,buffer-var ,buffer)) ,form)) 67 | (pointer form) 68 | (t `(let ((,buffer-var (cffi:make-shareable-byte-vector ,size-var))) 69 | (declare (dynamic-extent ,buffer-var)) ,form)))) 70 | (wrap-with-pointer-var (form) 71 | (if pointer 72 | `(let ((,pointer-var ,pointer)) ,form) 73 | `(cffi:with-pointer-to-vector-data (,pointer-var ,buffer-var) ,form)))) 74 | `(let ((,size-var ,size)) 75 | ,(wrap-with-buffer-var 76 | (wrap-with-pointer-var 77 | `(let ((,allocator (make-sized-monotonic-buffer-allocator :pointer ,pointer-var :size ,size-var :upstream ,upstream))) 78 | (declare (dynamic-extent ,allocator)) 79 | (multiple-value-call ,values 80 | (let ((*cobject-allocator* ,allocator)) 81 | ,@body))))))))) 82 | 83 | (defmacro with-default-allocator (&body body) 84 | `(let ((*cobject-allocator* *default-cobject-allocator*)) 85 | ,@body)) 86 | -------------------------------------------------------------------------------- /array.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defstruct (carray (:include cpointer) 4 | (:constructor %make-carray)) 5 | (dimensions '(0) :type (cons fixnum null))) 6 | 7 | (defmethod cobject-type ((array carray)) 8 | `(carray ,(carray-element-type array) ,(carray-dimensions array))) 9 | 10 | (defun cpointer-carray (cpointer dimensions) 11 | (%make-carray :pointer (cpointer-pointer cpointer) 12 | :shared-from (cpointer-shared-from cpointer) 13 | :element-type (cpointer-element-type cpointer) 14 | :dimensions (ensure-cons dimensions))) 15 | 16 | (defun caref (array &rest subscripts &aux (subscript (first subscripts))) 17 | (unless (<= 0 subscript (1- (first (carray-dimensions array)))) 18 | (error "Index ~D is out of bound." subscript)) 19 | (cref array subscript)) 20 | 21 | (defun (setf caref) (value array &rest subscripts &aux (subscript (first subscripts))) 22 | (unless (<= 0 subscript (1- (first (carray-dimensions array)))) 23 | (error "Index ~D is out of bound." subscript)) 24 | (setf (cref array subscript) value)) 25 | 26 | (declaim (inline clength) 27 | (ftype (function (carray) non-negative-fixnum) clength)) 28 | (defun clength (carray) 29 | (first (carray-dimensions carray))) 30 | 31 | (defgeneric ccoerce (cobject type)) 32 | 33 | (defgeneric (setf ccoerce) (value cobject type)) 34 | 35 | (defmethod ccoerce ((array carray) (type (eql 'list))) 36 | (declare (ignore type)) 37 | (loop :for i :below (clength array) 38 | :collect (caref array i))) 39 | 40 | (defmethod ccoerce ((cobject cobject) (type list)) 41 | (ccoerce cobject (car type))) 42 | 43 | (defmethod ccoerce ((array carray) (type (eql 'simple-vector))) 44 | (declare (ignore type)) 45 | (make-array (clength array) :initial-contents (ccoerce array 'list))) 46 | 47 | (defmethod ccoerce ((array carray) (type (eql 'simple-array))) 48 | (declare (ignore type)) 49 | (if (symbolp (carray-element-type array)) 50 | (make-array (clength array) :element-type (carray-element-type array) 51 | :initial-contents (ccoerce array 'list)) 52 | (ccoerce array 'simple-vector))) 53 | 54 | (defmethod ccoerce ((array carray) (type (eql 'vector))) 55 | (declare (ignore type)) 56 | (ccoerce array 'simple-array)) 57 | 58 | (defmethod ccoerce ((array carray) (type (eql 'array))) 59 | (declare (ignore type)) 60 | (ccoerce array 'simple-array)) 61 | 62 | (defmethod ccoerce ((array carray) (type (eql 'string))) 63 | (declare (ignore type)) 64 | (cffi:foreign-string-to-lisp (carray-pointer array))) 65 | 66 | (defmethod (setf ccoerce) ((value string) (array carray) (type (eql 'string))) 67 | (declare (ignore type)) 68 | (cffi:lisp-string-to-foreign value (carray-pointer array) (clength array))) 69 | 70 | (defmethod print-object ((array carray) stream) 71 | (if *print-readably* 72 | (progn 73 | (format stream "#.") 74 | (prin1 75 | `(make-carray 76 | ',(carray-dimensions array) 77 | :element-type ',(carray-element-type array) 78 | :initial-contents ',(ccoerce array 'array)) 79 | stream)) 80 | (print-unreadable-object (array stream) 81 | (loop :named print-element-loop 82 | :with length := (first (carray-dimensions array)) 83 | :initially 84 | (case (carray-element-type array) 85 | (character (ignore-errors 86 | (return-from print-element-loop 87 | (print-object (ccoerce array 'string) stream))))) 88 | :for i :below length 89 | :if (< i 10) 90 | :unless (zerop i) 91 | :do (format stream "~% ") 92 | :end 93 | :and :do (prin1 (caref array i) stream) 94 | :else 95 | :return (format stream " ... [~D elements elided]" (- length 10)))))) 96 | 97 | (defstruct (displaced-carray (:include carray) 98 | (:constructor %make-displaced-carray)) 99 | (displaced-index-offset 0 :type fixnum)) 100 | 101 | (defun displaced-carray-displaced-to (instance) 102 | (displaced-carray-shared-from instance)) 103 | 104 | (defun carray-displacement (array) 105 | (typecase array 106 | (displaced-carray 107 | (values (displaced-carray-displaced-to array) 108 | (displaced-carray-displaced-index-offset array))) 109 | (t (values nil nil)))) 110 | 111 | (defun make-carray (dimensions 112 | &key element-type 113 | initial-element initial-contents 114 | displaced-to 115 | (displaced-index-offset 0)) 116 | (let* ((dimensions (ensure-cons dimensions)) 117 | (primitive-type-p (primitive-type-p element-type)) 118 | (pointer-type-p (and (listp element-type) (eq (first element-type) 'cpointer))) 119 | (character-type-p (eq element-type 'character)) 120 | (element-foreign-type (nth-value 1 (cobject-class-definition element-type))) 121 | (element-size (cffi:foreign-type-size element-foreign-type)) 122 | (total-size (* element-size (reduce #'* dimensions))) 123 | (pointer (if displaced-to (cffi:inc-pointer (cobject-pointer displaced-to) (* element-size displaced-index-offset)) 124 | (funcall (cobject-allocator-allocator *cobject-allocator*) (make-instance 'cffi::foreign-array-type 125 | :element-type element-foreign-type 126 | :dimensions dimensions)))) 127 | (array (if displaced-to 128 | (progn 129 | (assert (<= 0 displaced-index-offset (+ displaced-index-offset (first dimensions)) (first (carray-dimensions displaced-to)))) 130 | (assert (cobject-type= element-type (carray-element-type displaced-to))) 131 | (%make-displaced-carray :pointer pointer 132 | :dimensions dimensions 133 | :element-type element-type 134 | :shared-from displaced-to 135 | :displaced-index-offset displaced-index-offset)) 136 | (manage-cobject (%make-carray :pointer pointer 137 | :dimensions dimensions 138 | :element-type element-type))))) 139 | (declare (type non-negative-fixnum element-size total-size) 140 | (type (cons non-negative-fixnum t) dimensions)) 141 | (when initial-element 142 | (assert (null initial-contents)) 143 | (assert (null displaced-to)) 144 | (cond 145 | (character-type-p 146 | (memset pointer (char-code initial-element) total-size)) 147 | (primitive-type-p 148 | (loop :for i :of-type fixnum :below (first dimensions) 149 | :do (setf (cffi:mem-aref pointer primitive-type-p i) initial-element))) 150 | (pointer-type-p 151 | (loop :for i :of-type fixnum :below (first dimensions) 152 | :do (setf (cffi:mem-aref pointer :pointer i) (cobject-pointer initial-element)))) 153 | (t (loop :with src := (cobject-pointer initial-element) 154 | :for i :of-type fixnum :below (first dimensions) 155 | :do (memcpy (cffi:inc-pointer pointer (* i element-size)) src element-size))))) 156 | (when initial-contents 157 | (assert (null initial-element)) 158 | (assert (null displaced-to)) 159 | (etypecase initial-contents 160 | (carray 161 | (assert (equal dimensions (carray-dimensions initial-contents))) 162 | (memcpy pointer (cobject-pointer initial-contents) total-size)) 163 | (sequence 164 | (unless character-type-p 165 | (assert (= (first dimensions) (length initial-contents)))) 166 | (let ((i 0)) 167 | (declare (type non-negative-fixnum i)) 168 | (map nil (cond 169 | (character-type-p 170 | (cffi:lisp-string-to-foreign (coerce initial-contents 'string) pointer total-size) 171 | (return-from make-carray array)) 172 | (primitive-type-p 173 | (lambda (object) 174 | (setf (cffi:mem-aref pointer primitive-type-p i) object) 175 | (incf i))) 176 | (pointer-type-p 177 | (lambda (object) 178 | (setf (cffi:mem-aref pointer :pointer i) (cobject-pointer object)) 179 | (incf i))) 180 | (t (lambda (object) 181 | (memcpy (cffi:inc-pointer pointer (* i element-size)) 182 | (cobject-pointer object) element-size) 183 | (incf i)))) 184 | initial-contents))))) 185 | array)) 186 | 187 | (defun pointer-carray (pointer element-type dimensions) 188 | (unless (listp dimensions) (setf dimensions (list dimensions))) 189 | (%make-carray :pointer pointer :dimensions dimensions :element-type element-type)) 190 | 191 | (defun creplace (target-carray1 source-carray2 192 | &key 193 | (start1 0) (end1 (clength target-carray1)) 194 | (start2 0) (end2 (clength source-carray2))) 195 | (assert (cobject-type= (carray-element-type target-carray1) (carray-element-type source-carray2))) 196 | (assert (<= 0 (- end2 start2) (- end1 start1))) 197 | (let ((element-size (cobject-class-object-size (carray-element-type target-carray1)))) 198 | (memcpy (cffi:inc-pointer (cobject-pointer target-carray1) (* start1 element-size)) 199 | (cffi:inc-pointer (cobject-pointer source-carray2) (* start2 element-size)) 200 | (* (- end2 start2) element-size)) 201 | target-carray1)) 202 | 203 | (defun cfill (carray item &key (start 0) (end (clength carray))) 204 | (loop :for i :from start :below end 205 | :do (setf (caref carray i) item) 206 | :finally (return carray))) 207 | 208 | (defun carray-equal (array1 array2) 209 | (unless (= (clength array1) (clength array2)) 210 | (return-from carray-equal nil)) 211 | (cpointer-equal array1 array2 (clength array1))) 212 | -------------------------------------------------------------------------------- /cffi-object.asd: -------------------------------------------------------------------------------- 1 | (defsystem cffi-object 2 | :version "1.0.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "Apache-2.0" 6 | :description "A Common Lisp library that enables fast and convenient interoperation with foreign objects." 7 | :homepage "https://github.com/bohonghuang/cffi-object" 8 | :bug-tracker "https://github.com/bohonghuang/cffi-object/issues" 9 | :source-control (:git "https://github.com/bohonghuang/cffi-object.git") 10 | :serial t 11 | :components ((:file "package") 12 | (:file "libc") 13 | (:file "type") 14 | (:file "definition") 15 | (:file "allocator") 16 | (:file "object") 17 | (:file "allocator-ecl" :if-feature :ecl) 18 | (:file "pointer") 19 | (:file "array") 20 | (:file "macros") 21 | (:file "defcfun") 22 | (:file "global")) 23 | :depends-on (#:uiop #:alexandria #:cffi #:trivial-garbage) 24 | :in-order-to ((test-op (test-op #:cffi-object/test)))) 25 | 26 | (defsystem cffi-object/test 27 | :depends-on (#:cffi-ops #:cffi-object #:cffi-object.ops #:parachute) 28 | :pathname "./test/" 29 | :components ((:file "package")) 30 | :perform (test-op (op c) (symbol-call '#:parachute '#:test (find-symbol (symbol-name '#:suite) '#:cffi-object.test)))) 31 | -------------------------------------------------------------------------------- /cffi-object.ops.asd: -------------------------------------------------------------------------------- 1 | (defsystem cffi-object.ops 2 | :version "1.0.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "Apache-2.0" 6 | :description "A Common Lisp library that enables fast and convenient interoperation with foreign objects." 7 | :homepage "https://github.com/bohonghuang/cffi-object" 8 | :bug-tracker "https://github.com/bohonghuang/cffi-object/issues" 9 | :source-control (:git "https://github.com/bohonghuang/cffi-object.git") 10 | :depends-on (#:cffi-object #:cffi-ops) 11 | :components ((:file "ops")) 12 | :in-order-to ((test-op (test-op #:cffi-object/test)))) 13 | -------------------------------------------------------------------------------- /defcfun.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defun cffi-pointer-type-p (type) 4 | (and (typep (setf type (cffi::ensure-parsed-base-type type)) 'cffi::foreign-pointer-type) type)) 5 | 6 | (defun cffi-object-type-p (type) 7 | (when-let ((type (cffi-pointer-type-p type))) 8 | (and (typep (setf type (cffi::ensure-parsed-base-type (cffi-pointer-type type))) 'cffi::foreign-struct-type) type))) 9 | 10 | (defparameter *return-argument-names* '(#:%%claw-result-)) 11 | 12 | (defparameter *return-pointer-as-object-p* nil) 13 | 14 | (defparameter *optimize-object-allocation-p* t) 15 | 16 | (defparameter *optimize-out-temporary-object-p* t) 17 | 18 | (defun symbol-name= (sym1 sym2) 19 | (string= (symbol-name sym1) (symbol-name sym2))) 20 | 21 | (defgeneric funcall-dynamic-extent-form (function args)) 22 | 23 | (defgeneric funcall-form-type (function args)) 24 | 25 | (defconstant +defcfun+ (macro-function 'cffi:defcfun)) 26 | 27 | (setf (macro-function 'defcfun) +defcfun+) 28 | 29 | (defun cobject-type-constructor (object-type) 30 | (if-let ((definition (when object-type (assoc-value *cobject-class-definitions* object-type)))) 31 | (values (cobject-class-definition-constructor definition) 32 | (cobject-class-definition-internal-constructor definition) 33 | (cobject-class-definition-copier definition)) 34 | (if-let ((type-name (when object-type (cffi::name object-type)))) 35 | (values (intern (format nil "~A~A" '#:make- type-name) (symbol-package type-name)) 36 | (intern (format nil "~A~A" '#:copy- type-name) (symbol-package type-name)) 37 | (intern (format nil "~A~A" '#:%%%make- type-name) (symbol-package type-name))) 38 | (error "Defining a C function that returns non-structure pointer is currently not supported.")))) 39 | 40 | (defun frob-return-pointer-from-result (return-pointer-from-result-p result) 41 | (labels ((resolve (return-pointer-from-result-p) 42 | (if (not (cffi-pointer-type-p (cffi-pointer-type return-pointer-from-result-p))) 43 | (or (ignore-some-conditions (cobject-class-definition-not-found-error) 44 | (cobject-class-definition-class 45 | (find-cobject-class-definition 46 | (cffi-pointer-type return-pointer-from-result-p)))) 47 | (cffi::name (cffi-pointer-type return-pointer-from-result-p))) 48 | `(:pointer ,(resolve (cffi-pointer-type return-pointer-from-result-p)))))) 49 | `(pointer-cpointer ,result 50 | ',(resolve 51 | return-pointer-from-result-p)))) 52 | 53 | (defmacro defcobjfun (name result &rest args) 54 | (destructuring-bind (name symbol) name 55 | (let* ((should-define-wrapper-p (not (member '&rest args))) 56 | (internal-symbol (if should-define-wrapper-p (intern (format nil "%~A" symbol) (symbol-package symbol)) symbol)) 57 | (return-pointer-from-result-p (cffi-pointer-type-p result)) 58 | (return-object-from-result-p (cffi-object-type-p result)) 59 | (return-object-from-argument-p (member (caar args) *return-argument-names* :test #'symbol-name=))) 60 | `(progn 61 | (declaim (inline ,internal-symbol)) 62 | (defcfun (,name ,internal-symbol) ,result . ,args) 63 | (export ',internal-symbol ',(symbol-package internal-symbol)) 64 | ,(when should-define-wrapper-p 65 | (if return-object-from-argument-p 66 | (let ((object-type (cffi-object-type-p (cadar args)))) 67 | (multiple-value-bind (object-constructor object-copier object-internal-constructor) (cobject-type-constructor object-type) 68 | `(progn 69 | (declaim (ftype function ,object-constructor) 70 | (notinline ,object-constructor)) 71 | (defun ,symbol ,(mapcar #'car (cdr args)) 72 | (let ((,(caar args) (,object-constructor))) 73 | (progn 74 | (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))) 75 | ,(caar args)))) 76 | ,(with-gensyms (function function-args body dynamic-extent-forms dynamic-extent-form temp-vars form name result) 77 | `(progn 78 | (defmethod funcall-form-type ((,function (eql ',symbol)) ,function-args) 79 | (declare (ignore ,function)) 80 | `(:object ,(cffi::unparse-type ',object-type))) 81 | (defmethod funcall-dynamic-extent-form ((,function (eql ',symbol)) ,function-args) 82 | (declare (ignore ,function)) 83 | (destructuring-bind ,(mapcar #'car (cdr args)) ,function-args 84 | (let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name))))))) 85 | (declare (ignorable ,temp-vars)) 86 | (let ((,dynamic-extent-forms nil)) 87 | ,@(loop :for (name type) :in (cdr args) 88 | :if (cffi-pointer-type-p type) 89 | :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) 90 | (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) 91 | (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) 92 | :else 93 | :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) 94 | (nreversef ,dynamic-extent-forms) 95 | (lambda (,(caar args) ,body) 96 | `(cffi:with-foreign-object (,,(caar args) ',',(cffi-pointer-type (cffi::ensure-parsed-base-type (cadar args)))) 97 | ,(reduce #'funcall ,(if *optimize-out-temporary-object-p* 98 | `(loop :for (,name . ,form) :in ,dynamic-extent-forms 99 | :if ,name 100 | :collect (let ((,form ,form)) 101 | (compose 102 | (lambda (,body) 103 | (let ((,result (funcall ,form ,body))) 104 | `(,@(subseq ,result 0 3) ,@,body))) 105 | #'list)) 106 | :else 107 | :collect ,form) 108 | `(mapcar #'cdr ,dynamic-extent-forms)) 109 | :initial-value (list ',internal-symbol ,(caar args) 110 | . ,(loop :for (name type) :in (cdr args) 111 | :collect (if (cffi-pointer-type-p type) 112 | (if *optimize-out-temporary-object-p* 113 | `(if (assoc-value ,dynamic-extent-forms ',name) 114 | (assoc-value ,temp-vars ',name) 115 | `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) 116 | ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) 117 | `(assoc-value ,temp-vars ',name)))) 118 | :from-end t) 119 | (let ((,,(caar args) (,',object-internal-constructor :pointer ,,(caar args)))) 120 | (declare (dynamic-extent ,,(caar args))) 121 | ,@,body))))))))) 122 | ,(when *optimize-object-allocation-p* 123 | (let ((args (cdr args))) 124 | (with-gensyms (var) 125 | `(define-compiler-macro ,symbol ,(mapcar #'car args) 126 | (with-gensyms (,var) 127 | (funcall (funcall-dynamic-extent-form ',symbol (list . ,(mapcar #'car args))) ,var `((,',object-copier ,,var))))))))))) 128 | (let ((result-wrapper 129 | (with-gensyms (result) 130 | `(lambda (,result) 131 | ,(cond 132 | ((and return-object-from-result-p *return-pointer-as-object-p*) 133 | (let ((internal-constructor (nth-value 2 (cobject-type-constructor return-object-from-result-p)))) 134 | `(locally (declare (notinline ,internal-constructor)) (,internal-constructor :pointer ,result)))) 135 | (return-pointer-from-result-p 136 | (frob-return-pointer-from-result return-pointer-from-result-p result)) 137 | (t result)))))) 138 | `(progn 139 | (defun ,symbol ,(mapcar #'car args) 140 | (,result-wrapper (,internal-symbol . ,(loop :for (name type) :in args :collect (if (cffi-pointer-type-p type) `(cobj:cobject-pointer ,name) name))))) 141 | ,(when (and *optimize-object-allocation-p* (loop :for (nil type) :in args :thereis (cffi-pointer-type-p type))) 142 | `(define-compiler-macro ,symbol ,(mapcar #'car args) 143 | ,(with-gensyms (dynamic-extent-forms dynamic-extent-form body temp-vars name form result) 144 | `(let ((,temp-vars (list . ,(loop :for (name nil) :in args :collect `(cons ',name (gensym ,(symbol-name name)))))) 145 | (,dynamic-extent-forms nil)) 146 | ,@(loop :for (name type) :in args 147 | :if (cffi-pointer-type-p type) 148 | :collect `(if-let ((,dynamic-extent-form (when (consp ,name) (funcall-dynamic-extent-form (car ,name) (cdr ,name))))) 149 | (push (cons ',name (compose (curry ,dynamic-extent-form (assoc-value ,temp-vars ',name)) #'list)) ,dynamic-extent-forms) 150 | (push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) 151 | :else 152 | :collect `(push (cons nil (compose (lambda (,body) `(let ((,(assoc-value ,temp-vars ',name) ,,name)) . ,,body)) #'list)) ,dynamic-extent-forms)) 153 | (nreversef ,dynamic-extent-forms) 154 | (reduce #'funcall ,(if *optimize-out-temporary-object-p* 155 | `(loop :for (,name . ,form) :in ,dynamic-extent-forms 156 | :if ,name 157 | :collect (let ((,form ,form)) 158 | (compose 159 | (lambda (,body) 160 | (let ((,result (funcall ,form ,body))) 161 | `(,@(subseq ,result 0 3) ,@,body))) 162 | #'list)) 163 | :else 164 | :collect ,form) 165 | `(mapcar #'cdr ,dynamic-extent-forms)) 166 | :initial-value (list ',result-wrapper 167 | (list ',internal-symbol 168 | . ,(loop :for (name type) :in args 169 | :collect (if (cffi-pointer-type-p type) 170 | (if *optimize-out-temporary-object-p* 171 | `(if (assoc-value ,dynamic-extent-forms ',name) 172 | (assoc-value ,temp-vars ',name) 173 | `(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) 174 | ``(cobj:cobject-pointer ,(assoc-value ,temp-vars ',name))) 175 | `(assoc-value ,temp-vars ',name))))) 176 | :from-end t))))))))))))) 177 | -------------------------------------------------------------------------------- /definition.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defstruct cobject-class-definition 4 | (class nil :type (or symbol list)) 5 | (internal-constructor nil :type (or symbol function)) 6 | (constructor nil :type (or symbol function)) 7 | (in-place-constructor nil :type (or symbol function)) 8 | (slot-accessors nil :type list) 9 | (copier nil :type (or symbol function)) 10 | (predicate nil :type (or symbol function)) 11 | (equality-comparator nil :type (or symbol function))) 12 | 13 | (defun cobject-class-definition-symbols (definition &optional internalp) 14 | (remove-if-not 15 | (conjoin #'symbolp #'identity) 16 | (nconc 17 | (list 18 | (cobject-class-definition-class definition) 19 | (cobject-class-definition-constructor definition) 20 | (cobject-class-definition-copier definition) 21 | (cobject-class-definition-predicate definition) 22 | (cobject-class-definition-equality-comparator definition)) 23 | (mapcar #'cdr (cobject-class-definition-slot-accessors definition)) 24 | (when internalp (list (cobject-class-definition-internal-constructor definition)))))) 25 | 26 | (declaim (type list *cobject-class-definitions*)) 27 | (defvar *cobject-class-definitions* nil) 28 | 29 | (declaim (ftype function %make-carray %make-cpointer)) 30 | (defun cobject-class-definition (type) 31 | "Get the class definition of a cobject at runtime." 32 | (if-let ((cons (find type *cobject-class-definitions* :key (compose #'cobject-class-definition-class #'cdr)))) 33 | (values (cdr cons) (car cons)) 34 | (if-let ((primitive-type (primitive-type-p type))) 35 | (values 36 | (case primitive-type 37 | (:char (make-cobject-class-definition 38 | :class type 39 | :internal-constructor (lambda (&key pointer shared-from) 40 | (declare (ignore shared-from)) 41 | (values (code-char (mod (cffi:mem-aref pointer :char) 255)) pointer)) 42 | :copier (lambda (src dest &optional pointer) 43 | (declare (ignore dest)) 44 | (when pointer (setf (cffi:mem-aref pointer :char) (char-code src))) 45 | (values src)))) 46 | (t nil)) 47 | primitive-type) 48 | (if (listp type) 49 | (symbol-macrolet ((as-array (let ((ctype (make-instance 50 | 'cffi::foreign-array-type 51 | :element-type (nth-value 1 (cobject-class-definition element-type)) 52 | :dimensions dimensions)) 53 | (internal-constructor (lambda (&key pointer shared-from) 54 | (%make-carray :pointer pointer 55 | :shared-from shared-from 56 | :element-type element-type 57 | :dimensions dimensions)))) 58 | (values (make-cobject-class-definition 59 | :class type 60 | :internal-constructor internal-constructor 61 | :constructor (lambda () (manage-cobject (funcall internal-constructor :pointer (cffi:foreign-alloc ctype))))) 62 | ctype))) 63 | (as-pointer (values (make-cobject-class-definition 64 | :class type 65 | :internal-constructor (lambda (&key pointer shared-from) 66 | (declare (ignore shared-from)) 67 | (%make-cpointer :pointer (cffi:mem-ref pointer :pointer) 68 | :element-type element-type))) 69 | (make-instance 'cffi::foreign-pointer-type :pointer-type (nth-value 1 (cobject-class-definition element-type)))))) 70 | (destructuring-ecase type 71 | ((carray element-type &optional dimensions) 72 | (if dimensions 73 | (if (listp dimensions) 74 | (if (every #'integerp dimensions) as-array as-pointer) 75 | (if (integerp dimensions) (progn (setf dimensions (list dimensions)) as-array) as-pointer)) 76 | as-pointer)) 77 | ((cpointer element-type) as-pointer))) 78 | (error "Undefined CFFI object class ~A." type))))) 79 | 80 | (define-condition cobject-class-definition-not-found-error (error) 81 | ((type :initform nil :initarg :type :type cffi::foreign-type)) 82 | (:report (lambda (condition stream) 83 | (format stream "Cannot find the CFFI object class for type ~A." (cffi::name (slot-value condition 'type)))))) 84 | 85 | (defun find-cobject-class-definition (type) 86 | "Get the class definition of a cobject at compile-time." 87 | (check-type type cffi::foreign-type) 88 | (or (assoc-value *cobject-class-definitions* type) 89 | (make-cobject-class-definition 90 | :class (case type 91 | (#.(cffi::ensure-parsed-base-type :float) 'single-float) 92 | (#.(cffi::ensure-parsed-base-type :double) 'double-float) 93 | (#.(mapcar #'cffi::ensure-parsed-base-type '(:int8 :int16 :int32 :int64)) 94 | `(signed-byte ,(* (cffi:foreign-type-size type) 8))) 95 | (#.(mapcar #'cffi::ensure-parsed-base-type '(:uint8 :uint16 :uint32 :uint64)) 96 | `(unsigned-byte ,(* (cffi:foreign-type-size type) 8))) 97 | (#.(cffi::ensure-parsed-base-type :void) 'null) 98 | (t (typecase type 99 | (cffi::foreign-string-type 'string) 100 | (cffi::foreign-array-type 101 | `(carray ,(cobject-class-definition-class 102 | (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi-element-type type)))) 103 | ,(cffi::dimensions type))) 104 | (cffi::foreign-pointer-type 105 | `(cpointer ,(cobject-class-definition-class 106 | (find-cobject-class-definition (cffi::ensure-parsed-base-type (cffi-pointer-type type)))))) 107 | (cffi::foreign-enum 108 | `(unsigned-byte ,(* (cffi:foreign-type-size (cffi::ensure-parsed-base-type :unsigned-int))))) 109 | (t (error 'cobject-class-definition-not-found-error :type type)))))))) 110 | -------------------------------------------------------------------------------- /global.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defparameter *global-cobjects* nil) 4 | 5 | (defun global-cobjects-bytes () 6 | (loop :with definitions := *cobject-class-definitions* 7 | :for (name . value) :in *global-cobjects* 8 | :for cobject := (symbol-value name) 9 | :for type := (cobject-type (symbol-value name)) 10 | :for (definition ctype) := (multiple-value-list (cobject-class-definition type)) 11 | :for constructor := (cobject-class-definition-constructor definition) 12 | :for size := (cffi:foreign-type-size ctype) 13 | :nconc (ccoerce (pointer-carray (cobject-pointer cobject) '(unsigned-byte 8) size) 'list) :into data 14 | :collect (let ((constructor (ensure-function constructor)) (size size) 15 | (offset offset) (symbol name)) 16 | (lambda (bytes) 17 | (let ((cobject (funcall constructor))) 18 | (cffi:with-pointer-to-vector-data (pointer bytes) 19 | (memcpy (cobject-pointer cobject) (cffi:inc-pointer pointer offset) size)) 20 | (setf (symbol-value symbol) cobject)))) 21 | :into initializers 22 | :sum size :into offset 23 | :finally (return (values (replace (cffi:make-shareable-byte-vector offset) data) initializers)))) 24 | 25 | (defparameter *global-cobject-initializer* nil) 26 | 27 | (defun load-global-cobjects () 28 | (funcall *global-cobject-initializer*)) 29 | 30 | (pushnew 'load-global-cobjects uiop:*image-restore-hook*) 31 | 32 | (defun save-global-cobjects () 33 | (multiple-value-bind (bytes initializers) (global-cobjects-bytes) 34 | (setf *global-cobject-initializer* 35 | (lambda () 36 | (loop :for initializer :in initializers 37 | :do (funcall initializer bytes)))))) 38 | 39 | (pushnew 'save-global-cobjects uiop:*image-dump-hook*) 40 | 41 | (defparameter *define-global-cobject* 'defparameter) 42 | 43 | (defmacro define-global-cobject (name val-form) 44 | `(progn 45 | (setf (assoc-value *global-cobjects* ',name) (lambda () ,val-form)) 46 | (,*define-global-cobject* ,name ,val-form))) 47 | -------------------------------------------------------------------------------- /libc.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (declaim (inline memcpy)) 4 | (cffi:defcfun "memcpy" :void 5 | (dest :pointer) 6 | (src :pointer) 7 | (n :size)) 8 | 9 | (declaim (inline memcmp)) 10 | (cffi:defcfun "memcmp" :int 11 | (s1 :pointer) 12 | (s2 :pointer) 13 | (n :size)) 14 | 15 | (declaim (inline memset)) 16 | (cffi:defcfun "memset" :int 17 | (s :pointer) 18 | (c :int) 19 | (n :size)) 20 | -------------------------------------------------------------------------------- /macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defmacro with-new-cobject-class-definition ((name-form type-form) &body body) 4 | (with-gensyms (name slots type) 5 | `(let* ((,name ,name-form) 6 | (,type (cffi::ensure-parsed-base-type ,type-form)) 7 | (,slots (cffi:foreign-slot-names ,type)) 8 | (predicate (symbolicate ,name '#:-p)) 9 | (equality-comparator (symbolicate ,name '#:-equal)) 10 | (constructor (symbolicate '#:make- ,name)) 11 | (internal-constructor (symbolicate '#:%%%make- ,name)) 12 | (in-place-constructor (symbolicate '#:%%make- ,name)) 13 | (copier (symbolicate '#:copy- ,name)) 14 | (slot-accessors (mapcar #'cons ,slots (mapcar (curry #'symbolicate ,name '#:-) ,slots))) 15 | (cobject-class-definition `(make-cobject-class-definition :class ',name 16 | :constructor ',constructor 17 | :internal-constructor ',internal-constructor 18 | :in-place-constructor ',in-place-constructor 19 | :slot-accessors ',slot-accessors 20 | :copier ',copier 21 | :predicate ',predicate 22 | :equality-comparator ',equality-comparator))) 23 | (declare (ignorable cobject-class-definition)) 24 | . ,body))) 25 | 26 | (defmacro with-parsed-desc ((name type) desc-form &body body) 27 | (with-gensyms (desc parsed-type) 28 | `(let ((,desc ,desc-form)) 29 | (destructuring-bind (,name &optional ,type) (if (and (listp ,desc) (not (keywordp (car ,desc)))) 30 | ,desc (list ,desc)) 31 | (let* ((,parsed-type (or ,type ,name)) 32 | (,parsed-type (typecase ,type 33 | (cffi::foreign-type ,parsed-type) 34 | (t (cffi::parse-type ,parsed-type))))) 35 | (unless ,type 36 | (setf ,name (cffi::name ,parsed-type))) 37 | (setf ,type ,parsed-type) 38 | (let ((*package* (symbol-package ,name))) 39 | ,@body)))))) 40 | 41 | (defmacro define-prototype-cobject-class (desc) 42 | (with-parsed-desc (name type) desc 43 | `(progn 44 | ,(with-new-cobject-class-definition (name type) 45 | `(eval-when (:compile-toplevel :load-toplevel :execute) 46 | (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition))) 47 | ,(let ((base-type (cffi::ensure-parsed-base-type type))) 48 | (unless (or (eq type base-type) (assoc-value *cobject-class-definitions* base-type)) 49 | (with-new-cobject-class-definition (name base-type) 50 | `(eval-when (:compile-toplevel :load-toplevel :execute) 51 | (setf (assoc-value *cobject-class-definitions* ',base-type) ,cobject-class-definition)))))))) 52 | 53 | (defmacro define-struct-cobject-class (desc &rest options) 54 | (let ((options (reduce #'append options))) 55 | (with-parsed-desc (name ctype) desc 56 | (let* ((type (cffi::ensure-parsed-base-type ctype)) 57 | (slots (cffi:foreign-slot-names type)) 58 | (slot-supplied-p-list (mapcar (compose #'gensym #'symbol-name) slots))) 59 | (with-new-cobject-class-definition (name ctype) 60 | (when-let ((constructor-option (getf options :constructor))) 61 | (setf (getf (cdr cobject-class-definition) :constructor) `',(setf constructor constructor-option))) 62 | (with-gensyms (pointer instance value stream destination) 63 | (let ((*cobject-class-definitions* (acons type (eval cobject-class-definition) *cobject-class-definitions*))) 64 | `(progn 65 | (declaim (inline ,internal-constructor)) 66 | (defstruct (,name 67 | (:include cobject) 68 | (:predicate ,predicate) 69 | (:copier nil) 70 | (:constructor ,internal-constructor))) 71 | ,@(loop :with slots := (cffi::slots type) 72 | :for (slot-name . slot-accessor) :in slot-accessors 73 | :for slot := (gethash slot-name slots) 74 | :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot-name)) 75 | :for slot-pointer := `(cffi:foreign-slot-pointer (cobject-pointer ,instance) ',type ',slot-name) 76 | :for slot-value := `(cffi:foreign-slot-value (cobject-pointer ,instance) ',type ',slot-name) 77 | :nconc `((declaim (inline ,slot-accessor)) 78 | (defun ,slot-accessor (,instance) 79 | ,(flet ((access-simple-slot () 80 | (typecase slot-type 81 | (cffi::foreign-struct-type 82 | `(,(cobject-class-definition-internal-constructor 83 | (find-cobject-class-definition slot-type)) 84 | :pointer ,slot-pointer 85 | :shared-from ,instance)) 86 | (cffi::foreign-array-type 87 | `(%make-carray 88 | :pointer ,slot-pointer 89 | :shared-from ,instance 90 | :dimensions ',(cffi::dimensions slot-type) 91 | :element-type ',(cobject-class-definition-class 92 | (find-cobject-class-definition 93 | (cffi::ensure-parsed-base-type 94 | (cffi-element-type slot-type)))))) 95 | (cffi::foreign-pointer-type 96 | `(%make-cpointer 97 | :pointer ,slot-value 98 | :element-type ',(cobject-class-definition-class 99 | (find-cobject-class-definition 100 | (cffi::ensure-parsed-base-type 101 | (cffi-pointer-type slot-type)))))) 102 | (t slot-value)))) 103 | (etypecase slot 104 | (cffi::aggregate-struct-slot 105 | (case (cffi::slot-count slot) 106 | (0 `(%make-cpointer 107 | :pointer ,slot-pointer 108 | :shared-from ,instance 109 | :element-type ',(cobject-class-definition-class (find-cobject-class-definition slot-type)))) 110 | (1 (access-simple-slot)) 111 | (t `(%make-carray 112 | :pointer ,slot-pointer 113 | :shared-from ,instance 114 | :dimensions '(,(cffi::slot-count slot)) 115 | :element-type ',(cobject-class-definition-class (find-cobject-class-definition slot-type)))))) 116 | (cffi::simple-struct-slot (access-simple-slot)))))) 117 | :nconc `((declaim (inline (setf ,slot-accessor))) 118 | (defun (setf ,slot-accessor) (,value ,instance) 119 | ,(flet ((access-simple-slot () 120 | (typecase slot-type 121 | (cffi::foreign-struct-type 122 | `(memcpy ,slot-pointer (cobject-pointer ,value) (cffi:foreign-type-size ',slot-type))) 123 | (cffi::foreign-array-type 124 | `(creplace (,slot-accessor ,instance) ,value)) 125 | (cffi::foreign-pointer-type 126 | `(setf ,slot-value (cobject-pointer ,value))) 127 | (t `(setf ,slot-value ,value))))) 128 | (etypecase slot 129 | (cffi::aggregate-struct-slot 130 | (case (cffi::slot-count slot) 131 | (1 (access-simple-slot)) 132 | (t `(creplace (,slot-accessor ,instance) ,value)))) 133 | (cffi::simple-struct-slot 134 | (access-simple-slot))))))) 135 | (declaim (inline ,in-place-constructor)) 136 | (defun ,in-place-constructor (,pointer &key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) 137 | (let ((,instance (,internal-constructor :pointer ,pointer))) 138 | (declare (ignorable ,instance) (dynamic-extent ,instance)) 139 | ,@(loop :for slot :in slots 140 | :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) 141 | :for slot-supplied-p :in slot-supplied-p-list 142 | :if (typep slot-type '(or cffi::foreign-struct-type cffi::foreign-array-type cffi::foreign-pointer-type)) 143 | :collect `(when ,slot-supplied-p 144 | (let ((,value (make-cobject :pointer ,slot))) 145 | (declare (dynamic-extent ,value)) 146 | (setf (,(assoc-value slot-accessors slot) ,instance) ,value))) 147 | :else 148 | :collect `(when ,slot-supplied-p 149 | (setf (,(assoc-value slot-accessors slot) ,instance) ,slot))) 150 | ,pointer)) 151 | (declaim (inline ,constructor)) 152 | (defun ,constructor (&key . ,(mapcar #'list slots (mapcar (constantly nil) slots) slot-supplied-p-list)) 153 | (let* ((,pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type)) 154 | (,instance (,internal-constructor :pointer ,pointer))) 155 | ,@(loop :for slot :in slots 156 | :for slot-type := (cffi::ensure-parsed-base-type (cffi:foreign-slot-type type slot)) 157 | :for slot-supplied-p :in slot-supplied-p-list 158 | :collect `(when ,slot-supplied-p 159 | (setf (,(assoc-value slot-accessors slot) ,instance) ,slot))) 160 | (manage-cobject ,instance))) 161 | (declaim (inline ,equality-comparator)) 162 | ,(with-gensyms (instance1 instance2) 163 | `(defun ,equality-comparator (,instance1 ,instance2) 164 | (zerop (memcmp (cobject-pointer ,instance1) 165 | (cobject-pointer ,instance2) 166 | (cffi:foreign-type-size ',type))))) 167 | (declaim (inline ,copier)) 168 | (defun ,copier (,instance &optional (,destination (manage-cobject (,internal-constructor :pointer (funcall (cobject-allocator-allocator *cobject-allocator*) ',type))))) 169 | (check-type ,instance ,name) 170 | (check-type ,destination ,name) 171 | (memcpy (cobject-pointer ,destination) (cobject-pointer ,instance) (cffi:foreign-type-size ',type)) 172 | ,destination) 173 | ,(with-gensyms (print-slots) 174 | `(defmethod print-object ((,instance ,name) ,stream) 175 | (flet ((,print-slots () 176 | ,@(loop :for (slot . slot-accessor) :in slot-accessors 177 | :collect `(format ,stream ," :~A ~S" ',slot (,slot-accessor ,instance))))) 178 | (if *print-readably* 179 | (progn 180 | (format ,stream "#.(~S" ',constructor) 181 | (,print-slots) 182 | (format ,stream ")")) 183 | (print-unreadable-object (,instance ,stream) 184 | (format ,stream "~S" ',name) 185 | (,print-slots) 186 | (format ,stream ,(concatenate 'string " @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") 187 | (cffi:pointer-address (cobject-pointer ,instance)))))))) 188 | (eval-when (:compile-toplevel :load-toplevel :execute) 189 | (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition)))))))))) 190 | 191 | (defmacro define-type-cobject-class (desc) 192 | (with-parsed-desc (name type) desc 193 | (let ((base-type (cffi::ensure-parsed-base-type type))) 194 | (with-new-cobject-class-definition (name type) 195 | (if-let ((definition (find-cobject-class-definition base-type))) 196 | `(progn 197 | (setf (find-class ',name) (find-class ',(cobject-class-definition-class definition)) 198 | (fdefinition ',predicate) (fdefinition ',(cobject-class-definition-predicate definition)) 199 | (fdefinition ',equality-comparator) (fdefinition ',(cobject-class-definition-equality-comparator definition)) 200 | (fdefinition ',constructor) (fdefinition ',(cobject-class-definition-constructor definition)) 201 | (fdefinition ',internal-constructor) (fdefinition ',(cobject-class-definition-internal-constructor definition)) 202 | (fdefinition ',in-place-constructor) (fdefinition ',(cobject-class-definition-in-place-constructor definition)) 203 | (fdefinition ',copier) (fdefinition ',(cobject-class-definition-copier definition)) 204 | . ,(mapcan 205 | (lambda (var val) 206 | `((fdefinition ',(cdr var)) (fdefinition ',(cdr val)) 207 | (fdefinition '(setf ,(cdr var))) (fdefinition '(setf ,(cdr val))))) 208 | slot-accessors (cobject-class-definition-slot-accessors definition))) 209 | (eval-when (:compile-toplevel :load-toplevel :execute) 210 | (setf (assoc-value *cobject-class-definitions* ',type) ,cobject-class-definition))) 211 | (error "Definition for the base type of ~A is not found." type)))))) 212 | 213 | (defmacro define-package-cobject-classes (desc) 214 | (unless (listp desc) 215 | (setf desc (list desc))) 216 | (destructuring-bind (target &optional source) desc 217 | (unless source 218 | (shiftf source target *package*)) 219 | (loop :with source-package := (find-package source) :and target-package := (find-package target) 220 | :with definitions :and type-set := (make-hash-table) 221 | :for (source-name . type-getter) :in (nconc (hash-table-alist cffi::*default-type-parsers*) 222 | (hash-table-alist cffi::*struct-type-parsers*)) 223 | :when (eql (symbol-package source-name) source-package) 224 | :do (symbol-macrolet ((name (intern (symbol-name (cffi::name type)) target-package))) 225 | (labels ((push-definition (type) 226 | (case (gethash type type-set) 227 | (push 228 | (format t "Note: Found circular type reference, generating forward declaration for ~A.~%" name) 229 | (push `(define-prototype-cobject-class (,name ,type)) definitions)) 230 | ((nil) 231 | (setf (gethash type type-set) 'push) 232 | (prog1 (typecase type 233 | (cffi::foreign-type-alias 234 | (push-definition (cffi::actual-type type)) 235 | (when (typep (cffi::actual-type type) 'cffi::foreign-struct-type) 236 | (push `(define-type-cobject-class (,name ,type)) definitions))) 237 | (cffi::foreign-pointer-type 238 | (push-definition (cffi-pointer-type type))) 239 | (cffi::foreign-struct-type 240 | (mapc (compose #'push-definition #'cffi::parse-type #'cffi::slot-type) 241 | (hash-table-values (cffi::slots type))) 242 | (push `(define-struct-cobject-class (,name ,type)) definitions))) 243 | (setf (gethash type type-set) t)))))) 244 | (ignore-some-conditions (warning) (push-definition (funcall type-getter))))) 245 | :finally (return `(progn . ,(nreverse definitions)))))) 246 | 247 | (defmacro define-cobject-class (desc &rest options) 248 | (if (and (or (keywordp desc) (and (symbolp desc) (not (symbol-package desc)))) (find-package desc)) 249 | `(define-package-cobject-classes ,desc . ,options) 250 | `(define-struct-cobject-class ,desc . ,options))) 251 | -------------------------------------------------------------------------------- /object.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (declaim (inline make-cobject)) 4 | (defstruct cobject 5 | (pointer (cffi:null-pointer) :type cffi:foreign-pointer :read-only t) 6 | (shared-from nil :type (or cobject null) :read-only t)) 7 | 8 | (defun cobject-eq (a b) 9 | (cffi:pointer-eq (cobject-pointer a) (cobject-pointer b))) 10 | 11 | (defun cobject-class-object-size (type) 12 | (when-let ((type (nth-value 1 (cobject-class-definition type)))) 13 | (cffi:foreign-type-size type))) 14 | 15 | (defun pointer-cobject (pointer type) 16 | (funcall 17 | (cobject-class-definition-internal-constructor 18 | (cobject-class-definition type)) 19 | :pointer pointer)) 20 | 21 | (defun manage-cobject (cobject) 22 | (let ((pointer (cobject-pointer cobject)) 23 | (deallocator (cobject-allocator-deallocator *cobject-allocator*))) 24 | (if (eq deallocator #'values) cobject (tg:finalize cobject (lambda () (funcall deallocator pointer)))))) 25 | 26 | (defun unmanage-cobject (cobject) 27 | (tg:cancel-finalization cobject) 28 | (cobject-pointer cobject)) 29 | 30 | (defgeneric cobject-type (object) 31 | (:method (object) 32 | (type-of object))) 33 | -------------------------------------------------------------------------------- /ops.lisp: -------------------------------------------------------------------------------- 1 | (defpackage cffi-object.ops 2 | (:use #:cl #:alexandria) 3 | (:nicknames #:cobj.ops) 4 | (:export #:enable-cobject-ops #:disable-cobject-ops)) 5 | 6 | (in-package #:cffi-object.ops) 7 | 8 | (defconstant +form-type+ (fdefinition 'cffi-ops::form-type)) 9 | 10 | (defconstant +ctypes-slots+ (fdefinition 'cffi-ops::ctypes-slots)) 11 | 12 | (defconstant +pointer-type-p+ (fdefinition 'cffi-ops::pointer-type-p)) 13 | 14 | (defconstant +ensure-pointer-type+ (fdefinition 'cffi-ops::ensure-pointer-type)) 15 | 16 | (setf (fdefinition 'cobj::funcall-dynamic-extent-form) (fdefinition 'cffi-ops::funcall-dynamic-extent-form) 17 | (fdefinition 'cobj::funcall-form-type) (fdefinition 'cffi-ops::funcall-form-type)) 18 | 19 | (defun ctypes-slots-with-cobject (types) 20 | (funcall +ctypes-slots+ (mapcar (lambda (type) 21 | (if (and (listp type) (eq (car type) :object)) 22 | (cons :pointer (cdr type)) 23 | type)) 24 | types))) 25 | 26 | (defgeneric funcall-form-type (function args)) 27 | 28 | (defun form-type-with-object-unwrapped (form) 29 | (multiple-value-bind (type form) (funcall +form-type+ form) 30 | (cond 31 | (cffi-ops::*value-required* (values type form)) 32 | ((and (listp type) (member (car type) '(nil :object))) 33 | (values (cons :pointer (cdr type)) `(cobj:cobject-pointer ,form))) 34 | (t (values type form))))) 35 | 36 | (defun pointer-or-object-type-p (type) 37 | (if (and (consp type) (eq (car type) :object)) t (funcall +pointer-type-p+ type))) 38 | 39 | (defun ensure-pointer-or-object-type (type) 40 | (if (and (consp type) (eq (car type) :object)) type (funcall +ensure-pointer-type+ type))) 41 | 42 | (defmacro & (form) 43 | `(cobj:cobject-pointer ,form)) 44 | 45 | (defun enable-cobject-ops () 46 | (setf (fdefinition 'cffi-ops::form-type) #'form-type-with-object-unwrapped 47 | (fdefinition 'cffi-ops::ctypes-slots) #'ctypes-slots-with-cobject 48 | (fdefinition 'cffi-ops::pointer-type-p) #'pointer-or-object-type-p 49 | (fdefinition 'cffi-ops::ensure-pointer-type) #'ensure-pointer-or-object-type 50 | (fdefinition 'cffi-ops:&) #'cobj:cobject-pointer 51 | (compiler-macro-function 'cffi-ops:&) (macro-function '&))) 52 | 53 | (defun disable-cobject-ops () 54 | (setf (fdefinition 'cffi-ops::form-type) +form-type+ 55 | (fdefinition 'cffi-ops::ctypes-slots) +ctypes-slots+ 56 | (fdefinition 'cffi-ops::pointer-type-p) +pointer-type-p+ 57 | (fdefinition 'cffi-ops::ensure-pointer-type) +ensure-pointer-type+ 58 | (compiler-macro-function 'cffi-ops:&) nil) 59 | (fmakunbound 'cffi-ops:&)) 60 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage cffi-object 2 | (:use #:cl #:alexandria) 3 | (:nicknames #:cobj) 4 | (:export #:cobject 5 | #:cobject-eq 6 | #:cobject-pointer 7 | #:cpointer 8 | #:pointer-cpointer 9 | #:cref 10 | #:cpointer-equal 11 | #:cpointer-eq 12 | #:carray 13 | #:make-carray 14 | #:pointer-carray 15 | #:cpointer-carray 16 | #:carray-dimensions 17 | #:carray-displacement 18 | #:carray-element-type 19 | #:ccoerce 20 | #:caref 21 | #:clength 22 | #:creplace 23 | #:cfill 24 | #:carray-equal 25 | #:define-cobject-class 26 | #:define-global-cobject 27 | #:*define-global-cobject* 28 | #:pointer-cobject 29 | #:manage-cobject 30 | #:unmanage-cobject 31 | #:with-monotonic-buffer-allocator 32 | #:with-default-allocator 33 | #:with-leaky-allocator 34 | #:defcobjfun)) 35 | 36 | (in-package #:cffi-object) 37 | -------------------------------------------------------------------------------- /pointer.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defstruct (cpointer (:include cobject) 4 | (:constructor %make-cpointer)) 5 | (element-type nil :type (or symbol cons))) 6 | 7 | (defmethod cobject-type ((pointer cpointer)) 8 | `(cpointer ,(cpointer-element-type pointer))) 9 | 10 | (defmethod print-object ((pointer cpointer) stream) 11 | (if *print-readably* 12 | (progn 13 | (format stream "#.") 14 | (prin1 `(pointer-cpointer 15 | (cffi:make-pointer 16 | ',(cffi:pointer-address (cpointer-pointer pointer))) 17 | ',(cpointer-element-type pointer)) 18 | stream)) 19 | (print-unreadable-object (pointer stream) 20 | (format stream #.(concatenate 'string "~A @0x~" (prin1-to-string (* 2 (cffi:foreign-type-size :size))) ",'0X") 21 | (cpointer-element-type pointer) 22 | (cffi:pointer-address (cobject-pointer pointer)))))) 23 | 24 | (defun cref (cpointer &optional (subscript 0)) 25 | (multiple-value-bind (definition type) 26 | (cobject-class-definition (cpointer-element-type cpointer)) 27 | (if definition 28 | (funcall 29 | (cobject-class-definition-internal-constructor definition) 30 | :pointer (cffi:mem-aptr (cobject-pointer cpointer) type subscript) 31 | :shared-from cpointer) 32 | (cffi:mem-aref (cobject-pointer cpointer) type subscript)))) 33 | 34 | (defun (setf cref) (value cpointer &optional (subscript 0)) 35 | (multiple-value-bind (definition type) 36 | (cobject-class-definition (cpointer-element-type cpointer)) 37 | (if definition 38 | (let* ((element-size (cffi:foreign-type-size type)) 39 | (pointer (cffi:inc-pointer (cobject-pointer cpointer) (* element-size subscript)))) 40 | (multiple-value-call (cobject-class-definition-copier definition) 41 | value (funcall 42 | (cobject-class-definition-internal-constructor definition) 43 | :pointer pointer 44 | :shared-from cpointer))) 45 | (setf (cffi:mem-aref (cobject-pointer cpointer) type subscript) value)))) 46 | 47 | (defun cpointer-equal (pointer1 pointer2 &optional (count 1)) 48 | (unless (cobject-type= (cpointer-element-type pointer1) (cpointer-element-type pointer2)) 49 | (return-from cpointer-equal nil)) 50 | (zerop (memcmp (cobject-pointer pointer1) 51 | (cobject-pointer pointer2) 52 | (* (cobject-class-object-size (cpointer-element-type pointer1)) count)))) 53 | 54 | (defun cpointer-eq (pointer1 pointer2) 55 | (cffi:pointer-eq (cobject-pointer pointer1) (cobject-pointer pointer2))) 56 | 57 | (defun pointer-cpointer (pointer element-type) 58 | (%make-cpointer :pointer pointer :element-type element-type)) 59 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage cffi-object.test 2 | (:use #:cl #:parachute #:cffi #:cffi-ops #:cffi-object)) 3 | 4 | (in-package #:cffi-object.test) 5 | 6 | (define-test suite) 7 | 8 | (defcstruct vector2 9 | (x :float) 10 | (y :float)) 11 | 12 | (define-cobject-class (vector2 (:struct vector2))) 13 | 14 | (define-test basic-struct :parent suite 15 | (foreign-free 16 | (prog1 (let ((vec1 (make-vector2 :x 1.0 :y 2.0))) 17 | (let ((vec2 (copy-vector2 vec1 (make-vector2))) 18 | (vec3 (copy-vector2 vec1))) 19 | (is = 1.0 (vector2-x vec1)) 20 | (is = 2.0 (vector2-y vec1)) 21 | (true (vector2-equal vec1 vec2)) 22 | (setf (vector2-x vec1) 3.0 23 | (vector2-y vec1) 4.0) 24 | (false (vector2-equal vec1 vec2)) 25 | (is = 3.0 (vector2-x vec1)) 26 | (is = 4.0 (vector2-y vec1)) 27 | (is = 1.0 (vector2-x vec2)) 28 | (is = 2.0 (vector2-y vec2)) 29 | (is = 1.0 (vector2-x vec3)) 30 | (is = 2.0 (vector2-y vec3))) 31 | (unmanage-cobject vec1)) 32 | (tg:gc :full t)))) 33 | 34 | (defcstruct camera-2d 35 | (offset (:struct vector2)) 36 | (target (:struct vector2)) 37 | (rotation :float) 38 | (zoom :float)) 39 | 40 | (define-cobject-class (camera-2d (:struct camera-2d))) 41 | 42 | (define-test struct-type-slot :parent suite 43 | ((lambda (vec) 44 | (is = 1.0 (vector2-x vec)) 45 | (is = 2.0 (vector2-y vec))) 46 | (prog1 (let ((cam (make-camera-2d :offset (make-vector2 :x 3.0 :y 4.0) 47 | :rotation 90.0 48 | :zoom 1.0))) 49 | (setf (camera-2d-target cam) (camera-2d-offset cam) 50 | (vector2-x (camera-2d-offset cam)) 1.0 51 | (vector2-y (camera-2d-offset cam)) 2.0) 52 | (is = 1.0 (vector2-x (camera-2d-offset cam))) 53 | (is = 2.0 (vector2-y (camera-2d-offset cam))) 54 | (is = 3.0 (vector2-x (camera-2d-target cam))) 55 | (is = 4.0 (vector2-y (camera-2d-target cam))) 56 | (is = 90.0 (camera-2d-rotation cam)) 57 | (is = 1.0 (camera-2d-zoom cam)) 58 | (camera-2d-offset cam)) 59 | (tg:gc :full t)))) 60 | 61 | (define-test struct-array :parent suite 62 | ((lambda (vec) 63 | (is = 3.0 (vector2-x vec)) 64 | (is = 4.0 (vector2-y vec))) 65 | (prog1 (let ((arr1 (make-carray 10 :element-type 'vector2))) 66 | (setf (caref arr1 0) (make-vector2 :x 1.0 :y 2.0) 67 | (caref arr1 9) (make-vector2 :x 3.0 :y 4.0)) 68 | (is = 1.0 (vector2-x (caref arr1 0))) 69 | (is = 2.0 (vector2-y (caref arr1 0))) 70 | (is = 3.0 (vector2-x (caref arr1 9))) 71 | (is = 4.0 (vector2-y (caref arr1 9))) 72 | (caref arr1 9)) 73 | (tg:gc :full t))) 74 | (let ((arr2 (make-carray 3 :element-type 'vector2 75 | :initial-element (make-vector2 :x 1.0 :y 2.0)))) 76 | (loop :for i :below 3 77 | :do (is = 1.0 (vector2-x (caref arr2 i))) 78 | (is = 2.0 (vector2-y (caref arr2 i))))) 79 | (let* ((list3 (list (make-vector2 :x 1.0 :y 2.0) 80 | (make-vector2 :x 3.0 :y 4.0) 81 | (make-vector2 :x 5.0 :y 6.0))) 82 | (arr3 (make-carray 3 :element-type 'vector2 83 | :initial-contents list3)) 84 | (arr4 (make-carray 3 :element-type 'vector2 85 | :initial-contents arr3)) 86 | (arr5 (make-carray 2 :element-type 'vector2 87 | :displaced-to arr3 88 | :displaced-index-offset 1))) 89 | (loop :for i :below 3 90 | :do (is = (vector2-x (nth i list3)) (vector2-x (caref arr3 i))) 91 | (is = (vector2-y (nth i list3)) (vector2-y (caref arr3 i))) 92 | (is = (vector2-x (caref arr3 i)) (vector2-x (caref arr4 i))) 93 | (is = (vector2-y (caref arr3 i)) (vector2-y (caref arr4 i))) 94 | :when (plusp i) 95 | :do (is = (vector2-x (caref arr3 i)) (vector2-x (caref arr5 (1- i)))) 96 | (incf (vector2-x (caref arr5 (1- i)))) 97 | (is = (vector2-x (caref arr3 i)) (vector2-x (caref arr5 (1- i)))) 98 | (is = (vector2-y (caref arr3 i)) (vector2-y (caref arr5 (1- i)))) 99 | (incf (vector2-y (caref arr3 i))) 100 | (is = (vector2-y (caref arr3 i)) (vector2-y (caref arr5 (1- i))))) 101 | (let ((arr6 (make-carray 3 :element-type 'vector2))) 102 | (is = 3 (clength arr6)) 103 | (cfill arr6 (make-vector2 :x -1.0 :y 0.0) :end 2) 104 | (creplace arr6 arr4 :start1 1 :end2 2) 105 | (is = -1.0 (vector2-x (caref arr6 0))) 106 | (is = 0.0 (vector2-y (caref arr6 0))) 107 | (is = 1.0 (vector2-x (caref arr6 1))) 108 | (is = 2.0 (vector2-y (caref arr6 1))) 109 | (is = 3.0 (vector2-x (caref arr6 2))) 110 | (is = 4.0 (vector2-y (caref arr6 2)))))) 111 | 112 | (define-test primitive-type-array :parent suite 113 | (let ((arr1 (make-carray 3 :element-type '(unsigned-byte 32)))) 114 | (cfill arr1 1) 115 | (creplace arr1 (make-carray 3 :element-type '(unsigned-byte 32) 116 | :initial-contents '(1 2 3)) 117 | :start1 1 :start2 1 :end2 2) 118 | (setf (caref arr1 2) 3) 119 | (is = 1 (caref arr1 0)) 120 | (is = 2 (caref arr1 1)) 121 | (is = 3 (caref arr1 2)) 122 | (let ((arr2 (make-carray 3 :element-type '(unsigned-byte 32) 123 | :initial-contents arr1))) 124 | (is carray-equal arr1 arr2) 125 | (setf (caref arr2 0) 0) 126 | (isnt carray-equal arr1 arr2)))) 127 | 128 | (defcstruct sockaddr 129 | (sa-family :ushort) 130 | (sa-data (:array :char 14))) 131 | 132 | (define-cobject-class (sockaddr (:struct sockaddr))) 133 | 134 | (define-test primitive-type-array-in-struct :parent suite 135 | (let ((sockaddr (make-sockaddr)) 136 | (port (make-carray 1 :element-type '(unsigned-byte 16) 137 | :initial-element 8080)) 138 | (addr (make-carray 4 :element-type '(unsigned-byte 8) 139 | :initial-contents #(192 168 31 1)))) 140 | (creplace (sockaddr-sa-data sockaddr) 141 | (pointer-carray (cobject-pointer port) '(signed-byte 8) 2) 142 | :start1 0) 143 | (creplace (sockaddr-sa-data sockaddr) 144 | (pointer-carray (cobject-pointer addr) '(signed-byte 8) 4) 145 | :start1 2) 146 | (is carray-equal 147 | (pointer-carray (cobject-pointer port) '(signed-byte 8) 2) 148 | (make-carray 2 :element-type '(signed-byte 8) 149 | :displaced-to (sockaddr-sa-data sockaddr) 150 | :displaced-index-offset 0)) 151 | (loop :with addr := (manage-cobject (pointer-carray (unmanage-cobject addr) '(signed-byte 8) 4)) 152 | :for i :below 4 153 | :for j :from 2 154 | :do (is = (caref addr i) (caref (sockaddr-sa-data sockaddr) j))))) 155 | 156 | (defcstruct sample 157 | (left :float) 158 | (right :float)) 159 | 160 | (define-cobject-class (sample (:struct sample))) 161 | 162 | (defcstruct sample-ring-buffer 163 | (data (:array (:struct sample) 2048)) 164 | (free-position :size) 165 | (data-position :size) 166 | (free-count :size) 167 | (data-count :size)) 168 | 169 | (define-cobject-class (sample-ring-buffer (:struct sample-ring-buffer))) 170 | 171 | (define-test object-array-in-struct :parent suite 172 | (loop :with ring-buffer := (make-sample-ring-buffer) 173 | :with sample-buffer := (make-carray 2048 :element-type 'sample) 174 | :for i :below 2048 175 | :for sample := (make-sample :left (coerce (sin (* i 1/2048 2 pi)) 'single-float) 176 | :right (coerce (cos (* i 1/2048 2 pi)) 'single-float)) 177 | :do (setf (caref (sample-ring-buffer-data ring-buffer) i) sample 178 | (caref sample-buffer i) sample) 179 | :finally (is carray-equal sample-buffer (sample-ring-buffer-data ring-buffer)))) 180 | 181 | (define-test nested-array :parent suite 182 | (let* ((arr1 (make-carray 2 :element-type '(carray sample 2) 183 | :initial-element (make-carray 2 :element-type 'sample 184 | :initial-element (make-sample :left 0.5 :right 1.0)))) 185 | (arr2 (pointer-carray (cobject-pointer arr1) 'sample 4))) 186 | (loop :for i :below 4 187 | :for sample := (make-sample :left (/ i 3.0) :right (- (/ i 3.0))) 188 | :do (setf (caref arr2 i) sample) 189 | :do (multiple-value-bind (i j) (truncate i 2) 190 | (is sample-equal sample (caref (caref arr1 i) j)))))) 191 | 192 | (define-test nested-pointer :parent suite 193 | (let* ((pptr (foreign-alloc :pointer)) 194 | (ptr (setf (mem-ref pptr :pointer) (foreign-alloc :uint32))) 195 | (value (setf (mem-ref ptr :uint32) 12345)) 196 | (cpptr (manage-cobject (pointer-cpointer pptr '(cpointer (unsigned-byte 32))))) 197 | (cptr (manage-cobject (pointer-cpointer ptr '(unsigned-byte 32))))) 198 | (is cpointer-eq (cref cpptr) cptr) 199 | (is = value (cref (cref cpptr))) 200 | (is = value (cref cptr)))) 201 | 202 | (define-test array-pointer :parent suite 203 | (let* ((arr1 (make-carray 2048 :element-type 'sample)) 204 | (arr2 (cref (pointer-cpointer (cobject-pointer arr1) '(carray sample 2048))))) 205 | (is carray-equal arr1 arr2) 206 | (is pointer-eq (cobject-pointer arr1) (cobject-pointer arr2)))) 207 | 208 | (defcstruct sample-vector 209 | (data (:pointer (:struct sample))) 210 | (size :size)) 211 | 212 | (define-cobject-class (sample-vector (:struct sample-vector))) 213 | 214 | (define-test object-pointer-in-struct :parent suite 215 | (let* ((buffer (make-carray 4 :element-type 'sample)) 216 | (buffer-pointer (pointer-cpointer (cobject-pointer buffer) 'sample)) 217 | (vector1 (make-sample-vector :data buffer :size 4)) 218 | (vector2 (make-sample-vector :data buffer-pointer :size 4))) 219 | (is cpointer-eq buffer-pointer (sample-vector-data vector1)) 220 | (is cpointer-eq buffer-pointer (sample-vector-data vector2)))) 221 | 222 | (defcstruct foreign-string 223 | (data :string)) 224 | 225 | (define-cobject-class (foreign-string (:struct foreign-string))) 226 | 227 | (define-test string :parent suite 228 | (let ((str (make-foreign-string :data "Test"))) 229 | (is string= "Test" (foreign-string-data str))) 230 | (let ((strarr (make-carray 3 :element-type 'string :initial-contents '("123" "456" "789")))) 231 | (is string= "123" (caref strarr 0)) 232 | (is string= "456" (caref strarr 1)) 233 | (is string= "789" (caref strarr 2)) 234 | (setf (caref strarr 0) "000") 235 | (is string= "000" (caref strarr 0)))) 236 | 237 | (define-test array-of-array-of-pointer :parent suite 238 | (let ((arr (make-carray 3 :element-type '(carray (cpointer (signed-byte 8)) 1) 239 | :initial-element (make-carray 1 :element-type '(cpointer (signed-byte 8)) 240 | :initial-element (pointer-cpointer (cffi-sys::make-pointer 123) '(signed-byte 8)))))) 241 | (loop :for i :below 3 242 | :do (is cpointer-eq (caref (caref arr i) 0) (pointer-cpointer (make-pointer 123) '(signed-byte 8)))))) 243 | 244 | (define-test pointer-of-pointer :parent suite 245 | (let* ((arr1 (make-carray 1 :element-type '(signed-byte 8) 246 | :initial-element 1)) 247 | (arr2 (make-carray 1 :element-type '(signed-byte 8) 248 | :initial-element 2)) 249 | (arr3 (make-carray 1 :element-type '(signed-byte 8) 250 | :initial-element 3)) 251 | (arr4 (make-carray 3 :element-type '(cpointer (signed-byte 8)) 252 | :initial-contents (list arr1 arr2 arr3)))) 253 | (loop :for ptr :in (ccoerce arr4 'list) 254 | :for arr :in (list arr1 arr2 arr3) 255 | :do (is cobject-eq arr ptr) 256 | (is = (caref arr 0) (cref ptr))))) 257 | 258 | (define-test array-of-array :parent suite 259 | (let* ((arr1 (make-carray 1 :element-type '(signed-byte 8) 260 | :initial-element 1)) 261 | (arr2 (make-carray 1 :element-type '(signed-byte 8) 262 | :initial-element 2)) 263 | (arr3 (make-carray 1 :element-type '(signed-byte 8) 264 | :initial-element 3)) 265 | (arr4 (make-carray 3 :element-type '(carray (signed-byte 8) 1) 266 | :initial-contents (list arr1 arr2 arr3)))) 267 | (loop :for ptr :in (ccoerce arr4 'list) 268 | :for arr :in (list arr1 arr2 arr3) 269 | :do (is = (caref arr 0) (caref ptr 0))))) 270 | 271 | (eval-when (:compile-toplevel :load-toplevel :execute) 272 | (cobj.ops:enable-cobject-ops)) 273 | 274 | (define-test ops :parent suite 275 | (let* ((vec2 (make-vector2 :x 1.0 :y 2.0)) 276 | (cam (make-camera-2d :offset vec2)) 277 | (cam2 (copy-camera-2d cam))) 278 | (clocally (declare (ctype (:object (:struct vector2)) vec2) 279 | (ctype (:object (:struct camera-2d)) cam)) 280 | (is = 1.0 (-> vec2 x)) 281 | (is = 2.0 (-> (& vec2) y)) 282 | (is = 1.0 (-> cam offset x)) 283 | (is = 2.0 (-> (& cam) offset y)) 284 | (is eql (find-class 'camera-2d) (class-of cam)) 285 | (of-type foreign-pointer (& cam)) 286 | (of-type foreign-pointer (& cam2))) 287 | (of-type foreign-pointer (& cam)))) 288 | 289 | (define-test character-array :parent suite 290 | (let ((arr (make-carray 10 :element-type 'character))) 291 | (loop :for c :across "Hello" 292 | :for i :from 0 293 | :do (setf (caref arr i) c) 294 | :finally (setf (caref arr 5) #\Nul)) 295 | (is string= "Hello" (ccoerce arr 'string)) 296 | (is = 10 (length (ccoerce arr 'list))) 297 | (is string= "Hello" (coerce (subseq (ccoerce arr 'list) 0 5) 'string)) 298 | (setf (ccoerce arr 'string) "World") 299 | (is string= "World" (ccoerce arr 'string))) 300 | (let ((arr (make-carray 5 :element-type 'character :initial-contents "Hello World!"))) 301 | (is string= "Hell" (ccoerce arr 'string))) 302 | (let ((arr (make-carray 20 :element-type 'character :initial-contents "Hello World!"))) 303 | (is string= "Hello World!" (ccoerce arr 'string))) 304 | (let ((arr (make-carray 20 :element-type 'character :initial-element #\Nul))) 305 | (is string= "" (ccoerce arr 'string)))) 306 | 307 | (define-test monotonic-buffer-allocator :parent suite 308 | (with-monotonic-buffer-allocator (:size 8) 309 | (with-monotonic-buffer-allocator (:size 8) 310 | (of-type cobj::sized-monotonic-buffer-allocator cobj::*cobject-allocator*) 311 | (make-vector2) 312 | (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) 313 | (make-vector2) 314 | (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) 315 | (is eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*cobject-allocator*)) 316 | (make-vector2) 317 | (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) 318 | (isnt eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*cobject-allocator*))) 319 | (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) 320 | (make-vector2) 321 | (is = 8 (cobj::sized-monotonic-buffer-allocator-offset cobj::*cobject-allocator*)) 322 | (isnt eq #'values (cobj::sized-monotonic-buffer-allocator-deallocator cobj::*cobject-allocator*))) 323 | (tg:gc :full t)) 324 | 325 | (define-test readable-cobject :parent suite :fix (*print-readably*) 326 | (setf *print-readably* t) 327 | (define-test readable-cpointer 328 | (let ((cpointer (pointer-cpointer (make-pointer 1234) '(unsigned-byte 32)))) 329 | (is cpointer-eq cpointer (read-from-string (prin1-to-string cpointer))))) 330 | (define-test readable-carray 331 | (let* ((carray (make-carray 10 :element-type '(unsigned-byte 32))) 332 | (displaced-carray (make-carray 10 :element-type '(unsigned-byte 32) 333 | :displaced-to carray))) 334 | (is carray-equal carray (read-from-string (prin1-to-string carray))) 335 | (is carray-equal displaced-carray (read-from-string (prin1-to-string displaced-carray))))) 336 | (define-test readable-simple-cobject 337 | (let ((vector2 (make-vector2))) 338 | (is vector2-equal vector2 (read-from-string (prin1-to-string vector2))))) 339 | (define-test readable-complex-cobject 340 | (let ((camera-2d (make-camera-2d))) 341 | (is camera-2d-equal camera-2d (read-from-string (prin1-to-string camera-2d)))))) 342 | 343 | (defcstruct aggregate-struct 344 | (a (:array :uint8 3) :count 0) 345 | (b (:array :uint8 1) :count 1) 346 | (c :uint8 :count 2)) 347 | 348 | (define-cobject-class (:struct aggregate-struct)) 349 | 350 | (defvar *aggregate-struct* nil) 351 | 352 | (define-test aggregate-struct-slot :parent suite :fix (*aggregate-struct*) 353 | (setf *aggregate-struct* (make-aggregate-struct :b (make-carray 1 :element-type '(unsigned-byte 8) :initial-contents '(1)) 354 | :c (make-carray 2 :element-type '(unsigned-byte 8) :initial-contents '(2 3)))) 355 | (define-test count=0 356 | (of-type cpointer (aggregate-struct-a *aggregate-struct*)) 357 | (is carray-equal (make-carray 3 :element-type '(unsigned-byte 8) :initial-contents '(1 2 3)) (cref (aggregate-struct-a *aggregate-struct*))) 358 | (fail (setf (aggregate-struct-a *aggregate-struct*) (make-carray 3 :element-type '(unsigned-byte 8) :initial-contents '(1 2 3))))) 359 | (define-test count=1 360 | (of-type carray (aggregate-struct-b *aggregate-struct*)) 361 | (is equal '(unsigned-byte 8) (carray-element-type (aggregate-struct-b *aggregate-struct*))) 362 | (is carray-equal (make-carray 1 :element-type '(unsigned-byte 8) :initial-contents '(1)) (aggregate-struct-b *aggregate-struct*))) 363 | (define-test count=2 364 | (of-type carray (aggregate-struct-c *aggregate-struct*)) 365 | (is equal '(unsigned-byte 8) (carray-element-type (aggregate-struct-b *aggregate-struct*))) 366 | (is carray-equal (make-carray 2 :element-type '(unsigned-byte 8) :initial-contents '(2 3)) (aggregate-struct-c *aggregate-struct*)))) 367 | 368 | (defcstruct void-pointer-struct 369 | (a :pointer) 370 | (b (:pointer :pointer)) 371 | (c (:pointer :void)) 372 | (d (:pointer (:pointer :void)))) 373 | 374 | (define-cobject-class (:struct void-pointer-struct)) 375 | 376 | (define-test void-pointer :parent suite 377 | (let* ((carray (make-carray 1 :element-type '(unsigned-byte 32) :initial-contents '(123456))) 378 | (cpointer (make-carray 1 :element-type '(cpointer (unsigned-byte 32)) :initial-contents (list carray)))) 379 | (is = 123456 (cref (cref cpointer))) 380 | (let ((struct (make-void-pointer-struct :a carray :b cpointer :c carray :d cpointer))) 381 | (is = 123456 (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-a struct)) '(unsigned-byte 32)))) 382 | (is = 123456 (cref (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-b struct)) '(cpointer (unsigned-byte 32)))))) 383 | (is = 123456 (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-c struct)) '(unsigned-byte 32)))) 384 | (is = 123456 (cref (cref (pointer-cpointer (cobject-pointer (void-pointer-struct-d struct)) '(cpointer (unsigned-byte 32))))))))) 385 | -------------------------------------------------------------------------------- /type.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-object) 2 | 3 | (defun primitive-type-p (type) 4 | (if (consp type) 5 | (destructuring-case type 6 | ((signed-byte n) 7 | (case n 8 | (8 :int8) 9 | (16 :int16) 10 | (32 :int32) 11 | (64 :int64))) 12 | ((unsigned-byte n) 13 | (case n 14 | (8 :uint8) 15 | (16 :uint16) 16 | (32 :uint32) 17 | (64 :uint64)))) 18 | (case type 19 | (single-float :float) 20 | (double-float :double) 21 | (character :char) 22 | (string :string)))) 23 | 24 | (defun cobject-type= (type1 type2) 25 | (if (and (listp type1) (listp type2) 26 | (member (car type1) '(carray cpointer)) 27 | (member (car type2) '(carray cpointer))) 28 | (progn 29 | (unless (eq (first type1) (first type2)) 30 | (return-from cobject-type= nil)) 31 | (unless (cobject-type= (second type1) (second type2)) 32 | (return-from cobject-type= nil)) 33 | (unless (listp (third type1)) 34 | (setf (third type1) (list (third type1)))) 35 | (unless (listp (third type2)) 36 | (setf (third type2) (list (third type2)))) 37 | (equal type1 type2)) 38 | (or (type= type1 type2) 39 | (and (symbolp type1) (symbolp type2) 40 | (eql (find-class type1 nil) (find-class type2 nil)))))) 41 | 42 | (setf (fdefinition 'cffi-element-type) (fdefinition 'cffi::element-type)) 43 | 44 | (defun cffi-pointer-type (type) 45 | (or (cffi::pointer-type type) :void)) 46 | --------------------------------------------------------------------------------