external/cffi.darcs/_darcs/pristine/src/types.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; types.lisp --- User-defined CFFI types.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;; Copyright (C) 2005-2007, Luis Oliveira  <loliveira@common-lisp.net>
   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)
  30
  31 ;;;# Built-In Types
  32
  33 (define-built-in-foreign-type :char)
  34 (define-built-in-foreign-type :unsigned-char)
  35 (define-built-in-foreign-type :short)
  36 (define-built-in-foreign-type :unsigned-short)
  37 (define-built-in-foreign-type :int)
  38 (define-built-in-foreign-type :unsigned-int)
  39 (define-built-in-foreign-type :long)
  40 (define-built-in-foreign-type :unsigned-long)
  41 (define-built-in-foreign-type :float)
  42 (define-built-in-foreign-type :double)
  43 (define-built-in-foreign-type :void)
  44
  45 #-cffi-features:no-long-long
  46 (progn
  47   (define-built-in-foreign-type :long-long)
  48   (define-built-in-foreign-type :unsigned-long-long))
  49
  50 ;;; When some lisp other than SCL supports :long-double we should
  51 ;;; use #-cffi-features:no-long-double here instead.
  52 #+(and scl long-float) (define-built-in-foreign-type :long-double)
  53
  54 ;;;# Foreign Pointers
  55
  56 (define-modify-macro incf-pointer (&optional (offset 1)) inc-pointer)
  57
  58 (defun mem-ref (ptr type &optional (offset 0))
  59   "Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggregate,
  60 we don't return its 'value' but a pointer to it, which is PTR itself."
  61   (let ((ptype (parse-type type)))
  62     (if (aggregatep ptype)
  63         (inc-pointer ptr offset)
  64         (let ((raw-value (%mem-ref ptr (canonicalize ptype) offset)))
  65           (translate-from-foreign raw-value ptype)))))
  66
  67 (define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0))
  68   "Compiler macro to open-code MEM-REF when TYPE is constant."
  69   (if (constantp type)
  70       (let ((parsed-type (parse-type (eval type))))
  71         (if (aggregatep parsed-type)
  72             `(inc-pointer ,ptr ,offset)
  73             (expand-from-foreign
  74              `(%mem-ref ,ptr ,(canonicalize parsed-type) ,offset)
  75              parsed-type)))
  76       form))
  77
  78 (defun mem-set (value ptr type &optional (offset 0))
  79   "Set the value of TYPE at OFFSET bytes from PTR to VALUE."
  80   (let ((ptype (parse-type type)))
  81     (%mem-set (translate-to-foreign value ptype)
  82               ptr (canonicalize ptype) offset)))
  83
  84 (define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env)
  85   "SETF expander for MEM-REF that doesn't rebind TYPE.
  86 This is necessary for the compiler macro on MEM-SET to be able
  87 to open-code (SETF MEM-REF) forms."
  88   (multiple-value-bind (dummies vals newval setter getter)
  89       (get-setf-expansion ptr env)
  90     (declare (ignore setter newval))
  91     ;; if either TYPE or OFFSET are constant, we avoid rebinding them
  92     ;; so that the compiler macros on MEM-SET and %MEM-SET work.
  93     (with-unique-names (store type-tmp offset-tmp)
  94       (values
  95        (append (unless (constantp type)   (list type-tmp))
  96                (unless (constantp offset) (list offset-tmp))
  97                dummies)
  98        (append (unless (constantp type)   (list type))
  99                (unless (constantp offset) (list offset))
 100                vals)
 101        (list store)
 102        `(progn
 103           (mem-set ,store ,getter
 104                    ,@(if (constantp type)   (list type)   (list type-tmp))
 105                    ,@(if (constantp offset) (list offset) (list offset-tmp)))
 106           ,store)
 107        `(mem-ref ,getter
 108                  ,@(if (constantp type)   (list type)   (list type-tmp))
 109                  ,@(if (constantp offset) (list offset) (list offset-tmp)))))))
 110
 111 (define-compiler-macro mem-set
 112     (&whole form value ptr type &optional (offset 0))
 113   "Compiler macro to open-code (SETF MEM-REF) when type is constant."
 114   (if (constantp type)
 115       (let ((parsed-type (parse-type (eval type))))
 116         `(%mem-set ,(expand-to-foreign value parsed-type) ,ptr
 117                    ,(canonicalize parsed-type) ,offset))
 118       form))
 119
 120 ;;;# Dereferencing Foreign Arrays
 121
 122 ;;; Maybe this should be named MEM-SVREF? [2007-02-28 LO]
 123 (defun mem-aref (ptr type &optional (index 0))
 124   "Like MEM-REF except for accessing 1d arrays."
 125   (mem-ref ptr type (* index (foreign-type-size type))))
 126
 127 (define-compiler-macro mem-aref (&whole form ptr type &optional (index 0))
 128   "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)."
 129   (if (constantp type)
 130       (if (constantp index)
 131           `(mem-ref ,ptr ,type
 132                     ,(* (eval index) (foreign-type-size (eval type))))
 133           `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type)))))
 134       form))
 135
 136 (define-setf-expander mem-aref (ptr type &optional (index 0) &environment env)
 137   "SETF expander for MEM-AREF."
 138   (multiple-value-bind (dummies vals newval setter getter)
 139       (get-setf-expansion ptr env)
 140     (declare (ignore setter newval))
 141     ;; we avoid rebinding type and index, if possible (and if type is not
 142     ;; constant, we don't bother about the index), so that the compiler macros
 143     ;; on MEM-SET or %MEM-SET can work.
 144     (with-unique-names (store type-tmp index-tmp)
 145       (values
 146        (append (unless (constantp type)
 147                  (list type-tmp))
 148                (unless (and (constantp type) (constantp index))
 149                  (list index-tmp))
 150                dummies)
 151        (append (unless (constantp type)
 152                  (list type))
 153                (unless (and (constantp type) (constantp index))
 154                  (list index))
 155                vals)
 156        (list store)
 157        ;; Here we'll try to calculate the offset from the type and index,
 158        ;; or if not possible at least get the type size early.
 159        `(progn
 160           ,(if (constantp type)
 161                (if (constantp index)
 162                    `(mem-set ,store ,getter ,type
 163                              ,(* (eval index) (foreign-type-size (eval type))))
 164                    `(mem-set ,store ,getter ,type
 165                              (* ,index-tmp ,(foreign-type-size (eval type)))))
 166                `(mem-set ,store ,getter ,type-tmp
 167                          (* ,index-tmp (foreign-type-size ,type-tmp))))
 168           ,store)
 169        `(mem-aref ,getter
 170                   ,@(if (constantp type)
 171                         (list type)
 172                         (list type-tmp))
 173                   ,@(if (and (constantp type) (constantp index))
 174                         (list index)
 175                         (list index-tmp)))))))
 176
 177 (define-foreign-type foreign-array-type ()
 178   ((dimensions :reader dimensions :initarg :dimensions)
 179    (element-type :reader element-type :initarg :element-type))
 180   (:actual-type :pointer))
 181
 182 (defmethod print-object ((type foreign-array-type) stream)
 183   "Print a FOREIGN-ARRAY-TYPE instance to STREAM unreadably."
 184   (print-unreadable-object (type stream :type t :identity nil)
 185     (format stream "~S ~S" (element-type type) (dimensions type))))
 186
 187 (define-parse-method :array (element-type &rest dimensions)
 188   (make-instance 'foreign-array-type
 189                  :element-type element-type
 190                  :dimensions dimensions))
 191
 192 (defun array-element-size (array-type)
 193   (foreign-type-size (element-type array-type)))
 194
 195 (defun indexes-to-row-major-index (dimensions &rest subscripts)
 196   (apply #'+ (maplist (lambda (x y)
 197                         (* (car x) (apply #'* (cdr y))))
 198                       subscripts
 199                       dimensions)))
 200
 201 (defun row-major-index-to-indexes (index dimensions)
 202   (loop with idx = index
 203         with rank = (length dimensions)
 204         with indexes = (make-list rank)
 205         for dim-index from (- rank 1) downto 0 do
 206         (setf (values idx (nth dim-index indexes))
 207               (floor idx (nth dim-index dimensions)))
 208         finally (return indexes)))
 209
 210 (defun lisp-array-to-foreign (array pointer array-type)
 211   "Copy elements from a Lisp array to POINTER."
 212   (let* ((type (follow-typedefs (parse-type array-type)))
 213          (el-type (element-type type))
 214          (dimensions (dimensions type)))
 215     (loop with foreign-type-size = (array-element-size type)
 216           with size = (reduce #'* dimensions)
 217           for i from 0 below size
 218           for offset = (* i foreign-type-size)
 219           for element = (apply #'aref array
 220                                (row-major-index-to-indexes i dimensions))
 221           do (setf (mem-ref pointer el-type offset) element))))
 222
 223 (defun foreign-array-to-lisp (pointer array-type)
 224   "Copy elements from ptr into a Lisp array. If POINTER is a null
 225 pointer, returns NIL."
 226   (unless (null-pointer-p pointer)
 227     (let* ((type (follow-typedefs (parse-type array-type)))
 228            (el-type (element-type type))
 229            (dimensions (dimensions type))
 230            (array (make-array dimensions)))
 231       (loop with foreign-type-size = (array-element-size type)
 232             with size = (reduce #'* dimensions)
 233             for i from 0 below size
 234             for offset = (* i foreign-type-size)
 235             for element = (mem-ref pointer el-type offset)
 236             do (setf (apply #'aref array
 237                             (row-major-index-to-indexes i dimensions))
 238                      element))
 239       array)))
 240
 241 (defun foreign-array-alloc (array array-type)
 242   "Allocate a foreign array containing the elements of lisp array.
 243 The foreign array must be freed with foreign-array-free."
 244   (check-type array array)
 245   (let* ((type (follow-typedefs (parse-type array-type)))
 246          (ptr (foreign-alloc (element-type type)
 247                              :count (reduce #'* (dimensions type)))))
 248     (lisp-array-to-foreign array ptr array-type)
 249     ptr))
 250
 251 (defun foreign-array-free (ptr)
 252   "Free a foreign array allocated by foreign-array-alloc."
 253   (foreign-free ptr))
 254
 255 (defmacro with-foreign-array ((var lisp-array array-type) &body body)
 256   "Bind var to a foreign array containing lisp-array elements in body."
 257   (with-unique-names (type)
 258     `(let ((,type (follow-typedefs (parse-type ,array-type))))
 259        (with-foreign-pointer (,var (* (reduce #'* (dimensions ,type))
 260                                       (array-element-size ,type)))
 261          (lisp-array-to-foreign ,lisp-array ,var ,array-type)
 262          ,@body))))
 263
 264 (defun foreign-aref (ptr array-type &rest indexes)
 265   (let* ((type (follow-typedefs (parse-type array-type)))
 266          (offset (* (array-element-size type)
 267                     (apply #'indexes-to-row-major-index
 268                            (dimensions type) indexes))))
 269     (mem-ref ptr (element-type type) offset)))
 270
 271 (defun (setf foreign-aref) (value ptr array-type &rest indexes)
 272   (let* ((type (follow-typedefs (parse-type array-type)))
 273          (offset (* (array-element-size type)
 274                     (apply #'indexes-to-row-major-index
 275                            (dimensions type) indexes))))
 276     (setf (mem-ref ptr (element-type type) offset) value)))
 277
 278 ;;; This type has defined type translators to allocate and free the
 279 ;;; array.  It will also invoke type translators for each of the
 280 ;;; array's element.  **But it doesn't free them yet**
 281 (define-foreign-type auto-array-type (foreign-array-type)
 282   ())
 283
 284 (define-parse-method :auto-array (element-type &rest dimensions)
 285   (assert (>= (length dimensions) 1))
 286   (make-instance 'auto-array-type
 287                  :element-type element-type
 288                  :dimensions dimensions))
 289
 290 (defmethod translate-to-foreign (array (type auto-array-type))
 291   (foreign-array-alloc array (unparse-type type)))
 292
 293 (defmethod translate-from-foreign (pointer (type auto-array-type))
 294   (foreign-array-to-lisp pointer (unparse-type type)))
 295
 296 (defmethod free-translated-object (pointer (type auto-array-type) param)
 297   (declare (ignore param))
 298   (foreign-array-free pointer))
 299
 300 ;;;# Foreign Structures
 301
 302 ;;;## Foreign Structure Slots
 303
 304 (defgeneric foreign-struct-slot-pointer (ptr slot)
 305   (:documentation
 306    "Get the address of SLOT relative to PTR."))
 307
 308 (defgeneric foreign-struct-slot-pointer-form (ptr slot)
 309   (:documentation
 310    "Return a form to get the address of SLOT in PTR."))
 311
 312 (defgeneric foreign-struct-slot-value (ptr slot)
 313   (:documentation
 314    "Return the value of SLOT in structure PTR."))
 315
 316 (defgeneric (setf foreign-struct-slot-value) (value ptr slot)
 317   (:documentation
 318    "Set the value of a SLOT in structure PTR."))
 319
 320 (defgeneric foreign-struct-slot-value-form (ptr slot)
 321   (:documentation
 322    "Return a form to get the value of SLOT in struct PTR."))
 323
 324 (defgeneric foreign-struct-slot-set-form (value ptr slot)
 325   (:documentation
 326    "Return a form to set the value of SLOT in struct PTR."))
 327
 328 (defclass foreign-struct-slot ()
 329   ((name   :initarg :name   :reader   slot-name)
 330    (offset :initarg :offset :accessor slot-offset)
 331    (type   :initarg :type   :accessor slot-type))
 332   (:documentation "Base class for simple and aggregate slots."))
 333
 334 (defmethod foreign-struct-slot-pointer (ptr (slot foreign-struct-slot))
 335   "Return the address of SLOT relative to PTR."
 336   (inc-pointer ptr (slot-offset slot)))
 337
 338 (defmethod foreign-struct-slot-pointer-form (ptr (slot foreign-struct-slot))
 339   "Return a form to get the address of SLOT relative to PTR."
 340   (let ((offset (slot-offset slot)))
 341     (if (zerop offset)
 342         ptr
 343         `(inc-pointer ,ptr ,offset))))
 344
 345 (defun foreign-slot-names (type)
 346   "Returns a list of TYPE's slot names in no particular order."
 347   (loop for value being the hash-values
 348         in (slots (follow-typedefs (parse-type type)))
 349         collect (slot-name value)))
 350
 351 ;;;### Simple Slots
 352
 353 (defclass simple-struct-slot (foreign-struct-slot)
 354   ()
 355   (:documentation "Non-aggregate structure slots."))
 356
 357 (defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot))
 358   "Return the value of a simple SLOT from a struct at PTR."
 359   (mem-ref ptr (slot-type slot) (slot-offset slot)))
 360
 361 (defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot))
 362   "Return a form to get the value of a slot from PTR."
 363   `(mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)))
 364
 365 (defmethod (setf foreign-struct-slot-value) (value ptr (slot simple-struct-slot))
 366   "Set the value of a simple SLOT to VALUE in PTR."
 367   (setf (mem-ref ptr (slot-type slot) (slot-offset slot)) value))
 368
 369 (defmethod foreign-struct-slot-set-form (value ptr (slot simple-struct-slot))
 370   "Return a form to set the value of a simple structure slot."
 371   `(setf (mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)) ,value))
 372
 373 ;;;### Aggregate Slots
 374
 375 (defclass aggregate-struct-slot (foreign-struct-slot)
 376   ((count :initarg :count :accessor slot-count))
 377   (:documentation "Aggregate structure slots."))
 378
 379 ;;; A case could be made for just returning an error here instead of
 380 ;;; this rather DWIM-ish behavior to return the address.  It would
 381 ;;; complicate being able to chain together slot names when accessing
 382 ;;; slot values in nested structures though.
 383 (defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot))
 384   "Return a pointer to SLOT relative to PTR."
 385   (foreign-struct-slot-pointer ptr slot))
 386
 387 (defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-slot))
 388   "Return a form to get the value of SLOT relative to PTR."
 389   (foreign-struct-slot-pointer-form ptr slot))
 390
 391 ;;; This is definitely an error though.  Eventually, we could define a
 392 ;;; new type of type translator that can convert certain aggregate
 393 ;;; types, notably C strings or arrays of integers.  For now, just error.
 394 (defmethod (setf foreign-struct-slot-value) (value ptr (slot aggregate-struct-slot))
 395   "Signal an error; setting aggregate slot values is forbidden."
 396   (declare (ignore value ptr))
 397   (error "Cannot set value of aggregate slot ~A." slot))
 398
 399 (defmethod foreign-struct-slot-set-form (value ptr (slot aggregate-struct-slot))
 400   "Signal an error; setting aggregate slot values is forbidden."
 401   (declare (ignore value ptr))
 402   (error "Cannot set value of aggregate slot ~A." slot))
 403
 404 ;;;## Defining Foreign Structures
 405
 406 (defun make-struct-slot (name offset type count)
 407   "Make the appropriate type of structure slot."
 408   ;; If TYPE is an aggregate type or COUNT is >1, create an
 409   ;; AGGREGATE-STRUCT-SLOT, otherwise a SIMPLE-STRUCT-SLOT.
 410   (if (or (> count 1) (aggregatep (parse-type type)))
 411       (make-instance 'aggregate-struct-slot :offset offset :type type
 412                      :name name :count count)
 413       (make-instance 'simple-struct-slot :offset offset :type type
 414                      :name name)))
 415
 416 ;;; Regarding structure alignment, the following ABIs were checked:
 417 ;;;   - System-V ABI: x86, x86-64, ppc, arm, mips and itanium. (more?)
 418 ;;;   - Mac OS X ABI Function Call Guide: ppc32, ppc64 and x86.
 419 ;;;
 420 ;;; Rules used here:
 421 ;;;
 422 ;;;   1. "An entire structure or union object is aligned on the same
 423 ;;;       boundary as its most strictly aligned member."
 424 ;;;
 425 ;;;   2. "Each member is assigned to the lowest available offset with
 426 ;;;       the appropriate alignment. This may require internal
 427 ;;;       padding, depending on the previous member."
 428 ;;;
 429 ;;;   3. "A structure's size is increased, if necessary, to make it a
 430 ;;;       multiple of the alignment. This may require tail padding,
 431 ;;;       depending on the last member."
 432 ;;;
 433 ;;; Special cases from darwin/ppc32's ABI:
 434 ;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevelABI/index.html
 435 ;;;
 436 ;;;   4. "The embedding alignment of the first element in a data
 437 ;;;       structure is equal to the element's natural alignment."
 438 ;;;
 439 ;;;   5. "For subsequent elements that have a natural alignment
 440 ;;;       greater than 4 bytes, the embedding alignment is 4, unless
 441 ;;;       the element is a vector."  (note: this applies for
 442 ;;;       structures too)
 443
 444 ;; FIXME: get a better name for this. --luis
 445 (defun get-alignment (type alignment-type firstp)
 446   "Return alignment for TYPE according to ALIGNMENT-TYPE."
 447   (declare (ignorable firstp))
 448   (ecase alignment-type
 449     (:normal #-(and cffi-features:darwin cffi-features:ppc32)
 450              (foreign-type-alignment type)
 451              #+(and cffi-features:darwin cffi-features:ppc32)
 452              (if firstp
 453                  (foreign-type-alignment type)
 454                  (min 4 (foreign-type-alignment type))))))
 455
 456 (defun adjust-for-alignment (type offset alignment-type firstp)
 457   "Return OFFSET aligned properly for TYPE according to ALIGNMENT-TYPE."
 458   (let* ((align (get-alignment type alignment-type firstp))
 459          (rem (mod offset align)))
 460     (if (zerop rem)
 461         offset
 462         (+ offset (- align rem)))))
 463
 464 (defun notice-foreign-struct-definition (name-and-options slots)
 465   "Parse and install a foreign structure definition."
 466   (destructuring-bind (name &key size (class 'foreign-struct-type))
 467       (ensure-list name-and-options)
 468     (let ((struct (make-instance class :name name))
 469           (current-offset 0)
 470           (max-align 1)
 471           (firstp t))
 472       ;; determine offsets
 473       (dolist (slotdef slots)
 474         (destructuring-bind (slotname type &key (count 1) offset) slotdef
 475           (when (eq (canonicalize-foreign-type type) :void)
 476             (error "void type not allowed in structure definition: ~S" slotdef))
 477           (setq current-offset
 478                 (or offset
 479                     (adjust-for-alignment type current-offset :normal firstp)))
 480           (let* ((slot (make-struct-slot slotname current-offset type count))
 481                  (align (get-alignment (slot-type slot) :normal firstp)))
 482             (setf (gethash slotname (slots struct)) slot)
 483             (when (> align max-align)
 484               (setq max-align align)))
 485           (incf current-offset (* count (foreign-type-size type))))
 486         (setq firstp nil))
 487       ;; calculate padding and alignment
 488       (setf (alignment struct) max-align) ; See point 1 above.
 489       (let ((tail-padding (- max-align (rem current-offset max-align))))
 490         (unless (= tail-padding max-align) ; See point 3 above.
 491           (incf current-offset tail-padding)))
 492       (setf (size struct) (or size current-offset))
 493       (notice-foreign-type name struct))))
 494
 495 (defmacro defcstruct (name-and-options &body fields)
 496   "Define the layout of a foreign structure."
 497   (discard-docstring fields)
 498   `(eval-when (:compile-toplevel :load-toplevel :execute)
 499      ;; n-f-s-d could do with this with mop:ensure-class.
 500      ,(let-when (class (getf (cdr (ensure-list name-and-options)) :class))
 501         `(defclass ,class (foreign-struct-type) ()))
 502      (notice-foreign-struct-definition ',name-and-options ',fields)))
 503
 504 ;;;## Accessing Foreign Structure Slots
 505
 506 (defun get-slot-info (type slot-name)
 507   "Return the slot info for SLOT-NAME or raise an error."
 508   (let* ((struct (follow-typedefs (parse-type type)))
 509          (info (gethash slot-name (slots struct))))
 510     (unless info
 511       (error "Undefined slot ~A in foreign type ~A." slot-name type))
 512     info))
 513
 514 (defun foreign-slot-pointer (ptr type slot-name)
 515   "Return the address of SLOT-NAME in the structure at PTR."
 516   (foreign-struct-slot-pointer ptr (get-slot-info type slot-name)))
 517
 518 (defun foreign-slot-offset (type slot-name)
 519   "Return the offset of SLOT in a struct TYPE."
 520   (slot-offset (get-slot-info type slot-name)))
 521
 522 (defun foreign-slot-value (ptr type slot-name)
 523   "Return the value of SLOT-NAME in the foreign structure at PTR."
 524   (foreign-struct-slot-value ptr (get-slot-info type slot-name)))
 525
 526 (define-compiler-macro foreign-slot-value (&whole form ptr type slot-name)
 527   "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant."
 528   (if (and (constantp type) (constantp slot-name))
 529       (foreign-struct-slot-value-form
 530        ptr (get-slot-info (eval type) (eval slot-name)))
 531       form))
 532
 533 (define-setf-expander foreign-slot-value (ptr type slot-name &environment env)
 534   "SETF expander for FOREIGN-SLOT-VALUE."
 535   (multiple-value-bind (dummies vals newval setter getter)
 536       (get-setf-expansion ptr env)
 537     (declare (ignore setter newval))
 538     (if (and (constantp type) (constantp slot-name))
 539         ;; if TYPE and SLOT-NAME are constant we avoid rebinding them
 540         ;; so that the compiler macro on FOREIGN-SLOT-SET works.
 541         (with-unique-names (store)
 542           (values
 543            dummies
 544            vals
 545            (list store)
 546            `(progn
 547               (foreign-slot-set ,store ,getter ,type ,slot-name)
 548               ,store)
 549            `(foreign-slot-value ,getter ,type ,slot-name)))
 550         ;; if not...
 551         (with-unique-names (store slot-name-tmp type-tmp)
 552           (values
 553            (list* type-tmp slot-name-tmp dummies)
 554            (list* type slot-name vals)
 555            (list store)
 556            `(progn
 557               (foreign-slot-set ,store ,getter ,type-tmp ,slot-name-tmp)
 558               ,store)
 559            `(foreign-slot-value ,getter ,type-tmp ,slot-name-tmp))))))
 560
 561 (defun foreign-slot-set (value ptr type slot-name)
 562   "Set the value of SLOT-NAME in a foreign structure."
 563   (setf (foreign-struct-slot-value ptr (get-slot-info type slot-name)) value))
 564
 565 (define-compiler-macro foreign-slot-set
 566     (&whole form value ptr type slot-name)
 567   "Optimizer when TYPE and SLOT-NAME are constant."
 568   (if (and (constantp type) (constantp slot-name))
 569       (foreign-struct-slot-set-form
 570        value ptr (get-slot-info (eval type) (eval slot-name)))
 571       form))
 572
 573 (defmacro with-foreign-slots ((vars ptr type) &body body)
 574   "Create local symbol macros for each var in VARS to reference
 575 foreign slots in PTR of TYPE.  Similar to WITH-SLOTS."
 576   (let ((ptr-var (gensym "PTR")))
 577     `(let ((,ptr-var ,ptr))
 578        (symbol-macrolet
 579            ,(loop for var in vars
 580                   collect `(,var (foreign-slot-value ,ptr-var ',type ',var)))
 581          ,@body))))
 582
 583 ;;;# Foreign Unions
 584 ;;;
 585 ;;; A union is a FOREIGN-STRUCT-TYPE in which all slots have an offset
 586 ;;; of zero.
 587
 588 ;;; See also the notes regarding ABI requirements in
 589 ;;; NOTICE-FOREIGN-STRUCT-DEFINITION
 590 (defun notice-foreign-union-definition (name-and-options slots)
 591   "Parse and install a foreign union definition."
 592   (destructuring-bind (name &key size)
 593       (ensure-list name-and-options)
 594     (let ((struct (make-instance 'foreign-struct-type :name name))
 595           (max-size 0)
 596           (max-align 0))
 597       (dolist (slotdef slots)
 598         (destructuring-bind (slotname type &key (count 1)) slotdef
 599           (when (eq (canonicalize-foreign-type type) :void)
 600             (error "void type not allowed in union definition: ~S" slotdef))
 601           (let* ((slot (make-struct-slot slotname 0 type count))
 602                  (size (* count (foreign-type-size type)))
 603                  (align (foreign-type-alignment (slot-type slot))))
 604             (setf (gethash slotname (slots struct)) slot)
 605             (when (> size max-size)
 606               (setf max-size size))
 607             (when (> align max-align)
 608               (setf max-align align)))))
 609       (setf (size struct) (or size max-size))
 610       (setf (alignment struct) max-align)
 611       (notice-foreign-type name struct))))
 612
 613 (defmacro defcunion (name &body fields)
 614   "Define the layout of a foreign union."
 615   (discard-docstring fields)
 616   `(eval-when (:compile-toplevel :load-toplevel :execute)
 617      (notice-foreign-union-definition ',name ',fields)))
 618
 619 ;;;# Operations on Types
 620
 621 (defmethod foreign-type-alignment (type)
 622   "Return the alignment in bytes of a foreign type."
 623   (foreign-type-alignment (parse-type type)))
 624
 625 (defun foreign-alloc (type &key (initial-element nil initial-element-p)
 626                       (initial-contents nil initial-contents-p)
 627                       (count 1 count-p) null-terminated-p)
 628   "Allocate enough memory to hold COUNT objects of type TYPE. If
 629 INITIAL-ELEMENT is supplied, each element of the newly allocated
 630 memory is initialized with its value. If INITIAL-CONTENTS is supplied,
 631 each of its elements will be used to initialize the contents of the
 632 newly allocated memory."
 633   (let (contents-length)
 634     ;; Some error checking, etc...
 635     (when (and null-terminated-p
 636                (not (eq (canonicalize-foreign-type type) :pointer)))
 637       (error "Cannot use :NULL-TERMINATED-P with non-pointer types."))
 638     (when (and initial-element-p initial-contents-p)
 639       (error "Cannot specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
 640     (when initial-contents-p
 641       (setq contents-length (length initial-contents))
 642       (if count-p
 643           (assert (>= count contents-length))
 644           (setq count contents-length)))
 645     ;; Everything looks good.
 646     (let ((ptr (%foreign-alloc (* (foreign-type-size type)
 647                                   (if null-terminated-p (1+ count) count)))))
 648       (when initial-element-p
 649         (dotimes (i count)
 650           (setf (mem-aref ptr type i) initial-element)))
 651       (when initial-contents-p
 652         (dotimes (i contents-length)
 653           (setf (mem-aref ptr type i) (elt initial-contents i))))
 654       (when null-terminated-p
 655         (setf (mem-aref ptr :pointer count) (null-pointer)))
 656       ptr)))
 657
 658 ;;; Simple compiler macro that kicks in when TYPE is constant and only
 659 ;;; the COUNT argument is passed.  (Note: hard-coding the type's size
 660 ;;; into the fasl will likely break CLISP fasl cross-platform
 661 ;;; compatibilty.)
 662 (define-compiler-macro foreign-alloc (&whole form type &rest args
 663                                       &key (count 1 count-p) &allow-other-keys)
 664   (if (or (and count-p (<= (length args) 2)) (null args))
 665       (cond
 666         ((and (constantp type) (constantp count))
 667          `(%foreign-alloc ,(* (eval count) (foreign-type-size (eval type)))))
 668         ((constantp type)
 669          `(%foreign-alloc (* ,count ,(foreign-type-size (eval type)))))
 670         (t form))
 671       form))
 672
 673 (defmacro with-foreign-object ((var type &optional (count 1)) &body body)
 674   "Bind VAR to a pointer to COUNT objects of TYPE during BODY.
 675 The buffer has dynamic extent and may be stack allocated."
 676   `(with-foreign-pointer
 677        (,var ,(if (constantp type)
 678                   ;; with-foreign-pointer may benefit from constant folding:
 679                   (if (constantp count)
 680                       (* (eval count) (foreign-type-size (eval type)))
 681                       `(* ,count ,(foreign-type-size (eval type))))
 682                   `(* ,count (foreign-type-size ,type))))
 683      ,@body))
 684
 685 (defmacro with-foreign-objects (bindings &body body)
 686   (if bindings
 687       `(with-foreign-object ,(car bindings)
 688          (with-foreign-objects ,(cdr bindings)
 689            ,@body))
 690       `(progn ,@body)))
 691
 692 ;;;## Anonymous Type Translators
 693 ;;;
 694 ;;; (:wrapper :to-c some-function :from-c another-function)
 695 ;;;
 696 ;;; TODO: We will need to add a FREE function to this as well I think.
 697 ;;; --james
 698
 699 (define-foreign-type foreign-type-wrapper ()
 700   ((to-c   :initarg :to-c   :reader wrapper-to-c)
 701    (from-c :initarg :from-c :reader wrapper-from-c))
 702   (:documentation "Wrapper type."))
 703
 704 (define-parse-method :wrapper (base-type &key to-c from-c)
 705   (make-instance 'foreign-type-wrapper
 706                  :actual-type (parse-type base-type)
 707                  :to-c (or to-c 'identity)
 708                  :from-c (or from-c 'identity)))
 709
 710 (defmethod translate-to-foreign (value (type foreign-type-wrapper))
 711   (translate-to-foreign
 712    (funcall (slot-value type 'to-c) value) (actual-type type)))
 713
 714 (defmethod translate-from-foreign (value (type foreign-type-wrapper))
 715   (funcall (slot-value type 'from-c)
 716            (translate-from-foreign value (actual-type type))))
 717
 718 ;;;# Other types
 719
 720 ;;; Boolean type. Maps to an :int by default. Only accepts integer types.
 721 (define-foreign-type foreign-boolean-type ()
 722   ())
 723
 724 (define-parse-method :boolean (&optional (base-type :int))
 725   (make-instance
 726    'foreign-boolean-type :actual-type
 727    (ecase (canonicalize-foreign-type base-type)
 728      ((:char :unsigned-char :int :unsigned-int :long :unsigned-long
 729        #-cffi-features:no-long-long :long-long
 730        #-cffi-features:no-long-long :unsigned-long-long) base-type))))
 731
 732 (defmethod translate-to-foreign (value (type foreign-boolean-type))
 733   (if value 1 0))
 734
 735 (defmethod translate-from-foreign (value (type foreign-boolean-type))
 736   (not (zerop value)))
 737
 738 (defmethod expand-to-foreign (value (type foreign-boolean-type))
 739   "Optimization for the :boolean type."
 740   (if (constantp value)
 741       (if (eval value) 1 0)
 742       `(if ,value 1 0)))
 743
 744 (defmethod expand-from-foreign (value (type foreign-boolean-type))
 745   "Optimization for the :boolean type."
 746   (if (constantp value) ; very unlikely, heh
 747       (not (zerop (eval value)))
 748       `(not (zerop ,value))))
 749
 750 ;;;# Typedefs for built-in types.
 751
 752 (defctype :uchar  :unsigned-char)
 753 (defctype :ushort :unsigned-short)
 754 (defctype :uint   :unsigned-int)
 755 (defctype :ulong  :unsigned-long)
 756
 757 #-cffi-features:no-long-long
 758 (progn
 759   (defctype :llong  :long-long)
 760   (defctype :ullong :unsigned-long-long))
 761
 762 ;;; We try to define the :[u]int{8,16,32,64} types by looking at
 763 ;;; the sizes of the built-in integer types and defining typedefs.
 764 (eval-when (:compile-toplevel :load-toplevel :execute)
 765   (macrolet
 766       ((match-types (sized-types mtypes)
 767          `(progn
 768             ,@(loop for (type . size) in sized-types
 769                     for m = (car (member size mtypes :key #'foreign-type-size))
 770                     when m collect `(defctype ,type ,m)))))
 771     ;; signed
 772     (match-types ((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8))
 773                  (:char :short :int :long
 774                   #-cffi-features:no-long-long :long-long))
 775     ;; unsigned
 776     (match-types ((:uint8 . 1) (:uint16 . 2) (:uint32 . 4) (:uint64 . 8))
 777                  (:unsigned-char :unsigned-short :unsigned-int :unsigned-long
 778                   #-cffi-features:no-long-long :unsigned-long-long))))