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