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 (in-package #:cffi-sys)
  43
  44 ;;;# Mis-*features*
  45 (eval-when (:compile-toplevel :load-toplevel :execute)
  46   (pushnew :cffi/no-foreign-funcall *features*))
  47
  48 ;;; Symbol case.
  49
  50 (defun canonicalize-symbol-name-case (name)
  51   (declare (string name))
  52   (string-upcase name))
  53
  54 ;;;# Allocation
  55 ;;;
  56 ;;; Functions and macros for allocating foreign memory on the stack
  57 ;;; and on the heap.  The main CFFI package defines macros that wrap
  58 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
  59 ;;; usage when the memory has dynamic extent.
  60
  61 (defentry %foreign-alloc (int) (int "malloc"))
  62
  63 ;(defun foreign-alloc (size)
  64 ;  "Allocate SIZE bytes on the heap and return a pointer."
  65 ;  (%foreign-alloc size))
  66
  67 (defentry foreign-free (int) (void "free"))
  68
  69 ;(defun foreign-free (ptr)
  70 ;  "Free a PTR allocated by FOREIGN-ALLOC."
  71 ;  (%free ptr))
  72
  73 (defmacro with-foreign-ptr ((var size &optional size-var) &body body)
  74   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  75 pointer in VAR is invalid beyond the dynamic extent of BODY, and
  76 may be stack-allocated if supported by the implementation.  If
  77 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
  78   (unless size-var
  79     (setf size-var (gensym "SIZE")))
  80   `(let* ((,size-var ,size)
  81           (,var (foreign-alloc ,size-var)))
  82      (unwind-protect
  83           (progn ,@body)
  84        (foreign-free ,var))))
  85
  86 ;;;# Misc. Pointer Operations
  87
  88 (defun pointerp (ptr)
  89   "Return true if PTR is a foreign pointer."
  90   (integerp ptr))
  91
  92 (defun null-ptr ()
  93   "Construct and return a null pointer."
  94   0)
  95
  96 (defun null-ptr-p (ptr)
  97   "Return true if PTR is a null pointer."
  98   (= ptr 0))
  99
 100 (defun inc-ptr (ptr offset)
 101   "Return a pointer OFFSET bytes past PTR."
 102   (+ ptr offset))
 103
 104 ;;;# Shareable Vectors
 105 ;;;
 106 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 107 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 108 ;;; implementation can't do this.
 109
 110 ;(defun make-shareable-byte-vector (size)
 111 ;  "Create a Lisp vector of SIZE bytes that can passed to
 112 ;WITH-POINTER-TO-VECTOR-DATA."
 113 ;  (make-array size :element-type '(unsigned-byte 8)))
 114
 115 ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 116 ;  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 117 ;  `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
 118 ;     ,@body))
 119
 120 ;;;# Dereferencing
 121
 122 (defmacro define-mem-ref/set (type gcl-type &optional c-name)
 123   (unless c-name
 124     (setq c-name (substitute #\_ #\Space type)))
 125   (let ((ref-fn (concatenate 'string "ref_" c-name))
 126         (set-fn (concatenate 'string "set_" c-name)))
 127     `(progn
 128        ;; ref
 129        (defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
 130            0 "return *ptr;")
 131        (defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
 132            (int) (,gcl-type ,ref-fn))
 133        ;; set
 134        (defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type)
 135            0 "*ptr = value;")
 136        (defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
 137            (int ,gcl-type) (void ,set-fn)))))
 138
 139 (define-mem-ref/set "char" char)
 140 (define-mem-ref/set "unsigned char" char)
 141 (define-mem-ref/set "short" int)
 142 (define-mem-ref/set "unsigned short" int)
 143 (define-mem-ref/set "int" int)
 144 (define-mem-ref/set "unsigned int" int)
 145 (define-mem-ref/set "long" int)
 146 (define-mem-ref/set "unsigned long" int)
 147 (define-mem-ref/set "float" float)
 148 (define-mem-ref/set "double" double)
 149 (define-mem-ref/set "void *" int "ptr")
 150
 151 (defun %mem-ref (ptr type &optional (offset 0))
 152   "Dereference an object of TYPE at OFFSET bytes from PTR."
 153   (unless (zerop offset)
 154     (incf ptr offset))
 155   (ecase type
 156     (:char            (ref-char ptr))
 157     (:unsigned-char   (ref-unsigned-char ptr))
 158     (:short           (ref-short ptr))
 159     (:unsigned-short  (ref-unsigned-short ptr))
 160     (:int             (ref-int ptr))
 161     (:unsigned-int    (ref-unsigned-int ptr))
 162     (:long            (ref-long ptr))
 163     (:unsigned-long   (ref-unsigned-long ptr))
 164     (:float           (ref-float ptr))
 165     (:double          (ref-double ptr))
 166     (:pointer         (ref-ptr ptr))))
 167
 168 (defun %mem-set (value ptr type &optional (offset 0))
 169   (unless (zerop offset)
 170     (incf ptr offset))
 171   (ecase type
 172     (:char            (set-char ptr value))
 173     (:unsigned-char   (set-unsigned-char ptr value))
 174     (:short           (set-short ptr value))
 175     (:unsigned-short  (set-unsigned-short ptr value))
 176     (:int             (set-int ptr value))
 177     (:unsigned-int    (set-unsigned-int ptr value))
 178     (:long            (set-long ptr value))
 179     (:unsigned-long   (set-unsigned-long ptr value))
 180     (:float           (set-float ptr value))
 181     (:double          (set-double ptr value))
 182     (:pointer         (set-ptr ptr value)))
 183   value)
 184
 185 ;;;# Calling Foreign Functions
 186
 187 ;; TODO: figure out if these type conversions make any sense...
 188 (defun convert-foreign-type (type-keyword)
 189   "Convert a CFFI type keyword to a GCL type."
 190   (ecase type-keyword
 191     (:char            'char)
 192     (:unsigned-char   'char)
 193     (:short           'int)
 194     (:unsigned-short  'int)
 195     (:int             'int)
 196     (:unsigned-int    'int)
 197     (:long            'int)
 198     (:unsigned-long   'int)
 199     (:float           'float)
 200     (:double          'double)
 201     (:pointer         'int)
 202     (:void            'void)))
 203
 204 (defparameter +cffi-types+
 205   '(:char :unsigned-char :short :unsigned-short :int :unsigned-int
 206     :long :unsigned-long :float :double :pointer))
 207
 208 (defcfun "int size_of(int type)" 0
 209   "switch (type) {
 210      case 0:  return sizeof(char);
 211      case 1:  return sizeof(unsigned char);
 212      case 2:  return sizeof(short);
 213      case 3:  return sizeof(unsigned short);
 214      case 4:  return sizeof(int);
 215      case 5:  return sizeof(unsigned int);
 216      case 6:  return sizeof(long);
 217      case 7:  return sizeof(unsigned long);
 218      case 8:  return sizeof(float);
 219      case 9:  return sizeof(double);
 220      case 10: return sizeof(void *);
 221      default: return -1;
 222    }")
 223
 224 (defentry size-of (int) (int "size_of"))
 225
 226 ;; TODO: all this is doable inside the defcfun; figure that out..
 227 (defun %foreign-type-size (type-keyword)
 228   "Return the size in bytes of a foreign type."
 229   (size-of (position type-keyword +cffi-types+)))
 230
 231 (defcfun "int align_of(int type)" 0
 232   "switch (type) {
 233      case 0:  return __alignof__(char);
 234      case 1:  return __alignof__(unsigned char);
 235      case 2:  return __alignof__(short);
 236      case 3:  return __alignof__(unsigned short);
 237      case 4:  return __alignof__(int);
 238      case 5:  return __alignof__(unsigned int);
 239      case 6:  return __alignof__(long);
 240      case 7:  return __alignof__(unsigned long);
 241      case 8:  return __alignof__(float);
 242      case 9:  return __alignof__(double);
 243      case 10: return __alignof__(void *);
 244      default: return -1;
 245    }")
 246
 247 (defentry align-of (int) (int "align_of"))
 248
 249 ;; TODO: like %foreign-type-size
 250 (defun %foreign-type-alignment (type-keyword)
 251   "Return the alignment in bytes of a foreign type."
 252   (align-of (position type-keyword +cffi-types+)))
 253
 254 #+ignore
 255 (defun convert-external-name (name)
 256   "Add an underscore to NAME if necessary for the ABI."
 257   #+darwinppc-target (concatenate 'string "_" name)
 258   #-darwinppc-target name)
 259
 260 (defmacro %foreign-funcall (function-name &rest args)
 261   "Perform a foreign function all, document it more later."
 262   `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
 263
 264 (defun defcfun-helper-forms (name rettype args types)
 265   "Return 2 values for DEFCFUN. A prelude form and a caller form."
 266   (let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name))))
 267     (values
 268      `(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
 269         (,(convert-foreign-type rettype) ,name))
 270      `(,ff-name ,@args))))
 271
 272 ;;;# Callbacks
 273
 274 ;;; XXX unimplemented
 275 (defmacro make-callback (name rettype arg-names arg-types body-form)
 276   0)
 277
 278 ;;;# Loading Foreign Libraries
 279
 280 (defun %load-foreign-library (name)
 281   "_Won't_ load the foreign library NAME."
 282   (declare (ignore name)))
 283
 284 ;;;# Foreign Globals
 285
 286 ;;; XXX unimplemented
 287 (defmacro foreign-var-ptr (name)
 288   "Return a pointer pointing to the foreign symbol NAME."
 289   0)