external/cffi.darcs/_darcs/pristine/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 ;;;# Administrivia
  30
  31 (defpackage #:cffi-sys
  32   (:use #:common-lisp #:alien #:c-call #:cffi-utils)
  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 ;;;# Features
  64
  65 (eval-when (:compile-toplevel :load-toplevel :execute)
  66   (mapc (lambda (feature) (pushnew feature *features*))
  67         '(;; OS/CPU features.
  68           #+unix    cffi-features:unix
  69           #+x86     cffi-features:x86
  70           #+amd64   cffi-features:x86-64
  71           #+(and ppc (not ppc64)) cffi-features:ppc32
  72           #+sparc   cffi-features:sparc
  73           #+sparc64 cffi-features:sparc64
  74           #+hppa    cffi-features:hppa
  75           #+hppa64  cffi-features:hppa64
  76           ;; Misfeatures
  77           cffi-features:flat-namespace
  78           )))
  79
  80 ;;; Symbol case.
  81
  82 (defun canonicalize-symbol-name-case (name)
  83   (declare (string name))
  84   (if (eq ext:*case-mode* :upper)
  85       (string-upcase name)
  86       (string-downcase name)))
  87
  88 ;;;# Basic Pointer Operations
  89
  90 (deftype foreign-pointer ()
  91   'sys:system-area-pointer)
  92
  93 (declaim (inline pointerp))
  94 (defun pointerp (ptr)
  95   "Return true if 'ptr is a foreign pointer."
  96   (sys:system-area-pointer-p ptr))
  97
  98 (declaim (inline pointer-eq))
  99 (defun pointer-eq (ptr1 ptr2)
 100   "Return true if 'ptr1 and 'ptr2 point to the same address."
 101   (sys:sap= ptr1 ptr2))
 102
 103 (declaim (inline null-pointer))
 104 (defun null-pointer ()
 105   "Construct and return a null pointer."
 106   (sys:int-sap 0))
 107
 108 (declaim (inline null-pointer-p))
 109 (defun null-pointer-p (ptr)
 110   "Return true if 'ptr is a null pointer."
 111   (zerop (sys:sap-int ptr)))
 112
 113 (declaim (inline inc-pointer))
 114 (defun inc-pointer (ptr offset)
 115   "Return a pointer pointing 'offset bytes past 'ptr."
 116   (sys:sap+ ptr offset))
 117
 118 (declaim (inline make-pointer))
 119 (defun make-pointer (address)
 120   "Return a pointer pointing to 'address."
 121   (sys:int-sap address))
 122
 123 (declaim (inline pointer-address))
 124 (defun pointer-address (ptr)
 125   "Return the address pointed to by 'ptr."
 126   (sys:sap-int ptr))
 127
 128 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 129   "Bind 'var to 'size bytes of foreign memory during 'body.  The
 130   pointer in 'var is invalid beyond the dynamic extent of 'body, and
 131   may be stack-allocated if supported by the implementation.  If
 132   'size-var is supplied, it will be bound to 'size during 'body."
 133   (unless size-var
 134     (setf size-var (gensym (symbol-name '#:size))))
 135   ;; If the size is constant we can stack-allocate.
 136   (cond ((constantp size)
 137          (let ((alien-var (gensym (symbol-name '#:alien))))
 138            `(with-alien ((,alien-var (array (unsigned 8) ,(eval size))))
 139              (let ((,size-var ,size)
 140                    (,var (alien-sap ,alien-var)))
 141                (declare (ignorable ,size-var))
 142                ,@body))))
 143         (t
 144          `(let ((,size-var ,size))
 145             (alien:with-bytes (,var ,size-var)
 146               ,@body)))))
 147
 148 ;;;# Allocation
 149 ;;;
 150 ;;; Functions and macros for allocating foreign memory on the stack and on the
 151 ;;; heap.  The main CFFI package defines macros that wrap 'foreign-alloc and
 152 ;;; 'foreign-free in 'unwind-protect for the common usage when the memory has
 153 ;;; dynamic extent.
 154
 155 (defun %foreign-alloc (size)
 156   "Allocate 'size bytes on the heap and return a pointer."
 157   (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size))
 158   (alien-funcall (extern-alien "malloc"
 159                                (function system-area-pointer unsigned))
 160                  size))
 161
 162 (defun foreign-free (ptr)
 163   "Free a 'ptr allocated by 'foreign-alloc."
 164   (declare (type system-area-pointer ptr))
 165   (alien-funcall (extern-alien "free"
 166                                (function (values) system-area-pointer))
 167                  ptr))
 168
 169 ;;;# Shareable Vectors
 170
 171 (defun make-shareable-byte-vector (size)
 172   "Create a Lisp vector of 'size bytes that can passed to
 173   'with-pointer-to-vector-data."
 174   (make-array size :element-type '(unsigned-byte 8)))
 175
 176 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 177   "Bind 'ptr-var to a foreign pointer to the data in 'vector."
 178   (let ((vector-var (gensym (symbol-name '#:vector))))
 179     `(let ((,vector-var ,vector))
 180        (ext:with-pinned-object (,vector-var)
 181          (let ((,ptr-var (sys:vector-sap ,vector-var)))
 182            ,@body)))))
 183
 184 ;;;# Dereferencing
 185
 186 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
 187 ;;; macros that optimize the case where the type keyword is constant
 188 ;;; at compile-time.
 189 (defmacro define-mem-accessors (&body pairs)
 190   `(progn
 191     (defun %mem-ref (ptr type &optional (offset 0))
 192       (ecase type
 193         ,@(loop for (keyword fn) in pairs
 194                 collect `(,keyword (,fn ptr offset)))))
 195     (defun %mem-set (value ptr type &optional (offset 0))
 196       (ecase type
 197         ,@(loop for (keyword fn) in pairs
 198                 collect `(,keyword (setf (,fn ptr offset) value)))))
 199     (define-compiler-macro %mem-ref
 200         (&whole form ptr type &optional (offset 0))
 201       (if (constantp type)
 202           (ecase (eval type)
 203             ,@(loop for (keyword fn) in pairs
 204                     collect `(,keyword `(,',fn ,ptr ,offset))))
 205           form))
 206     (define-compiler-macro %mem-set
 207         (&whole form value ptr type &optional (offset 0))
 208       (if (constantp type)
 209           (once-only (value)
 210             (ecase (eval type)
 211               ,@(loop for (keyword fn) in pairs
 212                       collect `(,keyword `(setf (,',fn ,ptr ,offset)
 213                                                 ,value)))))
 214           form))))
 215
 216 (define-mem-accessors
 217   (:char sys:signed-sap-ref-8)
 218   (:unsigned-char sys:sap-ref-8)
 219   (:short sys:signed-sap-ref-16)
 220   (:unsigned-short sys:sap-ref-16)
 221   (:int sys:signed-sap-ref-32)
 222   (:unsigned-int sys:sap-ref-32)
 223   (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64)
 224   (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64)
 225   (:long-long sys:signed-sap-ref-64)
 226   (:unsigned-long-long sys:sap-ref-64)
 227   (:float sys:sap-ref-single)
 228   (:double sys:sap-ref-double)
 229   #+long-float (:long-double sys:sap-ref-long)
 230   (:pointer sys:sap-ref-sap))
 231
 232 ;;;# Calling Foreign Functions
 233
 234 (defun convert-foreign-type (type-keyword)
 235   "Convert a CFFI type keyword to an ALIEN type."
 236   (ecase type-keyword
 237     (:char               'char)
 238     (:unsigned-char      'unsigned-char)
 239     (:short              'short)
 240     (:unsigned-short     'unsigned-short)
 241     (:int                'int)
 242     (:unsigned-int       'unsigned-int)
 243     (:long               'long)
 244     (:unsigned-long      'unsigned-long)
 245     (:long-long          '(signed 64))
 246     (:unsigned-long-long '(unsigned 64))
 247     (:float              'single-float)
 248     (:double             'double-float)
 249     #+long-float
 250     (:long-double        'long-float)
 251     (:pointer            'system-area-pointer)
 252     (:void               'void)))
 253
 254 (defun %foreign-type-size (type-keyword)
 255   "Return the size in bytes of a foreign type."
 256   (values (truncate (alien-internals:alien-type-bits
 257                      (alien-internals:parse-alien-type
 258                       (convert-foreign-type type-keyword)))
 259                     8)))
 260
 261 (defun %foreign-type-alignment (type-keyword)
 262   "Return the alignment in bytes of a foreign type."
 263   (values (truncate (alien-internals:alien-type-alignment
 264                      (alien-internals:parse-alien-type
 265                       (convert-foreign-type type-keyword)))
 266                     8)))
 267
 268 (defun foreign-funcall-type-and-args (args)
 269   "Return an 'alien function type for 'args."
 270   (let ((return-type nil))
 271     (loop for (type arg) on args by #'cddr
 272           if arg collect (convert-foreign-type type) into types
 273           and collect arg into fargs
 274           else do (setf return-type (convert-foreign-type type))
 275           finally (return (values types fargs return-type)))))
 276
 277 (defmacro %%foreign-funcall (name types fargs rettype)
 278   "Internal guts of '%foreign-funcall."
 279   `(alien-funcall (extern-alien ,name (function ,rettype ,@types))
 280                   ,@fargs))
 281
 282 (defmacro %foreign-funcall (name args &key library calling-convention)
 283   "Perform a foreign function call, document it more later."
 284   (declare (ignore library calling-convention))
 285   (multiple-value-bind (types fargs rettype)
 286       (foreign-funcall-type-and-args args)
 287     `(%%foreign-funcall ,name ,types ,fargs ,rettype)))
 288
 289 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
 290   "Funcall a pointer to a foreign function."
 291   (declare (ignore calling-convention))
 292   (multiple-value-bind (types fargs rettype)
 293       (foreign-funcall-type-and-args args)
 294     (with-unique-names (function)
 295       `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr))
 296          (alien-funcall ,function ,@fargs)))))
 297
 298 ;;; Callbacks
 299
 300 (defmacro %defcallback (name rettype arg-names arg-types body
 301                         &key calling-convention)
 302    `(alien:defcallback ,name
 303        (,(convert-foreign-type rettype)
 304          ,@(mapcar (lambda (sym type)
 305                      (list sym (convert-foreign-type type)))
 306                    arg-names arg-types))
 307      ,body))
 308
 309 (declaim (inline %callback))
 310 (defun %callback (name)
 311   (alien:callback-sap name))
 312
 313 ;;;# Loading and Closing Foreign Libraries
 314
 315 (defun %load-foreign-library (name path)
 316   "Load the foreign library 'name."
 317   (declare (ignore name))
 318   (ext:load-dynamic-object path))
 319
 320 (defun %close-foreign-library (name)
 321   "Closes the foreign library 'name."
 322   (ext:close-dynamic-object name))
 323
 324 (defun native-namestring (pathname)
 325   (ext:unix-namestring pathname))
 326
 327 ;;;# Foreign Globals
 328
 329 (defun %foreign-symbol-pointer (name library)
 330   "Returns a pointer to a foreign symbol 'name."
 331   (declare (ignore library))
 332   (let ((sap (sys:foreign-symbol-address name)))
 333     (if (zerop (sys:sap-int sap)) nil sap)))