libffi/type-descriptors.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; type-descriptors.lisp --- Build malloc'd libffi type descriptors
   4 ;;;
   5 ;;; Copyright (C) 2009, 2011 Liam M. Healy
   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 (in-package #:cffi)
  29
  30 (defmacro type-descriptor-ptr (type)
  31   `(foreign-symbol-pointer ,(format nil "ffi_type_~(~A~)" type)))
  32
  33 (defmacro type-descriptor-ptr/integer (type)
  34   `(foreign-symbol-pointer
  35     ,(format nil "ffi_type_~Aint~D"
  36              (if (string-equal type "unsigned"
  37                                :end1 (min 8 (length (string type))))
  38                  "u" "s")
  39              (* 8 (foreign-type-size type)))))
  40
  41 (defun %make-libffi-type-descriptor/struct (type)
  42   (labels
  43       ((slot-multiplicity (slot)
  44          (if (typep slot 'aggregate-struct-slot)
  45              (slot-count slot)
  46              1))
  47        (number-of-items (structure-type)
  48          "Total number of items in the foreign structure."
  49          (loop for val being the hash-value of (structure-slots structure-type)
  50                sum (slot-multiplicity val))))
  51     (let* ((ptr (foreign-alloc '(:struct ffi-type)))
  52            (nitems (number-of-items type))
  53            (type-pointer-array
  54             (foreign-alloc :pointer :count (1+ nitems))))
  55       (loop for slot in (slots-in-order type)
  56             for ltp = (make-libffi-type-descriptor
  57                        (parse-type (slot-type slot)))
  58             with slot-counter = 0
  59             do (if ltp
  60                    (loop
  61                          repeat (slot-multiplicity slot)
  62                          do (setf
  63                              (mem-aref
  64                               type-pointer-array :pointer slot-counter)
  65                              ltp)
  66                          (incf slot-counter))
  67                    (libffi-error nil
  68                                  "Slot type ~A in foreign structure is unknown to libffi."
  69                                  (unparse-type (slot-type slot)))))
  70       (setf (mem-aref type-pointer-array :pointer nitems)
  71             (null-pointer))
  72       (macrolet ((store (slot value)
  73                    `(setf (foreign-slot-value ptr '(:struct ffi-type) ',slot) ,value)))
  74         (store size 0)
  75         (store alignment 0)
  76         (store type +type-struct+)
  77         (store elements type-pointer-array))
  78       ptr)))
  79
  80 (defgeneric make-libffi-type-descriptor (object)
  81   (:documentation "Build a libffi struct that describes the type for libffi. This will be used as a cached static read-only argument when the actual call happens.")
  82   (:method ((object foreign-built-in-type))
  83     (let ((type-keyword (type-keyword object)))
  84       #.`(case type-keyword
  85            ,@(loop
  86                :for type :in (append *built-in-float-types*
  87                                      *other-builtin-types*)
  88                :collect `(,type (type-descriptor-ptr ,type)))
  89            ,@(loop
  90                :for type :in *built-in-integer-types*
  91                :collect `(,type (type-descriptor-ptr/integer ,type)))
  92            ;; there's a generic error report in an :around method
  93            )))
  94   (:method ((type foreign-pointer-type))
  95     ;; simplify all pointer types into a void*
  96     (type-descriptor-ptr :pointer))
  97   (:method ((type foreign-struct-type))
  98     (%make-libffi-type-descriptor/struct type))
  99   (:method :around (object)
 100     (let ((result (call-next-method)))
 101       (assert result () "~S failed on ~S. That's bad."
 102               'make-libffi-type-descriptor object)
 103       result))
 104   (:method ((type foreign-type-alias))
 105     ;; Set the type pointer on demand for alias types (e.g. typedef, enum, etc)
 106     (make-libffi-type-descriptor (actual-type type))))