1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!ALIEN")
12 (defglobal *alien-type-classes
* (make-hash-table :test
'eq
))
14 (defvar *new-auxiliary-types
* nil
)
16 ;;; the list of record types that have already been unparsed. This is
17 ;;; used to keep from outputting the slots again if the same structure
19 (defvar *record-types-already-unparsed
*)
21 ;;; not documented in CMU CL:-(
23 ;;; reverse engineering observations:
24 ;;; * seems to be set when translating return values
25 ;;; * seems to enable the translation of (VALUES), which is the
26 ;;; Lisp idiom for C's return type "void" (which is likely
27 ;;; why it's set when when translating return values)
28 (defvar *values-type-okay
* nil
)
30 (defvar *default-c-string-external-format
* nil
)
32 (defmacro define-alien-type-translator
(name lambda-list
&body body
)
33 (let ((defun-name (symbolicate "ALIEN-" name
"-TYPE-TRANSLATOR")))
34 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
35 (setf (symbol-function ',defun-name
)
36 ,(make-macro-lambda defun-name lambda-list body
37 'define-alien-type-translator name
))
38 (%define-alien-type-translator
',name
#',defun-name
))))
40 ;;; Process stuff in a new scope.
41 (defmacro with-auxiliary-alien-types
(env &body body
)
42 ``(symbol-macrolet ((&auxiliary-type-definitions
&
43 ,(append *new-auxiliary-types
*
44 (auxiliary-type-definitions ,env
))))
45 ,(let ((*new-auxiliary-types
* nil
))
48 (defmacro define-alien-type
(name type
&environment env
)
49 "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for
50 STRUCT and UNION types, in which case the name is taken from the type
52 (with-auxiliary-alien-types env
53 (let ((alien-type (parse-alien-type type env
)))
54 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
55 ,@(when *new-auxiliary-types
*
56 `((%def-auxiliary-alien-types
',*new-auxiliary-types
*
57 (sb!c
:source-location
))))
59 `((%define-alien-type
',name
',alien-type
(sb!c
:source-location
))))))))
61 (defstruct (alien-type-class (:copier nil
))
62 (name nil
:type symbol
)
63 (defstruct-name nil
:type symbol
)
64 (include nil
:type
(or null alien-type-class
))
65 (unparse nil
:type
(or null function
))
66 (type= nil
:type
(or null function
))
67 (lisp-rep nil
:type
(or null function
))
68 (alien-rep nil
:type
(or null function
))
69 (extract-gen nil
:type
(or null function
))
70 (deposit-gen nil
:type
(or null function
))
71 (naturalize-gen nil
:type
(or null function
))
72 (deport-gen nil
:type
(or null function
))
73 (deport-alloc-gen nil
:type
(or null function
))
74 (deport-pin-p nil
:type
(or null function
))
76 (arg-tn nil
:type
(or null function
))
77 (result-tn nil
:type
(or null function
))
78 (subtypep nil
:type
(or null function
)))
80 (defmethod print-object ((type-class alien-type-class
) stream
)
81 (print-unreadable-object (type-class stream
:type t
)
82 (prin1 (alien-type-class-name type-class
) stream
)))
84 (defun alien-type-class-or-lose (name)
85 (or (gethash name
*alien-type-classes
*)
86 (error "no alien type class ~S" name
)))
88 (defun create-alien-type-class-if-necessary (name defstruct-name include
)
89 (let ((old (gethash name
*alien-type-classes
*))
90 (include (and include
(alien-type-class-or-lose include
))))
92 (setf (alien-type-class-include old
) include
)
93 (setf (gethash name
*alien-type-classes
*)
94 (make-alien-type-class :name name
95 :defstruct-name defstruct-name
98 (defconstant-eqx +method-slot-alist
+
99 '((:unparse . alien-type-class-unparse
)
100 (:type
= . alien-type-class-type
=)
101 (:subtypep . alien-type-class-subtypep
)
102 (:lisp-rep . alien-type-class-lisp-rep
)
103 (:alien-rep . alien-type-class-alien-rep
)
104 (:extract-gen . alien-type-class-extract-gen
)
105 (:deposit-gen . alien-type-class-deposit-gen
)
106 (:naturalize-gen . alien-type-class-naturalize-gen
)
107 (:deport-gen . alien-type-class-deport-gen
)
108 (:deport-alloc-gen . alien-type-class-deport-alloc-gen
)
109 (:deport-pin-p . alien-type-class-deport-pin-p
)
111 (:arg-tn . alien-type-class-arg-tn
)
112 (:result-tn . alien-type-class-result-tn
))
115 (defun method-slot (method)
116 (cdr (or (assoc method
+method-slot-alist
+)
117 (error "no method ~S" method
))))
119 (defmacro invoke-alien-type-method
(method type
&rest args
)
120 (let ((slot (method-slot method
)))
121 (once-only ((type type
))
122 `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type
))
123 (alien-type-class-include class
)))
125 (error "method ~S not defined for ~S"
126 ',method
(alien-type-class ,type
)))
127 (let ((fn (,slot class
)))
133 (defmacro maybe-with-pinned-objects
(variables types
&body body
)
134 (declare (ignorable variables types
))
136 ;; Only pin things on GENCGC, since on CHENEYGC it'd imply
137 ;; disabling the GC. Which is something we don't want to do
138 ;; every time we're calling to C.
140 (loop for variable in variables
142 when
(invoke-alien-type-method :deport-pin-p type
)
145 `(with-pinned-objects ,pin-variables