src/early-types.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; early-types.lisp --- Low-level foreign type operations.
   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 ;;;# Early Type Definitions
  30 ;;;
  31 ;;; This module contains basic operations on foreign types.  These
  32 ;;; definitions are in a separate file because they may be used in
  33 ;;; compiler macros defined later on.
  34
  35 (in-package #:cffi)
  36
  37 ;;;# Foreign Types
  38 ;;;
  39 ;;; Type specifications are of the form (type {args}*). The type
  40 ;;; parser can specify how its arguments should look like through a
  41 ;;; lambda list.
  42 ;;;
  43 ;;; "type" is a shortcut for "(type)", ie, no args were specified.
  44 ;;;
  45 ;;; Examples of such types: boolean, (boolean), (boolean :int) If the
  46 ;;; boolean type parser specifies the lambda list: &optional
  47 ;;; (base-type :int), then all of the above three type specs would be
  48 ;;; parsed to an identical type.
  49 ;;;
  50 ;;; Type parsers, defined with DEFINE-PARSE-METHOD should return a
  51 ;;; subtype of the foreign-type class.
  52
  53 (defvar *default-type-parsers* (make-hash-table)
  54   "Hash table for :DEFAULT namespace")
  55 (defvar *struct-type-parsers* (make-hash-table)
  56   "Hash table for :STRUCT namespace")
  57 (defvar *union-type-parsers* (make-hash-table)
  58   "Hash table for :UNION namespace")
  59
  60 (define-condition cffi-error (error)
  61   ())
  62
  63 (define-condition foreign-type-error (cffi-error)
  64   ((type-name :initarg :type-name
  65               :initform (error "Must specify TYPE-NAME.")
  66               :accessor foreign-type-error/type-name)
  67    (namespace :initarg :namespace
  68               :initform :default
  69               :accessor foreign-type-error/namespace)))
  70
  71 (defun foreign-type-error/compound-name (e)
  72   (let ((name (foreign-type-error/type-name e))
  73         (namespace (foreign-type-error/namespace e)))
  74     (if (eq namespace :default)
  75         name
  76         `(,namespace ,name))))
  77
  78 (define-condition simple-foreign-type-error (simple-error foreign-type-error)
  79   ())
  80
  81 (defun simple-foreign-type-error (type-name namespace format-control &rest format-arguments)
  82   (error 'simple-foreign-type-error
  83          :type-name type-name :namespace namespace
  84          :format-control format-control :format-arguments format-arguments))
  85
  86 (define-condition undefined-foreign-type-error (foreign-type-error)
  87   ()
  88   (:report (lambda (e stream)
  89              (format stream "Unknown CFFI type ~S" (foreign-type-error/compound-name e)))))
  90
  91 (defun undefined-foreign-type-error (type-name &optional (namespace :default))
  92   (error 'undefined-foreign-type-error :type-name type-name :namespace namespace))
  93
  94 ;; TODO this is not according to the C namespace rules,
  95 ;; see bug: https://bugs.launchpad.net/cffi/+bug/1527947
  96 (deftype c-namespace-name ()
  97   '(member :default :struct :union))
  98
  99 (defun namespace-table (namespace)
 100   (ecase namespace
 101     (:default *default-type-parsers*)
 102     (:struct *struct-type-parsers*)
 103     (:union *union-type-parsers*)))
 104
 105 ;; for C namespaces read: https://stackoverflow.com/questions/12579142/type-namespace-in-c
 106 ;; (section 6.2.3 Name spaces of identifiers)
 107 ;; NOTE: :struct is probably an unfortunate name for the tagged (?) namespace
 108 (defun find-type-parser (symbol &optional (namespace :default))
 109   "Return the type parser for SYMBOL. NAMESPACE is either :DEFAULT (for
 110 variables, functions, and typedefs) or :STRUCT (for structs, unions, and enums)."
 111   (check-type symbol (and symbol (not null)))
 112   (or (gethash symbol (namespace-table namespace))
 113       (undefined-foreign-type-error symbol namespace)))
 114
 115 (defun find-default-type-parser (symbol)
 116   (check-type symbol (and symbol (not null)))
 117   (or (gethash symbol *default-type-parsers*)
 118       (undefined-foreign-type-error symbol :default)))
 119
 120 (defun (setf find-type-parser) (func symbol &optional (namespace :default))
 121   "Set the type parser for SYMBOL."
 122   (check-type symbol (and symbol (not null)))
 123   ;; TODO Shall we signal a redefinition warning here?
 124   (setf (gethash symbol (namespace-table namespace)) func))
 125
 126 (defun undefine-foreign-type (symbol &optional (namespace :default))
 127   (remhash symbol (namespace-table namespace))
 128   (values))
 129
 130 ;;; Using a generic function would have been nicer but generates lots
 131 ;;; of style warnings in SBCL.  (Silly reason, yes.)
 132 (defmacro define-parse-method (name lambda-list &body body)
 133   "Define a type parser on NAME and lists whose CAR is NAME."
 134   (discard-docstring body)
 135   (warn-if-kw-or-belongs-to-cl name)
 136   `(eval-when (:compile-toplevel :load-toplevel :execute)
 137      (setf (find-type-parser ',name)
 138            (lambda ,lambda-list ,@body))
 139      ',name))
 140
 141 ;;; Utility function for the simple case where the type takes no
 142 ;;; arguments.
 143 (defun notice-foreign-type (name type &optional (namespace :default))
 144   (setf (find-type-parser name namespace) (lambda () type))
 145   name)
 146
 147 ;;;# Generic Functions on Types
 148
 149 (defgeneric canonicalize (foreign-type)
 150   (:documentation
 151    "Return the most primitive foreign type for FOREIGN-TYPE, either a built-in
 152 type--a keyword--or a struct/union type--a list of the form (:STRUCT/:UNION name).
 153 Signals an error if FOREIGN-TYPE is undefined."))
 154
 155 (defgeneric aggregatep (foreign-type)
 156   (:documentation
 157    "Return true if FOREIGN-TYPE is an aggregate type."))
 158
 159 (defgeneric foreign-type-alignment (foreign-type)
 160   (:documentation
 161    "Return the structure alignment in bytes of a foreign type."))
 162
 163 (defgeneric foreign-type-size (foreign-type)
 164   (:documentation
 165    "Return the size in bytes of a foreign type."))
 166
 167 (defgeneric unparse-type (foreign-type)
 168   (:documentation
 169    "Unparse FOREIGN-TYPE to a type specification (symbol or list)."))
 170
 171 ;;;# Foreign Types
 172
 173 (defclass foreign-type ()
 174   ()
 175   (:documentation "Base class for all foreign types."))
 176
 177 (defmethod make-load-form ((type foreign-type) &optional env)
 178   "Return the form used to dump types to a FASL file."
 179   (declare (ignore env))
 180   `(parse-type ',(unparse-type type)))
 181
 182 (defmethod foreign-type-size (type)
 183   "Return the size in bytes of a foreign type."
 184   (foreign-type-size (parse-type type)))
 185
 186 (defclass named-foreign-type (foreign-type)
 187   ((name
 188     ;; Name of this foreign type, a symbol.
 189     :initform (error "Must specify a NAME.")
 190     :initarg :name
 191     :accessor name)))
 192
 193 (defmethod print-object ((type named-foreign-type) stream)
 194   "Print a FOREIGN-TYPEDEF instance to STREAM unreadably."
 195   (print-unreadable-object (type stream :type t :identity nil)
 196     (format stream "~S" (name type))))
 197
 198 ;;; Return the type's name which can be passed to PARSE-TYPE.  If
 199 ;;; that's not the case for some subclass of NAMED-FOREIGN-TYPE then
 200 ;;; it should specialize UNPARSE-TYPE.
 201 (defmethod unparse-type ((type named-foreign-type))
 202   (name type))
 203
 204 ;;;# Built-In Foreign Types
 205
 206 (defclass foreign-built-in-type (foreign-type)
 207   ((type-keyword
 208     ;; Keyword in CFFI-SYS representing this type.
 209     :initform (error "A type keyword is required.")
 210     :initarg :type-keyword
 211     :accessor type-keyword))
 212   (:documentation "A built-in foreign type."))
 213
 214 (defmethod canonicalize ((type foreign-built-in-type))
 215   "Return the built-in type keyword for TYPE."
 216   (type-keyword type))
 217
 218 (defmethod aggregatep ((type foreign-built-in-type))
 219   "Returns false, built-in types are never aggregate types."
 220   nil)
 221
 222 (defmethod foreign-type-alignment ((type foreign-built-in-type))
 223   "Return the alignment of a built-in type."
 224   (%foreign-type-alignment (type-keyword type)))
 225
 226 (defmethod foreign-type-size ((type foreign-built-in-type))
 227   "Return the size of a built-in type."
 228   (%foreign-type-size (type-keyword type)))
 229
 230 (defmethod unparse-type ((type foreign-built-in-type))
 231   "Returns the symbolic representation of a built-in type."
 232   (type-keyword type))
 233
 234 (defmethod print-object ((type foreign-built-in-type) stream)
 235   "Print a FOREIGN-TYPE instance to STREAM unreadably."
 236   (print-unreadable-object (type stream :type t :identity nil)
 237     (format stream "~S" (type-keyword type))))
 238
 239 (defvar *built-in-foreign-types* nil)
 240
 241 (defmacro define-built-in-foreign-type (keyword)
 242   "Defines a built-in foreign-type."
 243   `(eval-when (:compile-toplevel :load-toplevel :execute)
 244      (pushnew ,keyword *built-in-foreign-types*)
 245      (notice-foreign-type
 246       ,keyword (make-instance 'foreign-built-in-type :type-keyword ,keyword))))
 247
 248 ;;;# Foreign Pointer Types
 249
 250 (defclass foreign-pointer-type (foreign-built-in-type)
 251   ((pointer-type
 252     ;; Type of object pointed at by this pointer, or nil for an
 253     ;; untyped (void) pointer.
 254     :initform nil
 255     :initarg :pointer-type
 256     :accessor pointer-type))
 257   (:default-initargs :type-keyword :pointer))
 258
 259 ;;; Define the type parser for the :POINTER type.  If no type argument
 260 ;;; is provided, a void pointer will be created.
 261 (let ((void-pointer (make-instance 'foreign-pointer-type)))
 262   (define-parse-method :pointer (&optional type)
 263     (if type
 264         (make-instance 'foreign-pointer-type :pointer-type (parse-type type))
 265         ;; A bit of premature optimization here.
 266         void-pointer)))
 267
 268 ;;; Unparse a foreign pointer type when dumping to a fasl.
 269 (defmethod unparse-type ((type foreign-pointer-type))
 270   (if (pointer-type type)
 271       `(:pointer ,(unparse-type (pointer-type type)))
 272       :pointer))
 273
 274 ;;; Print a foreign pointer type unreadably in unparsed form.
 275 (defmethod print-object ((type foreign-pointer-type) stream)
 276   (print-unreadable-object (type stream :type t :identity nil)
 277     (format stream "~S" (unparse-type type))))
 278
 279 ;;;# Structure Type
 280
 281 (defgeneric bare-struct-type-p (foreign-type)
 282   (:documentation
 283    "Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. "))
 284
 285 (defmethod bare-struct-type-p ((type foreign-type))
 286   "Return true if FOREIGN-TYPE is a bare struct type or an alias of a bare struct type. "
 287   nil)
 288
 289 (defclass foreign-struct-type (named-foreign-type)
 290   ((slots
 291     ;; Hash table of slots in this structure, keyed by name.
 292     :initform (make-hash-table)
 293     :initarg :slots
 294     :accessor slots)
 295    (size
 296     ;; Cached size in bytes of this structure.
 297     :initarg :size
 298     :accessor size)
 299    (alignment
 300     ;; This struct's alignment requirements
 301     :initarg :alignment
 302     :accessor alignment)
 303    (bare
 304     ;; we use this flag to support the (old, deprecated) semantics of
 305     ;; bare struct types. FOO means (:POINTER (:STRUCT FOO) in
 306     ;; functions declarations whereas FOO in a structure definition is
 307     ;; a proper aggregate type: (:STRUCT FOO), etc.
 308     :initform nil
 309     :initarg :bare
 310     :reader bare-struct-type-p)))
 311
 312 (defun slots-in-order (structure-type)
 313   "A list of the structure's slots in order."
 314   (sort (loop for slots being the hash-value of (structure-slots structure-type)
 315               collect slots)
 316         #'<
 317         :key 'slot-offset))
 318
 319 (defmethod canonicalize ((type foreign-struct-type))
 320   (if (bare-struct-type-p type)
 321       :pointer
 322       `(:struct ,(name type))))
 323
 324 (defmethod unparse-type ((type foreign-struct-type))
 325   (if (bare-struct-type-p type)
 326       (name type)
 327       (canonicalize type)))
 328
 329 (defmethod aggregatep ((type foreign-struct-type))
 330   "Returns true, structure types are aggregate."
 331   t)
 332
 333 (defmethod foreign-type-size ((type foreign-struct-type))
 334   "Return the size in bytes of a foreign structure type."
 335   (size type))
 336
 337 (defmethod foreign-type-alignment ((type foreign-struct-type))
 338   "Return the alignment requirements for this struct."
 339   (alignment type))
 340
 341 (defclass foreign-union-type (foreign-struct-type) ())
 342
 343 (defmethod canonicalize ((type foreign-union-type))
 344   (if (bare-struct-type-p type)
 345       :pointer
 346       `(:union ,(name type))))
 347
 348 ;;;# Foreign Typedefs
 349
 350 (defclass foreign-type-alias (foreign-type)
 351   ((actual-type
 352     ;; The FOREIGN-TYPE instance this type is an alias for.
 353     :initarg :actual-type
 354     :accessor actual-type
 355     :initform (error "Must specify an ACTUAL-TYPE.")))
 356   (:documentation "A type that aliases another type."))
 357
 358 (defmethod canonicalize ((type foreign-type-alias))
 359   "Return the built-in type keyword for TYPE."
 360   (canonicalize (actual-type type)))
 361
 362 (defmethod aggregatep ((type foreign-type-alias))
 363   "Return true if TYPE's actual type is aggregate."
 364   (aggregatep (actual-type type)))
 365
 366 (defmethod foreign-type-alignment ((type foreign-type-alias))
 367   "Return the alignment of a foreign typedef."
 368   (foreign-type-alignment (actual-type type)))
 369
 370 (defmethod foreign-type-size ((type foreign-type-alias))
 371   "Return the size in bytes of a foreign typedef."
 372   (foreign-type-size (actual-type type)))
 373
 374 (defclass foreign-typedef (foreign-type-alias named-foreign-type)
 375   ())
 376
 377 (defun follow-typedefs (type)
 378   (if (typep type 'foreign-typedef)
 379       (follow-typedefs (actual-type type))
 380       type))
 381
 382 (defmethod bare-struct-type-p ((type foreign-typedef))
 383   (bare-struct-type-p (follow-typedefs type)))
 384
 385 (defun structure-slots (type)
 386   "The hash table of slots for the structure type."
 387   (slots (follow-typedefs type)))
 388
 389 ;;;# Type Translators
 390 ;;;
 391 ;;; Type translation is done with generic functions at runtime for
 392 ;;; subclasses of TRANSLATABLE-FOREIGN-TYPE.
 393 ;;;
 394 ;;; The main interface for defining type translations is through the
 395 ;;; generic functions TRANSLATE-{TO,FROM}-FOREIGN and
 396 ;;; FREE-TRANSLATED-OBJECT.
 397
 398 (defclass translatable-foreign-type (foreign-type) ())
 399
 400 ;;; ENHANCED-FOREIGN-TYPE is used to define translations on top of
 401 ;;; previously defined foreign types.
 402 (defclass enhanced-foreign-type (translatable-foreign-type
 403                                  foreign-type-alias)
 404   ((unparsed-type :accessor unparsed-type)))
 405
 406 ;;; If actual-type isn't parsed already, let's parse it.  This way we
 407 ;;; don't have to export PARSE-TYPE and users don't have to worry
 408 ;;; about this in DEFINE-FOREIGN-TYPE or DEFINE-PARSE-METHOD.
 409 (defmethod initialize-instance :after ((type enhanced-foreign-type) &key)
 410   (unless (typep (actual-type type) 'foreign-type)
 411     (setf (actual-type type) (parse-type (actual-type type)))))
 412
 413 (defmethod unparse-type ((type enhanced-foreign-type))
 414   (unparsed-type type))
 415
 416 ;;; Checks NAMEs, not object identity.
 417 (defun check-for-typedef-cycles (type)
 418   (labels ((%check (cur-type seen)
 419              (when (typep cur-type 'foreign-typedef)
 420                (when (member (name cur-type) seen)
 421                  (simple-foreign-type-error type :default
 422                                             "Detected cycle in type ~S." type))
 423                (%check (actual-type cur-type)
 424                        (cons (name cur-type) seen)))))
 425     (%check type nil)))
 426
 427 ;;; Only now we define PARSE-TYPE because it needs to do some extra
 428 ;;; work for ENHANCED-FOREIGN-TYPES.
 429 (defun parse-type (type)
 430   (let* ((spec (ensure-list type))
 431          (ptype (apply (find-default-type-parser (car spec)) (cdr spec))))
 432     (when (typep ptype 'foreign-typedef)
 433       (check-for-typedef-cycles ptype))
 434     (when (typep ptype 'enhanced-foreign-type)
 435       (setf (unparsed-type ptype) type))
 436     ptype))
 437
 438 (defun ensure-parsed-base-type (type)
 439   (follow-typedefs
 440    (if (typep type 'foreign-type)
 441        type
 442        (parse-type type))))
 443
 444 (defun canonicalize-foreign-type (type)
 445   "Convert TYPE to a built-in type by following aliases.
 446 Signals an error if the type cannot be resolved."
 447   (canonicalize (parse-type type)))
 448
 449 ;;; Translate VALUE to a foreign object of the type represented by
 450 ;;; TYPE, which will be a subclass of TRANSLATABLE-FOREIGN-TYPE.
 451 ;;; Returns the foreign value and an optional second value which will
 452 ;;; be passed to FREE-TRANSLATED-OBJECT as the PARAM argument.
 453 (defgeneric translate-to-foreign (value type)
 454   (:method (value type)
 455     (declare (ignore type))
 456     value))
 457
 458 (defgeneric translate-into-foreign-memory (value type pointer)
 459   (:documentation
 460    "Translate the Lisp value into the foreign memory location given by pointer.  Return value is not used.")
 461   (:argument-precedence-order type value pointer))
 462
 463 ;;; Similar to TRANSLATE-TO-FOREIGN, used exclusively by
 464 ;;; (SETF FOREIGN-STRUCT-SLOT-VALUE).
 465 (defgeneric translate-aggregate-to-foreign (ptr value type))
 466
 467 ;;; Translate the foreign object VALUE from the type repsented by
 468 ;;; TYPE, which will be a subclass of TRANSLATABLE-FOREIGN-TYPE.
 469 ;;; Returns the converted Lisp value.
 470 (defgeneric translate-from-foreign (value type)
 471   (:argument-precedence-order type value)
 472   (:method (value type)
 473     (declare (ignore type))
 474     value))
 475
 476 ;;; Free an object allocated by TRANSLATE-TO-FOREIGN.  VALUE is a
 477 ;;; foreign object of the type represented by TYPE, which will be a
 478 ;;; TRANSLATABLE-FOREIGN-TYPE subclass.  PARAM, if present, contains
 479 ;;; the second value returned by TRANSLATE-TO-FOREIGN, and is used to
 480 ;;; communicate between the two functions.
 481 ;;;
 482 ;;; FIXME: I don't think this PARAM argument is necessary anymore
 483 ;;; because the TYPE object can contain that information. [2008-12-31 LO]
 484 (defgeneric free-translated-object (value type param)
 485   (:method (value type param)
 486     (declare (ignore value type param))))
 487
 488 ;;;## Macroexpansion Time Translation
 489 ;;;
 490 ;;; The following EXPAND-* generic functions are similar to their
 491 ;;; TRANSLATE-* counterparts but are usually called at macroexpansion
 492 ;;; time. They offer a way to optimize the runtime translators.
 493
 494 ;;; This special variable is bound by the various :around methods
 495 ;;; below to the respective form generated by the above %EXPAND-*
 496 ;;; functions.  This way, an expander can "bail out" by calling the
 497 ;;; next method.  All 6 of the below-defined GFs have a default method
 498 ;;; that simply answers the rtf bound by the default :around method.
 499 (defvar *runtime-translator-form*)
 500
 501 ;;; EXPAND-FROM-FOREIGN
 502
 503 (defgeneric expand-from-foreign (value type)
 504   (:method (value type)
 505     (declare (ignore type))
 506     value))
 507
 508 (defmethod expand-from-foreign :around (value (type translatable-foreign-type))
 509   (let ((*runtime-translator-form* `(translate-from-foreign ,value ,type)))
 510     (call-next-method)))
 511
 512 (defmethod expand-from-foreign (value (type translatable-foreign-type))
 513   (declare (ignore value))
 514   *runtime-translator-form*)
 515
 516 ;;; EXPAND-TO-FOREIGN
 517
 518 ;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that
 519 ;; an unspecialized method was called.
 520 (defgeneric expand-to-foreign (value type)
 521   (:method (value type)
 522     (declare (ignore type))
 523     (values value t)))
 524
 525 (defmethod expand-to-foreign :around (value (type translatable-foreign-type))
 526   (let ((*runtime-translator-form* `(translate-to-foreign ,value ,type)))
 527     (call-next-method)))
 528
 529 (defmethod expand-to-foreign (value (type translatable-foreign-type))
 530   (declare (ignore value))
 531   (values *runtime-translator-form* t))
 532
 533 ;;; EXPAND-INTO-FOREIGN-MEMORY
 534
 535 (defgeneric expand-into-foreign-memory (value type ptr)
 536   (:method (value type ptr)
 537     (declare (ignore type ptr))
 538     value))
 539
 540 (defmethod expand-into-foreign-memory :around
 541     (value (type translatable-foreign-type) ptr)
 542   (let ((*runtime-translator-form*
 543          `(translate-into-foreign-memory ,value ,type ,ptr)))
 544     (call-next-method)))
 545
 546 (defmethod expand-into-foreign-memory (value (type translatable-foreign-type) ptr)
 547   (declare (ignore value ptr))
 548   *runtime-translator-form*)
 549
 550 ;;; EXPAND-TO-FOREIGN-DYN
 551
 552 (defgeneric expand-to-foreign-dyn (value var body type)
 553   (:method (value var body type)
 554     (declare (ignore type))
 555     `(let ((,var ,value)) ,@body)))
 556
 557 (defmethod expand-to-foreign-dyn :around
 558     (value var body (type enhanced-foreign-type))
 559   (let ((*runtime-translator-form*
 560          (with-unique-names (param)
 561            `(multiple-value-bind (,var ,param)
 562                 (translate-to-foreign ,value ,type)
 563               (unwind-protect
 564                    (progn ,@body)
 565                 (free-translated-object ,var ,type ,param))))))
 566     (call-next-method)))
 567
 568 ;;; If this method is called it means the user hasn't defined a
 569 ;;; to-foreign-dyn expansion, so we use the to-foreign expansion.
 570 ;;;
 571 ;;; However, we do so *only* if there's a specialized
 572 ;;; EXPAND-TO-FOREIGN for TYPE because otherwise we want to use the
 573 ;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to
 574 ;;; FREE-TRANSLATED-OBJECT.  (Or else there would occur no translation
 575 ;;; at all.)
 576 (defun foreign-expand-runtime-translator-or-binding (value var body type)
 577   (multiple-value-bind (expansion default-etp-p)
 578       (expand-to-foreign value type)
 579     (if default-etp-p
 580         *runtime-translator-form*
 581         `(let ((,var ,expansion))
 582            ,@body))))
 583
 584 (defmethod expand-to-foreign-dyn (value var body (type enhanced-foreign-type))
 585   (foreign-expand-runtime-translator-or-binding value var body type))
 586
 587 ;;; EXPAND-TO-FOREIGN-DYN-INDIRECT
 588 ;;; Like expand-to-foreign-dyn, but always give form that returns a
 589 ;;; pointer to the object, even if it's directly representable in
 590 ;;; CL, e.g. numbers.
 591
 592 (defgeneric expand-to-foreign-dyn-indirect (value var body type)
 593   (:method (value var body type)
 594     (declare (ignore type))
 595     `(let ((,var ,value)) ,@body)))
 596
 597 (defmethod expand-to-foreign-dyn-indirect :around
 598     (value var body (type translatable-foreign-type))
 599   (let ((*runtime-translator-form*
 600           `(with-foreign-object (,var ',(unparse-type type))
 601              (translate-into-foreign-memory ,value ,type ,var)
 602              ,@body)))
 603     (call-next-method)))
 604
 605 (defmethod expand-to-foreign-dyn-indirect
 606     (value var body (type foreign-pointer-type))
 607   `(with-foreign-object (,var :pointer)
 608      (translate-into-foreign-memory ,value ,type ,var)
 609      ,@body))
 610
 611 (defmethod expand-to-foreign-dyn-indirect
 612     (value var body (type foreign-built-in-type))
 613   `(with-foreign-object (,var ,type)
 614      (translate-into-foreign-memory ,value ,type ,var)
 615      ,@body))
 616
 617 (defmethod expand-to-foreign-dyn-indirect
 618     (value var body (type translatable-foreign-type))
 619   (foreign-expand-runtime-translator-or-binding value var body type))
 620
 621 (defmethod expand-to-foreign-dyn-indirect (value var body (type foreign-type-alias))
 622   (expand-to-foreign-dyn-indirect value var body (actual-type type)))
 623
 624 ;;; User interface for converting values from/to foreign using the
 625 ;;; type translators.  The compiler macros use the expanders when
 626 ;;; possible.
 627
 628 (defun convert-to-foreign (value type)
 629   (translate-to-foreign value (parse-type type)))
 630
 631 (define-compiler-macro convert-to-foreign (value type)
 632   (if (constantp type)
 633       (expand-to-foreign value (parse-type (eval type)))
 634       `(translate-to-foreign ,value (parse-type ,type))))
 635
 636 (defun convert-from-foreign (value type)
 637   (translate-from-foreign value (parse-type type)))
 638
 639 (define-compiler-macro convert-from-foreign (value type)
 640   (if (constantp type)
 641       (expand-from-foreign value (parse-type (eval type)))
 642       `(translate-from-foreign ,value (parse-type ,type))))
 643
 644 (defun convert-into-foreign-memory (value type ptr)
 645   (translate-into-foreign-memory value (parse-type type) ptr))
 646
 647 (define-compiler-macro convert-into-foreign-memory (value type ptr)
 648   (if (constantp type)
 649       (expand-into-foreign-memory value (parse-type (eval type)) ptr)
 650       `(translate-into-foreign-memory ,value (parse-type ,type) ,ptr)))
 651
 652 (defun free-converted-object (value type param)
 653   (free-translated-object value (parse-type type) param))
 654
 655 ;;;# Enhanced typedefs
 656
 657 (defclass enhanced-typedef (foreign-typedef)
 658   ())
 659
 660 (defmethod translate-to-foreign (value (type enhanced-typedef))
 661   (translate-to-foreign value (actual-type type)))
 662
 663 (defmethod translate-into-foreign-memory (value (type enhanced-typedef) pointer)
 664   (translate-into-foreign-memory value (actual-type type) pointer))
 665
 666 (defmethod translate-from-foreign (value (type enhanced-typedef))
 667   (translate-from-foreign value (actual-type type)))
 668
 669 (defmethod free-translated-object (value (type enhanced-typedef) param)
 670   (free-translated-object value (actual-type type) param))
 671
 672 (defmethod expand-from-foreign (value (type enhanced-typedef))
 673   (expand-from-foreign value (actual-type type)))
 674
 675 (defmethod expand-to-foreign (value (type enhanced-typedef))
 676   (expand-to-foreign value (actual-type type)))
 677
 678 (defmethod expand-to-foreign-dyn (value var body (type enhanced-typedef))
 679   (expand-to-foreign-dyn value var body (actual-type type)))
 680
 681 (defmethod expand-into-foreign-memory (value (type enhanced-typedef) ptr)
 682   (expand-into-foreign-memory value (actual-type type) ptr))
 683
 684 ;;;# User-defined Types and Translations.
 685
 686 (defmacro define-foreign-type (name supers slots &rest options)
 687   (multiple-value-bind (new-options simple-parser actual-type initargs)
 688       (let ((keywords '(:simple-parser :actual-type :default-initargs)))
 689         (apply #'values
 690                (remove-if (lambda (opt) (member (car opt) keywords)) options)
 691                (mapcar (lambda (kw) (cdr (assoc kw options))) keywords)))
 692     `(eval-when (:compile-toplevel :load-toplevel :execute)
 693        (defclass ,name ,(or supers '(enhanced-foreign-type))
 694          ,slots
 695          (:default-initargs ,@(when actual-type `(:actual-type ',actual-type))
 696              ,@initargs)
 697          ,@new-options)
 698        ,(when simple-parser
 699           `(define-parse-method ,(car simple-parser) (&rest args)
 700              (apply #'make-instance ',name args)))
 701        ',name)))
 702
 703 (defmacro defctype (name base-type &optional documentation)
 704   "Utility macro for simple C-like typedefs."
 705   (declare (ignore documentation))
 706   (warn-if-kw-or-belongs-to-cl name)
 707   (let* ((btype (parse-type base-type))
 708          (dtype (if (typep btype 'enhanced-foreign-type)
 709                     'enhanced-typedef
 710                     'foreign-typedef)))
 711     `(eval-when (:compile-toplevel :load-toplevel :execute)
 712        (notice-foreign-type
 713         ',name (make-instance ',dtype :name ',name :actual-type ,btype)))))
 714
 715 ;;; For Verrazano.  We memoize the type this way to help detect cycles.
 716 (defmacro defctype* (name base-type)
 717   "Like DEFCTYPE but defers instantiation until parse-time."
 718   `(eval-when (:compile-toplevel :load-toplevel :execute)
 719      (let (memoized-type)
 720        (define-parse-method ,name ()
 721          (unless memoized-type
 722            (setf memoized-type (make-instance 'foreign-typedef :name ',name
 723                                               :actual-type nil)
 724                  (actual-type memoized-type) (parse-type ',base-type)))
 725          memoized-type))))