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