├── .gitignore ├── LICENSE.txt ├── README.md ├── callback-heaven-examples.asd ├── callback-heaven.asd ├── callback-heaven.lisp ├── example ├── Makefile ├── example.c ├── example.h ├── example.lisp ├── lispcall.c ├── package.lisp └── test.lisp ├── package.lisp └── utilities.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dylib 4 | *.fasl 5 | system-index.txt 6 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2019, Robert Smith 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Callback Heaven 2 | 3 | Manage callbacks from C into Lisp by generating trampolines. 4 | -------------------------------------------------------------------------------- /callback-heaven-examples.asd: -------------------------------------------------------------------------------- 1 | ;;;; callback-heaven-examples.asd 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (asdf:defsystem #:callback-heaven-examples 6 | :description "A framework for calling Lisp from C." 7 | :author "Robert Smith " 8 | :license "BSD 3-clause (See LICENSE.txt)" 9 | :depends-on (#:cffi #:alexandria #:callback-heaven) 10 | :serial t 11 | :components ((:module "example" 12 | :serial t 13 | :components 14 | ((:file "package") 15 | (:file "example"))))) 16 | 17 | -------------------------------------------------------------------------------- /callback-heaven.asd: -------------------------------------------------------------------------------- 1 | ;;;; callback-heaven.asd 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (asdf:defsystem #:callback-heaven 6 | :description "A framework for calling Lisp from C." 7 | :author "Robert Smith " 8 | :license "BSD 3-clause (See LICENSE.txt)" 9 | :depends-on (#:cffi #:alexandria #:uiop) 10 | :serial t 11 | :components ((:file "package") 12 | (:file "utilities") 13 | (:file "callback-heaven"))) 14 | 15 | -------------------------------------------------------------------------------- /callback-heaven.lisp: -------------------------------------------------------------------------------- 1 | ;;;; callback-heaven.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2019 Robert Smith 4 | 5 | (in-package #:callback-heaven) 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; API GROUPS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | 9 | ;;; API groups are logical groups of functions callable from C. Each 10 | ;;; API group corresponds to a C header + file. 11 | 12 | (defvar *api-groups* (make-hash-table :test 'eq) 13 | "A table mapping API group names (SYMBOLs) to API-GROUP structures.") 14 | 15 | (defun api-group (group-name) 16 | "Return the API-GROUP associated with the name GROUP-NAME." 17 | (values (gethash group-name *api-groups*))) 18 | 19 | (defun (setf api-group) (new-value group-name) 20 | (setf (gethash group-name *api-groups*) new-value)) 21 | 22 | (defstruct api-group 23 | "An API-GROUP is a named set of C-compatible Lisp functions. These functions are described by the API-FUNCTION structure." 24 | (name nil :type symbol :read-only t) 25 | (documentation nil :type (or null string)) 26 | ;; FUNCTION-TABLE is a hash table mapping symbols to API-FUNCTIONs. 27 | (function-table nil :type hash-table :read-only t)) 28 | 29 | (defun find-or-make-api-group (group-name &optional (documentation nil docp)) 30 | "Find the API group designated by the name GROUP-NAME, or make it if it doesn't exist." 31 | (multiple-value-bind (ag foundp) (api-group group-name) 32 | (cond (foundp 33 | (when docp 34 | (setf (api-group-documentation ag) documentation)) 35 | ag) 36 | (t 37 | (setf (api-group group-name) 38 | (make-api-group :name group-name 39 | :documentation documentation 40 | :function-table (make-hash-table :test 'eq))))))) 41 | 42 | (defun api-group-function (group function-name) 43 | "Given an API group GROUP, look up the function named FUNCTION-NAME. Return NIL if not found." 44 | (check-type group api-group) 45 | (check-type function-name symbol) 46 | (values (gethash function-name (api-group-function-table group)))) 47 | 48 | (defun (setf api-group-function) (new-value group function-name) 49 | (setf (gethash function-name (api-group-function-table group)) 50 | new-value)) 51 | 52 | (defmacro define-api-group (name &optional (documentation nil docp)) 53 | "Declare the existence of the API group named NAME. Intended as a top-level form." 54 | (check-type name symbol) 55 | `(progn 56 | (find-or-make-api-group ',name ,@(if docp (list documentation) nil)) 57 | ',name)) 58 | 59 | 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; API FUNCTIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | ;;; API functions are individually callable functions from C, but 63 | ;;; defined in Lisp. 64 | 65 | (defstruct api-function 66 | "A representation of a Lisp function that is callable from C." 67 | ;; The Lisp name of the function, which can only be referenced recursively. 68 | (name nil :type symbol :read-only t) 69 | ;; The documentation string. 70 | (documentation nil :type (or null string) :read-only t) 71 | ;; The name of the callback. 72 | (callback-name nil :type symbol :read-only t) 73 | ;; A pointer to the callback function. 74 | (pointer nil :type cffi:foreign-pointer :read-only t) 75 | ;; The user-specified name of the function in the C world. By 76 | ;; default, this will make a reasonable attempt to generate a C 77 | ;; name, for instance, by changing #\- to #\_. 78 | (c-name nil :type string :read-only t) 79 | ;; The C return type, specified as a Lisp symbol. 80 | (return-type nil :read-only t) 81 | ;; The C argument names and types, specified as Lisp pairs. 82 | (arguments nil :read-only t)) 83 | 84 | (defun api-function-type (api-function) 85 | "Return the (C) function pointer type of the function API-FUNCTION." 86 | `(:function ,(api-function-return-type api-function) 87 | ,@(mapcar #'second (api-function-arguments api-function)))) 88 | 89 | (defmacro define-api-function ((name group-name &key c-name) 90 | return-type (&rest args-and-types) 91 | &body body) 92 | "Define an API function that is callable from C. 93 | 94 | - NAME should be the Lisp name of the function. 95 | 96 | - GROUP-NAME is the API group where this function lives. 97 | 98 | - Optionally, C-NAME is the name of this function as seen by C. 99 | 100 | - RETURN-TYPE is the CFFI return type of this function. Getting this incorrect is hazardous. 101 | 102 | - ARGS-AND-TYPES are pairs of (ARGUMENT TYPE) specified as CFFI types. 103 | 104 | For example: 105 | 106 | (define-api-function (square math-functions :c-name \"sq\") ((x :int)) 107 | (ldb (byte 64 0) (* x x))) 108 | " 109 | (check-type name symbol) 110 | (check-type group-name symbol) 111 | (check-type c-name (or null string)) 112 | (when (null c-name) 113 | (setf c-name (cffi:translate-name-to-foreign name nil))) 114 | 115 | (let* ((api-group (api-group group-name)) 116 | (current-api-function (api-group-function api-group name)) 117 | (callback-name (if current-api-function 118 | (api-function-callback-name current-api-function) 119 | (gensym (symbol-name name)))) 120 | (args (mapcar #'first args-and-types))) 121 | (multiple-value-bind (body declarations documentation) 122 | (alexandria:parse-body body :documentation t) 123 | `(progn 124 | (cffi:defcallback ,callback-name ,return-type ,args-and-types 125 | ,@(if documentation (list documentation) nil) 126 | ;; Ensure we can do a recursive call. 127 | (flet ((,name ,args 128 | #-sbcl 129 | (,callback-name ,@args) 130 | #+sbcl 131 | (cffi:foreign-funcall-pointer 132 | ;; Should we attempt to store this somewhere for 133 | ;; extra efficiency? 134 | (cffi:get-callback ',callback-name) 135 | () 136 | ,@(mapcan #'reverse args-and-types) 137 | ,return-type))) 138 | (declare (inline ,name) 139 | (ignorable (function ,name))) 140 | ,@body)) 141 | 142 | (setf (api-group-function (api-group ',group-name) ',name) 143 | (make-api-function :name ',name 144 | :callback-name ',callback-name 145 | :pointer (cffi:get-callback ',callback-name) 146 | :c-name ,c-name 147 | :return-type ',return-type 148 | :arguments ',args-and-types 149 | :documentation ,documentation)) 150 | 151 | ;; Neither CCL nor LispWorks need an update here, since the 152 | ;; pointers seem to persist across redefinitions. It's not 153 | ;; unsafe to do it anyway, however. 154 | ;; 155 | ;; NOTE: This only updates EXISTING definitions. Any additional 156 | ;; ones will require modification of the C translation data 157 | ;; structure, as well as regeneration of the C libraries. 158 | (let ((ctrans (gethash (api-group ',group-name) *api-group-translations*))) 159 | (when ctrans 160 | (update-foreign-function-index ctrans))) 161 | 162 | ',name)))) 163 | 164 | ;;;;;;;;;;;;;;;;;;;;;;; TRAMPOLINE GENERATION ;;;;;;;;;;;;;;;;;;;;;;;; 165 | 166 | ;;; API groups are translated into C files and their existence is kept 167 | ;;; track of by way of a "C space translation". We have to do this 168 | ;;; bookkeeping for the following reason. C doesn't have the Lisp 169 | ;;; functions defined; instead, it has stubs that must be patched 170 | ;;; in. The stubs look up the function pointer addresses in an array 171 | ;;; which Lisp fills out. Maintaining that array and filling it out is 172 | ;;; the role of the C-SPACE-TRANSLATION structure. 173 | 174 | (defstruct c-space-translation 175 | "Manages the translation of an API-GROUP to realized functions in C space." 176 | ;; The API group for this translation. 177 | (api-group nil :type api-group :read-only t) 178 | ;; A vector of function names corresponding to the function pointers 179 | ;; of FUNCTION-INDEX. 180 | index-translations 181 | ;; The name of the function pointer array in C. 182 | (function-index-c-name nil :type string :read-only t) 183 | ;; A foreign array of function pointers corresponding to this API 184 | ;; group. 185 | (function-index nil :type cffi:foreign-pointer :read-only t)) 186 | 187 | (defun function-index-size-variable-name (ctrans) 188 | "The C variable name indicating the number of functions in the index." 189 | (format nil "~A_SIZE" (string-upcase (c-space-translation-function-index-c-name ctrans)))) 190 | 191 | (defun function-index-setter-function-name (ctrans) 192 | "The C function name used to patch in the function pointers." 193 | (format nil "set_~A" (c-space-translation-function-index-c-name ctrans))) 194 | 195 | (defun foreign-function-index (api-group) 196 | "Generate an array (allocated with malloc) of function pointers for the API-GROUP which may be patched in. 197 | 198 | Note that this memory is not further managed!" 199 | (let* ((functions (api-group-function-table api-group)) 200 | (function-count (hash-table-count functions)) 201 | (function-index (cffi:foreign-alloc ':pointer 202 | :initial-element (cffi:null-pointer) 203 | :count function-count)) 204 | (index-translations (make-array function-count))) 205 | (loop :for i :below function-count 206 | :for name :being :the :hash-keys :of functions :using (hash-value f) 207 | :do (setf (cffi:mem-aref function-index ':pointer i) (api-function-pointer f) 208 | (aref index-translations i) name) 209 | :finally (return (values 210 | function-index 211 | index-translations))))) 212 | 213 | (defun update-foreign-function-index (ctrans) 214 | "Update the function pointers of CTRANS for any callbacks that have updated." 215 | (let* ((api-group (c-space-translation-api-group ctrans)) 216 | (function-index (c-space-translation-function-index ctrans)) 217 | (index-translations (c-space-translation-index-translations ctrans))) 218 | (loop :for i :from 0 219 | :for fname :across index-translations 220 | :for updated-ptr := (api-function-pointer (api-group-function api-group fname)) 221 | :do (setf (cffi:mem-aref function-index ':pointer i) updated-ptr) 222 | :finally (return (values 223 | function-index))))) 224 | 225 | (defvar *api-group-translations* (make-hash-table :test 'eq) 226 | "A table mapping API-GROUP objects (by identity!) to their C space translations.") 227 | 228 | (defun compute-c-space-translation (api-group) 229 | "Given an API group, compute C space translations for it." 230 | (multiple-value-bind (function-index index-translations) 231 | (foreign-function-index api-group) 232 | (setf (gethash api-group *api-group-translations*) 233 | (make-c-space-translation 234 | :api-group api-group 235 | :index-translations index-translations 236 | :function-index-c-name (format nil "function_index_group_~A" 237 | (cffi:translate-name-to-foreign (api-group-name api-group) nil)) 238 | :function-index function-index)))) 239 | 240 | (defun emit-documentation (documentation stream) 241 | (alexandria:when-let ((lines (and documentation 242 | (uiop:split-string documentation :separator '(#\Newline))))) 243 | ;; No need for an (ENDP LINES) clause here. LINES must be non-NULL due to the WHEN-LET above. 244 | (cond ((endp (rest lines)) 245 | (format stream "/** ~A */~%" (first lines))) 246 | (t 247 | (format stream "/**~%") 248 | (dolist (line lines) 249 | (if (string= "" line) 250 | (format stream " *~%") 251 | (format stream " * ~A~%" line))) 252 | (format stream " */~%"))))) 253 | 254 | (defun emit-api-function-prototype (api-function stream) 255 | (flet ((format-arg (arg-and-type) 256 | (format nil "~A~:[~; ~]~A" 257 | (type-name-to-foreign (second arg-and-type)) 258 | (%need-space-p arg-and-type) 259 | (cffi:translate-name-to-foreign (first arg-and-type) nil)))) 260 | (format stream "~A~:[ ~;~]~A(~{~A~^, ~})" 261 | (type-name-to-foreign (api-function-return-type api-function)) 262 | (listp (api-function-return-type api-function)) 263 | (api-function-c-name api-function) 264 | (mapcar #'format-arg (api-function-arguments api-function))))) 265 | 266 | (defun emit-api-function-header (ctrans stream) 267 | ;; Emit all of the API prototypes. 268 | (loop :with api-group := (c-space-translation-api-group ctrans) 269 | :for fname :across (c-space-translation-index-translations ctrans) 270 | :for f := (api-group-function api-group fname) 271 | :do (terpri stream) 272 | (emit-documentation (api-function-documentation f) stream) 273 | (emit-api-function-prototype f stream) 274 | (write-char #\; stream) 275 | (terpri stream))) 276 | 277 | (defun emit-api-function-definitions (ctrans stream &key 278 | (prefix nil) 279 | (postfix nil)) 280 | (let ((index-translations (c-space-translation-index-translations ctrans)) 281 | (api-group (c-space-translation-api-group ctrans))) 282 | (loop :for i :from 0 283 | :for fname :across index-translations 284 | :for f := (api-group-function api-group fname) 285 | :do (terpri stream) 286 | (emit-api-function-prototype f stream) 287 | (format stream " {~%") 288 | (unless (eq :void (api-function-return-type f)) 289 | (format stream " ~A ret;~%" (type-name-to-foreign (api-function-return-type f)))) 290 | (when prefix 291 | (if (functionp prefix) 292 | (funcall prefix stream ctrans f) 293 | (format stream " ~A~%" prefix))) 294 | (format stream " ~:[ret = ~;~]((~A)(~A[~D]))(~{~A~^, ~});~%" 295 | (eq :void (api-function-return-type f)) 296 | (type-name-to-foreign (api-function-type f)) 297 | (c-space-translation-function-index-c-name ctrans) 298 | i 299 | (mapcar (lambda (name) (cffi:translate-name-to-foreign name nil)) 300 | (mapcar #'first (api-function-arguments f)))) 301 | (when postfix 302 | (if (functionp postfix) 303 | (funcall postfix stream ctrans f) 304 | (format stream " ~A~%" postfix))) 305 | (unless (eq :void (api-function-return-type f)) 306 | (format stream " return ret;~%")) 307 | (format stream "}~%~%")))) 308 | 309 | (defun emit-function-index-definition (ctrans stream) 310 | (let ((idx-var (c-space-translation-function-index-c-name ctrans)) 311 | (size-var (function-index-size-variable-name ctrans))) 312 | (format stream "~&#define ~A ~D~%~%" 313 | size-var 314 | (length (c-space-translation-index-translations ctrans))) 315 | (format stream "static void **~A;~%~%" 316 | idx-var) 317 | (format stream "void ~A(void **functions) {~%~ 318 | ~4T~A = functions;~%~ 319 | }~%~%" 320 | (function-index-setter-function-name ctrans) 321 | idx-var))) 322 | 323 | (defun emit-includes (stream includes) 324 | (unless (endp includes) 325 | (format stream "~{#include ~A~^~%~}~%~%" includes))) 326 | 327 | ;;; Helper for EMIT-LIBRARY-FILES. 328 | (defun emit-h-file-contents (ctrans stream &key extra-includes) 329 | (let* ((api-group (c-space-translation-api-group ctrans)) 330 | (guard (format nil "GROUP_~A_HEADER_GUARD" 331 | (string-upcase 332 | (cffi:translate-name-to-foreign 333 | (api-group-name api-group) 334 | nil))))) 335 | (emit-documentation (api-group-documentation api-group) stream) 336 | (format stream "#ifndef ~A~%" guard) 337 | (format stream "#define ~A~%~%" guard) 338 | (emit-includes stream (list* "" "" extra-includes)) 339 | (emit-api-function-header ctrans stream) 340 | (format stream "~&~%~%#endif /* ~A */~%" guard))) 341 | 342 | ;;; Helper for EMIT-LIBRARY-FILES. 343 | (defun emit-c-file-contents (ctrans stream h-file &key prefix postfix extra-includes) 344 | (emit-includes stream (cons (format nil "~S" (file-namestring h-file)) 345 | extra-includes)) 346 | (emit-function-index-definition ctrans stream) 347 | (emit-api-function-definitions ctrans stream :prefix prefix :postfix postfix)) 348 | 349 | 350 | 351 | (defun emit-library-files (ctrans c-file h-file 352 | &key (if-exists ':supersede) 353 | (extra-c-file-includes '()) 354 | (extra-h-file-includes '()) 355 | (function-body-prefix nil) 356 | (function-body-postfix nil)) 357 | "Emit a header file H-FILE and a C file C-FILE for the C space translations CTRANS. 358 | 359 | The C file may be compiled either as a shared library or as a part of a larger system. Its \"exports\" are in the header file. 360 | 361 | * IF-EXISTS is an argument passed to OPEN. 362 | 363 | * EXTRA-C-FILE-INCLUDES is a LIST of STRINGs indicating extra files that should be included in C-FILE. 364 | 365 | * EXTRA-H-FILE-INCLUDES is a LIST of STRINGs indicating extra files that should be included in H-FILE. 366 | 367 | * FUNCTION-BODY-PREFIX allows the caller to specify a prefix to be added to each API-FUNCTION definition emitted in C-FILE. 368 | * If a STRING, it is inserted verbatim at the beginning of each API-FUNCTION. 369 | * If a FUNCTION, it will be called with three arguments: 1) the STREAM on which to write the prefix, 2) the current C-SPACE-TRANSLATION, and 3) the current API-FUNCTION. 370 | * If NULL, no prefix will be emitted. 371 | 372 | * FUNCTION-BODY-POSTFIX is just like FUNCTION-BODY-PREFIX, but for adding user code near the end of each API-FUNCTION, just before returning." 373 | (let ((c-file (pathname c-file)) 374 | (h-file (pathname h-file))) 375 | (with-open-file (stream h-file :direction ':output 376 | :if-does-not-exist ':create 377 | :if-exists if-exists) 378 | (emit-h-file-contents ctrans stream :extra-includes extra-h-file-includes)) 379 | 380 | (with-open-file (stream c-file :direction ':output 381 | :if-does-not-exist ':create 382 | :if-exists if-exists) 383 | (emit-c-file-contents ctrans stream h-file 384 | :prefix function-body-prefix 385 | :postfix function-body-postfix 386 | :extra-includes extra-c-file-includes)) 387 | 388 | (values c-file h-file))) 389 | -------------------------------------------------------------------------------- /example/Makefile: -------------------------------------------------------------------------------- 1 | # This assumes that quicklisp is already enabled by your sbcl init 2 | # files. If that is not the case, follow the installation instructions 3 | # at https://www.quicklisp.org/beta/. 4 | LISP=sbcl --noinform --non-interactive --eval '(push (truename "..") ql:*local-project-directories*)' 5 | CFLAGS += -fPIC 6 | 7 | UNAME_S := $(shell uname -s) 8 | ifeq ($(UNAME_S),Darwin) 9 | SOLINK += -dynamiclib 10 | SOEXT := dylib 11 | else 12 | SOLINK += -shared 13 | SOEXT := so 14 | endif 15 | 16 | .PHONY: all clean test 17 | all: libexample.$(SOEXT) 18 | 19 | example.c example.h: example.lisp 20 | $(LISP) \ 21 | --eval '(ql:quickload :callback-heaven-examples :silent t)' \ 22 | --eval '(callback-heaven-examples::emit-library-api)' \ 23 | --quit 24 | 25 | libexample.$(SOEXT): example.o lispcall.o 26 | cc $(SOLINK) -fPIC -o $@ $^ 27 | 28 | test: libexample.$(SOEXT) 29 | $(LISP) \ 30 | --eval '(ql:quickload :callback-heaven-examples :silent t)' \ 31 | --load 'test.lisp' \ 32 | --quit 33 | 34 | clean: 35 | rm -f *.o *.$(SOEXT) example.[ch] 36 | -------------------------------------------------------------------------------- /example/example.c: -------------------------------------------------------------------------------- 1 | #include "example.h" 2 | 3 | #define FUNCTION_INDEX_GROUP_EXAMPLE_SIZE 2 4 | 5 | static void **function_index_group_example; 6 | 7 | void set_function_index_group_example(void **functions) { 8 | function_index_group_example = functions; 9 | } 10 | 11 | 12 | int add(int a, int b) { 13 | int ret; 14 | ret = ((int (*)(int, int))(function_index_group_example[0]))(a, b); 15 | return ret; 16 | } 17 | 18 | 19 | void print_factorial(int n) { 20 | ((void (*)(int))(function_index_group_example[1]))(n); 21 | } 22 | 23 | -------------------------------------------------------------------------------- /example/example.h: -------------------------------------------------------------------------------- 1 | /** 2 | * @file example.h 3 | * 4 | * An example group. 5 | */ 6 | #ifndef GROUP_EXAMPLE_HEADER_GUARD 7 | #define GROUP_EXAMPLE_HEADER_GUARD 8 | 9 | #include 10 | #include 11 | 12 | 13 | /** Return the integer a + b. */ 14 | int add(int a, int b); 15 | 16 | /** 17 | * Print |n|! on standard output. 18 | * 19 | * The complete output will look something like 20 | * 21 | * Factorial 5 = 120 22 | * 23 | * @param n the integer whose absolute value will be used to compute the factorial. 24 | */ 25 | void print_factorial(int n); 26 | 27 | 28 | #endif /* GROUP_EXAMPLE_HEADER_GUARD */ 29 | -------------------------------------------------------------------------------- /example/example.lisp: -------------------------------------------------------------------------------- 1 | ;;;; example.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (in-package #:callback-heaven-examples) 6 | 7 | ;; First define your API group, and its API functions. 8 | 9 | (eval-when (:compile-toplevel :load-toplevel :execute) 10 | (define-api-group example 11 | ;; This documentation string will be included at the top of the .h 12 | ;; file that is generated for this API-GROUP. Here, we show an 13 | ;; example of a doxygen @file directive, but there is no requirement 14 | ;; to use doxygen syntax. CALLBACK-HEAVEN simply treats these as an 15 | ;; opaque string and emits them between C-style comment delimiters, 16 | ;; beginning with /** and ending with */. 17 | "@file example.h 18 | 19 | An example group.")) 20 | 21 | (define-api-function (add example) :int ((a :int) (b :int)) 22 | "Return the integer a + b." 23 | (ldb '#.(byte 32 0) (+ a b))) 24 | 25 | (define-api-function (print-factorial example) :void ((n :int)) 26 | "Print |n|! on standard output. 27 | 28 | The complete output will look something like 29 | 30 | Factorial 5 = 120 31 | 32 | @param n the integer whose absolute value will be used to compute the factorial." 33 | (flet ((factorial (n) 34 | (let ((result 1)) 35 | (loop :for i :from 1 :to n :do 36 | (setf result (* i result))) 37 | result))) 38 | (format t "Factorial ~A = ~A~%" n (factorial (abs n))) 39 | (values))) 40 | 41 | (defvar *ctrans* (compute-c-space-translation (api-group 'example))) 42 | 43 | (defun emit-library-api () 44 | (emit-library-files *ctrans* "example.c" "example.h")) 45 | 46 | ;; If the above API changes, you need to re-emit the C-API and 47 | ;; re-compile the shared library. The included Makefile will handle both 48 | ;; of these steps for you, just run: 49 | ;; 50 | ;; make clean; make 51 | ;; 52 | ;; For an example of loading and using the shared library, see the file 53 | ;; test.lisp. 54 | -------------------------------------------------------------------------------- /example/lispcall.c: -------------------------------------------------------------------------------- 1 | #include "example.h" 2 | 3 | void call_me_from_lisp(void) { 4 | print_factorial(add(2,3)); 5 | } 6 | -------------------------------------------------------------------------------- /example/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (defpackage #:callback-heaven-examples 6 | (:use #:cl #:callback-heaven)) 7 | 8 | -------------------------------------------------------------------------------- /example/test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; test.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2020 Robert Smith 4 | 5 | (in-package #:callback-heaven-examples) 6 | 7 | (assert (or (probe-file "libexample.dylib") 8 | (probe-file "libexample.so")) 9 | () 10 | "This file should only be loaded *after* generating the libexample shared library. ~@ 11 | You can run the code in this file by running \"make test\" in the examples directory.") 12 | 13 | ;; To load the shared library, make sure you are in the same directory 14 | ;; as the library and load it with: 15 | (cffi:define-foreign-library example 16 | (:darwin "libexample.dylib") 17 | (:unix "libexample.so") 18 | (t (:default "libexample"))) 19 | 20 | (cffi:use-foreign-library example) 21 | 22 | ;; CALLBACK-HEAVEN will also define a function (in the .c/.h files) with 23 | ;; the name set_function_index_group_. This function 24 | ;; will take in pointers to our defined lisp functions (in example.lisp) 25 | ;; and set-up the trampoline structure in C. We need to inform CFFI of 26 | ;; its existence: 27 | ;; 28 | (cffi:defcfun ("set_function_index_group_example" %set-function-index-group-example) 29 | :void 30 | (functions (:pointer (:pointer :void)))) 31 | 32 | (defun set-group-example-index () 33 | (%set-function-index-group-example 34 | (c-space-translation-function-index *ctrans*))) 35 | 36 | (set-group-example-index) 37 | 38 | ;; In lispcall.c we defined a function call_me_from_lisp, that will act as 39 | ;; our go-between. Tell CFFI of its existence, and invoke it. 40 | (cffi:defcfun ("call_me_from_lisp" %call-me-from-lisp) :void) 41 | 42 | (let ((expected (format nil "Factorial ~A = ~A~%" 5 120)) 43 | (actual (with-output-to-string (*standard-output*) 44 | (%call-me-from-lisp)))) 45 | (cond ((string= actual expected) 46 | (write-line "Test succeeded.") 47 | (uiop:quit 0)) 48 | (t 49 | (format t "~&Test failed.~@ 50 | Expected: ~S~@ 51 | Got: ~S~%" 52 | expected actual) 53 | (uiop:quit 1)))) 54 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2019 Robert Smith 4 | 5 | (defpackage #:callback-heaven 6 | (:use #:cl) 7 | (:export 8 | #:define-api-group ; MACRO 9 | #:define-api-function ; MACRO 10 | #:compute-c-space-translation ; FUNCTION 11 | #:c-space-translation-function-index ; FUNCTION 12 | #:emit-library-files ; FUNCTION 13 | #:api-group 14 | ) 15 | (:documentation "Functionality to write and emit C compatible libraries of functions.")) 16 | 17 | -------------------------------------------------------------------------------- /utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;;; utilities.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (in-package #:callback-heaven) 6 | 7 | (defparameter *simple-type-name-translations* 8 | '((:pointer "void*") 9 | 10 | (:char "char") 11 | (:unsigned-char "unsigned char") 12 | (:uchar "unsigned char") 13 | 14 | (:short "short") 15 | (:unsigned-short "unsigned short") 16 | (:ushort "unsigned short") 17 | 18 | (:int "int") 19 | (:unsigned-int "unsigned int") 20 | (:uint "unsigned int") 21 | 22 | (:long "long") 23 | (:unsigned-long "unsigned long") 24 | (:ulong "unsigned long") 25 | 26 | #-cffi-sys::no-long-long 27 | (:long-long "long long") 28 | #-cffi-sys::no-long-long 29 | (:llong "long long") 30 | #-cffi-sys::no-long-long 31 | (:unsigned-long-long "unsigned long long") 32 | #-cffi-sys::no-long-long 33 | (:ullong "unsigned long long") 34 | 35 | (:float "float") 36 | (:double "double") 37 | #+scl 38 | (:long-double "long double") 39 | 40 | (:void "void") 41 | 42 | (:int8 "int8_t") 43 | (:uint8 "uint8_t") 44 | 45 | (:int16 "int16_t") 46 | (:uint16 "uint16_t") 47 | 48 | (:int32 "int32_t") 49 | (:uint32 "uint32_t") 50 | 51 | (:int64 "int64_t") 52 | (:uint64 "uint64_t") 53 | 54 | ;; XXX: Fixme? 55 | (:boolean "int") 56 | (:string "char*"))) 57 | 58 | (defun %need-space-p (name) 59 | (and (second name) 60 | (not (typep (second name) 'list)) 61 | (not (eq ':pointer (second name))))) 62 | 63 | (defun type-name-to-foreign (name) 64 | (labels ((simple-name-p (name) 65 | (symbolp name)) 66 | 67 | (lookup-simple-type (name) 68 | (let ((translation (assoc name *simple-type-name-translations*))) 69 | (and translation 70 | (second translation))))) 71 | (cond 72 | ((simple-name-p name) (or (lookup-simple-type name) 73 | (cffi:translate-name-to-foreign name nil))) 74 | ((listp name) (case (first name) 75 | ((:struct) (format nil "struct ~A" 76 | (cffi:translate-name-to-foreign (second name) nil))) 77 | ((:pointer) (format nil "~A~:[~; ~]*" 78 | (type-name-to-foreign (second name)) 79 | (%need-space-p name))) 80 | ((:function) 81 | (destructuring-bind (return-type &rest arg-types) 82 | (rest name) 83 | (format nil "~A (*)(~{~A~^, ~})" 84 | (type-name-to-foreign return-type) 85 | (mapcar #'type-name-to-foreign arg-types)))) 86 | (otherwise (error "Unknown foreign type ~S" name)))) 87 | (t (error "Unknown foreign type ~S" name))))) 88 | --------------------------------------------------------------------------------