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