src/cffi-scl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Lisp.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;; Copyright (C) 2006-2007, Scieneer Pty Ltd.
   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 (in-package #:cffi-sys)
  30
  31 ;;;# Mis-features
  32
  33 (pushnew 'flat-namespace *features*)
  34
  35 ;;;# Symbol Case
  36
  37 (defun canonicalize-symbol-name-case (name)
  38   (declare (string name))
  39   (if (eq ext:*case-mode* :upper)
  40       (string-upcase name)
  41       (string-downcase name)))
  42
  43 ;;;# Basic Pointer Operations
  44
  45 (deftype foreign-pointer ()
  46   'sys:system-area-pointer)
  47
  48 (declaim (inline pointerp))
  49 (defun pointerp (ptr)
  50   "Return true if 'ptr is a foreign pointer."
  51   (sys:system-area-pointer-p ptr))
  52
  53 (declaim (inline pointer-eq))
  54 (defun pointer-eq (ptr1 ptr2)
  55   "Return true if 'ptr1 and 'ptr2 point to the same address."
  56   (sys:sap= ptr1 ptr2))
  57
  58 (declaim (inline null-pointer))
  59 (defun null-pointer ()
  60   "Construct and return a null pointer."
  61   (sys:int-sap 0))
  62
  63 (declaim (inline null-pointer-p))
  64 (defun null-pointer-p (ptr)
  65   "Return true if 'ptr is a null pointer."
  66   (zerop (sys:sap-int ptr)))
  67
  68 (declaim (inline inc-pointer))
  69 (defun inc-pointer (ptr offset)
  70   "Return a pointer pointing 'offset bytes past 'ptr."
  71   (sys:sap+ ptr offset))
  72
  73 (declaim (inline make-pointer))
  74 (defun make-pointer (address)
  75   "Return a pointer pointing to 'address."
  76   (sys:int-sap address))
  77
  78 (declaim (inline pointer-address))
  79 (defun pointer-address (ptr)
  80   "Return the address pointed to by 'ptr."
  81   (sys:sap-int ptr))
  82
  83 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  84   "Bind 'var to 'size bytes of foreign memory during 'body.  The
  85   pointer in 'var is invalid beyond the dynamic extent of 'body, and
  86   may be stack-allocated if supported by the implementation.  If
  87   'size-var is supplied, it will be bound to 'size during 'body."
  88   (unless size-var
  89     (setf size-var (gensym (symbol-name '#:size))))
  90   ;; If the size is constant we can stack-allocate.
  91   (cond ((constantp size)
  92          (let ((alien-var (gensym (symbol-name '#:alien))))
  93            `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
  94              (let ((,size-var ,size)
  95                    (,var (alien-sap ,alien-var)))
  96                (declare (ignorable ,size-var))
  97                ,@body))))
  98         (t
  99          `(let ((,size-var ,size))
 100             (alien:with-bytes (,var ,size-var)
 101               ,@body)))))
 102
 103 ;;;# Allocation
 104 ;;;
 105 ;;; Functions and macros for allocating foreign memory on the stack and on the
 106 ;;; heap.  The main CFFI package defines macros that wrap 'foreign-alloc and
 107 ;;; 'foreign-free in 'unwind-protect for the common usage when the memory has
 108 ;;; dynamic extent.
 109
 110 (defun %foreign-alloc (size)
 111   "Allocate 'size bytes on the heap and return a pointer."
 112   (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
 113   (alien-funcall (extern-alien "malloc"
 114                                (function system-area-pointer unsigned))
 115                  size))
 116
 117 (defun foreign-free (ptr)
 118   "Free a 'ptr allocated by 'foreign-alloc."
 119   (declare (type system-area-pointer ptr))
 120   (alien-funcall (extern-alien "free"
 121                                (function (values) system-area-pointer))
 122                  ptr))
 123
 124 ;;;# Shareable Vectors
 125
 126 (defun make-shareable-byte-vector (size)
 127   "Create a Lisp vector of 'size bytes that can passed to
 128   'with-pointer-to-vector-data."
 129   (make-array size :element-type '(unsigned-byte 8)))
 130
 131 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 132   "Bind 'ptr-var to a foreign pointer to the data in 'vector."
 133   (let ((vector-var (gensym (symbol-name '#:vector))))
 134     `(let ((,vector-var ,vector))
 135        (ext:with-pinned-object (,vector-var)
 136          (let ((,ptr-var (sys:vector-sap ,vector-var)))
 137            ,@body)))))
 138
 139 ;;;# Dereferencing
 140
 141 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
 142 ;;; macros that optimize the case where the type keyword is constant
 143 ;;; at compile-time.
 144 (defmacro define-mem-accessors (&body pairs)
 145   `(progn
 146     (defun %mem-ref (ptr type &optional (offset 0))
 147       (ecase type
 148         ,@(loop for (keyword fn) in pairs
 149                 collect `(,keyword (,fn ptr offset)))))
 150     (defun %mem-set (value ptr type &optional (offset 0))
 151       (ecase type
 152         ,@(loop for (keyword fn) in pairs
 153                 collect `(,keyword (setf (,fn ptr offset) value)))))
 154     (define-compiler-macro %mem-ref
 155         (&whole form ptr type &optional (offset 0))
 156       (if (constantp type)
 157           (ecase (eval type)
 158             ,@(loop for (keyword fn) in pairs
 159                     collect `(,keyword `(,',fn ,ptr ,offset))))
 160           form))
 161     (define-compiler-macro %mem-set
 162         (&whole form value ptr type &optional (offset 0))
 163       (if (constantp type)
 164           (once-only (value)
 165             (ecase (eval type)
 166               ,@(loop for (keyword fn) in pairs
 167                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
 168                                                 ,value)))))
 169           form))))
 170
 171 (define-mem-accessors
 172   (:char sys:signed-sap-ref-8)
 173   (:unsigned-char sys:sap-ref-8)
 174   (:short sys:signed-sap-ref-16)
 175   (:unsigned-short sys:sap-ref-16)
 176   (:int sys:signed-sap-ref-32)
 177   (:unsigned-int sys:sap-ref-32)
 178   (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
 179   (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
 180   (:long-long sys:signed-sap-ref-64)
 181   (:unsigned-long-long sys:sap-ref-64)
 182   (:float sys:sap-ref-single)
 183   (:double sys:sap-ref-double)
 184   #+long-float (:long-double sys:sap-ref-long)
 185   (:pointer sys:sap-ref-sap))
 186
 187 ;;;# Calling Foreign Functions
 188
 189 (defun convert-foreign-type (type-keyword)
 190   "Convert a CFFI type keyword to an ALIEN type."
 191   (ecase type-keyword
 192     (:char               'char)
 193     (:unsigned-char      'unsigned-char)
 194     (:short              'short)
 195     (:unsigned-short     'unsigned-short)
 196     (:int                'int)
 197     (:unsigned-int       'unsigned-int)
 198     (:long               'long)
 199     (:unsigned-long      'unsigned-long)
 200     (:long-long          '(signed 64))
 201     (:unsigned-long-long '(unsigned 64))
 202     (:float              'single-float)
 203     (:double             'double-float)
 204     #+long-float
 205     (:long-double        'long-float)
 206     (:pointer            'system-area-pointer)
 207     (:void               'void)))
 208
 209 (defun %foreign-type-size (type-keyword)
 210   "Return the size in bytes of a foreign type."
 211   (values (truncate (alien-internals:alien-type-bits
 212                      (alien-internals:parse-alien-type
 213                       (convert-foreign-type type-keyword)))
 214                     8)))
 215
 216 (defun %foreign-type-alignment (type-keyword)
 217   "Return the alignment in bytes of a foreign type."
 218   (values (truncate (alien-internals:alien-type-alignment
 219                      (alien-internals:parse-alien-type
 220                       (convert-foreign-type type-keyword)))
 221                     8)))
 222
 223 (defun foreign-funcall-type-and-args (args)
 224   "Return an 'alien function type for 'args."
 225   (let ((return-type nil))
 226     (loop for (type arg) on args by #'cddr
 227           if arg collect (convert-foreign-type type) into types
 228           and collect arg into fargs
 229           else do (setf return-type (convert-foreign-type type))
 230           finally (return (values types fargs return-type)))))
 231
 232 (defmacro %%foreign-funcall (name types fargs rettype)
 233   "Internal guts of '%foreign-funcall."
 234   `(alien-funcall (extern-alien ,name (function ,rettype ,@types))
 235                   ,@fargs))
 236
 237 (defmacro %foreign-funcall (name args &key library convention)
 238   "Perform a foreign function call, document it more later."
 239   (declare (ignore library convention))
 240   (multiple-value-bind (types fargs rettype)
 241       (foreign-funcall-type-and-args args)
 242     `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
 243
 244 (defmacro %foreign-funcall-pointer (ptr args &key convention)
 245   "Funcall a pointer to a foreign function."
 246   (declare (ignore convention))
 247   (multiple-value-bind (types fargs rettype)
 248       (foreign-funcall-type-and-args args)
 249     (with-unique-names (function)
 250       `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
 251          (alien-funcall ,function ,@fargs)))))
 252
 253 ;;; Callbacks
 254
 255 (defmacro %defcallback (name rettype arg-names arg-types body
 256                         &key convention)
 257   (declare (ignore convention))
 258    `(alien:defcallback ,name
 259        (,(convert-foreign-type rettype)
 260          ,@(mapcar (lambda (sym type)
 261                      (list sym (convert-foreign-type type)))
 262                    arg-names arg-types))
 263      ,body))
 264
 265 (declaim (inline %callback))
 266 (defun %callback (name)
 267   (alien:callback-sap name))
 268
 269 ;;;# Loading and Closing Foreign Libraries
 270
 271 (defun %load-foreign-library (name path)
 272   "Load the foreign library 'name."
 273   (declare (ignore name))
 274   (ext:load-dynamic-object path))
 275
 276 (defun %close-foreign-library (name)
 277   "Closes the foreign library 'name."
 278   (ext:close-dynamic-object name))
 279
 280 (defun native-namestring (pathname)
 281   (ext:unix-namestring pathname nil))
 282
 283 ;;;# Foreign Globals
 284
 285 (defun %foreign-symbol-pointer (name library)
 286   "Returns a pointer to a foreign symbol 'name."
 287   (declare (ignore library))
 288   (let ((sap (sys:foreign-symbol-address name)))
 289     (if (zerop (sys:sap-int sap)) nil sap)))