455 lines
17 KiB
Common Lisp
455 lines
17 KiB
Common Lisp
|
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
|
||
|
|
;;;
|
||
|
|
;;; cffi-ecl.lisp --- ECL backend for CFFI.
|
||
|
|
;;;
|
||
|
|
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
|
||
|
|
;;;
|
||
|
|
;;; Permission is hereby granted, free of charge, to any person
|
||
|
|
;;; obtaining a copy of this software and associated documentation
|
||
|
|
;;; files (the "Software"), to deal in the Software without
|
||
|
|
;;; restriction, including without limitation the rights to use, copy,
|
||
|
|
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
|
||
|
|
;;; of the Software, and to permit persons to whom the Software is
|
||
|
|
;;; furnished to do so, subject to the following conditions:
|
||
|
|
;;;
|
||
|
|
;;; The above copyright notice and this permission notice shall be
|
||
|
|
;;; included in all copies or substantial portions of the Software.
|
||
|
|
;;;
|
||
|
|
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||
|
|
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||
|
|
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
||
|
|
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||
|
|
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
|
||
|
|
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||
|
|
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||
|
|
;;; DEALINGS IN THE SOFTWARE.
|
||
|
|
;;;
|
||
|
|
|
||
|
|
;;;# Administrivia
|
||
|
|
|
||
|
|
(defpackage #:cffi-sys
|
||
|
|
(:use #:common-lisp #:alexandria)
|
||
|
|
(:import-from #:si #:null-pointer-p)
|
||
|
|
(:export
|
||
|
|
#:*cffi-ecl-method*
|
||
|
|
#:canonicalize-symbol-name-case
|
||
|
|
#:foreign-pointer
|
||
|
|
#:pointerp
|
||
|
|
#:pointer-eq
|
||
|
|
#:%foreign-alloc
|
||
|
|
#:foreign-free
|
||
|
|
#:with-foreign-pointer
|
||
|
|
#:null-pointer
|
||
|
|
#:null-pointer-p
|
||
|
|
#:inc-pointer
|
||
|
|
#:make-pointer
|
||
|
|
#:pointer-address
|
||
|
|
#:%mem-ref
|
||
|
|
#:%mem-set
|
||
|
|
#:%foreign-funcall
|
||
|
|
#:%foreign-funcall-pointer
|
||
|
|
#:%foreign-funcall-varargs
|
||
|
|
#:%foreign-funcall-pointer-varargs
|
||
|
|
#:%foreign-type-alignment
|
||
|
|
#:%foreign-type-size
|
||
|
|
#:%load-foreign-library
|
||
|
|
#:%close-foreign-library
|
||
|
|
#:native-namestring
|
||
|
|
#:make-shareable-byte-vector
|
||
|
|
#:with-pointer-to-vector-data
|
||
|
|
#:%defcallback
|
||
|
|
#:%callback
|
||
|
|
#:%foreign-symbol-pointer))
|
||
|
|
|
||
|
|
(in-package #:cffi-sys)
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; ECL allows many ways of calling a foreign function, and also many
|
||
|
|
;;; ways of finding the pointer associated to a function name. They
|
||
|
|
;;; depend on whether the FFI relies on libffi or on the C/C++ compiler,
|
||
|
|
;;; and whether they use the shared library loader to locate symbols
|
||
|
|
;;; or they are linked by the linker.
|
||
|
|
;;;
|
||
|
|
;;; :DFFI
|
||
|
|
;;;
|
||
|
|
;;; ECL uses libffi to call foreign functions. The only way to find out
|
||
|
|
;;; foreign symbols is by loading shared libraries and using dlopen()
|
||
|
|
;;; or similar.
|
||
|
|
;;;
|
||
|
|
;;; :DLOPEN
|
||
|
|
;;;
|
||
|
|
;;; ECL compiles FFI code as C/C++ statements. The names are resolved
|
||
|
|
;;; at run time by the shared library loader every time the function
|
||
|
|
;;; is called
|
||
|
|
;;;
|
||
|
|
;;; :C/C++
|
||
|
|
;;;
|
||
|
|
;;; ECL compiles FFI code as C/C++ statements, but the name resolution
|
||
|
|
;;; happens at link time. In this case you have to tell the ECL
|
||
|
|
;;; compiler which are the right ld-flags (c:*ld-flags*) to link in
|
||
|
|
;;; the library.
|
||
|
|
;;;
|
||
|
|
(defvar *cffi-ecl-method*
|
||
|
|
#+dffi :dffi
|
||
|
|
#+(and dlopen (not dffi)) :dlopen
|
||
|
|
#-(or dffi dlopen) :c/c++
|
||
|
|
"The type of code that CFFI generates for ECL: :DFFI when using the
|
||
|
|
dynamical foreign function interface; :DLOPEN when using C code and
|
||
|
|
dynamical references to symbols; :C/C++ for C/C++ code with static
|
||
|
|
references to symbols.")
|
||
|
|
|
||
|
|
;;;# Mis-features
|
||
|
|
|
||
|
|
#-long-long
|
||
|
|
(pushnew 'no-long-long *features*)
|
||
|
|
(pushnew 'flat-namespace *features*)
|
||
|
|
|
||
|
|
;;;# Symbol Case
|
||
|
|
|
||
|
|
(defun canonicalize-symbol-name-case (name)
|
||
|
|
(declare (string name))
|
||
|
|
(string-upcase name))
|
||
|
|
|
||
|
|
;;;# Allocation
|
||
|
|
|
||
|
|
(defun %foreign-alloc (size)
|
||
|
|
"Allocate SIZE bytes of foreign-addressable memory."
|
||
|
|
(si:allocate-foreign-data :void size))
|
||
|
|
|
||
|
|
(defun foreign-free (ptr)
|
||
|
|
"Free a pointer PTR allocated by FOREIGN-ALLOC."
|
||
|
|
(si:free-foreign-data ptr))
|
||
|
|
|
||
|
|
(defmacro with-foreign-pointer ((var size &optional size-var) &body body)
|
||
|
|
"Bind VAR to SIZE bytes of foreign memory during BODY. The
|
||
|
|
pointer in VAR is invalid beyond the dynamic extent of BODY, and
|
||
|
|
may be stack-allocated if supported by the implementation. If
|
||
|
|
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
|
||
|
|
(unless size-var
|
||
|
|
(setf size-var (gensym "SIZE")))
|
||
|
|
`(let* ((,size-var ,size)
|
||
|
|
(,var (%foreign-alloc ,size-var)))
|
||
|
|
(unwind-protect
|
||
|
|
(progn ,@body)
|
||
|
|
(foreign-free ,var))))
|
||
|
|
|
||
|
|
;;;# Misc. Pointer Operations
|
||
|
|
|
||
|
|
(deftype foreign-pointer ()
|
||
|
|
'si:foreign-data)
|
||
|
|
|
||
|
|
(defun null-pointer ()
|
||
|
|
"Construct and return a null pointer."
|
||
|
|
(si:allocate-foreign-data :void 0))
|
||
|
|
|
||
|
|
(defun inc-pointer (ptr offset)
|
||
|
|
"Return a pointer OFFSET bytes past PTR."
|
||
|
|
(ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
|
||
|
|
|
||
|
|
(defun pointerp (ptr)
|
||
|
|
"Return true if PTR is a foreign pointer."
|
||
|
|
(typep ptr 'si:foreign-data))
|
||
|
|
|
||
|
|
(defun pointer-eq (ptr1 ptr2)
|
||
|
|
"Return true if PTR1 and PTR2 point to the same address."
|
||
|
|
(= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
|
||
|
|
|
||
|
|
(defun make-pointer (address)
|
||
|
|
"Return a pointer pointing to ADDRESS."
|
||
|
|
(ffi:make-pointer address :void))
|
||
|
|
|
||
|
|
(defun pointer-address (ptr)
|
||
|
|
"Return the address pointed to by PTR."
|
||
|
|
(ffi:pointer-address ptr))
|
||
|
|
|
||
|
|
;;;# Shareable Vectors
|
||
|
|
;;;
|
||
|
|
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
|
||
|
|
;;; should be defined to perform a copy-in/copy-out if the Lisp
|
||
|
|
;;; implementation can't do this.
|
||
|
|
|
||
|
|
(defun make-shareable-byte-vector (size)
|
||
|
|
"Create a Lisp vector of SIZE bytes that can passed to
|
||
|
|
WITH-POINTER-TO-VECTOR-DATA."
|
||
|
|
(make-array size :element-type '(unsigned-byte 8)))
|
||
|
|
|
||
|
|
(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
|
||
|
|
"Bind PTR-VAR to a foreign pointer to the data in VECTOR."
|
||
|
|
`(let ((,ptr-var (si:make-foreign-data-from-array ,vector)))
|
||
|
|
,@body))
|
||
|
|
|
||
|
|
;;;# Type Operations
|
||
|
|
|
||
|
|
(defconstant +translation-table+
|
||
|
|
'((:char :byte "char")
|
||
|
|
(:unsigned-char :unsigned-byte "unsigned char")
|
||
|
|
(:short :short "short")
|
||
|
|
(:unsigned-short :unsigned-short "unsigned short")
|
||
|
|
(:int :int "int")
|
||
|
|
(:unsigned-int :unsigned-int "unsigned int")
|
||
|
|
(:long :long "long")
|
||
|
|
(:unsigned-long :unsigned-long "unsigned long")
|
||
|
|
#+long-long
|
||
|
|
(:long-long :long-long "long long")
|
||
|
|
#+long-long
|
||
|
|
(:unsigned-long-long :unsigned-long-long "unsigned long long")
|
||
|
|
(:float :float "float")
|
||
|
|
(:double :double "double")
|
||
|
|
(:pointer :pointer-void "void*")
|
||
|
|
(:void :void "void")))
|
||
|
|
|
||
|
|
(defun cffi-type->ecl-type (type-keyword)
|
||
|
|
"Convert a CFFI type keyword to an ECL type keyword."
|
||
|
|
(or (second (find type-keyword +translation-table+ :key #'first))
|
||
|
|
(error "~S is not a valid CFFI type" type-keyword)))
|
||
|
|
|
||
|
|
(defun ecl-type->c-type (type-keyword)
|
||
|
|
"Convert a CFFI type keyword to an valid C type keyword."
|
||
|
|
(or (third (find type-keyword +translation-table+ :key #'second))
|
||
|
|
(error "~S is not a valid CFFI type" type-keyword)))
|
||
|
|
|
||
|
|
(defun %foreign-type-size (type-keyword)
|
||
|
|
"Return the size in bytes of a foreign type."
|
||
|
|
(nth-value 0 (ffi:size-of-foreign-type
|
||
|
|
(cffi-type->ecl-type type-keyword))))
|
||
|
|
|
||
|
|
(defun %foreign-type-alignment (type-keyword)
|
||
|
|
"Return the alignment in bytes of a foreign type."
|
||
|
|
(nth-value 1 (ffi:size-of-foreign-type
|
||
|
|
(cffi-type->ecl-type type-keyword))))
|
||
|
|
|
||
|
|
;;;# Dereferencing
|
||
|
|
|
||
|
|
(defun %mem-ref (ptr type &optional (offset 0))
|
||
|
|
"Dereference an object of TYPE at OFFSET bytes from PTR."
|
||
|
|
(let* ((type (cffi-type->ecl-type type))
|
||
|
|
(type-size (ffi:size-of-foreign-type type)))
|
||
|
|
(si:foreign-data-ref-elt
|
||
|
|
(si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
|
||
|
|
|
||
|
|
(defun %mem-set (value ptr type &optional (offset 0))
|
||
|
|
"Set an object of TYPE at OFFSET bytes from PTR."
|
||
|
|
(let* ((type (cffi-type->ecl-type type))
|
||
|
|
(type-size (ffi:size-of-foreign-type type)))
|
||
|
|
(si:foreign-data-set-elt
|
||
|
|
(si:foreign-data-recast ptr (+ offset type-size) :void)
|
||
|
|
offset type value)))
|
||
|
|
|
||
|
|
;;; Inline versions that use C expressions instead of function calls.
|
||
|
|
|
||
|
|
(defparameter +mem-ref-strings+
|
||
|
|
(loop for (cffi-type ecl-type c-string) in +translation-table+
|
||
|
|
for string = (format nil "*((~A *)(((char*)#0)+#1))" c-string)
|
||
|
|
collect (list cffi-type ecl-type string)))
|
||
|
|
|
||
|
|
(defparameter +mem-set-strings+
|
||
|
|
(loop for (cffi-type ecl-type c-string) in +translation-table+
|
||
|
|
for string = (format nil "*((~A *)(((char*)#0)+#1))=#2" c-string)
|
||
|
|
collect (list cffi-type ecl-type string)))
|
||
|
|
|
||
|
|
(define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset 0))
|
||
|
|
(if (and (constantp type) (constantp offset))
|
||
|
|
(let ((record (assoc (eval type) +mem-ref-strings+)))
|
||
|
|
`(ffi:c-inline (,ptr ,offset)
|
||
|
|
(:pointer-void :cl-index) ; argument types
|
||
|
|
,(second record) ; return type
|
||
|
|
,(third record) ; the precomputed expansion
|
||
|
|
:one-liner t))
|
||
|
|
whole))
|
||
|
|
|
||
|
|
(define-compiler-macro %mem-set (&whole whole value ptr type &optional (offset 0))
|
||
|
|
(if (and (constantp type) (constantp offset))
|
||
|
|
(let ((record (assoc (eval type) +mem-set-strings+)))
|
||
|
|
`(ffi:c-inline (,ptr ,offset ,value) ; arguments with type translated
|
||
|
|
(:pointer-void :cl-index ,(second record))
|
||
|
|
:void ; does not return anything
|
||
|
|
,(third record) ; precomputed expansion
|
||
|
|
:one-liner t))
|
||
|
|
whole))
|
||
|
|
|
||
|
|
;;;# Calling Foreign Functions
|
||
|
|
|
||
|
|
(defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
|
||
|
|
|
||
|
|
(defun c-inline-function-call (thing fixed-types types values return-type dynamic-call variadic)
|
||
|
|
(when dynamic-call
|
||
|
|
(when (stringp thing)
|
||
|
|
(setf thing `(%foreign-symbol-pointer ,thing nil)))
|
||
|
|
(push thing values)
|
||
|
|
(push :pointer-void types))
|
||
|
|
(let* ((decl-args
|
||
|
|
(format nil "~{~A~^, ~}~A"
|
||
|
|
(mapcar #'ecl-type->c-type fixed-types) (if (null variadic) "" ", ...")))
|
||
|
|
(call-args
|
||
|
|
(if dynamic-call
|
||
|
|
;; #0 is already used in a cast (it is a function pointer)
|
||
|
|
(subseq +ecl-inline-codes+ 3 (max 3 (1- (* (length values) 3))))
|
||
|
|
;; #0 is not used, so we start from the beginning
|
||
|
|
(subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3))))))
|
||
|
|
(clines
|
||
|
|
(if dynamic-call
|
||
|
|
nil
|
||
|
|
(format nil "extern ~A ~A(~A);"
|
||
|
|
(ecl-type->c-type return-type) thing decl-args)))
|
||
|
|
(call-code
|
||
|
|
(if dynamic-call
|
||
|
|
(format nil "((~A (*)(~A))(#0))(~A)"
|
||
|
|
(ecl-type->c-type return-type) decl-args call-args)
|
||
|
|
(format nil "~A(~A)" thing call-args))))
|
||
|
|
`(progn
|
||
|
|
(ffi:clines ,@(ensure-list clines))
|
||
|
|
(ffi:c-inline ,values ,types ,return-type ,call-code :one-liner t :side-effects t))))
|
||
|
|
|
||
|
|
(defun dffi-function-pointer-call (pointer types values return-type)
|
||
|
|
(when (stringp pointer)
|
||
|
|
(setf pointer `(%foreign-symbol-pointer ,pointer nil)))
|
||
|
|
#-dffi
|
||
|
|
`(error "In interpreted code, attempted to call a foreign function~% ~A~%~
|
||
|
|
but ECL was built without support for that." ,pointer)
|
||
|
|
#+dffi
|
||
|
|
`(si::call-cfun ,pointer ,return-type (list ,@types) (list ,@values)))
|
||
|
|
|
||
|
|
(defun foreign-funcall-parse-args (args)
|
||
|
|
"Return three values, lists of arg types, values, and result type."
|
||
|
|
(let ((return-type :void))
|
||
|
|
(loop for (type arg) on args by #'cddr
|
||
|
|
if arg collect (cffi-type->ecl-type type) into types
|
||
|
|
and collect arg into values
|
||
|
|
else do (setf return-type (cffi-type->ecl-type type))
|
||
|
|
finally (return (values types values return-type)))))
|
||
|
|
|
||
|
|
(defmacro %foreign-funcall (name args &key library convention)
|
||
|
|
"Call a foreign function."
|
||
|
|
(declare (ignore library convention))
|
||
|
|
(multiple-value-bind (types values return-type)
|
||
|
|
(foreign-funcall-parse-args args)
|
||
|
|
`(ext:with-backend
|
||
|
|
:bytecodes
|
||
|
|
,(dffi-function-pointer-call name types values return-type)
|
||
|
|
:c/c++
|
||
|
|
,(ecase *cffi-ecl-method*
|
||
|
|
(:dffi (dffi-function-pointer-call name types values return-type))
|
||
|
|
(:dlopen (c-inline-function-call name types types values return-type t nil))
|
||
|
|
(:c/c++ (c-inline-function-call name types types values return-type nil nil))))))
|
||
|
|
|
||
|
|
(defmacro %foreign-funcall-pointer (pointer args &key convention)
|
||
|
|
"Funcall a pointer to a foreign function."
|
||
|
|
(declare (ignore convention))
|
||
|
|
(multiple-value-bind (types values return-type)
|
||
|
|
(foreign-funcall-parse-args args)
|
||
|
|
`(ext:with-backend
|
||
|
|
:bytecodes
|
||
|
|
,(dffi-function-pointer-call pointer types values return-type)
|
||
|
|
:c/c++
|
||
|
|
,(if (eq *cffi-ecl-method* :dffi)
|
||
|
|
(dffi-function-pointer-call pointer types values return-type)
|
||
|
|
(c-inline-function-call pointer types types values return-type t nil)))))
|
||
|
|
|
||
|
|
(defmacro %foreign-funcall-varargs (name args varargs &key library convention)
|
||
|
|
(declare (ignore library convention))
|
||
|
|
(multiple-value-bind (fixed-types fixed-values)
|
||
|
|
(foreign-funcall-parse-args args)
|
||
|
|
(multiple-value-bind (varargs-types varargs-values return-type)
|
||
|
|
(foreign-funcall-parse-args varargs)
|
||
|
|
(let ((all-types (append fixed-types varargs-types))
|
||
|
|
(values (append fixed-values varargs-values)))
|
||
|
|
`(ext:with-backend
|
||
|
|
:bytecodes
|
||
|
|
,(dffi-function-pointer-call name all-types values return-type)
|
||
|
|
:c/c++
|
||
|
|
,(ecase *cffi-ecl-method*
|
||
|
|
(:dffi (dffi-function-pointer-call name all-types values return-type))
|
||
|
|
(:dlopen (c-inline-function-call name fixed-types all-types values return-type t t))
|
||
|
|
(:c/c++ (c-inline-function-call name fixed-types all-types values return-type nil t))))))))
|
||
|
|
|
||
|
|
(defmacro %foreign-funcall-pointer-varargs (pointer args varargs &key convention)
|
||
|
|
(declare (ignore convention))
|
||
|
|
(multiple-value-bind (fixed-types fixed-values)
|
||
|
|
(foreign-funcall-parse-args args)
|
||
|
|
(multiple-value-bind (varargs-types varargs-values return-type)
|
||
|
|
(foreign-funcall-parse-args varargs)
|
||
|
|
(let ((all-types (append fixed-types varargs-types))
|
||
|
|
(values (append fixed-values varargs-values)))
|
||
|
|
`(ext:with-backend
|
||
|
|
:bytecodes
|
||
|
|
,(dffi-function-pointer-call pointer all-types values return-type)
|
||
|
|
:c/c++
|
||
|
|
,(if (eq *cffi-ecl-method* :dffi)
|
||
|
|
(dffi-function-pointer-call pointer all-types values return-type)
|
||
|
|
(c-inline-function-call pointer fixed-types all-types values return-type t t)))))))
|
||
|
|
|
||
|
|
;;;# Foreign Libraries
|
||
|
|
|
||
|
|
(defun %load-foreign-library (name path)
|
||
|
|
"Load a foreign library."
|
||
|
|
(declare (ignore name))
|
||
|
|
#-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
|
||
|
|
FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.")
|
||
|
|
#+dffi
|
||
|
|
(handler-case (si:load-foreign-module path)
|
||
|
|
(file-error ()
|
||
|
|
(error "file error while trying to load `~A'" path))))
|
||
|
|
|
||
|
|
(defun %close-foreign-library (handle)
|
||
|
|
"Close a foreign library."
|
||
|
|
(handler-case (si::unload-foreign-module handle)
|
||
|
|
(undefined-function ()
|
||
|
|
(restart-case (error "Detected ECL prior to version 15.2.21. ~
|
||
|
|
Function CFFI:CLOSE-FOREIGN-LIBRARY isn't implemented yet.")
|
||
|
|
(ignore () :report "Continue anyway (foreign library will remain opened).")))))
|
||
|
|
|
||
|
|
(defun native-namestring (pathname)
|
||
|
|
(namestring pathname))
|
||
|
|
|
||
|
|
;;;# Callbacks
|
||
|
|
|
||
|
|
;;; Create a package to contain the symbols for callback functions.
|
||
|
|
;;; We want to redefine callbacks with the same symbol so the internal
|
||
|
|
;;; data structures are reused.
|
||
|
|
(defpackage #:cffi-callbacks
|
||
|
|
(:use))
|
||
|
|
|
||
|
|
(defvar *callbacks* (make-hash-table))
|
||
|
|
|
||
|
|
;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
|
||
|
|
;;; internal callback for NAME.
|
||
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
|
|
(defun intern-callback (name)
|
||
|
|
(intern (format nil "~A::~A"
|
||
|
|
(if-let (package (symbol-package name))
|
||
|
|
(package-name package)
|
||
|
|
"#")
|
||
|
|
(symbol-name name))
|
||
|
|
'#:cffi-callbacks)))
|
||
|
|
|
||
|
|
(defmacro %defcallback (name rettype arg-names arg-types body
|
||
|
|
&key convention)
|
||
|
|
(declare (ignore convention))
|
||
|
|
(let ((cb-name (intern-callback name))
|
||
|
|
(cb-type #.(if (> ext:+ecl-version-number+ 160102)
|
||
|
|
:default :cdecl)))
|
||
|
|
`(progn
|
||
|
|
(ffi:defcallback (,cb-name ,cb-type)
|
||
|
|
,(cffi-type->ecl-type rettype)
|
||
|
|
,(mapcar #'list arg-names
|
||
|
|
(mapcar #'cffi-type->ecl-type arg-types))
|
||
|
|
,body)
|
||
|
|
(setf (gethash ',name *callbacks*) ',cb-name))))
|
||
|
|
|
||
|
|
(defun %callback (name)
|
||
|
|
(multiple-value-bind (symbol winp)
|
||
|
|
(gethash name *callbacks*)
|
||
|
|
(unless winp
|
||
|
|
(error "Undefined callback: ~S" name))
|
||
|
|
(ffi:callback symbol)))
|
||
|
|
|
||
|
|
;;;# Foreign Globals
|
||
|
|
|
||
|
|
(defun %foreign-symbol-pointer (name library)
|
||
|
|
"Returns a pointer to a foreign symbol NAME."
|
||
|
|
(declare (ignore library))
|
||
|
|
(handler-case
|
||
|
|
(si:find-foreign-symbol (coerce name 'base-string)
|
||
|
|
:default :pointer-void 0)
|
||
|
|
(error (c) nil)))
|