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 (check-for-typedef-cycles ptype
)
317 (when (typep ptype
'enhanced-foreign-type
)
318 (setf (unparsed-type ptype
) type
))
321 (defun canonicalize-foreign-type (type)
322 "Convert TYPE to a built-in type by following aliases.
323 Signals an error if the type cannot be resolved."
324 (canonicalize (parse-type type
)))
326 ;;; Translate VALUE to a foreign object of the type represented by
327 ;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE. Returns
328 ;;; the foreign value and an optional second value which will be
329 ;;; passed to FREE-TRANSLATED-OBJECT as the PARAM argument.
330 (defgeneric translate-to-foreign
(value type
)
331 (:method
(value type
)
332 (declare (ignore type
))
335 ;;; Translate the foreign object VALUE from the type repsented by
336 ;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE. Returns
337 ;;; the converted Lisp value.
338 (defgeneric translate-from-foreign
(value type
)
339 (:method
(value type
)
340 (declare (ignore type
))
343 ;;; Free an object allocated by TRANSLATE-TO-FOREIGN. VALUE is a
344 ;;; foreign object of the type represented by TYPE, which will be a
345 ;;; ENHANCED-FOREIGN-TYPE subclass. PARAM, if present, contains the
346 ;;; second value returned by TRANSLATE-TO-FOREIGN, and is used to
347 ;;; communicate between the two functions.
348 (defgeneric free-translated-object
(value type param
)
349 (:method
(value type param
)
350 (declare (ignore value type param
))))
352 ;;;## Macroexpansion Time Translation
354 ;;; The following EXPAND-* generic functions are similar to their
355 ;;; TRANSLATE-* counterparts but are usually called at macroexpansion
356 ;;; time. They offer a way to optimize the runtime translators.
358 ;;; This special variable is bound by the various :around methods
359 ;;; below to the respective form generated by the above %EXPAND-*
360 ;;; functions. This way, an expander can "bail out" by calling the
361 ;;; next method. All 6 of the below-defined GFs have a default method
362 ;;; that simply answers the rtf bound by the default :around method.
363 (defvar *runtime-translator-form
*)
365 ;;; EXPAND-FROM-FOREIGN
367 (defgeneric expand-from-foreign
(value type
)
368 (:method
(value type
)
369 (declare (ignore type
))
372 (defmethod expand-from-foreign :around
(value (type enhanced-foreign-type
))
373 (let ((*runtime-translator-form
* `(translate-from-foreign ,value
,type
)))
376 (defmethod expand-from-foreign (value (type enhanced-foreign-type
))
377 (declare (ignore value
))
378 *runtime-translator-form
*)
380 ;;; EXPAND-TO-FOREIGN
382 ;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that
383 ;; an unspecialized method was called.
384 (defgeneric expand-to-foreign
(value type
)
385 (:method
(value type
)
386 (declare (ignore type
))
389 (defmethod expand-to-foreign :around
(value (type enhanced-foreign-type
))
390 (let ((*runtime-translator-form
*
391 `(values (translate-to-foreign ,value
,type
))))
394 (defmethod expand-to-foreign (value (type enhanced-foreign-type
))
395 (declare (ignore value
))
396 (values *runtime-translator-form
* t
))
398 ;;; EXPAND-TO-FOREIGN-DYN
400 (defgeneric expand-to-foreign-dyn
(value var body type
)
401 (:method
(value var body type
)
402 (declare (ignore type
))
403 `(let ((,var
,value
)) ,@body
)))
405 (defmethod expand-to-foreign-dyn :around
406 (value var body
(type enhanced-foreign-type
))
407 (let ((*runtime-translator-form
*
408 (with-unique-names (param)
409 `(multiple-value-bind (,var
,param
)
410 (translate-to-foreign ,value
,type
)
413 (free-translated-object ,var
,type
,param
))))))
416 ;;; If this method is called it means the user hasn't defined a
417 ;;; to-foreign-dyn expansion, so we use the to-foreign expansion.
419 ;;; However, we do so *only* if there's a specialized
420 ;;; EXPAND-TO-FOREIGN for TYPE because otherwise we want to use the
421 ;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to
422 ;;; FREE-TRANSLATED-OBJECT. (Or else there would occur no translation
424 (defmethod expand-to-foreign-dyn (value var body
(type enhanced-foreign-type
))
425 (multiple-value-bind (expansion default-etp-p
)
426 (expand-to-foreign value type
)
428 *runtime-translator-form
*
429 `(let ((,var
,expansion
))
432 ;;; User interface for converting values from/to foreign using the
433 ;;; type translators. The compiler macros use the expanders when
436 (defun convert-to-foreign (value type
)
437 (translate-to-foreign value
(parse-type type
)))
439 (define-compiler-macro convert-to-foreign
(value type
)
441 (expand-to-foreign value
(parse-type (eval type
)))
442 `(translate-to-foreign ,value
(parse-type ,type
))))
444 (defun convert-from-foreign (value type
)
445 (translate-from-foreign value
(parse-type type
)))
447 (define-compiler-macro convert-from-foreign
(value type
)
449 (expand-from-foreign value
(parse-type (eval type
)))
450 `(translate-from-foreign ,value
(parse-type ,type
))))
452 (defun free-converted-object (value type param
)
453 (free-translated-object value
(parse-type type
) param
))
455 ;;;# Enhanced typedefs
457 (defclass enhanced-typedef
(foreign-typedef)
460 (defmethod translate-to-foreign (value (type enhanced-typedef
))
461 (translate-to-foreign value
(actual-type type
)))
463 (defmethod translate-from-foreign (value (type enhanced-typedef
))
464 (translate-from-foreign value
(actual-type type
)))
466 (defmethod free-translated-object (value (type enhanced-typedef
) param
)
467 (free-translated-object value
(actual-type type
) param
))
469 (defmethod expand-from-foreign (value (type enhanced-typedef
))
470 (expand-from-foreign value
(actual-type type
)))
472 (defmethod expand-to-foreign (value (type enhanced-typedef
))
473 (expand-to-foreign value
(actual-type type
)))
475 (defmethod expand-to-foreign-dyn (value var body
(type enhanced-typedef
))
476 (expand-to-foreign-dyn value var body
(actual-type type
)))
478 ;;;# User-defined Types and Translations.
480 (defmacro define-foreign-type
(name supers slots
&rest options
)
481 (multiple-value-bind (new-options simple-parser actual-type initargs
)
482 (let ((keywords '(:simple-parser
:actual-type
:default-initargs
)))
484 (remove-if (lambda (opt) (member (car opt
) keywords
)) options
)
485 (mapcar (lambda (kw) (cdr (assoc kw options
))) keywords
)))
486 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
487 (defclass ,name
,(or supers
'(enhanced-foreign-type))
489 (:default-initargs
,@(when actual-type
`(:actual-type
',actual-type
))
493 `(define-parse-method ,(car simple-parser
) (&rest args
)
494 (apply #'make-instance
',name args
)))
497 (defmacro defctype
(name base-type
&optional documentation
)
498 "Utility macro for simple C-like typedefs."
499 (declare (ignore documentation
))
500 (warn-if-kw-or-belongs-to-cl name
)
501 (let* ((btype (parse-type base-type
))
502 (dtype (if (typep btype
'enhanced-foreign-type
)
505 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
507 ',name
(make-instance ',dtype
:name
',name
:actual-type
,btype
)))))
509 ;;; For Verrazano. We memoize the type this way to help detect cycles.
510 (defmacro defctype
* (name base-type
)
511 "Like DEFCTYPE but defers instantiation until parse-time."
512 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
514 (define-parse-method ,name
()
515 (unless memoized-type
516 (setf memoized-type
(make-instance 'foreign-typedef
:name
',name
518 (actual-type memoized-type
) (parse-type ',base-type
)))