early-types.lisp - clic - Clic is an command line interactive client for gopher… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 <[email protected]> | |
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <[email protected]> | |
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-e… | |
75 ()) | |
76 | |
77 (defun simple-foreign-type-error (type-name namespace format-control &re… | |
78 (error 'simple-foreign-type-error | |
79 :type-name type-name :namespace namespace | |
80 :format-control format-control :format-arguments format-argumen… | |
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/c… | |
86 | |
87 (defun undefined-foreign-type-error (type-name &optional (namespace :def… | |
88 (error 'undefined-foreign-type-error :type-name type-name :namespace n… | |
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/t… | |
96 ;; (section 6.2.3 Name spaces of identifiers) | |
97 ;; NOTE: :struct is probably an unfortunate name for the tagged (?) name… | |
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… | |
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 :defaul… | |
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 bu… | |
139 type--a keyword--or a struct/union type--a list of the form (:STRUCT/:UN… | |
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 ,keyw… | |
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 t… | |
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 b… | |
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 ba… | |
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 structu… | |
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… | |
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 p… | |
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… | |
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-t… | |
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-… | |
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-… | |
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-… | |
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) … | |
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)) opt… | |
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-… | |
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 ',n… | |
711 :actual-type nil) | |
712 (actual-type memoized-type) (parse-type ',base-type))) | |
713 memoized-type)))) |