├── package.lisp ├── setf.lisp ├── cffi-ops.asd ├── test └── package.lisp ├── macros.lisp ├── README.org ├── walker.lisp └── LICENSE /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage cffi-ops 2 | (:use #:cl #:alexandria #:arrow-macros #:cffi #:trivial-macroexpand-all) 3 | (:import-from #:cffi #:ctype) 4 | (:export #:ctype #:cthe #:clocally #:clet #:clet* #:csetf #:& #:-> #:[] #:foreign-alloca) 5 | (:nicknames #:cops)) 6 | 7 | (in-package #:cffi-ops) 8 | -------------------------------------------------------------------------------- /setf.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-ops) 2 | 3 | (define-setf-expander %cthe (ctype form &environment env) 4 | (declare (ignore ctype)) 5 | (get-setf-expansion (expand-form form) env)) 6 | 7 | (define-setf-expander -> (init &rest exps &environment env) 8 | (get-setf-expansion (expand-form `(-> ,init . ,exps)) env)) 9 | 10 | (define-setf-expander [] (pointer &optional (index 0) &environment env) 11 | (get-setf-expansion (expand-form `([] ,pointer ,index)) env)) 12 | -------------------------------------------------------------------------------- /cffi-ops.asd: -------------------------------------------------------------------------------- 1 | (defsystem cffi-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 library that helps write concise CFFI-related code. " 7 | :homepage "https://github.com/bohonghuang/cffi-ops" 8 | :bug-tracker "https://github.com/bohonghuang/cffi-ops/issues" 9 | :source-control (:git "https://github.com/bohonghuang/cffi-ops.git") 10 | :components ((:file "package") 11 | (:file "walker" :depends-on ("package")) 12 | (:file "setf" :depends-on ("package" "walker")) 13 | (:file "macros" :depends-on ("package" "walker"))) 14 | :depends-on (#:alexandria #:cffi #:arrow-macros #:trivial-macroexpand-all) 15 | :in-order-to ((test-op (test-op #:cffi-ops/test)))) 16 | 17 | (defsystem cffi-ops/test 18 | :depends-on (#:cffi-ops #:parachute) 19 | :pathname "./test/" 20 | :components ((:file "package")) 21 | :perform (test-op (op c) (symbol-call '#:parachute '#:test (find-symbol (symbol-name '#:suite) '#:cffi-ops.test)))) 22 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage cffi-ops.test 2 | (:use #:cl #:parachute #:cffi #:cffi-ops)) 3 | 4 | (in-package #:cffi-ops.test) 5 | 6 | (defcstruct vector3 7 | (x :float) 8 | (y :float) 9 | (z :float)) 10 | 11 | (defcstruct matrix3 12 | (v1 (:struct vector3)) 13 | (v2 (:struct vector3)) 14 | (v3 (:struct vector3))) 15 | 16 | (defun vector3-add (output v1 v2) 17 | (clocally 18 | (declare (ctype (:pointer (:struct vector3)) v1 v2)) 19 | (setf (-> (cthe (:pointer (:struct vector3)) output) x) (+ (-> v1 x) (-> v2 x)) 20 | (-> (cthe (:pointer (:struct vector3)) output) y) (+ (-> v1 y) (-> v2 y)) 21 | (-> (cthe (:pointer (:struct vector3)) output) z) (+ (-> v1 z) (-> v2 z))))) 22 | 23 | (define-test suite) 24 | 25 | (define-test simple :parent suite 26 | (clet ((m1 (foreign-alloc '(:array (:struct matrix3) 3)))) 27 | (declare (dynamic-extent m1)) 28 | (setf (-> ([] m1 0) v1 x) 1.0 29 | (-> ([] m1 0) v1 y) 2.0 30 | (-> ([] m1 0) v1 z) 3.0) 31 | (clet* ((m2 ([] m1)) 32 | (v1 (& (-> m2 v1))) 33 | (v2 (foreign-alloc '(:struct vector3)))) 34 | (csetf ([] v2) ([] v1)) 35 | (setf (-> v2 x) 3.0 36 | (-> v2 z) 1.0) 37 | (vector3-add v1 v1 v2) 38 | (is = (-> v1 x) 4.0) 39 | (is = (-> v1 y) 4.0) 40 | (is = (-> v1 z) 4.0) 41 | (foreign-free v2)))) 42 | 43 | (define-test nested-array :parent suite 44 | (clet ((m (foreign-alloc '(:array (:array :float 3) 3)))) 45 | (declare (dynamic-extent m)) 46 | (loop :for row :below 3 47 | :do (loop :for col :below 3 48 | :do (setf ([] ([] m row) col) (+ (* row 3.0) col)))) 49 | (clet ((m1 ([] (cthe (:pointer (:struct matrix3)) m)))) 50 | (is = 0.0 (-> (-> m1 v1) x)) 51 | (is = 1.0 (-> (-> m1 v1) y)) 52 | (is = 2.0 (-> (-> m1 v1) z)) 53 | (is = 3.0 (-> (-> m1 v2) x)) 54 | (is = 4.0 (-> (-> m1 v2) y)) 55 | (is = 5.0 (-> (-> m1 v2) z)) 56 | (is = 6.0 (-> (-> m1 v3) x)) 57 | (is = 7.0 (-> (-> m1 v3) y)) 58 | (is = 8.0 (-> (-> m1 v3) z))))) 59 | -------------------------------------------------------------------------------- /macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-ops) 2 | 3 | (declaim (inline memcpy)) 4 | (defcfun "memcpy" :void 5 | (dest :pointer) 6 | (src :pointer) 7 | (n :size)) 8 | 9 | (defmacro cthe (ctype form) 10 | "Similar to THE, but declares the CFFI type for FORM." 11 | `(%cthe ',ctype ,form)) 12 | 13 | (defun body-declarations (body) 14 | (values 15 | (loop :for (declaration . rest) :on body 16 | :while (and (listp declaration) (eq (car declaration) 'declare)) 17 | :do (setf body rest) 18 | :append (cdr declaration)) 19 | body)) 20 | 21 | (defmacro clocally (&body body &environment *macro-environment*) 22 | "Similar to LOCALLY but allows using CTYPE to declare CFFI types for variables." 23 | (multiple-value-bind (body-declarations body) (body-declarations body) 24 | (multiple-value-bind (ctypes declarations) 25 | (loop :for declaration :in body-declarations 26 | :if (eq (car declaration) 'ctype) 27 | :collect (cdr declaration) :into ctypes 28 | :else :if (eq (car declaration) 'dynamic-extent) 29 | :do (progn) 30 | :else 31 | :collect declaration :into declarations 32 | :finally (return (values ctypes declarations))) 33 | (let* ((types (mapcan (lambda (type-vars) 34 | (mapcar (rcurry #'cons (car type-vars)) (cdr type-vars))) 35 | ctypes)) 36 | (slots (ctypes-slots (mapcar #'cdr types)))) 37 | (let ((*type-dictionary* (nconc types *type-dictionary*)) 38 | (*struct-slots* (nconc slots *struct-slots*))) 39 | `(%cthe nil ,(let ((*value-required* t)) 40 | (expand-form (macroexpand-all `(locally (declare . ,declarations) . ,body) #-ecl *macro-environment*))))))))) 41 | 42 | (defmacro clet (bindings &body body &environment *macro-environment*) 43 | "Equivalent to variable definition and initialization statements in C, but with type inference. For each element (NAME FORM) of BINDINGS, NAME is always bound to a CFFI pointer, with the following cases for different FORMs: 44 | - A variable with pointer type: NAME is directly bound to this pointer variable. 45 | - A variable with non-pointer type: The variable is copied onto the stack semantically, and the bound pointer is pointed to it." 46 | #+sbcl (declare (sb-ext:muffle-conditions warning)) 47 | (multiple-value-bind (body-declarations body) 48 | (body-declarations body) 49 | (loop :with type :and form 50 | :with dynamic-extent-vars := (mapcan (lambda (declaration) 51 | (when (eq (car declaration) 'dynamic-extent) 52 | (cdr declaration))) 53 | body-declarations) 54 | :for (name val) :in bindings 55 | :when (consp val) 56 | :do (destructuring-case val 57 | ((foreign-alloca type) 58 | (push name dynamic-extent-vars) 59 | (setf val `(foreign-alloc ,type)))) 60 | :do (setf (values type form) (form-type (expand-form val))) 61 | :collect (cons name (ensure-pointer-type type)) :into types 62 | :collect (let ((name name) (val val) (type type)) 63 | (compose 64 | (cond 65 | ((member name dynamic-extent-vars) 66 | (lambda (body) 67 | (with-gensyms (var) 68 | (funcall (funcall-dynamic-extent-form (car val) (cdr val)) var `((let ((,name ,var)) ,@body)))))) 69 | ((pointer-type-p type) (lambda (body) `(let ((,name ,val)) . ,body))) 70 | (t (lambda (body) `(with-foreign-object (,name ',type) (csetf (%cthe '(:pointer ,type) ,name) ,val) . ,body)))) 71 | #'list)) 72 | :into forms 73 | :finally 74 | (return 75 | (reduce #'funcall forms 76 | :from-end t 77 | :initial-value `(clocally 78 | (declare 79 | . ,(mapcar (lambda (type) 80 | `(ctype ,(cdr type) ,(car type))) 81 | types)) 82 | (declare . ,(remove 'dynamic-extent body-declarations :key #'car)) 83 | . ,body)))))) 84 | 85 | (defmacro clet* (bindings &body body) 86 | "Similar to CLET, but the initialization FORM of the variable can use variables defined earlier." 87 | (if bindings 88 | `(clet (,(car bindings)) 89 | (declare . ,(remove (caar bindings) (body-declarations body) :key #'cdr :test-not #'member)) 90 | (clet* ,(cdr bindings) 91 | . ,body)) 92 | `(clocally . ,body))) 93 | 94 | (defmacro csetf (&rest args &environment *macro-environment*) 95 | "Equivalent to assignment statements in C, which assign the rvalue of each pair to the lvalue. Note that both the lvalues and rvalues are represented as CFFI pointers here, and the assignment operation is actually a memory copy." 96 | (when args 97 | (destructuring-bind (var val &rest args) args 98 | (multiple-value-bind (ltype lform) (form-type (let ((*value-required* nil)) (expand-form var))) 99 | (multiple-value-bind (rtype rform) (form-type (let ((*value-required* nil)) (expand-form val))) 100 | (assert (eq (cffi::ensure-parsed-base-type (cffi::pointer-type (cffi::ensure-parsed-base-type ltype))) 101 | (cffi::ensure-parsed-base-type (cffi::pointer-type (cffi::ensure-parsed-base-type rtype))))) 102 | `(progn 103 | (memcpy ,lform ,rform ,(foreign-type-size (cffi::unparse-type (cffi::pointer-type (cffi::ensure-parsed-base-type ltype))))) 104 | (csetf . ,args))))))) 105 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: cffi-ops 2 | Write CFFI stuff quickly without runtime overhead. 3 | * Introduction 4 | CFFI is powerful, but using its API to write C-style code can sometimes be cumbersome because it requires you to repeatedly pass in types, 5 | unlike the dot operator in C that has some type inference capabilities. 6 | 7 | This library provides CFFI with dot operator-like functionality at compile time, 8 | allowing you to write CFFI-related code as simple as C with just a small amount of FFI type declarations. 9 | 10 | This library has been tested to work on SBCL, CCL, ECL, ABCL, and CLISP, 11 | and theoretically is portable across implementations that provide ~macroexpand-all~. 12 | * Rules 13 | Here is a comparison table between C syntax: 14 | 15 | | C | ~cffi-ops~ | 16 | |--------------------------+--------------------------------------------------------------------------------| 17 | | ~x->y.z~ or ~x->y->z~ | ~(-> x y z)~ (Note that ~x~, ~y~, and ~z~ must be the same symbols used in ~defcstruct~) | 18 | | ~&x->y~ | ~(& (-> x y))~ | 19 | | ~*x~ | ~([] x)~ | 20 | | ~x[n]~ | ~([] x n)~ | 21 | | ~&x[n]~ or ~x + n~ | ~(& ([] x n))~ | 22 | | ~x.y = z~ | ~(setf (-> x y) z)~ if ~z~ is a variable | 23 | | | ~(csetf (-> x y) z)~ if ~z~ is a CFFI pointer | 24 | | ~A _a, *a = &_a~ | ~(clet ((a (foreign-alloca '(:struct A)))) ...)~ | 25 | | ~A *a = malloc(sizeof(A))~ | ~(clet ((a (cffi:foreign-alloc '(:struct A)))) ...)~ | 26 | | ~A _a = *b, *a = &_a~ | ~(clet ((a ([] b))) ...)~ | 27 | | ~A *a = b~ | ~(clet ((a b)) ...)~ | 28 | 29 | Please note that since it is not possible to directly manipulate C compound types in Lisp, 30 | binding and assignment of compound types require the use of ~clet~ (or ~clet*~) and ~csetf~, 31 | which bind and operate on variables that are CFFI pointers. 32 | 33 | And the symbol ~->~ is directly exported from the [[https://github.com/hipeta/arrow-macros][arrow-macros]] package, 34 | so this library is fully compatible with ~arrow-macros~, 35 | which means you can freely use all the macros (including ~->~) provided by ~arrow-macros~ inside or outside of ~clocally~, ~clet~, ~clet*~, or ~csetf~. 36 | * Example 37 | For the following C code: 38 | 39 | #+BEGIN_SRC c 40 | #include 41 | #include 42 | 43 | typedef struct { 44 | float x; 45 | float y; 46 | float z; 47 | } Vector3; 48 | 49 | typedef struct { 50 | Vector3 v1; 51 | Vector3 v2; 52 | Vector3 v3; 53 | } Matrix3; 54 | 55 | void Vector3Add(Vector3 *output, const Vector3 *v1, const Vector3 *v2) { 56 | output->x = v1->x + v2->x; 57 | output->y = v1->y + v2->y; 58 | output->z = v1->z + v2->z; 59 | } 60 | 61 | int main(int argc, char *argv[]) { 62 | Matrix3 m1[3]; 63 | m1[0].v1.x = 1.0; 64 | m1[0].v1.y = 2.0; 65 | m1[0].v1.z = 3.0; 66 | Matrix3 m2 = *m1; 67 | Vector3 *v1 = &m2.v1; 68 | Vector3 *v2 = malloc(sizeof(Vector3)); 69 | ,*v2 = *v1; 70 | v2->x = 3.0; 71 | v2->z = 1.0; 72 | Vector3Add(v1, v1, v2); 73 | assert(v1->x == 4.0); 74 | assert(v1->y == 4.0); 75 | assert(v1->z == 4.0); 76 | free(v2); 77 | return 0; 78 | } 79 | #+END_SRC 80 | 81 | The equivalent Lisp code (written using ~cffi-ops~) is: 82 | 83 | #+BEGIN_SRC lisp 84 | (defpackage cffi-ops-example 85 | (:use #:cl #:cffi #:cffi-ops)) 86 | 87 | (in-package #:cffi-ops-example) 88 | 89 | (defcstruct vector3 90 | (x :float) 91 | (y :float) 92 | (z :float)) 93 | 94 | (defcstruct matrix3 95 | (v1 (:struct vector3)) 96 | (v2 (:struct vector3)) 97 | (v3 (:struct vector3))) 98 | 99 | (defun vector3-add (output v1 v2) 100 | (clocally 101 | (declare (ctype (:pointer (:struct vector3)) output v1 v2)) 102 | (setf (-> output x) (+ (-> v1 x) (-> v2 x)) 103 | (-> output y) (+ (-> v1 y) (-> v2 y)) 104 | (-> output z) (+ (-> v1 z) (-> v2 z))))) 105 | 106 | (defun main () 107 | (clet ((m1 (foreign-alloca '(:array (:struct matrix3) 3)))) 108 | (setf (-> ([] m1 0) v1 x) 1.0 109 | (-> ([] m1 0) v1 y) 2.0 110 | (-> ([] m1 0) v1 z) 3.0) 111 | (clet* ((m2 ([] m1)) 112 | (v1 (& (-> m2 v1))) 113 | (v2 (foreign-alloc '(:struct vector3)))) 114 | (csetf ([] v2) ([] v1)) 115 | (setf (-> v2 x) 3.0 116 | (-> v2 z) 1.0) 117 | (vector3-add v1 v1 v2) 118 | (assert (= (-> v1 x) 4.0)) 119 | (assert (= (-> v1 y) 4.0)) 120 | (assert (= (-> v1 z) 4.0)) 121 | (foreign-free v2)))) 122 | #+END_SRC 123 | 124 | And the equivalent Lisp code (written without using ~cffi-ops~) is: 125 | 126 | #+BEGIN_SRC lisp 127 | (defpackage cffi-example 128 | (:use #:cl #:cffi)) 129 | 130 | (in-package #:cffi-example) 131 | 132 | (defcstruct vector3 133 | (x :float) 134 | (y :float) 135 | (z :float)) 136 | 137 | (defcstruct matrix3 138 | (v1 (:struct vector3)) 139 | (v2 (:struct vector3)) 140 | (v3 (:struct vector3))) 141 | 142 | (declaim (inline memcpy)) 143 | (defcfun "memcpy" :void 144 | (dest :pointer) 145 | (src :pointer) 146 | (n :size)) 147 | 148 | (defun vector3-add (output v1 v2) 149 | (with-foreign-slots (((xout x) (yout y) (zout z)) output (:struct vector3)) 150 | (with-foreign-slots (((x1 x) (y1 y) (z1 z)) v1 (:struct vector3)) 151 | (with-foreign-slots (((x2 x) (y2 y) (z2 z)) v2 (:struct vector3)) 152 | (setf xout (+ x1 x2) yout (+ y1 y2) zout (+ z1 z2)))))) 153 | 154 | (defun main () 155 | (with-foreign-object (m1 '(:struct matrix3) 3) 156 | (with-foreign-slots ((x y z) 157 | (foreign-slot-pointer 158 | (mem-aptr m1 '(:struct matrix3) 0) 159 | '(:struct matrix3) 'v1) 160 | (:struct vector3)) 161 | (setf x 1.0 y 2.0 z 3.0)) 162 | (with-foreign-object (m2 '(:struct matrix3)) 163 | (memcpy m2 m1 (foreign-type-size '(:struct matrix3))) 164 | (let ((v1 (foreign-slot-pointer m2 '(:struct matrix3) 'v1)) 165 | (v2 (foreign-alloc '(:struct vector3)))) 166 | (memcpy v2 v1 (foreign-type-size '(:struct vector3))) 167 | (with-foreign-slots ((x z) v2 (:struct vector3)) 168 | (setf x 3.0 z 1.0)) 169 | (vector3-add v1 v1 v2) 170 | (with-foreign-slots ((x y z) v1 (:struct vector3)) 171 | (assert (= x 4.0)) 172 | (assert (= y 4.0)) 173 | (assert (= z 4.0))) 174 | (foreign-free v2))))) 175 | #+END_SRC 176 | 177 | Both of them should generate almost equivalent machine code in SBCL and have very similar performance. 178 | -------------------------------------------------------------------------------- /walker.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cffi-ops) 2 | 3 | (defvar *value-required* t) 4 | 5 | (defvar *type-dictionary* nil) 6 | 7 | (defvar *struct-slots* nil) 8 | 9 | (defvar *macro-environment* nil) 10 | 11 | (declaim (notinline ctypes-slots)) 12 | (defun ctypes-slots (types) 13 | (let ((type-table (make-hash-table))) 14 | (labels ((ctype-slots (ctype) 15 | (setf ctype (cffi::ensure-parsed-base-type ctype)) 16 | (unless (gethash ctype type-table) 17 | (typecase ctype 18 | (cffi::foreign-struct-type 19 | (loop :for slot-name :in (cffi:foreign-slot-names ctype) 20 | :for slot-type := (cffi:foreign-slot-type ctype slot-name) 21 | :do (setf (gethash slot-type type-table) t) 22 | :nconc (cons slot-name (ctype-slots slot-type)))) 23 | (cffi::foreign-pointer-type 24 | (ctype-slots (cffi::pointer-type ctype))) 25 | (cffi::foreign-array-type 26 | (ctype-slots (cffi::element-type ctype))))))) 27 | (remove-duplicates (mapcan #'ctype-slots types))))) 28 | 29 | (declaim (notinline pointer-type-p)) 30 | (defun pointer-type-p (type) 31 | (typep (cffi::ensure-parsed-base-type type) 'cffi::foreign-pointer-type)) 32 | 33 | (declaim (notinline ensure-pointer-type)) 34 | (defun ensure-pointer-type (type) 35 | (setf type (cffi::ensure-parsed-base-type type) 36 | type (typecase type 37 | (cffi::foreign-pointer-type (cffi::pointer-type type)) 38 | (t type))) 39 | `(:pointer 40 | ,(typecase type 41 | (cffi::foreign-array-type (cffi::element-type type)) 42 | (cffi::foreign-type (cffi::unparse-type type)) 43 | (t type)))) 44 | 45 | (defgeneric funcall-form-type (function args) 46 | (:method (function args) (declare (ignore function args))) 47 | (:method ((function (eql 'foreign-alloc)) args) 48 | (destructuring-bind (type) args 49 | (assert (constantp type *macro-environment*)) 50 | `(:pointer ,(eval type))))) 51 | 52 | (declaim (notinline form-type)) 53 | (defun form-type (form) 54 | (setf form (macroexpand form *macro-environment*)) 55 | (etypecase form 56 | (symbol (values (assoc-value *type-dictionary* form) form)) 57 | (list (destructuring-case form 58 | ((the type tform) 59 | (declare (ignore type)) 60 | (values (form-type tform) form)) 61 | ((%cthe ctype cform) 62 | (assert (constantp ctype *macro-environment*)) 63 | (values (eval ctype) cform)) 64 | ((t &rest args) 65 | (declare (ignore args)) 66 | (values (funcall-form-type (car form) (cdr form)) form)))))) 67 | 68 | (declaim (inline %cthe)) 69 | (defun %cthe (ctype form) 70 | (declare (ignore ctype)) 71 | (values form)) 72 | 73 | (define-compiler-macro %cthe (ctype form) 74 | (declare (ignore ctype)) form) 75 | 76 | (defun expand-slot (slot form) 77 | (multiple-value-bind (type form) 78 | (let ((*value-required* nil)) (form-type (expand-form form))) 79 | (loop :for parsed-type := (cffi::ensure-parsed-base-type type) 80 | :for expansions :from 0 81 | :while (typep parsed-type 'cffi::foreign-pointer-type) 82 | :when (plusp expansions) 83 | :do (setf form `(mem-ref ,form ',(cffi::unparse-type type))) 84 | :do (setf type (cffi::unparse-type (cffi::pointer-type parsed-type)))) 85 | (let ((rtype (foreign-slot-type type slot))) 86 | (if *value-required* 87 | `(%cthe ',rtype (foreign-slot-value ,form ',type ',slot)) 88 | `(%cthe '(:pointer ,rtype) (foreign-slot-pointer ,form ',type ',slot)))))) 89 | 90 | (defun expand-aref (pointer index) 91 | (multiple-value-bind (type pointer) 92 | (multiple-value-bind (value-type value-form) 93 | (let ((*value-required* t)) 94 | (form-type (expand-form pointer))) 95 | (when (typep (cffi::ensure-parsed-base-type value-type) 'cffi::foreign-array-type) 96 | (setf (values value-type value-form) (let ((*value-required* nil)) (form-type (expand-form pointer))) 97 | value-type (cadr value-type))) ; (:pointer (:array ...)) -> (:array ...) 98 | (values value-type value-form)) 99 | (let ((index (let ((*value-required* t)) (expand-form index)))) 100 | (multiple-value-bind (type rtype) 101 | (let ((rtype (cffi::ensure-parsed-base-type type))) 102 | (etypecase rtype 103 | (cffi::foreign-pointer-type 104 | (values type (cffi::unparse-type (cffi::pointer-type rtype)))) 105 | (cffi::foreign-array-type 106 | (values `(:pointer ,(cffi::element-type rtype)) ; (:array ...) -> (:pointer ...) 107 | (cffi::element-type rtype))))) 108 | (if *value-required* 109 | `(%cthe ',rtype (mem-aref ,pointer ',rtype ,index)) 110 | `(%cthe ',type (mem-aptr ,pointer ',rtype ,index))))))) 111 | 112 | (defun expand-ref (form) 113 | (multiple-value-bind (type form) 114 | (let ((*value-required* nil)) 115 | (form-type (expand-form form))) 116 | `(%cthe ',type ,form))) 117 | 118 | (defun expand-form (form) 119 | (typecase form 120 | (cons 121 | (destructuring-case form 122 | (((declare quote) &rest args) (declare (ignore args)) form) 123 | (((let let*) bindings &rest body) 124 | (list* (car form) 125 | (mapcar (lambda (binding) 126 | (typecase binding 127 | (symbol binding) 128 | (list (list (first binding) (expand-form (second binding)))))) 129 | bindings) 130 | (mapcar #'expand-form body))) 131 | (((flet labels) bindings &rest body) 132 | (list* (car form) 133 | (mapcar 134 | (lambda (binding) 135 | (destructuring-bind (name lambda-list &rest body) binding 136 | `(,name ,lambda-list . ,(mapcar #'expand-form body)))) 137 | bindings) 138 | (mapcar #'expand-form body))) 139 | ((%cthe type form) `(%cthe ,type ,(expand-form form))) 140 | ((-> init &rest args) (declare (ignore args)) 141 | (let ((*struct-slots* (if-let ((type (form-type (expand-form init)))) 142 | (nconc (ctypes-slots (list type)) *struct-slots*) 143 | *struct-slots*))) 144 | (expand-form (macroexpand form *macro-environment*)))) 145 | (([] pointer &optional (index 0)) (expand-aref pointer index)) 146 | ((& form) (expand-ref form)) 147 | ((t &rest args) 148 | (cond 149 | ((find (car form) *struct-slots*) (expand-slot (car form) (first args))) 150 | ((proper-list-p args) (cons (car form) (let ((*value-required* t)) (mapcar #'expand-form args)))) 151 | (t form))))) 152 | (t form))) 153 | 154 | (defgeneric funcall-dynamic-extent-form (function args) 155 | (:method (function args) (declare (ignore function args))) 156 | (:method ((function (eql 'foreign-alloc)) args) 157 | (destructuring-bind (type) args 158 | (lambda (var body) 159 | (assert (constantp type *macro-environment*)) 160 | `(with-foreign-object (,var ',(eval type)) . ,body))))) 161 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------