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