112ac1d3 |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net> |
310da1d5 |
3 | ;; |
112ac1d3 |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
310da1d5 |
11 | ;; |
112ac1d3 |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
310da1d5 |
14 | ;; |
112ac1d3 |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
22 | |
42e68ad2 |
23 | ;; $Id: ffi.lisp,v 1.28 2006-02-26 16:12:25 espen Exp $ |
310da1d5 |
24 | |
25 | (in-package "GLIB") |
26 | |
310da1d5 |
27 | |
28 | ;;;; Foreign function call interface |
29 | |
30 | (defvar *package-prefix* nil) |
31 | |
32 | (defun set-package-prefix (prefix &optional (package *package*)) |
33 | (let ((package (find-package package))) |
a7d19b2a |
34 | (setq *package-prefix* (delete package *package-prefix* :key #'car)) |
310da1d5 |
35 | (push (cons package prefix) *package-prefix*)) |
36 | prefix) |
37 | |
38 | (defun package-prefix (&optional (package *package*)) |
39 | (let ((package (find-package package))) |
40 | (or |
41 | (cdr (assoc package *package-prefix*)) |
42 | (substitute #\_ #\- (string-downcase (package-name package)))))) |
43 | |
44 | (defun find-prefix-package (prefix) |
45 | (or |
46 | (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=)) |
47 | (find-package (string-upcase prefix)))) |
48 | |
49 | (defmacro use-prefix (prefix &optional (package *package*)) |
50 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
51 | (set-package-prefix ,prefix ,package))) |
52 | |
53 | |
54 | (defun default-alien-fname (lisp-name) |
1ff84b06 |
55 | (let* ((name (substitute #\_ #\- (string-downcase lisp-name))) |
56 | (stripped-name |
57 | (cond |
58 | ((and |
59 | (char= (char name 0) #\%) |
60 | (string= "_p" name :start2 (- (length name) 2))) |
61 | (subseq name 1 (- (length name) 2))) |
62 | ((char= (char name 0) #\%) |
63 | (subseq name 1)) |
64 | ((string= "_p" name :start2 (- (length name) 2)) |
65 | (subseq name 0 (- (length name) 2))) |
66 | (name))) |
67 | (prefix (package-prefix *package*))) |
310da1d5 |
68 | (if (or (not prefix) (string= prefix "")) |
1ff84b06 |
69 | stripped-name |
70 | (format nil "~A_~A" prefix stripped-name)))) |
310da1d5 |
71 | |
72 | (defun default-alien-type-name (type-name) |
73 | (let ((prefix (package-prefix *package*))) |
74 | (apply |
75 | #'concatenate |
76 | 'string |
77 | (mapcar |
78 | #'string-capitalize |
79 | (cons prefix (split-string (symbol-name type-name) #\-)))))) |
80 | |
81 | (defun default-type-name (alien-name) |
82 | (let ((parts |
83 | (mapcar |
84 | #'string-upcase |
85 | (split-string-if alien-name #'upper-case-p)))) |
86 | (intern |
87 | (concatenate-strings |
88 | (rest parts) #\-) (find-prefix-package (first parts))))) |
89 | |
90 | |
9adccb27 |
91 | (defmacro defbinding (name lambda-list return-type &rest docs/args) |
310da1d5 |
92 | (multiple-value-bind (lisp-name c-name) |
93 | (if (atom name) |
94 | (values name (default-alien-fname name)) |
95 | (values-list name)) |
96 | |
97 | (let ((supplied-lambda-list lambda-list) |
98 | (docs nil) |
99 | (args nil)) |
100 | (dolist (doc/arg docs/args) |
101 | (if (stringp doc/arg) |
102 | (push doc/arg docs) |
103 | (progn |
104 | (destructuring-bind (expr type &optional (style :in)) doc/arg |
3840beb2 |
105 | (unless (member style '(:in :out :in-out :return)) |
310da1d5 |
106 | (error "Bogus argument style ~S in ~S." style doc/arg)) |
107 | (when (and |
108 | (not supplied-lambda-list) |
3840beb2 |
109 | (namep expr) (member style '(:in :in-out :return))) |
310da1d5 |
110 | (push expr lambda-list)) |
7a6c048d |
111 | (push (list (cond |
112 | ((and (namep expr) (eq style :out)) expr) |
113 | ((namep expr) (make-symbol (string expr))) |
114 | ((gensym))) |
75689fea |
115 | expr type style) args))))) |
310da1d5 |
116 | |
117 | (%defbinding |
118 | c-name lisp-name (or supplied-lambda-list (nreverse lambda-list)) |
9adccb27 |
119 | return-type (reverse docs) (reverse args))))) |
310da1d5 |
120 | |
73572c12 |
121 | #+(or cmu sbcl) |
9adccb27 |
122 | (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args) |
73572c12 |
123 | (collect ((alien-types) (alien-bindings) (alien-parameters) |
124 | (return-values) (cleanup-forms)) |
310da1d5 |
125 | (dolist (arg args) |
9adccb27 |
126 | (destructuring-bind (var expr type style) arg |
127 | (let ((declaration (alien-type type)) |
75689fea |
128 | (cleanup (cleanup-form type var))) |
9adccb27 |
129 | |
310da1d5 |
130 | (cond |
3840beb2 |
131 | ((member style '(:out :in-out)) |
132 | (alien-types `(* ,declaration)) |
133 | (alien-parameters `(addr ,var)) |
134 | (alien-bindings |
135 | `(,var ,declaration |
fefc2058 |
136 | ,@(cond |
75689fea |
137 | ((eq style :in-out) (list (to-alien-form type expr))) |
fefc2058 |
138 | ((eq declaration 'system-area-pointer) |
139 | (list '(make-pointer 0)))))) |
75689fea |
140 | (return-values (from-alien-form type var))) |
3840beb2 |
141 | ((eq style :return) |
142 | (alien-types declaration) |
143 | (alien-bindings |
75689fea |
144 | `(,var ,declaration ,(to-alien-form type expr))) |
3840beb2 |
145 | (alien-parameters var) |
75689fea |
146 | (return-values (from-alien-form type var))) |
3840beb2 |
147 | (cleanup |
148 | (alien-types declaration) |
149 | (alien-bindings |
75689fea |
150 | `(,var ,declaration ,(to-alien-form type expr))) |
3840beb2 |
151 | (alien-parameters var) |
152 | (cleanup-forms cleanup)) |
153 | (t |
154 | (alien-types declaration) |
75689fea |
155 | (alien-parameters (to-alien-form type expr))))))) |
310da1d5 |
156 | |
157 | (let* ((alien-name (make-symbol (string lisp-name))) |
158 | (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters)))) |
159 | `(defun ,lisp-name ,lambda-list |
160 | ,@docs |
73572c12 |
161 | #+cmu(declare (optimize (inhibit-warnings 3))) |
162 | #+sbcl(declare (muffle-conditions compiler-note)) |
310da1d5 |
163 | (with-alien ((,alien-name |
164 | (function |
9adccb27 |
165 | ,(alien-type return-type) |
310da1d5 |
166 | ,@(alien-types)) |
167 | :extern ,foreign-name) |
168 | ,@(alien-bindings)) |
9adccb27 |
169 | ,(if return-type |
170 | `(values |
171 | (unwind-protect |
75689fea |
172 | ,(from-alien-form return-type alien-funcall) |
9adccb27 |
173 | ,@(cleanup-forms)) |
3840beb2 |
174 | ,@(return-values)) |
310da1d5 |
175 | `(progn |
9adccb27 |
176 | (unwind-protect |
177 | ,alien-funcall |
178 | ,@(cleanup-forms)) |
3840beb2 |
179 | (values ,@(return-values))))))))) |
310da1d5 |
180 | |
181 | |
9adccb27 |
182 | ;;; Creates bindings at runtime |
310da1d5 |
183 | (defun mkbinding (name return-type &rest arg-types) |
73572c12 |
184 | #+cmu(declare (optimize (inhibit-warnings 3))) |
185 | #+sbcl(declare (muffle-conditions compiler-note)) |
9adccb27 |
186 | (let* ((ftype |
187 | `(function ,@(mapcar #'alien-type (cons return-type arg-types)))) |
310da1d5 |
188 | (alien |
73572c12 |
189 | (%heap-alien |
190 | (make-heap-alien-info |
191 | :type (parse-alien-type ftype #+sbcl nil) |
177abaa0 |
192 | :sap-form (let ((address (foreign-symbol-address name))) |
193 | (etypecase address |
194 | (integer (int-sap address)) |
195 | (system-area-pointer address)))))) |
9adccb27 |
196 | (translate-arguments (mapcar #'to-alien-function arg-types)) |
197 | (translate-return-value (from-alien-function return-type)) |
198 | (cleanup-arguments (mapcar #'cleanup-function arg-types))) |
199 | |
310da1d5 |
200 | #'(lambda (&rest args) |
201 | (map-into args #'funcall translate-arguments args) |
202 | (prog1 |
9adccb27 |
203 | (funcall translate-return-value |
73572c12 |
204 | (apply #'alien-funcall alien args)) |
310da1d5 |
205 | (mapc #'funcall cleanup-arguments args))))) |
206 | |
8755b1a5 |
207 | |
73572c12 |
208 | |
586328b4 |
209 | ;;;; C callbacks |
210 | |
211 | (defmacro define-callback (name return-type args &body body) |
212 | (let ((define-callback |
213 | #+cmu'alien:def-callback |
214 | #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback |
215 | #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)) |
216 | (multiple-value-bind (doc declaration body) |
217 | (cond |
218 | ((and (stringp (first body)) (eq (cadr body) 'declare)) |
219 | (values (first body) (second body) (cddr body))) |
220 | ((stringp (first body)) |
221 | (values (first body) nil (rest body))) |
222 | ((eq (caar body) 'declare) |
223 | (values nil (first body) (rest body))) |
224 | (t (values nil nil body))) |
75689fea |
225 | `(progn |
226 | #+cmu(defparameter ,name nil) |
227 | (,define-callback ,name |
228 | #+(and sbcl alien-callbacks),(alien-type return-type) |
229 | (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type) |
230 | ,@(mapcar #'(lambda (arg) |
231 | (destructuring-bind (name type) arg |
232 | `(,name ,(alien-type type)))) |
233 | args)) |
234 | ,@(when doc (list doc)) |
235 | ,(to-alien-form return-type |
236 | `(let (,@(loop |
237 | for (name type) in args |
238 | as from-alien-form = (callback-from-alien-form type name) |
239 | collect `(,name ,from-alien-form))) |
240 | ,@(when declaration (list declaration)) |
241 | (unwind-protect |
242 | (progn ,@body) |
243 | ,@(loop |
586328b4 |
244 | for (name type) in args |
75689fea |
245 | do (callback-cleanup-form type name)))))))))) |
586328b4 |
246 | |
247 | (defun callback-address (callback) |
248 | #+cmu(alien::callback-trampoline callback) |
249 | #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback) |
250 | #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback)) |
8755b1a5 |
251 | |
7e29d6b1 |
252 | #+sbcl |
586328b4 |
253 | (deftype callback () |
254 | #-alien-callbacks'sb-alien:alien-function |
255 | #+alien-callbacks'sb-alien:alien) |
256 | |
257 | |
258 | ;;; These are for backward compatibility |
259 | |
260 | (defmacro defcallback (name (return-type &rest args) &body body) |
261 | `(define-callback ,name ,return-type ,args ,@body)) |
262 | |
263 | #-cmu |
264 | (defun callback (callback) |
265 | (callback-address callback)) |
266 | |
267 | |
310da1d5 |
268 | |
75689fea |
269 | ;;;; The "type method" system |
270 | |
271 | (defun find-applicable-type-method (name type-spec &optional (error-p t)) |
272 | (let ((type-methods (get name 'type-methods))) |
273 | (labels ((search-method-in-cpl-order (classes) |
274 | (when classes |
275 | (or |
276 | (gethash (class-name (first classes)) type-methods) |
277 | (search-method-in-cpl-order (rest classes))))) |
278 | (lookup-method (type-spec) |
279 | (if (and (symbolp type-spec) (find-class type-spec nil)) |
280 | (search-method-in-cpl-order |
281 | (class-precedence-list (find-class type-spec))) |
282 | (or |
283 | (let ((specifier (etypecase type-spec |
284 | (symbol type-spec) |
285 | (list (first type-spec))))) |
286 | (gethash specifier type-methods)) |
287 | (multiple-value-bind (expanded-type expanded-p) |
288 | (type-expand-1 type-spec) |
289 | (when expanded-p |
290 | (lookup-method expanded-type)))))) |
291 | (search-built-in-type-hierarchy (sub-tree) |
292 | (when (subtypep type-spec (first sub-tree)) |
293 | (or |
294 | (search-nodes (cddr sub-tree)) |
295 | (second sub-tree)))) |
296 | (search-nodes (nodes) |
297 | (loop |
298 | for node in nodes |
299 | as function = (search-built-in-type-hierarchy node) |
300 | until function |
301 | finally (return function)))) |
302 | (or |
303 | (lookup-method type-spec) |
304 | ;; This is to handle unexpandable types whichs doesn't name a class |
305 | (unless (and (symbolp type-spec) (find-class type-spec nil)) |
306 | (search-nodes (get name 'built-in-type-hierarchy))) |
307 | (and |
308 | error-p |
309 | (error "No applicable type method for ~A when call width type specifier ~A" name type-spec)))))) |
310 | |
311 | |
312 | (defun insert-type-in-hierarchy (specifier function nodes) |
313 | (cond |
314 | ((let ((node (find specifier nodes :key #'first))) |
315 | (when node |
316 | (setf (second node) function) |
317 | nodes))) |
318 | ((let ((node |
319 | (find-if |
320 | #'(lambda (node) |
321 | (subtypep specifier (first node))) |
322 | nodes))) |
323 | (when node |
324 | (setf (cddr node) |
325 | (insert-type-in-hierarchy specifier function (cddr node))) |
326 | nodes))) |
327 | ((let ((sub-nodes (remove-if-not |
328 | #'(lambda (node) |
329 | (subtypep (first node) specifier)) |
330 | nodes))) |
331 | (cons |
332 | (list* specifier function sub-nodes) |
333 | (nset-difference nodes sub-nodes)))))) |
334 | |
335 | |
336 | (defun add-type-method (name specifier function) |
337 | (setf (gethash specifier (get name 'type-methods)) function) |
338 | (when (typep (find-class specifier nil) 'built-in-class) |
339 | (setf (get name 'built-in-type-hierarchy) |
340 | (insert-type-in-hierarchy specifier function |
341 | (get name 'built-in-type-hierarchy))))) |
342 | |
343 | |
344 | ;; TODO: handle optional, key and rest arguments |
345 | (defmacro define-type-generic (name lambda-list &optional documentation) |
346 | (if (or |
347 | (not lambda-list) |
348 | (find (first lambda-list) '(&optional &key &rest &allow-other-keys))) |
349 | (error "A type generic needs at least one required argument") |
350 | `(progn |
351 | (setf (get ',name 'type-methods) (make-hash-table)) |
352 | (setf (get ',name 'built-in-type-hierarchy) ()) |
353 | (defun ,name ,lambda-list |
354 | ,documentation |
355 | (funcall |
356 | (find-applicable-type-method ',name ,(first lambda-list)) |
357 | ,@lambda-list))))) |
358 | |
359 | |
360 | (defmacro define-type-method (name lambda-list &body body) |
361 | (let ((specifier (cadar lambda-list)) |
362 | (args (cons (caar lambda-list) (rest lambda-list)))) |
363 | `(progn |
364 | (add-type-method ',name ',specifier #'(lambda ,args ,@body)) |
365 | ',name))) |
366 | |
367 | |
368 | |
369 | ;;;; Definitons and translations of fundamental types |
370 | |
371 | (define-type-generic alien-type (type-spec)) |
372 | (define-type-generic size-of (type-spec)) |
373 | (define-type-generic to-alien-form (type-spec form)) |
374 | (define-type-generic from-alien-form (type-spec form)) |
375 | (define-type-generic cleanup-form (type-spec form) |
9adccb27 |
376 | "Creates a form to clean up after the alien call has finished.") |
75689fea |
377 | (define-type-generic callback-from-alien-form (type-spec form)) |
378 | (define-type-generic callback-cleanup-form (type-spec form)) |
310da1d5 |
379 | |
75689fea |
380 | (define-type-generic to-alien-function (type-spec)) |
381 | (define-type-generic from-alien-function (type-spec)) |
382 | (define-type-generic cleanup-function (type-spec)) |
310da1d5 |
383 | |
75689fea |
384 | (define-type-generic copy-to-alien-form (type-spec form)) |
385 | (define-type-generic copy-to-alien-function (type-spec)) |
386 | (define-type-generic copy-from-alien-form (type-spec form)) |
387 | (define-type-generic copy-from-alien-function (type-spec)) |
388 | (define-type-generic writer-function (type-spec)) |
389 | (define-type-generic reader-function (type-spec)) |
390 | (define-type-generic destroy-function (type-spec)) |
9ca5565a |
391 | |
75689fea |
392 | (define-type-generic unbound-value (type-spec) |
393 | "Returns a value which should be intepreted as unbound for slots with virtual allocation") |
12b7df04 |
394 | |
310da1d5 |
395 | |
42e68ad2 |
396 | #+sbcl |
397 | (eval-when (:compile-toplevel :load-toplevel :execute) |
398 | (defun sb-sizeof-bits (type) |
399 | (sb-alien-internals:alien-type-bits |
400 | (sb-alien-internals:parse-alien-type type nil))) |
401 | |
402 | (defun sb-sizeof (type) |
403 | (/ (sb-sizeof-bits type) 8))) |
404 | |
405 | |
8755b1a5 |
406 | ;; Sizes of fundamental C types in bytes (8 bits) |
42e68ad2 |
407 | (defconstant +size-of-short+ |
408 | #+sbcl (sb-sizeof 'sb-alien:short) |
409 | #-sbcl 2) |
410 | (defconstant +size-of-int+ |
411 | #+sbcl (sb-sizeof 'sb-alien:int) |
412 | #-sbcl 4) |
413 | (defconstant +size-of-long+ |
414 | #+sbcl (sb-sizeof 'sb-alien:long) |
415 | #-sbcl 4) |
416 | (defconstant +size-of-pointer+ |
417 | #+sbcl (sb-sizeof 'sb-alien:system-area-pointer) |
418 | #-sbcl 4) |
419 | (defconstant +size-of-float+ |
420 | #+sbcl (sb-sizeof 'sb-alien:float) |
421 | #-sbcl 4) |
422 | (defconstant +size-of-double+ |
423 | #+sbcl (sb-sizeof 'sb-alien:double) |
424 | #-sbcl 8) |
425 | |
8755b1a5 |
426 | |
427 | ;; Sizes of fundamental C types in bits |
428 | (defconstant +bits-of-byte+ 8) |
42e68ad2 |
429 | (defconstant +bits-of-short+ |
430 | #+sbcl (sb-sizeof-bits 'sb-alien:short) |
431 | #-sbcl 16) |
432 | (defconstant +bits-of-int+ |
433 | #+sbcl (sb-sizeof-bits 'sb-alien:int) |
434 | #-sbcl 32) |
435 | (defconstant +bits-of-long+ |
436 | #+sbcl (sb-sizeof-bits 'sb-alien:long) |
437 | #-sbcl 32) |
8755b1a5 |
438 | |
439 | |
9adccb27 |
440 | (deftype int () '(signed-byte #.+bits-of-int+)) |
441 | (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+)) |
442 | (deftype long () '(signed-byte #.+bits-of-long+)) |
443 | (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+)) |
444 | (deftype short () '(signed-byte #.+bits-of-short+)) |
445 | (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+)) |
446 | (deftype signed (&optional (size '*)) `(signed-byte ,size)) |
447 | (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size)) |
448 | (deftype char () 'base-char) |
449 | (deftype pointer () 'system-area-pointer) |
75689fea |
450 | (deftype boolean (&optional (size '*)) (declare (ignore size)) t) |
451 | (deftype copy-of (type) type) |
310da1d5 |
452 | |
75689fea |
453 | (define-type-method alien-type ((type t)) |
454 | (error "No alien type corresponding to the type specifier ~A" type)) |
310da1d5 |
455 | |
75689fea |
456 | (define-type-method to-alien-form ((type t) form) |
457 | (declare (ignore form)) |
458 | (error "Not a valid type specifier for arguments: ~A" type)) |
310da1d5 |
459 | |
75689fea |
460 | (define-type-method to-alien-function ((type t)) |
461 | (error "Not a valid type specifier for arguments: ~A" type)) |
310da1d5 |
462 | |
75689fea |
463 | (define-type-method from-alien-form ((type t) form) |
464 | (declare (ignore form)) |
465 | (error "Not a valid type specifier for return values: ~A" type)) |
310da1d5 |
466 | |
75689fea |
467 | (define-type-method from-alien-function ((type t)) |
468 | (error "Not a valid type specifier for return values: ~A" type)) |
9adccb27 |
469 | |
75689fea |
470 | (define-type-method cleanup-form ((type t) form) |
471 | (declare (ignore form type)) |
9adccb27 |
472 | nil) |
310da1d5 |
473 | |
75689fea |
474 | (define-type-method cleanup-function ((type t)) |
475 | (declare (ignore type)) |
9adccb27 |
476 | #'identity) |
477 | |
75689fea |
478 | (define-type-method callback-from-alien-form ((type t) form) |
479 | (copy-from-alien-form type form)) |
586328b4 |
480 | |
75689fea |
481 | (define-type-method callback-cleanup-form ((type t) form) |
482 | (declare (ignore form type)) |
586328b4 |
483 | nil) |
484 | |
75689fea |
485 | (define-type-method destroy-function ((type t)) |
486 | (declare (ignore type)) |
cdd375f3 |
487 | #'(lambda (location &optional offset) |
9adccb27 |
488 | (declare (ignore location offset)))) |
489 | |
75689fea |
490 | (define-type-method copy-to-alien-form ((type t) form) |
491 | (to-alien-form type form)) |
492 | |
493 | (define-type-method copy-to-alien-function ((type t)) |
494 | (to-alien-function type)) |
9ca5565a |
495 | |
75689fea |
496 | (define-type-method copy-from-alien-form ((type t) form) |
497 | (from-alien-form type form)) |
9ca5565a |
498 | |
75689fea |
499 | (define-type-method copy-from-alien-function ((type t)) |
500 | (from-alien-function type)) |
9ca5565a |
501 | |
9ca5565a |
502 | |
75689fea |
503 | (define-type-method to-alien-form ((type real) form) |
9adccb27 |
504 | (declare (ignore type)) |
75689fea |
505 | form) |
506 | |
507 | (define-type-method to-alien-function ((type real)) |
508 | (declare (ignore type)) |
509 | #'identity) |
510 | |
511 | (define-type-method from-alien-form ((type real) form) |
512 | (declare (ignore type)) |
513 | form) |
514 | |
515 | (define-type-method from-alien-function ((type real)) |
516 | (declare (ignore type)) |
517 | #'identity) |
518 | |
519 | |
520 | (define-type-method alien-type ((type integer)) |
521 | (declare (ignore type)) |
522 | (alien-type 'signed-byte)) |
523 | |
524 | (define-type-method size-of ((type integer)) |
525 | (declare (ignore type)) |
526 | (size-of 'signed-byte)) |
527 | |
528 | (define-type-method writer-function ((type integer)) |
529 | (declare (ignore type)) |
530 | (writer-function 'signed-byte)) |
531 | |
532 | (define-type-method reader-function ((type integer)) |
533 | (declare (ignore type)) |
534 | (reader-function 'signed-byte)) |
535 | |
536 | |
537 | (define-type-method alien-type ((type signed-byte)) |
538 | (destructuring-bind (&optional (size '*)) |
539 | (rest (mklist (type-expand-to 'signed-byte type))) |
9adccb27 |
540 | (ecase size |
73572c12 |
541 | (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8)) |
542 | (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short) |
543 | ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int) |
544 | (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long)))) |
9adccb27 |
545 | |
75689fea |
546 | (define-type-method size-of ((type signed-byte)) |
547 | (destructuring-bind (&optional (size '*)) |
548 | (rest (mklist (type-expand-to 'signed-byte type))) |
9adccb27 |
549 | (ecase size |
550 | (#.+bits-of-byte+ 1) |
551 | (#.+bits-of-short+ +size-of-short+) |
552 | ((* #.+bits-of-int+) +size-of-int+) |
553 | (#.+bits-of-long+ +size-of-long+)))) |
554 | |
75689fea |
555 | (define-type-method writer-function ((type signed-byte)) |
556 | (destructuring-bind (&optional (size '*)) |
557 | (rest (mklist (type-expand-to 'signed-byte type))) |
9adccb27 |
558 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
559 | (ecase size |
560 | (8 #'(lambda (value location &optional (offset 0)) |
561 | (setf (signed-sap-ref-8 location offset) value))) |
562 | (16 #'(lambda (value location &optional (offset 0)) |
563 | (setf (signed-sap-ref-16 location offset) value))) |
564 | (32 #'(lambda (value location &optional (offset 0)) |
565 | (setf (signed-sap-ref-32 location offset) value))) |
566 | (64 #'(lambda (value location &optional (offset 0)) |
567 | (setf (signed-sap-ref-64 location offset) value))))))) |
568 | |
75689fea |
569 | (define-type-method reader-function ((type signed-byte)) |
570 | (destructuring-bind (&optional (size '*)) |
571 | (rest (mklist (type-expand-to 'signed-byte type))) |
9adccb27 |
572 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
573 | (ecase size |
3005806e |
574 | (8 #'(lambda (sap &optional (offset 0) weak-p) |
575 | (declare (ignore weak-p)) |
9adccb27 |
576 | (signed-sap-ref-8 sap offset))) |
3005806e |
577 | (16 #'(lambda (sap &optional (offset 0) weak-p) |
578 | (declare (ignore weak-p)) |
9adccb27 |
579 | (signed-sap-ref-16 sap offset))) |
3005806e |
580 | (32 #'(lambda (sap &optional (offset 0) weak-p) |
581 | (declare (ignore weak-p)) |
9adccb27 |
582 | (signed-sap-ref-32 sap offset))) |
3005806e |
583 | (64 #'(lambda (sap &optional (offset 0) weak-p) |
584 | (declare (ignore weak-p)) |
9adccb27 |
585 | (signed-sap-ref-64 sap offset))))))) |
586 | |
75689fea |
587 | |
588 | (define-type-method alien-type ((type unsigned-byte)) |
589 | (destructuring-bind (&optional (size '*)) |
590 | (rest (mklist (type-expand-to 'unsigned-byte type))) |
9adccb27 |
591 | (ecase size |
73572c12 |
592 | (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8)) |
593 | (#.+bits-of-short+ #+cmu 'c-call:unsigned-short |
594 | #+sbcl 'sb-alien:unsigned-short) |
595 | ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int |
596 | #+sbcl 'sb-alien:unsigned-int) |
597 | (#.+bits-of-long+ #+cmu 'c-call:unsigned-long |
598 | #+sbcl 'sb-alien:unsigned-long)))) |
9adccb27 |
599 | |
9adccb27 |
600 | |
75689fea |
601 | (define-type-method size-of ((type unsigned-byte)) |
602 | (destructuring-bind (&optional (size '*)) |
603 | (rest (mklist (type-expand-to 'unsigned-byte type))) |
604 | (size-of `(signed ,size)))) |
605 | |
606 | (define-type-method writer-function ((type unsigned-byte)) |
607 | (destructuring-bind (&optional (size '*)) |
608 | (rest (mklist (type-expand-to 'unsigned-byte type))) |
9adccb27 |
609 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
610 | (ecase size |
611 | (8 #'(lambda (value location &optional (offset 0)) |
612 | (setf (sap-ref-8 location offset) value))) |
613 | (16 #'(lambda (value location &optional (offset 0)) |
614 | (setf (sap-ref-16 location offset) value))) |
615 | (32 #'(lambda (value location &optional (offset 0)) |
616 | (setf (sap-ref-32 location offset) value))) |
617 | (64 #'(lambda (value location &optional (offset 0)) |
618 | (setf (sap-ref-64 location offset) value))))))) |
619 | |
75689fea |
620 | (define-type-method reader-function ((type unsigned-byte)) |
621 | (destructuring-bind (&optional (size '*)) |
622 | (rest (mklist (type-expand-to 'unsigned-byte type))) |
9adccb27 |
623 | (let ((size (if (eq size '*) +bits-of-int+ size))) |
624 | (ecase size |
3005806e |
625 | (8 #'(lambda (sap &optional (offset 0) weak-p) |
626 | (declare (ignore weak-p)) |
9adccb27 |
627 | (sap-ref-8 sap offset))) |
3005806e |
628 | (16 #'(lambda (sap &optional (offset 0) weak-p) |
629 | (declare (ignore weak-p)) |
9adccb27 |
630 | (sap-ref-16 sap offset))) |
3005806e |
631 | (32 #'(lambda (sap &optional (offset 0) weak-p) |
632 | (declare (ignore weak-p)) |
9adccb27 |
633 | (sap-ref-32 sap offset))) |
3005806e |
634 | (64 #'(lambda (sap &optional (offset 0) weak-p) |
635 | (declare (ignore weak-p)) |
9adccb27 |
636 | (sap-ref-64 sap offset))))))) |
78778e5a |
637 | |
75689fea |
638 | (define-type-method alien-type ((type single-float)) |
639 | (declare (ignore type)) |
73572c12 |
640 | #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float) |
310da1d5 |
641 | |
75689fea |
642 | (define-type-method size-of ((type single-float)) |
643 | (declare (ignore type)) |
310da1d5 |
644 | +size-of-float+) |
645 | |
75689fea |
646 | (define-type-method to-alien-form ((type single-float) form) |
647 | (declare (ignore type)) |
af6d8c9a |
648 | `(coerce ,form 'single-float)) |
649 | |
75689fea |
650 | (define-type-method to-alien-function ((type single-float)) |
651 | (declare (ignore type)) |
af6d8c9a |
652 | #'(lambda (number) |
653 | (coerce number 'single-float))) |
654 | |
75689fea |
655 | (define-type-method writer-function ((type single-float)) |
656 | (declare (ignore type)) |
9adccb27 |
657 | #'(lambda (value location &optional (offset 0)) |
8755b1a5 |
658 | (setf (sap-ref-single location offset) (coerce value 'single-float)))) |
310da1d5 |
659 | |
75689fea |
660 | (define-type-method reader-function ((type single-float)) |
661 | (declare (ignore type)) |
3005806e |
662 | #'(lambda (sap &optional (offset 0) weak-p) |
663 | (declare (ignore weak-p)) |
9adccb27 |
664 | (sap-ref-single sap offset))) |
310da1d5 |
665 | |
666 | |
75689fea |
667 | (define-type-method alien-type ((type double-float)) |
668 | (declare (ignore type)) |
73572c12 |
669 | #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float) |
310da1d5 |
670 | |
75689fea |
671 | (define-type-method size-of ((type double-float)) |
672 | (declare (ignore type)) |
3d285e35 |
673 | +size-of-double+) |
310da1d5 |
674 | |
75689fea |
675 | (define-type-method to-alien-form ((type double-float) form) |
676 | (declare (ignore type)) |
af6d8c9a |
677 | `(coerce ,form 'double-float)) |
678 | |
75689fea |
679 | (define-type-method to-alien-function ((type double-float)) |
680 | (declare (ignore type)) |
af6d8c9a |
681 | #'(lambda (number) |
682 | (coerce number 'double-float))) |
683 | |
75689fea |
684 | (define-type-method writer-function ((type double-float)) |
685 | (declare (ignore type)) |
9adccb27 |
686 | #'(lambda (value location &optional (offset 0)) |
687 | (setf (sap-ref-double location offset) (coerce value 'double-float)))) |
310da1d5 |
688 | |
75689fea |
689 | (define-type-method reader-function ((type double-float)) |
690 | (declare (ignore type)) |
3005806e |
691 | #'(lambda (sap &optional (offset 0) weak-p) |
692 | (declare (ignore weak-p)) |
9adccb27 |
693 | (sap-ref-double sap offset))) |
310da1d5 |
694 | |
695 | |
75689fea |
696 | (define-type-method alien-type ((type base-char)) |
697 | (declare (ignore type)) |
73572c12 |
698 | #+cmu 'c-call:char #+sbcl 'sb-alien:char) |
310da1d5 |
699 | |
75689fea |
700 | (define-type-method size-of ((type base-char)) |
701 | (declare (ignore type)) |
310da1d5 |
702 | 1) |
703 | |
75689fea |
704 | (define-type-method to-alien-form ((type base-char) form) |
705 | (declare (ignore type)) |
706 | form) |
707 | |
708 | (define-type-method to-alien-function ((type base-char)) |
709 | (declare (ignore type)) |
710 | #'identity) |
711 | |
712 | (define-type-method from-alien-form ((type base-char) form) |
713 | (declare (ignore type)) |
714 | form) |
715 | |
716 | (define-type-method from-alien-function ((type base-char)) |
717 | (declare (ignore type)) |
718 | #'identity) |
719 | |
720 | (define-type-method writer-function ((type base-char)) |
721 | (declare (ignore type)) |
9adccb27 |
722 | #'(lambda (char location &optional (offset 0)) |
723 | (setf (sap-ref-8 location offset) (char-code char)))) |
310da1d5 |
724 | |
75689fea |
725 | (define-type-method reader-function ((type base-char)) |
726 | (declare (ignore type)) |
3005806e |
727 | #'(lambda (location &optional (offset 0) weak-p) |
728 | (declare (ignore weak-p)) |
9adccb27 |
729 | (code-char (sap-ref-8 location offset)))) |
310da1d5 |
730 | |
731 | |
75689fea |
732 | (define-type-method alien-type ((type string)) |
733 | (declare (ignore type)) |
9adccb27 |
734 | (alien-type 'pointer)) |
310da1d5 |
735 | |
75689fea |
736 | (define-type-method size-of ((type string)) |
737 | (declare (ignore type)) |
9adccb27 |
738 | (size-of 'pointer)) |
310da1d5 |
739 | |
75689fea |
740 | (define-type-method to-alien-form ((type string) string) |
741 | (declare (ignore type)) |
310da1d5 |
742 | `(let ((string ,string)) |
743 | ;; Always copy strings to prevent seg fault due to GC |
6896c0f3 |
744 | #+cmu |
310da1d5 |
745 | (copy-memory |
73572c12 |
746 | (vector-sap (coerce string 'simple-base-string)) |
6896c0f3 |
747 | (1+ (length string))) |
748 | #+sbcl |
749 | (let ((utf8 (%deport-utf8-string string))) |
750 | (copy-memory (vector-sap utf8) (length utf8))))) |
310da1d5 |
751 | |
75689fea |
752 | (define-type-method to-alien-function ((type string)) |
753 | (declare (ignore type)) |
9adccb27 |
754 | #'(lambda (string) |
6896c0f3 |
755 | #+cmu |
9adccb27 |
756 | (copy-memory |
73572c12 |
757 | (vector-sap (coerce string 'simple-base-string)) |
6896c0f3 |
758 | (1+ (length string))) |
759 | #+sbcl |
760 | (let ((utf8 (%deport-utf8-string string))) |
761 | (copy-memory (vector-sap utf8) (length utf8))))) |
9adccb27 |
762 | |
75689fea |
763 | (define-type-method from-alien-form ((type string) string) |
764 | (declare (ignore type)) |
9adccb27 |
765 | `(let ((string ,string)) |
766 | (unless (null-pointer-p string) |
9ca5565a |
767 | (prog1 |
6896c0f3 |
768 | #+cmu(%naturalize-c-string string) |
769 | #+sbcl(%naturalize-utf8-string string) |
9ca5565a |
770 | (deallocate-memory string))))) |
310da1d5 |
771 | |
75689fea |
772 | (define-type-method from-alien-function ((type string)) |
773 | (declare (ignore type)) |
9adccb27 |
774 | #'(lambda (string) |
775 | (unless (null-pointer-p string) |
9ca5565a |
776 | (prog1 |
6896c0f3 |
777 | #+cmu(%naturalize-c-string string) |
778 | #+sbcl(%naturalize-utf8-string string) |
9ca5565a |
779 | (deallocate-memory string))))) |
310da1d5 |
780 | |
75689fea |
781 | (define-type-method cleanup-form ((type string) string) |
782 | (declare (ignore type)) |
9adccb27 |
783 | `(let ((string ,string)) |
784 | (unless (null-pointer-p string) |
785 | (deallocate-memory string)))) |
786 | |
75689fea |
787 | (define-type-method cleanup-function ((type string)) |
788 | (declare (ignore type)) |
9adccb27 |
789 | #'(lambda (string) |
790 | (unless (null-pointer-p string) |
791 | (deallocate-memory string)))) |
792 | |
75689fea |
793 | (define-type-method copy-from-alien-form ((type string) string) |
794 | (declare (ignore type)) |
9ca5565a |
795 | `(let ((string ,string)) |
796 | (unless (null-pointer-p string) |
6896c0f3 |
797 | #+cmu(%naturalize-c-string string) |
798 | #+sbcl(%naturalize-utf8-string string)))) |
9ca5565a |
799 | |
75689fea |
800 | (define-type-method copy-from-alien-function ((type string)) |
801 | (declare (ignore type)) |
9ca5565a |
802 | #'(lambda (string) |
803 | (unless (null-pointer-p string) |
6896c0f3 |
804 | #+cmu(%naturalize-c-string string) |
805 | #+sbcl(%naturalize-utf8-string string)))) |
9ca5565a |
806 | |
75689fea |
807 | (define-type-method writer-function ((type string)) |
808 | (declare (ignore type)) |
9adccb27 |
809 | #'(lambda (string location &optional (offset 0)) |
810 | (assert (null-pointer-p (sap-ref-sap location offset))) |
811 | (setf (sap-ref-sap location offset) |
6896c0f3 |
812 | #+cmu |
9adccb27 |
813 | (copy-memory |
73572c12 |
814 | (vector-sap (coerce string 'simple-base-string)) |
6896c0f3 |
815 | (1+ (length string))) |
816 | #+sbcl |
817 | (let ((utf8 (%deport-utf8-string string))) |
818 | (copy-memory (vector-sap utf8) (length utf8)))))) |
9adccb27 |
819 | |
75689fea |
820 | (define-type-method reader-function ((type string)) |
821 | (declare (ignore type)) |
3005806e |
822 | #'(lambda (location &optional (offset 0) weak-p) |
823 | (declare (ignore weak-p)) |
9adccb27 |
824 | (unless (null-pointer-p (sap-ref-sap location offset)) |
6896c0f3 |
825 | #+cmu(%naturalize-c-string (sap-ref-sap location offset)) |
826 | #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset))))) |
9adccb27 |
827 | |
75689fea |
828 | (define-type-method destroy-function ((type string)) |
829 | (declare (ignore type)) |
9adccb27 |
830 | #'(lambda (location &optional (offset 0)) |
831 | (unless (null-pointer-p (sap-ref-sap location offset)) |
832 | (deallocate-memory (sap-ref-sap location offset)) |
833 | (setf (sap-ref-sap location offset) (make-pointer 0))))) |
834 | |
75689fea |
835 | (define-type-method unbound-value ((type string)) |
836 | (declare (ignore type)) |
837 | nil) |
9adccb27 |
838 | |
6896c0f3 |
839 | |
75689fea |
840 | (define-type-method alien-type ((type pathname)) |
841 | (declare (ignore type)) |
9adccb27 |
842 | (alien-type 'string)) |
843 | |
75689fea |
844 | (define-type-method size-of ((type pathname)) |
845 | (declare (ignore type)) |
9adccb27 |
846 | (size-of 'string)) |
310da1d5 |
847 | |
75689fea |
848 | (define-type-method to-alien-form ((type pathname) path) |
849 | (declare (ignore type)) |
850 | (to-alien-form 'string `(namestring (translate-logical-pathname ,path)))) |
9adccb27 |
851 | |
75689fea |
852 | (define-type-method to-alien-function ((type pathname)) |
853 | (declare (ignore type)) |
9adccb27 |
854 | (let ((string-function (to-alien-function 'string))) |
855 | #'(lambda (path) |
856 | (funcall string-function (namestring path))))) |
857 | |
75689fea |
858 | (define-type-method from-alien-form ((type pathname) string) |
859 | (declare (ignore type)) |
860 | `(parse-namestring ,(from-alien-form 'string string))) |
9adccb27 |
861 | |
75689fea |
862 | (define-type-method from-alien-function ((type pathname)) |
863 | (declare (ignore type)) |
9adccb27 |
864 | (let ((string-function (from-alien-function 'string))) |
865 | #'(lambda (string) |
866 | (parse-namestring (funcall string-function string))))) |
867 | |
75689fea |
868 | (define-type-method cleanup-form ((type pathnanme) string) |
869 | (declare (ignore type)) |
870 | (cleanup-form 'string string)) |
9adccb27 |
871 | |
75689fea |
872 | (define-type-method cleanup-function ((type pathnanme)) |
873 | (declare (ignore type)) |
9adccb27 |
874 | (cleanup-function 'string)) |
875 | |
75689fea |
876 | (define-type-method writer-function ((type pathname)) |
877 | (declare (ignore type)) |
9adccb27 |
878 | (let ((string-writer (writer-function 'string))) |
879 | #'(lambda (path location &optional (offset 0)) |
880 | (funcall string-writer (namestring path) location offset)))) |
881 | |
75689fea |
882 | (define-type-method reader-function ((type pathname)) |
883 | (declare (ignore type)) |
9adccb27 |
884 | (let ((string-reader (reader-function 'string))) |
3005806e |
885 | #'(lambda (location &optional (offset 0) weak-p) |
886 | (declare (ignore weak-p)) |
9adccb27 |
887 | (let ((string (funcall string-reader location offset))) |
888 | (when string |
889 | (parse-namestring string)))))) |
890 | |
75689fea |
891 | (define-type-method destroy-function ((type pathname)) |
892 | (declare (ignore type)) |
9adccb27 |
893 | (destroy-function 'string)) |
894 | |
75689fea |
895 | (define-type-method unbound-value ((type pathname)) |
896 | (declare (ignore type)) |
12b7df04 |
897 | (unbound-value 'string)) |
898 | |
9adccb27 |
899 | |
75689fea |
900 | (define-type-method alien-type ((type boolean)) |
901 | (destructuring-bind (&optional (size '*)) |
902 | (rest (mklist (type-expand-to 'boolean type))) |
903 | (alien-type `(signed-byte ,size)))) |
9adccb27 |
904 | |
75689fea |
905 | (define-type-method size-of ((type boolean)) |
906 | (destructuring-bind (&optional (size '*)) |
907 | (rest (mklist (type-expand-to 'boolean type))) |
908 | (size-of `(signed-byte ,size)))) |
9adccb27 |
909 | |
75689fea |
910 | (define-type-method to-alien-form ((type boolean) boolean) |
911 | (declare (ignore type)) |
310da1d5 |
912 | `(if ,boolean 1 0)) |
913 | |
75689fea |
914 | (define-type-method to-alien-function ((type boolean)) |
915 | (declare (ignore type)) |
9adccb27 |
916 | #'(lambda (boolean) |
917 | (if boolean 1 0))) |
918 | |
75689fea |
919 | (define-type-method from-alien-form ((type boolean) boolean) |
920 | (declare (ignore type)) |
9adccb27 |
921 | `(not (zerop ,boolean))) |
922 | |
75689fea |
923 | (define-type-method from-alien-function ((type boolean)) |
924 | (declare (ignore type)) |
9adccb27 |
925 | #'(lambda (boolean) |
926 | (not (zerop boolean)))) |
927 | |
75689fea |
928 | (define-type-method writer-function ((type boolean)) |
929 | (destructuring-bind (&optional (size '*)) |
930 | (rest (mklist (type-expand-to 'boolean type))) |
931 | (let ((writer (writer-function `(signed-byte ,size)))) |
932 | #'(lambda (boolean location &optional (offset 0)) |
933 | (funcall writer (if boolean 1 0) location offset))))) |
934 | |
935 | (define-type-method reader-function ((type boolean)) |
936 | (destructuring-bind (&optional (size '*)) |
937 | (rest (mklist (type-expand-to 'boolean type))) |
938 | (let ((reader (reader-function `(signed-byte ,size)))) |
939 | #'(lambda (location &optional (offset 0) weak-p) |
940 | (declare (ignore weak-p)) |
941 | (not (zerop (funcall reader location offset))))))) |
942 | |
943 | |
944 | (define-type-method alien-type ((type or)) |
945 | (let* ((expanded-type (type-expand-to 'or type)) |
946 | (alien-type (alien-type (second expanded-type)))) |
9adccb27 |
947 | (unless (every #'(lambda (type) |
948 | (eq alien-type (alien-type type))) |
75689fea |
949 | (cddr expanded-type)) |
950 | (error "No common alien type specifier for union type: ~A" type)) |
310da1d5 |
951 | alien-type)) |
952 | |
75689fea |
953 | (define-type-method size-of ((type or)) |
954 | (size-of (second (type-expand-to 'or type)))) |
9adccb27 |
955 | |
75689fea |
956 | (define-type-method to-alien-form ((type or) form) |
9adccb27 |
957 | `(let ((value ,form)) |
75689fea |
958 | (etypecase value |
959 | ,@(mapcar |
960 | #'(lambda (type) |
961 | `(,type ,(to-alien-form type 'value))) |
962 | (rest (type-expand-to 'or type)))))) |
963 | |
964 | (define-type-method to-alien-function ((type or)) |
965 | (let* ((expanded-type (type-expand-to 'or type)) |
966 | (functions (mapcar #'to-alien-function (rest expanded-type)))) |
9adccb27 |
967 | #'(lambda (value) |
968 | (loop |
969 | for function in functions |
75689fea |
970 | for alt-type in (rest expanded-type) |
971 | when (typep value alt-type) |
9adccb27 |
972 | do (return (funcall function value)) |
75689fea |
973 | finally (error "~S is not of type ~A" value type))))) |
974 | |
9adccb27 |
975 | |
75689fea |
976 | (define-type-method alien-type ((type pointer)) |
977 | (declare (ignore type)) |
310da1d5 |
978 | 'system-area-pointer) |
979 | |
75689fea |
980 | (define-type-method size-of ((type pointer)) |
981 | (declare (ignore type)) |
9adccb27 |
982 | +size-of-pointer+) |
310da1d5 |
983 | |
75689fea |
984 | (define-type-method to-alien-form ((type pointer) form) |
985 | (declare (ignore type)) |
986 | form) |
987 | |
988 | (define-type-method to-alien-function ((type pointer)) |
989 | (declare (ignore type)) |
990 | #'identity) |
991 | |
992 | (define-type-method from-alien-form ((type pointer) form) |
993 | (declare (ignore type)) |
994 | form) |
995 | |
996 | (define-type-method from-alien-function ((type pointer)) |
997 | (declare (ignore type)) |
998 | #'identity) |
999 | |
1000 | (define-type-method writer-function ((type pointer)) |
1001 | (declare (ignore type)) |
9adccb27 |
1002 | #'(lambda (sap location &optional (offset 0)) |
1003 | (setf (sap-ref-sap location offset) sap))) |
310da1d5 |
1004 | |
75689fea |
1005 | (define-type-method reader-function ((type pointer)) |
1006 | (declare (ignore type)) |
3005806e |
1007 | #'(lambda (location &optional (offset 0) weak-p) |
1008 | (declare (ignore weak-p)) |
9adccb27 |
1009 | (sap-ref-sap location offset))) |
310da1d5 |
1010 | |
1011 | |
75689fea |
1012 | (define-type-method alien-type ((type null)) |
1013 | (declare (ignore type)) |
9adccb27 |
1014 | (alien-type 'pointer)) |
310da1d5 |
1015 | |
75689fea |
1016 | (define-type-method size-of ((type null)) |
1017 | (declare (ignore type)) |
9adccb27 |
1018 | (size-of 'pointer)) |
1019 | |
75689fea |
1020 | (define-type-method to-alien-form ((type null) null) |
1021 | (declare (ignore null type)) |
310da1d5 |
1022 | `(make-pointer 0)) |
1023 | |
75689fea |
1024 | (define-type-method to-alien-function ((type null)) |
1025 | (declare (ignore type)) |
9adccb27 |
1026 | #'(lambda (null) |
1027 | (declare (ignore null)) |
1028 | (make-pointer 0))) |
310da1d5 |
1029 | |
310da1d5 |
1030 | |
75689fea |
1031 | (define-type-method alien-type ((type nil)) |
1032 | (declare (ignore type)) |
73572c12 |
1033 | 'void) |
9adccb27 |
1034 | |
75689fea |
1035 | (define-type-method from-alien-function ((type nil)) |
1036 | (declare (ignore type)) |
9adccb27 |
1037 | #'(lambda (value) |
1038 | (declare (ignore value)) |
1039 | (values))) |
9ca5565a |
1040 | |
75689fea |
1041 | (define-type-method to-alien-form ((type nil) form) |
9ca5565a |
1042 | (declare (ignore type)) |
75689fea |
1043 | form) |
9ca5565a |
1044 | |
9ca5565a |
1045 | |
75689fea |
1046 | (define-type-method to-alien-form ((type copy-of) form) |
1047 | (copy-to-alien-form (second (type-expand-to 'copy-of type)) form)) |
9ca5565a |
1048 | |
75689fea |
1049 | (define-type-method to-alien-function ((type copy-of)) |
1050 | (copy-to-alien-function (second (type-expand-to 'copy-of type)))) |
9ca5565a |
1051 | |
75689fea |
1052 | (define-type-method from-alien-form ((type copy-of) form) |
1053 | (copy-from-alien-form (second (type-expand-to 'copy-of type)) form)) |
9ca5565a |
1054 | |
75689fea |
1055 | (define-type-method from-alien-function ((type copy-of)) |
1056 | (copy-from-alien-function (second (type-expand-to 'copy-of type)))) |
9ca5565a |
1057 | |
cdd375f3 |
1058 | |
75689fea |
1059 | (define-type-method alien-type ((type callback)) |
cdd375f3 |
1060 | (declare (ignore type)) |
46759268 |
1061 | (alien-type 'pointer)) |
1062 | |
75689fea |
1063 | (define-type-method to-alien-form ((type callback) callback) |
1064 | (declare (ignore type )) |
586328b4 |
1065 | `(callback-address ,callback)) |