- ;; Reverse the direct slot definitions so the effective slots
- ;; will be in correct order.
- (setf direct-slots (reverse direct-slots))
- ;; This nreverse caused me so much frustration that I leave it
- ;; here just as a reminder of what not to do.
-; (setf direct-slots (nreverse direct-slots))
- )
- (call-next-method))
-
-
- (defmethod validate-superclass ((class alien-class)
- (super pcl::standard-class))
- (subtypep (class-name super) 'alien-instance))
-
- (defgeneric make-instance-from-alien (class location &rest initargs &key)))
-
-(defmethod make-instance-from-alien ((class symbol) location
- &rest initargs &key)
- (apply #'make-instance-from-alien (find-class class) location initargs))
-
-(defmethod make-instance-from-alien ((class alien-class) location
- &rest initargs &key)
- (let ((instance (allocate-instance class)))
- (apply
- #'from-alien-initialize-instance
- instance :location location initargs)
- instance))
-
-(defun ensure-alien-instance (class location &rest initargs)
- (or
- (find-cached-instance location)
- (apply #'make-instance-from-alien class location initargs)))
-
-(defmethod allocate-alien-storage ((class alien-class))
- (allocate-memory (alien-class-size class)))
-
-
-
-;;;; Superclass for wrapping structures with reference counting
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass alien-object (alien-instance)
- ()
- (:metaclass alien-class)
- (:size 0)))
-
-(define-type-method-fun alien-ref (type-spec))
-(define-type-method-fun alien-unref (type-spec))
-
-(defmethod from-alien-initialize-instance ((object alien-object)
- &rest initargs &key)
- (declare (ignore initargs))
- (call-next-method)
- (reference-instance object))
-
-(defmethod instance-finalizer ((object alien-object))
- (let ((location (alien-instance-location object))
- (unref (fdefinition (alien-unref (class-of object)))))
- (declare (type system-area-pointer location) (type function unref))
- #'(lambda ()
- (remove-cached-instance location)
- (funcall unref location))))
-
-(defmethod reference-instance ((object alien-object))
- (funcall (alien-ref (class-of object)) object)
- object)
-
-(defmethod unreference-instance ((object alien-object))
- (funcall (alien-unref (class-of object)) object)
- nil)
-
-(deftype-method translate-to-alien
- alien-object (type-spec object &optional copy)
- (if copy
- `(,(alien-ref type-spec) ,object)
- `(alien-instance-location ,object)))
-
-(deftype-method translate-from-alien
- alien-object (type-spec location &optional alloc)
- ;; Reference counted objects are always treated as if alloc were :reference
- (declare (ignore alloc))
- `(let ((location ,location))
- (unless (null-pointer-p location)
- (ensure-alien-instance ',type-spec location))))
-
-(deftype-method
- cleanup-alien alien-object (type-spec sap &optional copied)
- (when copied
- `(let ((sap ,sap))
- (unless (null-pointer-p sap)
- (,(alien-unref type-spec) sap)))))
-
-
-
-;;;; Superclass for wrapping of non-refcounted structures
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass alien-structure (alien-instance)
- ((static
- :allocation :instance
- :reader alien-structure-static-p
- :initform nil
- :type boolean))
- (:metaclass alien-class)
- (:size 0)))
-
-(define-type-method-fun alien-copier (type-spec))
-(define-type-method-fun alien-deallocator (type-spec))
-
-(defmethod from-alien-initialize-instance ((structure alien-structure)
- &rest initargs &key static)
- (declare (ignore initargs))
- (call-next-method)
- (setf (slot-value structure 'static) static))
-
-(defmethod instance-finalizer ((structure alien-structure))
- (let ((location (alien-instance-location structure)))
- (declare (type system-area-pointer location))
- (if (alien-structure-static-p structure)
- #'(lambda ()
- (remove-cached-instance location))
- (let ((deallocator
- (fdefinition (alien-deallocator (class-of structure)))))
- (declare (type function deallocator))
- #'(lambda ()
- (remove-cached-instance location)
- (funcall deallocator location))))))
-
-
-(deftype-method alien-copier alien-structure (type-spec)
- (declare (ignore type-spec))
- 'copy-memory)
-
-(deftype-method alien-deallocator alien-structure (type-spec)
- (declare (ignore type-spec))
- 'deallocate-memory)
-
-(deftype-method translate-to-alien
- alien-structure (type-spec object &optional copy)
- `(let ((object ,object))
- (if (and ,copy (not (alien-structure-static-p object)))
- (,(alien-copier type-spec)
- `(alien-instance-location object)
- ,(alien-class-size (find-class type-spec)))
- (alien-instance-location object))))
-
-(deftype-method translate-from-alien
- alien-structure (type-spec location &optional (alloc :reference))
- `(let ((location ,location))
- (unless (null-pointer-p location)
- ,(ecase alloc
- (:copy `(ensure-alien-instance ',type-spec location))
- (:static `(ensure-alien-instance ',type-spec location :static t))
- (:reference
- `(ensure-alien-instance
- ',type-spec
- `(,(alien-copier type-spec)
- location ,(alien-class-size (find-class type-spec)))))))))
-
-(deftype-method cleanup-alien alien-structure (type-spec sap &optional copied)
- (when copied
- `(let ((sap ,sap))
- (unless (or
- (null-pointer-p sap)
- (alien-structure-static-p (find-cached-instance sap)))
- (,(alien-deallocator type-spec) sap)))))
-
-
-
-;;;; Superclass for static structures such as gdk:visual
-
-(defclass static-structure (alien-structure)
- ()
- (:metaclass alien-class)
- (:size 0))
-
-
-(defmethod from-alien-initialize-instance ((structure alien-structure)
- &rest initargs)
- (declare (ignore initargs))
- (call-next-method)
- (setf (slot-value structure 'static) t))
-
-
-
-;;;; Superclass wrapping types in the glib type system
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass gtype (alien-object)
- ()
- (:metaclass alien-class)
- (:size 4 #|(size-of 'pointer)|#)))
-
-
-(defun %alien-instance-type-number (location)
- (let ((class (sap-ref-sap location 0)))
- (sap-ref-unsigned class 0)))
-
-
-(deftype-method translate-from-alien gtype (type-spec location &optional alloc)
- (declare (ignore type-spec alloc))
- `(let ((location ,location))
- (unless (null-pointer-p location)
- (ensure-alien-instance
- (type-from-number (%alien-instance-type-number location))
- location))))
-
-
-
-;;;; Metaclass for subclasses of gtype-class
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass gtype-class (alien-class)))
-
-
-(defmethod shared-initialize ((class gtype-class) names
- &rest initargs &key name)
- (declare (ignore initargs names))
- (call-next-method)
- (setf
- (slot-value class 'size)
- (type-instance-size (find-type-number (or name (class-name class))))))
-
-
-(defmethod validate-superclass
- ((class gtype-class) (super pcl::standard-class))
- (subtypep (class-name super) 'gtype))
-