3rdparties/software/cffi_0.21.0/src/cffi-mkcl.lisp (12048 bytes)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; cffi-mkcl.lisp --- MKCL backend for CFFI. 4 ;;; 5 ;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin 6 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com> 7 ;;; 8 ;;; Permission is hereby granted, free of charge, to any person 9 ;;; obtaining a copy of this software and associated documentation 10 ;;; files (the "Software"), to deal in the Software without 11 ;;; restriction, including without limitation the rights to use, copy, 12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 13 ;;; of the Software, and to permit persons to whom the Software is 14 ;;; furnished to do so, subject to the following conditions: 15 ;;; 16 ;;; The above copyright notice and this permission notice shall be 17 ;;; included in all copies or substantial portions of the Software. 18 ;;; 19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 26 ;;; DEALINGS IN THE SOFTWARE. 27 ;;; 28 29 ;;;# Administrivia 30 31 (defpackage #:cffi-sys 32 (:use #:common-lisp #:alexandria) 33 (:export 34 #:canonicalize-symbol-name-case 35 #:foreign-pointer 36 #:pointerp 37 #:pointer-eq 38 #:null-pointer 39 #:null-pointer-p 40 #:inc-pointer 41 #:make-pointer 42 #:pointer-address 43 #:%foreign-alloc 44 #:foreign-free 45 #:with-foreign-pointer 46 #:%foreign-funcall 47 #:%foreign-funcall-pointer 48 #:%foreign-type-alignment 49 #:%foreign-type-size 50 #:%load-foreign-library 51 #:%close-foreign-library 52 #:native-namestring 53 #:%mem-ref 54 #:%mem-set 55 #:make-shareable-byte-vector 56 #:with-pointer-to-vector-data 57 #:%foreign-symbol-pointer 58 #:%defcallback 59 #:%callback)) 60 61 (in-package #:cffi-sys) 62 63 ;;;# Mis-features 64 65 (pushnew 'flat-namespace *features*) 66 67 ;;;# Symbol Case 68 69 (defun canonicalize-symbol-name-case (name) 70 (declare (string name)) 71 (string-upcase name)) 72 73 ;;;# Allocation 74 75 (defun %foreign-alloc (size) 76 "Allocate SIZE bytes of foreign-addressable memory." 77 (si:allocate-foreign-data :void size)) 78 79 (defun foreign-free (ptr) 80 "Free a pointer PTR allocated by FOREIGN-ALLOC." 81 (si:free-foreign-data ptr) 82 nil) 83 84 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) 85 "Bind VAR to SIZE bytes of foreign memory during BODY. The 86 pointer in VAR is invalid beyond the dynamic extent of BODY, and 87 may be stack-allocated if supported by the implementation. If 88 SIZE-VAR is supplied, it will be bound to SIZE during BODY." 89 (unless size-var 90 (setf size-var (gensym "SIZE"))) 91 `(let* ((,size-var ,size) 92 (,var (%foreign-alloc ,size-var))) 93 (unwind-protect 94 (progn ,@body) 95 (foreign-free ,var)))) 96 97 ;;;# Misc. Pointer Operations 98 99 (deftype foreign-pointer () 100 'si:foreign) 101 102 (defun null-pointer () 103 "Construct and return a null pointer." 104 (si:make-foreign-null-pointer)) 105 106 (defun null-pointer-p (ptr) 107 "Return true if PTR is a null pointer." 108 (si:null-pointer-p ptr)) 109 110 (defun inc-pointer (ptr offset) 111 "Return a pointer OFFSET bytes past PTR." 112 (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void)) 113 114 (defun pointerp (ptr) 115 "Return true if PTR is a foreign pointer." 116 ;;(typep ptr 'si:foreign) 117 (si:foreignp ptr)) 118 119 (defun pointer-eq (ptr1 ptr2) 120 "Return true if PTR1 and PTR2 point to the same address." 121 (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2))) 122 123 (defun make-pointer (address) 124 "Return a pointer pointing to ADDRESS." 125 (ffi:make-pointer address :void)) 126 127 (defun pointer-address (ptr) 128 "Return the address pointed to by PTR." 129 (ffi:pointer-address ptr)) 130 131 ;;;# Shareable Vectors 132 ;;; 133 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA 134 ;;; should be defined to perform a copy-in/copy-out if the Lisp 135 ;;; implementation can't do this. 136 137 (defun make-shareable-byte-vector (size) 138 "Create a Lisp vector of SIZE bytes that can passed to 139 WITH-POINTER-TO-VECTOR-DATA." 140 (make-array size :element-type '(unsigned-byte 8))) 141 142 ;;; MKCL, built with the Boehm GC never moves allocated data, so this 143 ;;; isn't nearly as hard to do. 144 (defun %vector-address (vector) 145 "Return the address of VECTOR's data." 146 (check-type vector (vector (unsigned-byte 8))) 147 #-mingw64 148 (ffi:c-inline (vector) (object) 149 :unsigned-long 150 "(uintptr_t) #0->vector.self.b8" 151 :side-effects nil 152 :one-liner t) 153 #+mingw64 154 (ffi:c-inline (vector) (object) 155 :unsigned-long-long 156 "(uintptr_t) #0->vector.self.b8" 157 :side-effects nil 158 :one-liner t)) 159 160 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) 161 "Bind PTR-VAR to a foreign pointer to the data in VECTOR." 162 `(let ((,ptr-var (make-pointer (%vector-address ,vector)))) 163 ,@body)) 164 165 ;;;# Dereferencing 166 167 (defun %mem-ref (ptr type &optional (offset 0)) 168 "Dereference an object of TYPE at OFFSET bytes from PTR." 169 (let* ((type (cffi-type->mkcl-type type)) 170 (type-size (ffi:size-of-foreign-type type))) 171 (si:foreign-ref-elt 172 (si:foreign-recast ptr (+ offset type-size) :void) offset type))) 173 174 (defun %mem-set (value ptr type &optional (offset 0)) 175 "Set an object of TYPE at OFFSET bytes from PTR." 176 (let* ((type (cffi-type->mkcl-type type)) 177 (type-size (ffi:size-of-foreign-type type))) 178 (si:foreign-set-elt 179 (si:foreign-recast ptr (+ offset type-size) :void) 180 offset type value))) 181 182 ;;;# Type Operations 183 184 (defconstant +translation-table+ 185 '((:char :byte "char") 186 (:unsigned-char :unsigned-byte "unsigned char") 187 (:short :short "short") 188 (:unsigned-short :unsigned-short "unsigned short") 189 (:int :int "int") 190 (:unsigned-int :unsigned-int "unsigned int") 191 (:long :long "long") 192 (:unsigned-long :unsigned-long "unsigned long") 193 (:long-long :long-long "long long") 194 (:unsigned-long-long :unsigned-long-long "unsigned long long") 195 (:float :float "float") 196 (:double :double "double") 197 (:pointer :pointer-void "void*") 198 (:void :void "void"))) 199 200 (defun cffi-type->mkcl-type (type-keyword) 201 "Convert a CFFI type keyword to an MKCL type keyword." 202 (or (second (find type-keyword +translation-table+ :key #'first)) 203 (error "~S is not a valid CFFI type" type-keyword))) 204 205 (defun mkcl-type->c-type (type-keyword) 206 "Convert a CFFI type keyword to an valid C type keyword." 207 (or (third (find type-keyword +translation-table+ :key #'second)) 208 (error "~S is not a valid CFFI type" type-keyword))) 209 210 (defun %foreign-type-size (type-keyword) 211 "Return the size in bytes of a foreign type." 212 (nth-value 0 (ffi:size-of-foreign-type 213 (cffi-type->mkcl-type type-keyword)))) 214 215 (defun %foreign-type-alignment (type-keyword) 216 "Return the alignment in bytes of a foreign type." 217 (nth-value 1 (ffi:size-of-foreign-type 218 (cffi-type->mkcl-type type-keyword)))) 219 220 ;;;# Calling Foreign Functions 221 222 #| 223 (defconstant +mkcl-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") 224 |# 225 226 (defun produce-function-pointer-call (pointer types values return-type) 227 #| 228 (if (stringp pointer) 229 (produce-function-pointer-call 230 `(%foreign-symbol-pointer ,pointer nil) types values return-type) 231 `(ffi:c-inline 232 ,(list* pointer values) 233 ,(list* :pointer-void types) ,return-type 234 ,(with-output-to-string (s) 235 (let ((types (mapcar #'mkcl-type->c-type types))) 236 ;; On AMD64, the following code only works with the extra 237 ;; argument ",...". If this is not present, functions 238 ;; like sprintf do not work 239 (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)" 240 (mkcl-type->c-type return-type) types 241 (subseq +mkcl-inline-codes+ 3 242 (max 3 (+ 2 (* (length values) 3))))))) 243 :one-liner t :side-effects t)) 244 |# 245 ;; The version here below is definitely not as efficient as the one above 246 ;; but it has the great vertue of working in all cases, (contrary to the 247 ;; silent and unsafe limitations of the one above). JCB 248 ;; I should re-optimize this one day, when I get time... JCB 249 (progn 250 (when (stringp pointer) 251 (setf pointer `(%foreign-symbol-pointer ,pointer nil))) 252 `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values)))) 253 254 255 (defun foreign-funcall-parse-args (args) 256 "Return three values, lists of arg types, values, and result type." 257 (let ((return-type :void)) 258 (loop for (type arg) on args by #'cddr 259 if arg collect (cffi-type->mkcl-type type) into types 260 and collect arg into values 261 else do (setf return-type (cffi-type->mkcl-type type)) 262 finally (return (values types values return-type))))) 263 264 (defmacro %foreign-funcall (name args &key library convention) 265 "Call a foreign function." 266 (declare (ignore library convention)) 267 (multiple-value-bind (types values return-type) 268 (foreign-funcall-parse-args args) 269 (produce-function-pointer-call name types values return-type))) 270 271 (defmacro %foreign-funcall-pointer (ptr args &key convention) 272 "Funcall a pointer to a foreign function." 273 (declare (ignore convention)) 274 (multiple-value-bind (types values return-type) 275 (foreign-funcall-parse-args args) 276 (produce-function-pointer-call ptr types values return-type))) 277 278 ;;;# Foreign Libraries 279 280 (defun %load-foreign-library (name path) 281 "Load a foreign library." 282 (declare (ignore name)) 283 (handler-case (si:load-foreign-module path) 284 (file-error () 285 (error "file error while trying to load `~A'" path)))) 286 287 (defun %close-foreign-library (handle) 288 ;;(declare (ignore handle)) 289 ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.") 290 (si:unload-foreign-module handle)) 291 292 (defun native-namestring (pathname) 293 (namestring pathname)) 294 295 ;;;# Callbacks 296 297 ;;; Create a package to contain the symbols for callback functions. 298 ;;; We want to redefine callbacks with the same symbol so the internal 299 ;;; data structures are reused. 300 (defpackage #:cffi-callbacks 301 (:use)) 302 303 (defvar *callbacks* (make-hash-table)) 304 305 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the 306 ;;; internal callback for NAME. 307 (eval-when (:compile-toplevel :load-toplevel :execute) 308 (defun intern-callback (name) 309 (intern (format nil "~A::~A" 310 (if-let (package (symbol-package name)) 311 (package-name package) 312 "#") 313 (symbol-name name)) 314 '#:cffi-callbacks))) 315 316 (defmacro %defcallback (name rettype arg-names arg-types body 317 &key convention) 318 (declare (ignore convention)) 319 (let ((cb-name (intern-callback name))) 320 `(progn 321 (ffi:defcallback (,cb-name :cdecl) 322 ,(cffi-type->mkcl-type rettype) 323 ,(mapcar #'list arg-names 324 (mapcar #'cffi-type->mkcl-type arg-types)) 325 ;;(block ,cb-name ,@body) 326 (block ,cb-name ,body)) 327 (setf (gethash ',name *callbacks*) ',cb-name)))) 328 329 (defun %callback (name) 330 (multiple-value-bind (symbol winp) 331 (gethash name *callbacks*) 332 (unless winp 333 (error "Undefined callback: ~S" name)) 334 (ffi:callback symbol))) 335 336 ;;;# Foreign Globals 337 338 (defun %foreign-symbol-pointer (name library) 339 "Returns a pointer to a foreign symbol NAME." 340 (declare (ignore library)) 341 (values (ignore-errors (si:find-foreign-symbol name :default :pointer-void 0)))) 342