Coverage report: /home/luis/src/cffi/src/early-types.lisp
Kind | Covered | All | % |
expression | 198 | 233 | 85.0 |
branch | 9 | 14 | 64.3 |
Key
Not instrumented
Executed
Not executed
Both branches taken
One branch taken
Neither branch taken
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
;;; Only now we define PARSE-TYPE because it needs to do some extra
301
;;; work for ENHANCED-FOREIGN-TYPES.
302
(defun parse-type (type)
303
(let* ((spec (ensure-list type))
304
(ptype (apply (find-type-parser (car spec)) (cdr spec))))
305
(when (typep ptype 'enhanced-foreign-type)
306
(setf (unparsed-type ptype) type))
309
(defun canonicalize-foreign-type (type)
310
"Convert TYPE to a built-in type by following aliases.
311
Signals an error if the type cannot be resolved."
312
(canonicalize (parse-type type)))
314
;;; Translate VALUE to a foreign object of the type represented by
315
;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE. Returns
316
;;; the foreign value and an optional second value which will be
317
;;; passed to FREE-TRANSLATED-OBJECT as the PARAM argument.
318
(defgeneric translate-to-foreign (value type)
319
(:method (value type)
320
(declare (ignore type))
323
;;; Translate the foreign object VALUE from the type repsented by
324
;;; TYPE, which will be a subclass of ENHANCED-FOREIGN-TYPE. Returns
325
;;; the converted Lisp value.
326
(defgeneric translate-from-foreign (value type)
327
(:method (value type)
328
(declare (ignore type))
331
;;; Free an object allocated by TRANSLATE-TO-FOREIGN. VALUE is a
332
;;; foreign object of the type represented by TYPE, which will be a
333
;;; ENHANCED-FOREIGN-TYPE subclass. PARAM, if present, contains the
334
;;; second value returned by TRANSLATE-TO-FOREIGN, and is used to
335
;;; communicate between the two functions.
336
(defgeneric free-translated-object (value type param)
337
(:method (value type param)
338
(declare (ignore value type param))))
340
;;;## Macroexpansion Time Translation
342
;;; The following EXPAND-* generic functions are similar to their
343
;;; TRANSLATE-* counterparts but are usually called at macroexpansion
344
;;; time. They offer a way to optimize the runtime translators.
346
;;; This special variable is bound by the various :around methods
347
;;; below to the respective form generated by the above %EXPAND-*
348
;;; functions. This way, an expander can "bail out" by calling the
349
;;; next method. All 6 of the below-defined GFs have a default method
350
;;; that simply answers the rtf bound by the default :around method.
351
(defvar *runtime-translator-form*)
353
;;; EXPAND-FROM-FOREIGN
355
(defgeneric expand-from-foreign (value type)
356
(:method (value type)
357
(declare (ignore type))
360
(defmethod expand-from-foreign :around (value (type enhanced-foreign-type))
361
(let ((*runtime-translator-form* `(translate-from-foreign ,value ,type)))
364
(defmethod expand-from-foreign (value (type enhanced-foreign-type))
365
(declare (ignore value))
366
*runtime-translator-form*)
368
;;; EXPAND-TO-FOREIGN
370
;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that
371
;; an unspecialized method was called.
372
(defgeneric expand-to-foreign (value type)
373
(:method (value type)
374
(declare (ignore type))
377
(defmethod expand-to-foreign :around (value (type enhanced-foreign-type))
378
(let ((*runtime-translator-form*
379
`(values (translate-to-foreign ,value ,type))))
382
(defmethod expand-to-foreign (value (type enhanced-foreign-type))
383
(declare (ignore value))
384
(values *runtime-translator-form* t))
386
;;; EXPAND-TO-FOREIGN-DYN
388
(defgeneric expand-to-foreign-dyn (value var body type)
389
(:method (value var body type)
390
(declare (ignore type))
391
`(let ((,var ,value)) ,@body)))
393
(defmethod expand-to-foreign-dyn :around
394
(value var body (type enhanced-foreign-type))
395
(let ((*runtime-translator-form*
396
(with-unique-names (param)
397
`(multiple-value-bind (,var ,param)
398
(translate-to-foreign ,value ,type)
401
(free-translated-object ,var ,type ,param))))))
404
;;; If this method is called it means the user hasn't defined a
405
;;; to-foreign-dyn expansion, so we use the to-foreign expansion.
407
;;; However, we do so *only* if there's a specialized
408
;;; EXPAND-TO-FOREIGN for TYPE because otherwise we want to use the
409
;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to
410
;;; FREE-TRANSLATED-OBJECT. (Or else there would occur no translation
412
(defmethod expand-to-foreign-dyn (value var body (type enhanced-foreign-type))
413
(multiple-value-bind (expansion default-etp-p)
414
(expand-to-foreign value type)
416
*runtime-translator-form*
417
`(let ((,var ,expansion))
421
(if (specializedp #'expand-to-foreign value type)
422
`(let ((,var ,(expand-to-foreign value type)))
424
*runtime-translator-form*)
426
;;; User interface for converting values from/to foreign using the
427
;;; type translators. The compiler macros use the expanders when
430
(defun convert-to-foreign (value type)
431
(translate-to-foreign value (parse-type type)))
433
(define-compiler-macro convert-to-foreign (value type)
435
(expand-to-foreign value (parse-type (eval type)))
436
`(translate-to-foreign ,value (parse-type ,type))))
438
(defun convert-from-foreign (value type)
439
(translate-from-foreign value (parse-type type)))
441
(define-compiler-macro convert-from-foreign (value type)
443
(expand-from-foreign value (parse-type (eval type)))
444
`(translate-from-foreign ,value (parse-type ,type))))
446
(defun free-converted-object (value type param)
447
(free-translated-object value (parse-type type) param))
449
;;;# Enhanced typedefs
451
(defclass enhanced-typedef (foreign-typedef)
454
(defmethod translate-to-foreign (value (type enhanced-typedef))
455
(translate-to-foreign value (actual-type type)))
457
(defmethod translate-from-foreign (value (type enhanced-typedef))
458
(translate-from-foreign value (actual-type type)))
460
(defmethod free-translated-object (value (type enhanced-typedef) param)
461
(free-translated-object value (actual-type type) param))
463
(defmethod expand-from-foreign (value (type enhanced-typedef))
464
(expand-from-foreign value (actual-type type)))
466
(defmethod expand-to-foreign (value (type enhanced-typedef))
467
(expand-to-foreign value (actual-type type)))
469
(defmethod expand-to-foreign-dyn (value var body (type enhanced-typedef))
470
(expand-to-foreign-dyn value var body (actual-type type)))
472
;;;# User-defined Types and Translations.
474
(defmacro define-foreign-type (name supers slots &rest options)
475
(multiple-value-bind (new-options simple-parser actual-type initargs)
476
(let ((keywords '(:simple-parser :actual-type :default-initargs)))
478
(remove-if (lambda (opt) (member (car opt) keywords)) options)
479
(mapcar (lambda (kw) (cdr (assoc kw options))) keywords)))
480
`(eval-when (:compile-toplevel :load-toplevel :execute)
481
(defclass ,name ,(or supers '(enhanced-foreign-type))
483
(:default-initargs ,@(when actual-type `(:actual-type ',actual-type))
487
`(notice-foreign-type ',(car simple-parser) (make-instance ',name)))
490
(defmacro defctype (name base-type &optional documentation)
491
"Utility macro for simple C-like typedefs."
492
(declare (ignore documentation))
493
(warn-if-kw-or-belongs-to-cl name)
494
(let* ((btype (parse-type base-type))
495
(dtype (if (typep btype 'enhanced-foreign-type)
498
`(eval-when (:compile-toplevel :load-toplevel :execute)
500
',name (make-instance ',dtype :name ',name :actual-type ,btype)))))