external/cffi.darcs/src/cffi-gcl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, Luis Oliveira  <loliveira(@)common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 ;;; GCL specific notes:
  29 ;;;
  30 ;;; On ELF systems, a library can be loaded with the help of this:
  31 ;;;   http://www.copyleft.de/lisp/gcl-elf-loader.html
  32 ;;;
  33 ;;; Another way is to link the library when creating a new image:
  34 ;;;   (compiler::link nil "new_image" "" "-lfoo")
  35 ;;;
  36 ;;; As GCL's FFI is not dynamic, CFFI declarations will only work
  37 ;;; after compiled and loaded.
  38
  39 ;;; *** this port is broken ***
  40 ;;; gcl doesn't compile the rest of CFFI anyway..
  41
  42 ;;;# Administrivia
  43
  44 (defpackage #:cffi-sys
  45   (:use #:common-lisp)
  46   (:export
  47    #:canonicalize-symbol-name-case
  48    #:pointerp
  49    #:%foreign-alloc
  50    #:foreign-free
  51    #:with-foreign-ptr
  52    #:null-ptr
  53    #:null-ptr-p
  54    #:inc-ptr
  55    #:%mem-ref
  56    #:%mem-set
  57    #:%foreign-funcall
  58    #:%foreign-type-alignment
  59    #:%foreign-type-size
  60    #:%load-foreign-library
  61    ;#:make-shareable-byte-vector
  62    ;#:with-pointer-to-vector-data
  63    #:foreign-var-ptr
  64    #:make-callback))
  65
  66 (in-package #:cffi-sys)
  67
  68 ;;;# Mis-*features*
  69 (eval-when (:compile-toplevel :load-toplevel :execute)
  70   (pushnew :cffi/no-foreign-funcall *features*))
  71
  72 ;;; Symbol case.
  73
  74 (defun canonicalize-symbol-name-case (name)
  75   (declare (string name))
  76   (string-upcase name))
  77
  78 ;;;# Allocation
  79 ;;;
  80 ;;; Functions and macros for allocating foreign memory on the stack
  81 ;;; and on the heap.  The main CFFI package defines macros that wrap
  82 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
  83 ;;; usage when the memory has dynamic extent.
  84
  85 (defentry %foreign-alloc (int) (int "malloc"))
  86
  87 ;(defun foreign-alloc (size)
  88 ;  "Allocate SIZE bytes on the heap and return a pointer."
  89 ;  (%foreign-alloc size))
  90
  91 (defentry foreign-free (int) (void "free"))
  92
  93 ;(defun foreign-free (ptr)
  94 ;  "Free a PTR allocated by FOREIGN-ALLOC."
  95 ;  (%free ptr))
  96
  97 (defmacro with-foreign-ptr ((var size &optional size-var) &body body)
  98   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  99 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 100 may be stack-allocated if supported by the implementation.  If
 101 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 102   (unless size-var
 103     (setf size-var (gensym "SIZE")))
 104   `(let* ((,size-var ,size)
 105           (,var (foreign-alloc ,size-var)))
 106      (unwind-protect
 107           (progn ,@body)
 108        (foreign-free ,var))))
 109
 110 ;;;# Misc. Pointer Operations
 111
 112 (defun pointerp (ptr)
 113   "Return true if PTR is a foreign pointer."
 114   (integerp ptr))
 115
 116 (defun null-ptr ()
 117   "Construct and return a null pointer."
 118   0)
 119
 120 (defun null-ptr-p (ptr)
 121   "Return true if PTR is a null pointer."
 122   (= ptr 0))
 123
 124 (defun inc-ptr (ptr offset)
 125   "Return a pointer OFFSET bytes past PTR."
 126   (+ ptr offset))
 127
 128 ;;;# Shareable Vectors
 129 ;;;
 130 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 131 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 132 ;;; implementation can't do this.
 133
 134 ;(defun make-shareable-byte-vector (size)
 135 ;  "Create a Lisp vector of SIZE bytes that can passed to
 136 ;WITH-POINTER-TO-VECTOR-DATA."
 137 ;  (make-array size :element-type '(unsigned-byte 8)))
 138
 139 ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 140 ;  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 141 ;  `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
 142 ;     ,@body))
 143
 144 ;;;# Dereferencing
 145
 146 (defmacro define-mem-ref/set (type gcl-type &optional c-name)
 147   (unless c-name
 148     (setq c-name (substitute #\_ #\Space type)))
 149   (let ((ref-fn (concatenate 'string "ref_" c-name))
 150         (set-fn (concatenate 'string "set_" c-name)))
 151     `(progn
 152        ;; ref
 153        (defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
 154            0 "return *ptr;")
 155        (defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
 156            (int) (,gcl-type ,ref-fn))
 157        ;; set
 158        (defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type)
 159            0 "*ptr = value;")
 160        (defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
 161            (int ,gcl-type) (void ,set-fn)))))
 162
 163 (define-mem-ref/set "char" char)
 164 (define-mem-ref/set "unsigned char" char)
 165 (define-mem-ref/set "short" int)
 166 (define-mem-ref/set "unsigned short" int)
 167 (define-mem-ref/set "int" int)
 168 (define-mem-ref/set "unsigned int" int)
 169 (define-mem-ref/set "long" int)
 170 (define-mem-ref/set "unsigned long" int)
 171 (define-mem-ref/set "float" float)
 172 (define-mem-ref/set "double" double)
 173 (define-mem-ref/set "void *" int "ptr")
 174
 175 (defun %mem-ref (ptr type &optional (offset 0))
 176   "Dereference an object of TYPE at OFFSET bytes from PTR."
 177   (unless (zerop offset)
 178     (incf ptr offset))
 179   (ecase type
 180     (:char            (ref-char ptr))
 181     (:unsigned-char   (ref-unsigned-char ptr))
 182     (:short           (ref-short ptr))
 183     (:unsigned-short  (ref-unsigned-short ptr))
 184     (:int             (ref-int ptr))
 185     (:unsigned-int    (ref-unsigned-int ptr))
 186     (:long            (ref-long ptr))
 187     (:unsigned-long   (ref-unsigned-long ptr))
 188     (:float           (ref-float ptr))
 189     (:double          (ref-double ptr))
 190     (:pointer         (ref-ptr ptr))))
 191
 192 (defun %mem-set (value ptr type &optional (offset 0))
 193   (unless (zerop offset)
 194     (incf ptr offset))
 195   (ecase type
 196     (:char            (set-char ptr value))
 197     (:unsigned-char   (set-unsigned-char ptr value))
 198     (:short           (set-short ptr value))
 199     (:unsigned-short  (set-unsigned-short ptr value))
 200     (:int             (set-int ptr value))
 201     (:unsigned-int    (set-unsigned-int ptr value))
 202     (:long            (set-long ptr value))
 203     (:unsigned-long   (set-unsigned-long ptr value))
 204     (:float           (set-float ptr value))
 205     (:double          (set-double ptr value))
 206     (:pointer         (set-ptr ptr value)))
 207   value)
 208
 209 ;;;# Calling Foreign Functions
 210
 211 ;; TODO: figure out if these type conversions make any sense...
 212 (defun convert-foreign-type (type-keyword)
 213   "Convert a CFFI type keyword to a GCL type."
 214   (ecase type-keyword
 215     (:char            'char)
 216     (:unsigned-char   'char)
 217     (:short           'int)
 218     (:unsigned-short  'int)
 219     (:int             'int)
 220     (:unsigned-int    'int)
 221     (:long            'int)
 222     (:unsigned-long   'int)
 223     (:float           'float)
 224     (:double          'double)
 225     (:pointer         'int)
 226     (:void            'void)))
 227
 228 (defparameter +cffi-types+
 229   '(:char :unsigned-char :short :unsigned-short :int :unsigned-int
 230     :long :unsigned-long :float :double :pointer))
 231
 232 (defcfun "int size_of(int type)" 0
 233   "switch (type) {
 234      case 0:  return sizeof(char);
 235      case 1:  return sizeof(unsigned char);
 236      case 2:  return sizeof(short);
 237      case 3:  return sizeof(unsigned short);
 238      case 4:  return sizeof(int);
 239      case 5:  return sizeof(unsigned int);
 240      case 6:  return sizeof(long);
 241      case 7:  return sizeof(unsigned long);
 242      case 8:  return sizeof(float);
 243      case 9:  return sizeof(double);
 244      case 10: return sizeof(void *);
 245      default: return -1;
 246    }")
 247
 248 (defentry size-of (int) (int "size_of"))
 249
 250 ;; TODO: all this is doable inside the defcfun; figure that out..
 251 (defun %foreign-type-size (type-keyword)
 252   "Return the size in bytes of a foreign type."
 253   (size-of (position type-keyword +cffi-types+)))
 254
 255 (defcfun "int align_of(int type)" 0
 256   "switch (type) {
 257      case 0:  return __alignof__(char);
 258      case 1:  return __alignof__(unsigned char);
 259      case 2:  return __alignof__(short);
 260      case 3:  return __alignof__(unsigned short);
 261      case 4:  return __alignof__(int);
 262      case 5:  return __alignof__(unsigned int);
 263      case 6:  return __alignof__(long);
 264      case 7:  return __alignof__(unsigned long);
 265      case 8:  return __alignof__(float);
 266      case 9:  return __alignof__(double);
 267      case 10: return __alignof__(void *);
 268      default: return -1;
 269    }")
 270
 271 (defentry align-of (int) (int "align_of"))
 272
 273 ;; TODO: like %foreign-type-size
 274 (defun %foreign-type-alignment (type-keyword)
 275   "Return the alignment in bytes of a foreign type."
 276   (align-of (position type-keyword +cffi-types+)))
 277
 278 #+ignore
 279 (defun convert-external-name (name)
 280   "Add an underscore to NAME if necessary for the ABI."
 281   #+darwinppc-target (concatenate 'string "_" name)
 282   #-darwinppc-target name)
 283
 284 (defmacro %foreign-funcall (function-name &rest args)
 285   "Perform a foreign function all, document it more later."
 286   `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
 287
 288 (defun defcfun-helper-forms (name rettype args types)
 289   "Return 2 values for DEFCFUN. A prelude form and a caller form."
 290   (let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name))))
 291     (values
 292      `(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
 293         (,(convert-foreign-type rettype) ,name))
 294      `(,ff-name ,@args))))
 295
 296 ;;;# Callbacks
 297
 298 ;;; XXX unimplemented
 299 (defmacro make-callback (name rettype arg-names arg-types body-form)
 300   0)
 301
 302 ;;;# Loading Foreign Libraries
 303
 304 (defun %load-foreign-library (name)
 305   "_Won't_ load the foreign library NAME."
 306   (declare (ignore name)))
 307
 308 ;;;# Foreign Globals
 309
 310 ;;; XXX unimplemented
 311 (defmacro foreign-var-ptr (name)
 312   "Return a pointer pointing to the foreign symbol NAME."
 313   0)