diff options
| -rw-r--r-- | lisplib.c | 19 | ||||
| -rw-r--r-- | share/txr/stdlib/ffi.tl | 91 |
2 files changed, 110 insertions, 0 deletions
@@ -520,6 +520,24 @@ static val keyparams_instantiate(val set_fun) return nil; } +static val ffi_set_entries(val dlt, val fun) +{ + val name[] = { + lit("with-dyn-lib"), lit("deffi"), lit("deffi-type"), lit("deffi-cb"), + lit("sizeof"), + nil + }; + set_dlt_entries(dlt, name, fun); + return nil; +} + +static val ffi_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~affi.tl"), stdlib_path, nao)); + return nil; +} + val dlt_register(val dlt, val (*instantiate)(val), val (*set_entries)(val, val)) @@ -559,6 +577,7 @@ void lisplib_init(void) dlt_register(dl_table, pmac_instantiate, pmac_set_entries); dlt_register(dl_table, error_instantiate, error_set_entries); dlt_register(dl_table, keyparams_instantiate, keyparams_set_entries); + dlt_register(dl_table, ffi_instantiate, ffi_set_entries); } val lisplib_try_load(val sym) diff --git a/share/txr/stdlib/ffi.tl b/share/txr/stdlib/ffi.tl new file mode 100644 index 00000000..2d61e640 --- /dev/null +++ b/share/txr/stdlib/ffi.tl @@ -0,0 +1,91 @@ +;; Copyright 2017 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, this +;; list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defmacro sys:dlib-expr (spec) + (typecase spec + (null ^(dlopen)) + (str ^(dlopen ,spec rtld-now)) + (t spec))) + +(defmacro with-dyn-lib (lib . body) + (let ((keep-var (gensym "lib-"))) + ^(prog1 + (defvarl ,keep-var (sys:dlib-expr ,lib)) + (symacrolet ((sys:ffi-lib ,keep-var)) + ,*body)))) + +(defun sys:analyze-argtypes (form argtypes) + (let ((p (posq : argtypes))) + (when p + (if (zerop p) + (compile-error form "variadic with zero fixed arguments not allowed") + (del [argtypes p]))) + (list* (length argtypes) p argtypes))) + +(defmacro deffi (:form f name fun-expr rettype argtypes) + (let ((fun-ref (cond + ((stringp fun-expr) + ^(dlsym-checked sys:ffi-lib ,fun-expr)) + ((consp fun-expr) + (mac-param-bind f (sym ver) fun-expr + ^(dlvsym-checked sys:ffi-lib ,sym ,ver))) + (t fun-expr))) + (args-sym (gensym "args-")) + (ret-type-sym (gensym "ret-type-")) + (arg-types-sym (gensym "arg-types-")) + (call-desc-sym (gensym "call-desc-")) + (fun-sym (gensym "ffi-fun-"))) + (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes) + ^(progn + (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) + (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) + (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic + ,ret-type-sym + ,arg-types-sym)) + (defvarl ,fun-sym ,fun-ref) + (defun ,name ,args-sym + (ffi-call ,call-desc-sym ,fun-sym ,args-sym)))))) + +(defmacro deffi-type (name type-expr) + ^(ffi-typedef ',name (ffi-type-compile ',type-expr))) + +(defmacro deffi-cb (:form f name rettype argtypes) + (let ((ret-type-sym (gensym "ret-type-")) + (arg-types-sym (gensym "arg-types-")) + (call-desc-sym (gensym "call-desc-")) + (fun-sym (gensym "fun-"))) + (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes) + ^(progn + (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) + (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) + (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic + ,ret-type-sym + ,arg-types-sym)) + (defun ,name (,fun-sym) + [ffi-make-closure ,fun-sym ,call-desc-sym]))))) + +(defmacro sizeof (type) + (ffi-size (ffi-type-compile type))) |