3 (defun generated-cstruct-name (symbol)
4 (or (get symbol
'generated-cstruct-name
)
5 (setf (get symbol
'generated-cstruct-name
) (gensym (format nil
"GEN-~A-CSTRUCT-" (symbol-name symbol
))))))
7 (defun generated-cunion-name (symbol)
8 (or (get symbol
'generated-cunion-name
)
9 (setf (get symbol
'generated-cunion-name
) (gensym (format nil
"GEN-~A-CSTRUCT-" (symbol-name symbol
))))))
11 (defun generate-cstruct-1 (struct)
12 `(defcstruct ,(generated-cstruct-name (var-structure-name struct
))
13 ,@(iter (for slot in
(var-struct-all-slots struct
))
14 (collect `(,(var-structure-slot-name slot
) ,(var-structure-slot-type slot
)
15 ,@(when (var-structure-slot-count slot
)
16 (list `(:count
,(var-structure-slot-count slot
)))))))))
18 (defun generate-c-structures (structure)
19 (iter (for str in
(all-structures structure
))
20 (collect (generate-cstruct-1 str
))))
22 (defun generate-union-1 (struct)
23 `(defcunion ,(generated-cunion-name (var-structure-name struct
))
24 ,@(iter (for variant in
(all-structures struct
))
25 (unless (eq struct variant
)
26 (collect `(,(var-structure-name variant
)
27 ,(generated-cunion-name (var-structure-name variant
))))))))
29 (defun generate-unions (struct)
30 (iter (for str in
(all-structures struct
))
31 (collect (generate-union-1 str
))))
33 (defun generate-structure-1 (str)
34 `(defstruct ,(if (var-structure-parent str
)
35 `(,(var-structure-name str
) (:include
,(var-structure-name (var-structure-parent str
))
36 (,(var-structure-discriminator-slot (var-structure-parent str
))
37 ,(first (var-structure-variant-discriminating-values
39 (var-structure-variants
40 (var-structure-parent str
))
41 :key
#'var-structure-variant-structure
))))))
42 `,(var-structure-name str
))
43 ,@(iter (for slot in
(var-structure-slots str
))
44 (collect `(,(var-structure-slot-name slot
)
45 ,(var-structure-slot-initform slot
))))))
47 (defun generate-structures (str)
48 (iter (for variant in
(reverse (all-structures str
)))
49 (collect (generate-structure-1 variant
))))
51 (defun generate-native-type-decision-procedure-1 (str proxy-var
)
52 (if (null (var-structure-discriminator-slot str
))
53 `(values ',(generated-cstruct-name (var-structure-name str
))
54 ',(mapcar #'var-structure-slot-name
(var-struct-all-slots str
)))
56 ,@(iter (for variant in
(var-structure-variants str
))
57 (for v-str
= (var-structure-variant-structure variant
))
58 (collect `(,(var-structure-name v-str
)
59 ,(generate-native-type-decision-procedure-1 v-str proxy-var
))))
60 (,(var-structure-name str
)
61 (values ',(generated-cstruct-name (var-structure-name str
))
62 ',(mapcar #'var-structure-slot-name
(var-struct-all-slots str
)))))))
64 (defun generate-proxy-type-decision-procedure-1 (str native-var
)
65 (if (null (var-structure-discriminator-slot str
))
66 `(values ',(var-structure-name str
)
67 ',(mapcar #'var-structure-slot-name
(var-struct-all-slots str
))
68 ',(generated-cstruct-name (var-structure-name str
)))
69 `(case (foreign-slot-value ,native-var
70 ',(generated-cstruct-name (var-structure-name str
))
71 ',(var-structure-discriminator-slot str
))
72 ,@(iter (for variant in
(var-structure-variants str
))
73 (for v-str
= (var-structure-variant-structure variant
))
74 (collect `(,(var-structure-variant-discriminating-values variant
)
75 ,(generate-proxy-type-decision-procedure-1
78 (t (values ',(var-structure-name str
)
79 ',(mapcar #'var-structure-slot-name
(var-struct-all-slots str
))
80 ',(generated-cstruct-name (var-structure-name str
)))))))
82 (defun generate-proxy-type-decision-procedure (str)
83 (let ((native (gensym "NATIVE-")))
85 ,(generate-proxy-type-decision-procedure-1 str native
))))
87 (defun generate-native-type-decision-procedure (str)
88 (let ((proxy (gensym "PROXY-")))
90 ,(generate-native-type-decision-procedure-1 str proxy
))))
92 (defun compile-proxy-type-decision-procedure (str)
93 (compile nil
(generate-proxy-type-decision-procedure str
)))
95 (defun compile-native-type-decision-procedure (str)
96 (compile nil
(generate-native-type-decision-procedure str
)))
98 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info
))
100 native-type-decision-procedure
101 proxy-type-decision-procedure
)
103 (defmethod make-load-form ((object g-boxed-variant-cstruct-info
) &optional env
)
104 (make-load-form-saving-slots object
:environment env
))
106 (defmacro define-boxed-variant-cstruct
(name g-type-name
&body slots
)
107 (let* ((structure (parse-variant-structure-definition name slots
)))
108 `(progn ,@(generate-c-structures structure
)
109 ,@(generate-unions structure
)
110 ,@(generate-structures structure
)
111 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
112 (setf (get ',name
'g-boxed-foreign-info
)
113 (make-g-boxed-variant-cstruct-info :name
',name
116 :native-type-decision-procedure
117 ,(generate-native-type-decision-procedure structure
)
118 :proxy-type-decision-procedure
119 ,(generate-proxy-type-decision-procedure structure
)))))))
121 (defun decide-native-type (info proxy
)
122 (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info
) proxy
))
124 (defmethod create-temporary-native ((type g-boxed-variant-cstruct-info
) proxy
)
125 (multiple-value-bind (actual-cstruct slots
) (decide-native-type type proxy
)
126 (let ((native-structure (foreign-alloc
127 (generated-cstruct-name
129 (g-boxed-variant-cstruct-info-root type
))))))
130 (iter (for slot in slots
)
131 (setf (foreign-slot-value native-structure actual-cstruct slot
)
132 (slot-value proxy slot
)))
135 (defun decide-proxy-type (info native-structure
)
136 (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info
) native-structure
))
138 (defmethod free-temporary-native ((type g-boxed-variant-cstruct-info
) proxy native-ptr
)
139 (multiple-value-bind (actual-struct slots actual-cstruct
) (decide-proxy-type type native-ptr
)
140 (unless (eq (type-of proxy
) actual-struct
)
142 (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
143 (type-of proxy
) actual-struct
)
144 (skip-parsing-values () (return-from free-temporary-native
))))
145 (iter (for slot in slots
)
146 (setf (slot-value proxy slot
)
147 (foreign-slot-value native-ptr actual-cstruct slot
)))))
149 (defmethod create-proxy-for-native ((type g-boxed-variant-cstruct-info
) native-ptr
)
150 (multiple-value-bind (actual-struct slots actual-cstruct
) (decide-proxy-type type native-ptr
)
151 (let ((proxy (make-instance actual-struct
)))
152 (iter (for slot in slots
)
153 (setf (slot-value proxy slot
)
154 (foreign-slot-value native-ptr actual-cstruct slot
)))
157 (defmethod create-reference-proxy ((type g-boxed-variant-cstruct-info
) native-ptr
)
158 (create-proxy-for-native type native-ptr
))
160 (defmethod free-reference-proxy ((type g-boxed-variant-cstruct-info
) proxy native-ptr
)
161 (multiple-value-bind (actual-cstruct slots
) (decide-native-type type proxy
)
162 (iter (for slot in slots
)
163 (setf (foreign-slot-value native-ptr actual-cstruct slot
)
164 (slot-value proxy slot
)))))