Coverage report: /home/luis/src/cffi/src/early-types.lisp

KindCoveredAll%
expression198233 85.0
branch914 64.3
Key
Not instrumented
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
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)
54
   "Hash table of defined type parsers.")
55
 
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)))
60
 
61
 (defun (setf find-type-parser) (func symbol)
62
   "Set the type parser for SYMBOL."
63
   (setf (gethash symbol *type-parsers*) func))
64
 
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))
74
      ',name))
75
 
76
 ;;; Utility function for the simple case where the type takes no
77
 ;;; arguments.
78
 (defun notice-foreign-type (name type)
79
   (setf (find-type-parser name) (lambda () type))
80
   name)
81
 
82
 ;;;# Generic Functions on Types
83
 
84
 (defgeneric canonicalize (foreign-type)
85
   (:documentation
86
    "Return the built-in foreign type for FOREIGN-TYPE.
87
 Signals an error if FOREIGN-TYPE is undefined."))
88
 
89
 (defgeneric aggregatep (foreign-type)
90
   (:documentation
91
    "Return true if FOREIGN-TYPE is an aggregate type."))
92
 
93
 (defgeneric foreign-type-alignment (foreign-type)
94
   (:documentation
95
    "Return the structure alignment in bytes of a foreign type."))
96
 
97
 (defgeneric foreign-type-size (foreign-type)
98
   (:documentation
99
    "Return the size in bytes of a foreign type."))
100
 
101
 (defgeneric unparse-type (foreign-type)
102
   (:documentation
103
    "Unparse FOREIGN-TYPE to a type specification (symbol or list)."))
104
 
105
 ;;;# Foreign Types
106
 
107
 (defclass foreign-type ()
108
   ()
109
   (:documentation "Base class for all foreign types."))
110
 
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)))
115
 
116
 (defmethod foreign-type-size (type)
117
   "Return the size in bytes of a foreign type."
118
   (foreign-type-size (parse-type type)))
119
 
120
 (defclass named-foreign-type (foreign-type)
121
   ((name
122
     ;; Name of this foreign type, a symbol.
123
     :initform (error "Must specify a NAME.")
124
     :initarg :name
125
     :accessor name)))
126
 
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))))
131
 
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))
136
   (name type))
137
 
138
 ;;;# Built-In Foreign Types
139
 
140
 (defclass foreign-built-in-type (foreign-type)
141
   ((type-keyword
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."))
147
 
148
 (defmethod canonicalize ((type foreign-built-in-type))
149
   "Return the built-in type keyword for TYPE."
150
   (type-keyword type))
151
 
152
 (defmethod aggregatep ((type foreign-built-in-type))
153
   "Returns false, built-in types are never aggregate types."
154
   nil)
155
 
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)))
159
 
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)))
163
 
164
 (defmethod unparse-type ((type foreign-built-in-type))
165
   "Returns the symbolic representation of a built-in type."
166
   (type-keyword type))
167
 
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))))
172
 
173
 (defmacro define-built-in-foreign-type (keyword)
174
   "Defines a built-in foreign-type."
175
   `(eval-when (:compile-toplevel :load-toplevel :execute)
176
      (notice-foreign-type
177
       ,keyword (make-instance 'foreign-built-in-type :type-keyword ,keyword))))
178
 
179
 ;;;# Foreign Pointer Types
180
 
181
 (defclass foreign-pointer-type (foreign-built-in-type)
182
   ((pointer-type
183
     ;; Type of object pointed at by this pointer, or nil for an
184
     ;; untyped (void) pointer.
185
     :initform nil
186
     :initarg :pointer-type
187
     :accessor pointer-type))
188
   (:default-initargs :type-keyword :pointer))
189
 
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)
194
     (if type
195
         (make-instance 'foreign-pointer-type :pointer-type (parse-type type))
196
         ;; A bit of premature optimization here.
197
         void-pointer)))
198
 
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)))
203
       :pointer))
204
 
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))))
209
 
210
 ;;;# Structure Type
211
 
212
 (defclass foreign-struct-type (named-foreign-type)
213
   ((slots
214
     ;; Hash table of slots in this structure, keyed by name.
215
     :initform (make-hash-table)
216
     :initarg :slots
217
     :accessor slots)
218
    (size
219
     ;; Cached size in bytes of this structure.
220
     :initarg :size
221
     :accessor size)
222
    (alignment
223
     ;; This struct's alignment requirements
224
     :initarg :alignment
225
     :accessor alignment))
226
   (:documentation "Hash table of plists containing slot information."))
227
 
228
 (defmethod canonicalize ((type foreign-struct-type))
229
   "Returns :POINTER, since structures can not be passed by value."
230
   :pointer)
231
 
232
 (defmethod aggregatep ((type foreign-struct-type))
233
   "Returns true, structure types are aggregate."
234
   t)
235
 
236
 (defmethod foreign-type-size ((type foreign-struct-type))
237
   "Return the size in bytes of a foreign structure type."
238
   (size type))
239
 
240
 (defmethod foreign-type-alignment ((type foreign-struct-type))
241
   "Return the alignment requirements for this struct."
242
   (alignment type))
243
 
244
 ;;;# Foreign Typedefs
245
 
246
 (defclass foreign-type-alias (foreign-type)
247
   ((actual-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."))
253
 
254
 (defmethod canonicalize ((type foreign-type-alias))
255
   "Return the built-in type keyword for TYPE."
256
   (canonicalize (actual-type type)))
257
 
258
 (defmethod aggregatep ((type foreign-type-alias))
259
   "Return true if TYPE's actual type is aggregate."
260
   (aggregatep (actual-type type)))
261
 
262
 (defmethod foreign-type-alignment ((type foreign-type-alias))
263
   "Return the alignment of a foreign typedef."
264
   (foreign-type-alignment (actual-type type)))
265
 
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)))
269
 
270
 (defclass foreign-typedef (foreign-type-alias named-foreign-type)
271
   ())
272
 
273
 (defun follow-typedefs (type)
274
   (if (eq (type-of type) 'foreign-typedef)
275
       (follow-typedefs (actual-type type))
276
       type))
277
 
278
 ;;;# Type Translators
279
 ;;;
280
 ;;; Type translation is done with generic functions at runtime for
281
 ;;; subclasses of ENHANCED-FOREIGN-TYPE/
282
 ;;;
283
 ;;; The main interface for defining type translations is through the
284
 ;;; generic functions TRANSLATE-{TO,FROM}-FOREIGN and
285
 ;;; FREE-TRANSLATED-OBJECT.
286
 
287
 (defclass enhanced-foreign-type (foreign-type-alias)
288
   ((unparsed-type :accessor unparsed-type)))
289
 
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)))))
296
 
297
 (defmethod unparse-type ((type enhanced-foreign-type))
298
   (unparsed-type type))
299
 
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))
307
     ptype))
308
 
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)))
313
 
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))
321
     value))
322
 
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))
329
     value))
330
 
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))))
339
 
340
 ;;;## Macroexpansion Time Translation
341
 ;;;
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.
345
 
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*)
352
 
353
 ;;; EXPAND-FROM-FOREIGN
354
 
355
 (defgeneric expand-from-foreign (value type)
356
   (:method (value type)
357
     (declare (ignore type))
358
     value))
359
 
360
 (defmethod expand-from-foreign :around (value (type enhanced-foreign-type))
361
   (let ((*runtime-translator-form* `(translate-from-foreign ,value ,type)))
