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