560af5c5 |
1 | ;; Common Lisp bindings for GTK+ v2.0 |
2 | ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no> |
3 | ;; |
4 | ;; This library is free software; you can redistribute it and/or |
5 | ;; modify it under the terms of the GNU Lesser General Public |
6 | ;; License as published by the Free Software Foundation; either |
7 | ;; version 2 of the License, or (at your option) any later version. |
8 | ;; |
9 | ;; This library is distributed in the hope that it will be useful, |
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;; Lesser General Public License for more details. |
13 | ;; |
14 | ;; You should have received a copy of the GNU Lesser General Public |
15 | ;; License along with this library; if not, write to the Free Software |
16 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
17 | |
fb754a8b |
18 | ;; $Id: gtype.lisp,v 1.3 2000-08-23 14:27:41 espen Exp $ |
560af5c5 |
19 | |
20 | (in-package "GLIB") |
21 | |
22 | (use-prefix "g") |
23 | |
24 | |
25 | ;;;; |
26 | |
27 | (deftype type-number () '(unsigned 32)) |
28 | |
29 | (define-foreign ("g_type_name" alien-type-name) (type) (static string) |
30 | ((find-type-number type) type-number)) |
31 | |
32 | (define-foreign %type-from-name () type-number |
33 | (name string)) |
34 | |
35 | ;(define-foreign type-parent () type-number |
36 | ; (type type-number)) |
37 | |
38 | (define-foreign type-instance-size (type) int |
39 | ((find-type-number type) type-number)) |
40 | |
41 | (define-foreign type-create-instance (type) pointer |
42 | ((find-type-number type) type-number)) |
43 | |
44 | (define-foreign type-free-instance () nil |
45 | (instance pointer)) |
46 | |
47 | |
48 | (defvar *type-to-number-hash* (make-hash-table)) |
49 | (defvar *number-to-type-hash* (make-hash-table)) |
50 | |
51 | (defun type-number-from-alien-name (name &optional (error t)) |
52 | (if (string= name "invalid") |
53 | 0 |
54 | (let ((type-number (%type-from-name name))) |
55 | (cond |
56 | ((and (zerop type-number) error) |
57 | (error "Invalid alien type name: ~A" name)) |
58 | ((zerop type-number) nil) |
59 | (t type-number))))) |
60 | |
61 | (defun (setf alien-type-name) (alien-name type) |
62 | (let ((type-name (ensure-type-name type)) |
63 | (type-number (type-number-from-alien-name alien-name))) |
64 | (setf (gethash type-number *number-to-type-hash*) type-name) |
65 | (setf (gethash type-name *type-to-number-hash*) type-number))) |
66 | |
67 | (defun (setf find-type-number) (type-number type) |
68 | (setf (gethash (ensure-type-name type) *type-to-number-hash*) type-number)) |
69 | |
70 | (defun find-type-number (type) |
71 | (etypecase type |
72 | (integer type) |
73 | (symbol (gethash type *type-to-number-hash*)) |
74 | (pcl::class (gethash (class-name type) *type-to-number-hash*)))) |
75 | |
76 | (defun type-from-number (type-number) |
77 | (gethash type-number *number-to-type-hash*)) |
78 | |
79 | (defun type-number-of (object) |
80 | (find-type-number (type-of object))) |
81 | |
82 | |
83 | |
84 | ;;;; Superclass for all metaclasses implementing some sort of virtual slots |
85 | |
86 | (eval-when (:compile-toplevel :load-toplevel :execute) |
87 | (defclass virtual-class (pcl::standard-class)) |
88 | |
89 | (defclass direct-virtual-slot-definition (standard-direct-slot-definition) |
90 | ((location |
91 | :reader slot-definition-location |
92 | :initarg :location))) |
93 | |
94 | (defclass effective-virtual-slot-definition |
95 | (standard-effective-slot-definition))) |
96 | |
97 | |
98 | (defmethod direct-slot-definition-class ((class virtual-class) initargs) |
99 | (if (eq (getf initargs :allocation) :virtual) |
100 | (find-class 'direct-virtual-slot-definition) |
101 | (call-next-method))) |
102 | |
103 | |
104 | (defmethod effective-slot-definition-class ((class virtual-class) initargs) |
105 | (if (eq (getf initargs :allocation) :virtual) |
106 | (find-class 'effective-virtual-slot-definition) |
107 | (call-next-method))) |
108 | |
109 | |
110 | (defun %direct-slot-definitions-slot-value (slotds slot &optional default) |
111 | (let ((slotd |
112 | (find-if |
113 | #'(lambda (slotd) |
114 | (and |
115 | (slot-exists-p slotd slot) |
116 | (slot-boundp slotd slot))) |
117 | slotds))) |
118 | (if slotd |
119 | (slot-value slotd slot) |
120 | default))) |
121 | |
122 | |
123 | (defgeneric compute-virtual-slot-location (class slotd direct-slotds)) |
124 | |
125 | (defmethod compute-virtual-slot-location |
126 | ((class virtual-class) |
127 | (slotd effective-virtual-slot-definition) |
128 | direct-slotds) |
129 | (let ((location |
130 | (%direct-slot-definitions-slot-value direct-slotds 'location))) |
131 | (if (and location (symbolp location)) |
132 | (list location `(setf ,location)) |
133 | location))) |
134 | |
135 | |
136 | (defmethod compute-effective-slot-definition |
137 | ((class virtual-class) direct-slotds) |
138 | (let ((slotd (call-next-method))) |
139 | (when (typep slotd 'effective-virtual-slot-definition) |
140 | (setf |
141 | (slot-value slotd 'pcl::location) |
142 | (compute-virtual-slot-location class slotd direct-slotds))) |
143 | slotd)) |
144 | |
145 | |
146 | (defmethod slot-value-using-class |
147 | ((class virtual-class) (object standard-object) |
148 | (slotd effective-virtual-slot-definition)) |
149 | (let ((reader (first (slot-definition-location slotd)))) |
150 | (if reader |
151 | (funcall reader object) |
152 | (slot-unbound class object (slot-definition-name slotd))))) |
153 | |
154 | |
155 | (defmethod slot-boundp-using-class |
156 | ((class virtual-class) (object standard-object) |
157 | (slotd effective-virtual-slot-definition)) |
158 | (and (first (slot-definition-location slotd)) t)) |
159 | |
160 | |
161 | |
162 | (defmethod (setf slot-value-using-class) |
163 | (value (class virtual-class) (object standard-object) |
164 | (slotd effective-virtual-slot-definition)) |
165 | (let ((writer (second (slot-definition-location slotd)))) |
166 | (cond |
167 | ((null writer) |
168 | (error |
169 | "Can't set read-only slot ~A in ~A" |
170 | (slot-definition-name slotd) |
171 | object)) |
172 | ((or (functionp writer) (symbolp writer)) |
173 | (funcall writer value object) |
174 | object) |
175 | (t |
176 | (funcall (fdefinition writer) value object) |
177 | object)))) |
178 | |
179 | |
180 | (defmethod validate-superclass |
181 | ((class virtual-class) (super pcl::standard-class)) |
182 | t) |
183 | |
184 | |
185 | |
186 | ;;;; Superclass for wrapping of C structures |
187 | |
188 | (eval-when (:compile-toplevel :load-toplevel :execute) |
189 | (defclass alien-instance () |
190 | ((location |
191 | :reader alien-instance-location |
192 | :type system-area-pointer))) |
193 | |
194 | (defgeneric allocate-alien-storage (class)) |
195 | (defgeneric reference-instance (object)) |
196 | (defgeneric unreference-instance (object)) |
197 | (defgeneric from-alien-initialize-instance (object &rest initargs)) |
198 | (defgeneric instance-finalizer (object))) |
199 | |
200 | |
201 | (internal *instance-cache*) |
202 | (defvar *instance-cache* (make-hash-table :test #'eql)) |
203 | |
204 | (defun cache-instance (object) |
205 | (setf |
206 | (gethash (system:sap-int (alien-instance-location object)) *instance-cache*) |
207 | (ext:make-weak-pointer object))) |
208 | |
209 | (defun find-cached-instance (location) |
210 | (let ((ref (gethash (system:sap-int location) *instance-cache*))) |
211 | (when ref |
212 | (ext:weak-pointer-value ref)))) |
213 | |
214 | (defun remove-cached-instance (location) |
215 | (remhash (system:sap-int location) *instance-cache*)) |
216 | |
217 | |
218 | (defmethod initialize-instance :before ((instance alien-instance) |
219 | &rest initargs &key) |
220 | (declare (ignore initargs)) |
221 | (setf |
222 | (slot-value instance 'location) |
223 | (allocate-alien-storage (class-of instance))) |
224 | (cache-instance instance) |
225 | (ext:finalize instance (instance-finalizer instance))) |
226 | |
227 | |
228 | (defmethod from-alien-initialize-instance ((instance alien-instance) |
229 | &rest initargs &key location) |
230 | (declare (ignore initargs)) |
231 | (setf (slot-value instance 'location) location) |
232 | (cache-instance instance)) |
233 | |
234 | |
235 | (deftype-method translate-type-spec alien-instance (type-spec) |
236 | (declare (ignore type-spec)) |
237 | 'system-area-pointer) |
238 | |
239 | |
240 | |
241 | ;;;; Metaclass used for subclasses of alien-instance |
242 | |
243 | (eval-when (:compile-toplevel :load-toplevel :execute) |
244 | (defclass alien-class (virtual-class) |
245 | ((size |
246 | :reader alien-class-size))) |
247 | |
248 | (defclass direct-alien-slot-definition (direct-virtual-slot-definition) |
249 | ((allocation |
250 | :initform :alien) |
251 | (offset |
252 | :reader slot-definition-offset |
253 | :initarg :offset |
254 | :initform 0))) |
255 | |
256 | (defclass effective-alien-slot-definition (effective-virtual-slot-definition) |
257 | ((offset |
258 | :reader slot-definition-offset))) |
259 | |
260 | (defclass effective-virtual-alien-slot-definition |
261 | (effective-virtual-slot-definition)) |
262 | |
263 | |
264 | (defmethod alien-class-superclass ((class alien-class)) |
265 | (find-if |
266 | #'(lambda (class) |
267 | (subtypep (class-name class) 'alien-instance)) |
268 | (pcl::class-direct-superclasses class))) |
269 | |
270 | |
271 | (defmethod shared-initialize ((class alien-class) names |
272 | &rest initargs &key size alien-name name) |
273 | (declare (ignore initargs)) |
274 | (call-next-method) |
275 | |
560af5c5 |
276 | (when alien-name |
277 | (setf (alien-type-name (or name (class-name class))) (first alien-name))) |
278 | (when size |
279 | (setf (slot-value class 'size) (first size)))) |
280 | |
281 | |
282 | (defmethod shared-initialize :after ((class alien-class) names |
283 | &rest initargs &key) |
284 | (declare (ignore initargs names)) |
285 | (let* ((super (alien-class-superclass class)) |
286 | (actual-size |
287 | (if (eq (class-name super) 'alien-instance) |
288 | 0 |
289 | (alien-class-size super)))) |
290 | (dolist (slotd (class-slots class)) |
291 | (when (eq (slot-definition-allocation slotd) :alien) |
292 | (with-slots (offset type) slotd |
293 | (setq actual-size (max actual-size (+ offset (size-of type))))))) |
294 | (cond |
295 | ((not (slot-boundp class 'size)) |
296 | (setf (slot-value class 'size) actual-size)) |
297 | ((> actual-size (slot-value class 'size)) |
298 | (warn "The actual size of class ~A is lager than specified" class))))) |
299 | |
300 | |
301 | (defmethod direct-slot-definition-class ((class alien-class) initargs) |
302 | (case (getf initargs :allocation) |
303 | ((nil :alien) (find-class 'direct-alien-slot-definition)) |
304 | ; (:instance (error "Allocation :instance not allowed in class ~A" class)) |
305 | (t (call-next-method)))) |
306 | |
307 | |
308 | (defmethod effective-slot-definition-class ((class alien-class) initargs) |
309 | (case (getf initargs :allocation) |
310 | (:alien (find-class 'effective-alien-slot-definition)) |
311 | (:virtual (find-class 'effective-virtual-alien-slot-definition)) |
312 | (t (call-next-method)))) |
313 | |
314 | |
315 | (defmethod compute-virtual-slot-location |
316 | ((class alien-class) (slotd effective-alien-slot-definition) |
317 | direct-slotds) |
318 | (with-slots (offset type) slotd |
319 | (setf offset (%direct-slot-definitions-slot-value direct-slotds 'offset)) |
320 | (let ((reader (get-reader-function type)) |
321 | (writer (get-writer-function type)) |
322 | (destroy (get-destroy-function type))) |
323 | (list |
324 | #'(lambda (object) |
325 | (funcall reader (alien-instance-location object) offset)) |
326 | #'(lambda (value object) |
327 | (let ((location (alien-instance-location object))) |
328 | (funcall destroy location offset) |
329 | (funcall writer value location offset))))))) |
330 | |
331 | |
332 | (defmethod compute-virtual-slot-location |
333 | ((class alien-class) |
334 | (slotd effective-virtual-alien-slot-definition) |
335 | direct-slotds) |
336 | (let ((location (call-next-method))) |
337 | (if (or (stringp location) (consp location)) |
338 | (destructuring-bind (reader &optional writer) (mklist location) |
339 | (with-slots (type) slotd |
340 | (list |
341 | (if (stringp reader) |
342 | (let* ((alien-type (translate-type-spec type)) |
343 | (alien |
344 | (alien::%heap-alien |
345 | (alien::make-heap-alien-info |
346 | :type (alien::parse-alien-type |
347 | `(function ,alien-type system-area-pointer)) |
348 | :sap-form (system:foreign-symbol-address reader)))) |
349 | (from-alien (get-from-alien-function type))) |
350 | #'(lambda (object) |
351 | (funcall |
352 | from-alien |
353 | (alien-funcall |
354 | alien (alien-instance-location object))))) |
355 | reader) |
356 | (if (stringp writer) |
357 | (let* ((alien-type (translate-type-spec type)) |
358 | (alien |
359 | (alien::%heap-alien |
360 | (alien::make-heap-alien-info |
361 | :type (alien::parse-alien-type |
362 | `(function |
363 | void ,alien-type system-area-pointer)) |
364 | :sap-form (system:foreign-symbol-address writer)))) |
365 | (to-alien (get-to-alien-function type)) |
366 | (cleanup (get-cleanup-function type))) |
367 | #'(lambda (value object) |
368 | (let ((alien-value (funcall to-alien value)) |
369 | (location (alien-instance-location object))) |
370 | (alien-funcall alien location alien-value) |
371 | (funcall cleanup alien-value)))) |
372 | writer)))) |
373 | location))) |
374 | |
375 | |
376 | (defmethod compute-slots ((class alien-class)) |
377 | ;; Translating the user supplied relative (to previous slot) offsets |
378 | ;; to absolute offsets. |
379 | ;; This code is broken and have to be fixed for real use. |
380 | (with-slots (direct-slots) class |
381 | (let* ((super (alien-class-superclass class)) |
382 | (slot-offset |
383 | (if (eq (class-name super) 'alien-instance) |
384 | 0 |
385 | (alien-class-size super)))) |
386 | (dolist (slotd direct-slots) |
387 | (when (eq (slot-definition-allocation slotd) :alien) |
388 | (with-slots (offset type) slotd |
389 | (setf |
390 | offset (+ slot-offset offset) |
391 | slot-offset (+ offset (size-of type))))))) |
392 | |
393 | ;; Reverse the direct slot definitions so the effective slots |
394 | ;; will be in correct order. |
7aa7bd27 |
395 | (setf direct-slots (reverse direct-slots)) |
396 | ;; This nreverse caused me so much frustration that I leave it |
397 | ;; here just as a reminder of what not to do. |
398 | ; (setf direct-slots (nreverse direct-slots)) |
399 | ) |
560af5c5 |
400 | (call-next-method)) |
401 | |
402 | |
403 | (defmethod validate-superclass ((class alien-class) |
404 | (super pcl::standard-class)) |
405 | (subtypep (class-name super) 'alien-instance)) |
406 | |
407 | (defgeneric make-instance-from-alien (class location &rest initargs &key))) |
408 | |
409 | (defmethod make-instance-from-alien ((class symbol) location |
410 | &rest initargs &key) |
411 | (apply #'make-instance-from-alien (find-class class) location initargs)) |
412 | |
413 | (defmethod make-instance-from-alien ((class alien-class) location |
414 | &rest initargs &key) |
415 | (let ((instance (allocate-instance class))) |
416 | (apply |
417 | #'from-alien-initialize-instance |
418 | instance :location location initargs) |
419 | instance)) |
420 | |
421 | (defun ensure-alien-instance (class location &rest initargs) |
422 | (or |
423 | (find-cached-instance location) |
424 | (apply #'make-instance-from-alien class location initargs))) |
425 | |
426 | (defmethod allocate-alien-storage ((class alien-class)) |
427 | (allocate-memory (alien-class-size class))) |
428 | |
429 | |
430 | |
431 | ;;;; Superclass for wrapping structures with reference counting |
432 | |
433 | (eval-when (:compile-toplevel :load-toplevel :execute) |
434 | (defclass alien-object (alien-instance) |
435 | () |
436 | (:metaclass alien-class) |
437 | (:size 0))) |
438 | |
439 | (define-type-method-fun alien-ref (type-spec)) |
440 | (define-type-method-fun alien-unref (type-spec)) |
441 | |
442 | (defmethod from-alien-initialize-instance ((object alien-object) |
443 | &rest initargs &key) |
444 | (declare (ignore initargs)) |
445 | (call-next-method) |
446 | (reference-instance object)) |
447 | |
448 | (defmethod instance-finalizer ((object alien-object)) |
449 | (let ((location (alien-instance-location object)) |
450 | (unref (fdefinition (alien-unref (class-of object))))) |
451 | (declare (type system-area-pointer location) (type function unref)) |
452 | #'(lambda () |
453 | (remove-cached-instance location) |
454 | (funcall unref location)))) |
455 | |
456 | (defmethod reference-instance ((object alien-object)) |
457 | (funcall (alien-ref (class-of object)) object) |
458 | object) |
459 | |
460 | (defmethod unreference-instance ((object alien-object)) |
461 | (funcall (alien-unref (class-of object)) object) |
462 | nil) |
463 | |
464 | (deftype-method translate-to-alien |
465 | alien-object (type-spec object &optional copy) |
466 | (if copy |
467 | `(,(alien-ref type-spec) ,object) |
468 | `(alien-instance-location ,object))) |
469 | |
470 | (deftype-method translate-from-alien |
471 | alien-object (type-spec location &optional alloc) |
fb754a8b |
472 | ;; Reference counted objects are always treated as if alloc were :reference |
473 | (declare (ignore alloc)) |
560af5c5 |
474 | `(let ((location ,location)) |
475 | (unless (null-pointer-p location) |
476 | (ensure-alien-instance ',type-spec location)))) |
477 | |
478 | (deftype-method |
479 | cleanup-alien alien-object (type-spec sap &optional copied) |
480 | (when copied |
481 | `(let ((sap ,sap)) |
482 | (unless (null-pointer-p sap) |
483 | (,(alien-unref type-spec) sap))))) |
484 | |
485 | |
486 | |
487 | ;;;; Superclass for wrapping of non-refcounted structures |
488 | |
489 | (eval-when (:compile-toplevel :load-toplevel :execute) |
490 | (defclass alien-structure (alien-instance) |
491 | ((static |
492 | :allocation :instance |
493 | :reader alien-structure-static-p |
494 | :initform nil |
495 | :type boolean)) |
496 | (:metaclass alien-class) |
497 | (:size 0))) |
498 | |
499 | (define-type-method-fun alien-copier (type-spec)) |
500 | (define-type-method-fun alien-deallocator (type-spec)) |
501 | |
502 | (defmethod from-alien-initialize-instance ((structure alien-structure) |
503 | &rest initargs &key static) |
504 | (declare (ignore initargs)) |
505 | (call-next-method) |
506 | (setf (slot-value structure 'static) static)) |
507 | |
508 | (defmethod instance-finalizer ((structure alien-structure)) |
509 | (let ((location (alien-instance-location structure))) |
510 | (declare (type system-area-pointer location)) |
511 | (if (alien-structure-static-p structure) |
512 | #'(lambda () |
513 | (remove-cached-instance location)) |
514 | (let ((deallocator |
515 | (fdefinition (alien-deallocator (class-of structure))))) |
516 | (declare (type function deallocator)) |
517 | #'(lambda () |
518 | (remove-cached-instance location) |
519 | (funcall deallocator location)))))) |
520 | |
521 | |
522 | (deftype-method alien-copier alien-structure (type-spec) |
523 | (declare (ignore type-spec)) |
524 | 'copy-memory) |
525 | |
526 | (deftype-method alien-deallocator alien-structure (type-spec) |
527 | (declare (ignore type-spec)) |
528 | 'deallocate-memory) |
529 | |
530 | (deftype-method translate-to-alien |
531 | alien-structure (type-spec object &optional copy) |
532 | `(let ((object ,object)) |
533 | (if (and ,copy (not (alien-structure-static-p object))) |
534 | (,(alien-copier type-spec) |
535 | `(alien-instance-location object) |
536 | ,(alien-class-size (find-class type-spec))) |
537 | (alien-instance-location object)))) |
538 | |
539 | (deftype-method translate-from-alien |
fb754a8b |
540 | alien-structure (type-spec location &optional (alloc :reference)) |
560af5c5 |
541 | `(let ((location ,location)) |
542 | (unless (null-pointer-p location) |
543 | ,(ecase alloc |
fb754a8b |
544 | (:copy `(ensure-alien-instance ',type-spec location)) |
560af5c5 |
545 | (:static `(ensure-alien-instance ',type-spec location :static t)) |
fb754a8b |
546 | (:reference |
547 | `(ensure-alien-instance |
548 | ',type-spec |
549 | `(,(alien-copier type-spec) |
550 | location ,(alien-class-size (find-class type-spec))))))))) |
560af5c5 |
551 | |
552 | (deftype-method cleanup-alien alien-structure (type-spec sap &optional copied) |
553 | (when copied |
554 | `(let ((sap ,sap)) |
555 | (unless (or |
556 | (null-pointer-p sap) |
557 | (alien-structure-static-p (find-cached-instance sap))) |
558 | (,(alien-deallocator type-spec) sap))))) |
559 | |
560 | |
561 | |
562 | ;;;; Superclass for static structures such as gdk:visual |
563 | |
564 | (defclass static-structure (alien-structure) |
565 | () |
566 | (:metaclass alien-class) |
567 | (:size 0)) |
568 | |
569 | |
570 | (defmethod from-alien-initialize-instance ((structure alien-structure) |
571 | &rest initargs) |
572 | (declare (ignore initargs)) |
573 | (call-next-method) |
574 | (setf (slot-value structure 'static) t)) |
575 | |
576 | |
577 | |
578 | ;;;; Superclass wrapping types in the glib type system |
579 | |
580 | (eval-when (:compile-toplevel :load-toplevel :execute) |
581 | (defclass gtype (alien-object) |
582 | () |
583 | (:metaclass alien-class) |
584 | (:size 4 #|(size-of 'pointer)|#))) |
585 | |
586 | |
587 | (defun %alien-instance-type-number (location) |
588 | (let ((class (sap-ref-sap location 0))) |
589 | (sap-ref-unsigned class 0))) |
590 | |
591 | |
592 | (deftype-method translate-from-alien gtype (type-spec location &optional alloc) |
593 | (declare (ignore type-spec alloc)) |
594 | `(let ((location ,location)) |
595 | (unless (null-pointer-p location) |
596 | (ensure-alien-instance |
597 | (type-from-number (%alien-instance-type-number location)) |
598 | location)))) |
599 | |
600 | |
601 | |
602 | ;;;; Metaclass for subclasses of gtype-class |
603 | |
604 | (eval-when (:compile-toplevel :load-toplevel :execute) |
605 | (defclass gtype-class (alien-class))) |
606 | |
607 | |
608 | (defmethod shared-initialize ((class gtype-class) names |
609 | &rest initargs &key name) |
610 | (declare (ignore initargs names)) |
611 | (call-next-method) |
612 | (setf |
613 | (slot-value class 'size) |
614 | (type-instance-size (find-type-number (or name (class-name class)))))) |
615 | |
616 | |
617 | (defmethod validate-superclass |
618 | ((class gtype-class) (super pcl::standard-class)) |
619 | (subtypep (class-name super) 'gtype)) |
620 | |
621 | |
622 | (defmethod allocate-alien-storage ((class gtype-class)) |
623 | (type-create-instance (find-type-number class))) |
624 | |
625 | |
626 | ;;;; Initializing type numbers |
627 | |
628 | (setf (alien-type-name 'invalid) "invalid") |
629 | (setf (alien-type-name 'char) "gchar") |
630 | (setf (alien-type-name 'unsigned-char) "guchar") |
631 | (setf (alien-type-name 'boolean) "gboolean") |
632 | (setf (alien-type-name 'int) "gint") |
633 | (setf (alien-type-name 'unsigned-int) "guint") |
634 | (setf (alien-type-name 'long) "glong") |
635 | (setf (alien-type-name 'unsigned-long) "gulong") |
636 | (setf (alien-type-name 'enum) "GEnum") |
637 | (setf (alien-type-name 'flags) "GFlags") |
638 | (setf (alien-type-name 'single-float) "gfloat") |
639 | (setf (alien-type-name 'double-float) "gdouble") |
640 | (setf (alien-type-name 'string) "gstring") |
641 | (setf (find-type-number 'fixnum) (find-type-number 'int)) |