1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; early-types.lisp --- Low-level foreign type operations.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
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:
16 ;;; The above copyright notice and this permission notice shall be
17 ;;; included in all copies or substantial portions of the Software.
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.
29 ;;;# Early Type Definitions
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.
39 ;;; Type specifications are of the form (type {args}*). The type
40 ;;; parser can specify how its arguments should look like through a
43 ;;; "type" is a shortcut for "(type)", ie, no args were specified.
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.
50 ;;; Type parsers, defined with DEFINE-PARSE-METHOD should return a
51 ;;; subtype of the foreign-type class.
53 (defvar *type-parsers
* (make-hash-table)
54 "Hash table of defined type parsers.")
56 (defun find-type-parser (symbol)
57 "Return the type parser for SYMBOL."
58 (or (gethash symbol
*type-parsers
*)
59 (error "Unknown CFFI type: ~S." symbol
)))
61 (defun (setf find-type-parser
) (func symbol
)
62 "Set the type parser for SYMBOL."
63 (setf (gethash symbol
*type-parsers
*) func
))
65 ;;; Using a generic function would have been nicer but generates lots
66 ;;; of style warnings in SBCL. (Silly reason, yes.)
67 (defmacro define-parse-method
(name lambda-list
&body body
)
68 "Define a type parser on NAME and lists whose CAR is NAME."
69 (discard-docstring body
)
70 (warn-if-kw-or-belongs-to-cl name
)
71 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
72 (setf (find-type-parser ',name
)
73 (lambda ,lambda-list
,@body
))
76 ;;; Utility function for the simple case where the type takes no
78 (defun notice-foreign-type (name type
)
79 (setf (find-type-parser name
) (lambda () type
))
82 ;;;# Generic Functions on Types
84 (defgeneric canonicalize
(foreign-type)
86 "Return the built-in foreign type for FOREIGN-TYPE.
87 Signals an error if FOREIGN-TYPE is undefined."))
89 (defgeneric aggregatep
(foreign-type)
91 "Return true if FOREIGN-TYPE is an aggregate type."))
93 (defgeneric foreign-type-alignment
(foreign-type)
95 "Return the structure alignment in bytes of a foreign type."))
97 (defgeneric foreign-type-size
(foreign-type)
99 "Return the size in bytes of a foreign type."))
101 (defgeneric unparse-type
(foreign-type)
103 "Unparse FOREIGN-TYPE to a type specification (symbol or list)."))
107 (defclass foreign-type
()
109 (:documentation
"Base class for all foreign types."))
111 (defmethod make-load-form ((type foreign-type
) &optional env
)
112 "Return the form used to dump types to a FASL file."
113 (declare (ignore env
))
114 `(parse-type ',(unparse-type type
)))
116 (defmethod foreign-type-size (type)
117 "Return the size in bytes of a foreign type."
118 (foreign-type-size (parse-type type
)))
120 (defclass named-foreign-type
(foreign-type)
122 ;; Name of this foreign type, a symbol.
123 :initform
(error "Must specify a NAME.")
127 (defmethod print-object ((type named-foreign-type
) stream
)
128 "Print a FOREIGN-TYPEDEF instance to STREAM unreadably."
129 (print-unreadable-object (type stream
:type t
:identity nil
)
130 (format stream
"~S" (name type
))))
132 ;;; Return the type's name which can be passed to PARSE-TYPE. If
133 ;;; that's not the case for some subclass of NAMED-FOREIGN-TYPE then
134 ;;; it should specialize UNPARSE-TYPE.
135 (defmethod unparse-type ((type named-foreign-type
))
138 ;;;# Built-In Foreign Types
140 (defclass foreign-built-in-type
(foreign-type)
142 ;; Keyword in CFFI-SYS representing this type.
143 :initform
(error "A type keyword is required.")
144 :initarg
:type-keyword
145 :accessor type-keyword
))
146 (:documentation
"A built-in foreign type."))
148 (defmethod canonicalize ((type foreign-built-in-type
))
149 "Return the built-in type keyword for TYPE."
152 (defmethod aggregatep ((type foreign-built-in-type
))
153 "Returns false, built-in types are never aggregate types."
156 (defmethod foreign-type-alignment ((type foreign-built-in-type
))
157 "Return the alignment of a built-in type."
158 (%foreign-type-alignment
(type-keyword type
)))
160 (defmethod foreign-type-size ((type foreign-built-in-type
))
161 "Return the size of a built-in type."
162 (%foreign-type-size
(type-keyword type
)))
164 (defmethod unparse-type ((type foreign-built-in-type
))
165 "Returns the symbolic representation of a built-in type."
168 (defmethod print-object ((type foreign-built-in-type
) stream
)
169 "Print a FOREIGN-TYPE instance to STREAM unreadably."
170 (print-unreadable-object (type stream
:type t
:identity nil
)
171 (format stream
"~S" (type-keyword type
))))
173 (defmacro define-built-in-foreign-type
(keyword)
174 "Defines a built-in foreign-type."
175 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
177 ,keyword
(make-instance 'foreign-built-in-type
:type-keyword
,keyword
))))
179 ;;;# Foreign Pointer Types
181 (defclass foreign-pointer-type
(foreign-built-in-type)
183 ;; Type of object pointed at by this pointer, or nil for an
184 ;; untyped (void) pointer.
186 :initarg
:pointer-type
187 :accessor pointer-type
))
188 (:default-initargs
:type-keyword
:pointer
))
190 ;;; Define the type parser for the :POINTER type. If no type argument
191 ;;; is provided, a void pointer will be created.
192 (let ((void-pointer (make-instance 'foreign-pointer-type
)))
193 (define-parse-method :pointer
(&optional type
)
195 (make-instance 'foreign-pointer-type
:pointer-type
(parse-type type
))
196 ;; A bit of premature optimization here.
199 ;;; Unparse a foreign pointer type when dumping to a fasl.
200 (defmethod unparse-type ((type foreign-pointer-type
))
201 (if (pointer-type type
)
202 `(:pointer
,(unparse-type (pointer-type type
)))
205 ;;; Print a foreign pointer type unreadably in unparsed form.
206 (defmethod print-object ((type foreign-pointer-type
) stream
)
207 (print-unreadable-object (type stream
:type t
:identity nil
)
208 (format stream
"~S" (unparse-type type
))))
212 (defclass foreign-struct-type
(named-foreign-type)
214 ;; Hash table of slots in this structure, keyed by name.
215 :initform
(make-hash-table)
219 ;; Cached size in bytes of this structure.
223 ;; This struct's alignment requirements
225 :accessor alignment
))
226 (:documentation
"Hash table of plists containing slot information."))
228 (defmethod canonicalize ((type foreign-struct-type
))
229 "Returns :POINTER, since structures can not be passed by value."
232 (defmethod aggregatep ((type foreign-struct-type
))
233 "Returns true, structure types are aggregate."
236 (defmethod foreign-type-size ((type foreign-struct-type
))
237 "Return the size in bytes of a foreign structure type."
240 (defmethod foreign-type-alignment ((type foreign-struct-type
))
241 "Return the alignment requirements for this struct."
244 ;;;# Foreign Typedefs
246 (defclass foreign-type-alias
(foreign-type)
248 ;; The FOREIGN-TYPE instance this type is an alias for.
249 :initarg
:actual-type
250 :accessor actual-type
251 :initform
(error "Must specify an ACTUAL-TYPE.")))
252 (:documentation
"A type that aliases another type."))
254 (defmethod canonicalize ((type foreign-type-alias
))
255 "Return the built-in type keyword for TYPE."
256 (canonicalize (actual-type type
)))
258 (defmethod aggregatep ((type foreign-type-alias
))
259 "Return true if TYPE's actual type is aggregate."
260 (aggregatep (actual-type type
)))
262 (defmethod foreign-type-alignment ((type foreign-type-alias
))
263 "Return the alignment of a foreign typedef."
264 (foreign-type-alignment (actual-type type
)))
266 (defmethod foreign-type-size ((type foreign-type-alias
))
267 "Return the size in bytes of a foreign typedef."
268 (foreign-type-size (actual-type type
)))
270 (defclass foreign-typedef
(foreign-type-alias named-foreign-type
)
273 (defun follow-typedefs (type)
274 (if (eq (type-of type
) 'foreign-typedef
)
275 (follow-typedefs (actual-type type
))
278 ;;;# Type Translators
280 ;;; Type translation is done with generic functions at runtime for
281 ;;; subclasses of ENHANCED-FOREIGN-TYPE/
283 ;;; The main interface for defining type translations is through the
284 ;;; generic functions TRANSLATE-{TO,FROM}-FOREIGN and
285 ;;; FREE-TRANSLATED-OBJECT.
287 (defclass enhanced-foreign-type
(foreign-type-alias)
288 ((unparsed-type :accessor unparsed-type
)))
290 ;;; If actual-type isn't parsed already, let's parse it. This way we
291 ;;; don't have to export PARSE-TYPE and users don't have to worry
292 ;;; about this in DEFINE-FOREIGN-TYPE or DEFINE-PARSE-METHOD.
293 (defmethod initialize-instance :after
((type enhanced-foreign-type
) &key
)
294 (unless (typep (actual-type type
) 'foreign-type
)
295 (setf (actual-type type
) (parse-type (actual-type type
)))))
297 (defmethod unparse-type ((type enhanced-foreign-type
))
298 (unparsed-type type
))
300 ;;; Checks NAMEs, not object identity.
301 (defun check-for-typedef-cycles (type)
302 (let ((seen (make-hash-table :test
'eq
)))
303 (labels ((%check
(cur-type)
304 (when (typep cur-type
'foreign-typedef
)
305 (when (gethash (name cur-type
) seen
)
306 (error "Detected cycle in type ~S." type
))
307 (setf (gethash (name cur-type
) seen
) t
)
308 (%check
(actual-type cur-type
)))))
311 ;;; Only now we define PARSE-TYPE because it needs to do some extra
312 ;;; work for ENHANCED-FOREIGN-TYPES.
313 (defun parse-type (type)
314 (let* ((spec (ensure-list type
))
315 (ptype (apply (find-type-parser (car spec
)) (cdr spec
))))
316 (when (typep ptype
'foreign-typedef
)
317 (check-for-typedef-cycles ptype
))
318 (when (typep ptype
'enhanced-foreign-type
)
319 (setf (unparsed-type ptype
) type
))
322 (defun canonicalize-foreign-type (type)
323 "Convert TYPE to a built-in type by following aliases.
324 Signals an error if the type cannot be resolved."
325 (canonicalize (parse-type type
)))
327 ;;; Translate VALUE to a foreign object of the type represented by
328 ;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE. Returns
329 ;;; the foreign value and an optional second value which will be
330 ;;; passed to FREE-TRANSLATED-OBJECT as the PARAM argument.
331 (defgeneric translate-to-foreign
(value type
)
332 (:method
(value type
)
333 (declare (ignore type
))
336 ;;; Translate the foreign object VALUE from the type repsented by
337 ;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE. Returns
338 ;;; the converted Lisp value.
339 (defgeneric translate-from-foreign
(value type
)
340 (:method
(value type
)
341 (declare (ignore type
))
344 ;;; Free an object allocated by TRANSLATE-TO-FOREIGN. VALUE is a
345 ;;; foreign object of the type represented by TYPE, which will be a
346 ;;; ENHANCED-FOREIGN-TYPE subclass. PARAM, if present, contains the
347 ;;; second value returned by TRANSLATE-TO-FOREIGN, and is used to
348 ;;; communicate between the two functions.
349 (defgeneric free-translated-object
(value type param
)
350 (:method
(value type param
)
351 (declare (ignore value type param
))))
353 ;;;## Macroexpansion Time Translation
355 ;;; The following EXPAND-* generic functions are similar to their
356 ;;; TRANSLATE-* counterparts but are usually called at macroexpansion
357 ;;; time. They offer a way to optimize the runtime translators.
359 ;;; This special variable is bound by the various :around methods
360 ;;; below to the respective form generated by the above %EXPAND-*
361 ;;; functions. This way, an expander can "bail out" by calling the
362 ;;; next method. All 6 of the below-defined GFs have a default method
363 ;;; that simply answers the rtf bound by the default :around method.
364 (defvar *runtime-translator-form
*)
366 ;;; EXPAND-FROM-FOREIGN
368 (defgeneric expand-from-foreign
(value type
)
369 (:method
(value type
)
370 (declare (ignore type
))
373 (defmethod expand-from-foreign :around
(value (type enhanced-foreign-type
))
374 (let ((*runtime-translator-form
* `(translate-from-foreign ,value
,type
)))
377 (defmethod expand-from-foreign (value (type enhanced-foreign-type
))
378 (declare (ignore value
))
379 *runtime-translator-form
*)
381 ;;; EXPAND-TO-FOREIGN
383 ;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that
384 ;; an unspecialized method was called.
385 (defgeneric expand-to-foreign
(value type
)
386 (:method
(value type
)
387 (declare (ignore type
))
390 (defmethod expand-to-foreign :around
(value (type enhanced-foreign-type
))
391 (let ((*runtime-translator-form
*
392 `(values (translate-to-foreign ,value
,type
))))
395 (defmethod expand-to-foreign (value (type enhanced-foreign-type
))
396 (declare (ignore value
))
397 (values *runtime-translator-form
* t
))
399 ;;; EXPAND-TO-FOREIGN-DYN
401 (defgeneric expand-to-foreign-dyn
(value var body type
)
402 (:method
(value var body type
)
403 (declare (ignore type
))
404 `(let ((,var
,value
)) ,@body
)))
406 (defmethod expand-to-foreign-dyn :around
407 (value var body
(type enhanced-foreign-type
))
408 (let ((*runtime-translator-form
*
409 (with-unique-names (param)
410 `(multiple-value-bind (,var
,param
)
411 (translate-to-foreign ,value
,type
)
414 (free-translated-object ,var
,type
,param
))))))
417 ;;; If this method is called it means the user hasn't defined a
418 ;;; to-foreign-dyn expansion, so we use the to-foreign expansion.
420 ;;; However, we do so *only* if there's a specialized
421 ;;; EXPAND-TO-FOREIGN for TYPE because otherwise we want to use the
422 ;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to
423 ;;; FREE-TRANSLATED-OBJECT. (Or else there would occur no translation
425 (defmethod expand-to-foreign-dyn (value var body
(type enhanced-foreign-type
))
426 (multiple-value-bind (expansion default-etp-p
)
427 (expand-to-foreign value type
)
429 *runtime-translator-form
*
430 `(let ((,var
,expansion
))
433 ;;; User interface for converting values from/to foreign using the
434 ;;; type translators. The compiler macros use the expanders when
437 (defun convert-to-foreign (value type
)
438 (translate-to-foreign value
(parse-type type
)))
440 (define-compiler-macro convert-to-foreign
(value type
)
442 (expand-to-foreign value
(parse-type (eval type
)))
443 `(translate-to-foreign ,value
(parse-type ,type
))))
445 (defun convert-from-foreign (value type
)
446 (translate-from-foreign value
(parse-type type
)))
448 (define-compiler-macro convert-from-foreign
(value type
)
450 (expand-from-foreign value
(parse-type (eval type
)))
451 `(translate-from-foreign ,value
(parse-type ,type
))))
453 (defun free-converted-object (value type param
)
454 (free-translated-object value
(parse-type type
) param
))
456 ;;;# Enhanced typedefs
458 (defclass enhanced-typedef
(foreign-typedef)
461 (defmethod translate-to-foreign (value (type enhanced-typedef
))
462 (translate-to-foreign value
(actual-type type
)))
464 (defmethod translate-from-foreign (value (type enhanced-typedef
))
465 (translate-from-foreign value
(actual-type type
)))
467 (defmethod free-translated-object (value (type enhanced-typedef
) param
)
468 (free-translated-object value
(actual-type type
) param
))
470 (defmethod expand-from-foreign (value (type enhanced-typedef
))
471 (expand-from-foreign value
(actual-type type
)))
473 (defmethod expand-to-foreign (value (type enhanced-typedef
))
474 (expand-to-foreign value
(actual-type type
)))
476 (defmethod expand-to-foreign-dyn (value var body
(type enhanced-typedef
))
477 (expand-to-foreign-dyn value var body
(actual-type type
)))
479 ;;;# User-defined Types and Translations.
481 (defmacro define-foreign-type
(name supers slots
&rest options
)
482 (multiple-value-bind (new-options simple-parser actual-type initargs
)
483 (let ((keywords '(:simple-parser
:actual-type
:default-initargs
)))
485 (remove-if (lambda (opt) (member (car opt
) keywords
)) options
)
486 (mapcar (lambda (kw) (cdr (assoc kw options
))) keywords
)))
487 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
488 (defclass ,name
,(or supers
'(enhanced-foreign-type))
490 (:default-initargs
,@(when actual-type
`(:actual-type
',actual-type
))
494 `(define-parse-method ,(car simple-parser
) (&rest args
)
495 (apply #'make-instance
',name args
)))
498 (defmacro defctype
(name base-type
&optional documentation
)
499 "Utility macro for simple C-like typedefs."
500 (declare (ignore documentation
))
501 (warn-if-kw-or-belongs-to-cl name
)
502 (let* ((btype (parse-type base-type
))
503 (dtype (if (typep btype
'enhanced-foreign-type
)
506 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
508 ',name
(make-instance ',dtype
:name
',name
:actual-type
,btype
)))))
510 ;;; For Verrazano. We memoize the type this way to help detect cycles.
511 (defmacro defctype
* (name base-type
)
512 "Like DEFCTYPE but defers instantiation until parse-time."
513 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
515 (define-parse-method ,name
()
516 (unless memoized-type
517 (setf memoized-type
(make-instance 'foreign-typedef
:name
',name
519 (actual-type memoized-type
) (parse-type ',base-type
)))