362
     (call-next-method)))
363
 
364
 (defmethod expand-from-foreign (value (type enhanced-foreign-type))
365
   (declare (ignore value))
366
   *runtime-translator-form*)
367
 
368
 ;;; EXPAND-TO-FOREIGN
369
 
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))
375
     (values value t)))
376
 
377
 (defmethod expand-to-foreign :around (value (type enhanced-foreign-type))
378
   (let ((*runtime-translator-form*
379
          `(values (translate-to-foreign ,value ,type))))
380
     (call-next-method)))
381
 
382
 (defmethod expand-to-foreign (value (type enhanced-foreign-type))
383
   (declare (ignore value))
384
   (values *runtime-translator-form* t))
385
 
386
 ;;; EXPAND-TO-FOREIGN-DYN
387
 
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)))
392
 
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)
399
               (unwind-protect
400
                    (progn ,@body)
401
                 (free-translated-object ,var ,type ,param))))))
402
     (call-next-method)))
403
 
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.
406
 ;;;
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
411
 ;;; at all.)
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)
415
     (if default-etp-p
416
         *runtime-translator-form*
417
         `(let ((,var ,expansion))
418
            ,@body))))
419
 
420
 #- (and)
421
   (if (specializedp #'expand-to-foreign value type)
422
       `(let ((,var ,(expand-to-foreign value type)))
423
          ,@body)
424
       *runtime-translator-form*)
425
 
426
 ;;; User interface for converting values from/to foreign using the
427
 ;;; type translators.  The compiler macros use the expanders when
428
 ;;; possible.
429
 
430
 (defun convert-to-foreign (value type)
431
   (translate-to-foreign value (parse-type type)))
432
 
433
 (define-compiler-macro convert-to-foreign (value type)
434
   (if (constantp type)
435
       (expand-to-foreign value (parse-type (eval type)))
436
       `(translate-to-foreign ,value (parse-type ,type))))
437
 
438
 (defun convert-from-foreign (value type)
439
   (translate-from-foreign value (parse-type type)))
440
 
441
 (define-compiler-macro convert-from-foreign (value type)
442
   (if (constantp type)
443
       (expand-from-foreign value (parse-type (eval type)))
444
       `(translate-from-foreign ,value (parse-type ,type))))
445
 
446
 (defun free-converted-object (value type param)
447
   (free-translated-object value (parse-type type) param))
448
 
449
 ;;;# Enhanced typedefs
450
 
451
 (defclass enhanced-typedef (foreign-typedef)
452
   ())
453
 
454
 (defmethod translate-to-foreign (value (type enhanced-typedef))
455
   (translate-to-foreign value (actual-type type)))
456
 
457
 (defmethod translate-from-foreign (value (type enhanced-typedef))
458
   (translate-from-foreign value (actual-type type)))
459
 
460
 (defmethod free-translated-object (value (type enhanced-typedef) param)
461
   (free-translated-object value (actual-type type) param))
462
 
463
 (defmethod expand-from-foreign (value (type enhanced-typedef))
464
   (expand-from-foreign value (actual-type type)))
465
 
466
 (defmethod expand-to-foreign (value (type enhanced-typedef))
467
   (expand-to-foreign value (actual-type type)))
468
 
469
 (defmethod expand-to-foreign-dyn (value var body (type enhanced-typedef))
470
   (expand-to-foreign-dyn value var body (actual-type type)))
471
 
472
 ;;;# User-defined Types and Translations.
473
 
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)))
477
         (apply #'values
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))
482
          ,slots
483
          (:default-initargs ,@(when actual-type `(:actual-type ',actual-type))
484
              ,@initargs)
485
          ,@new-options)
486
        ,(when simple-parser
487
           `(notice-foreign-type ',(car simple-parser) (make-instance ',name)))
488
        ',name)))
489
 
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)
496
                     'enhanced-typedef
497
                     'foreign-typedef)))
498
     `(eval-when (:compile-toplevel :load-toplevel :execute)
499
        (notice-foreign-type
500
         ',name (make-instance ',dtype :name ',name :actual-type ,btype)))))