- (defmethod alien-class-superclass ((class alien-class))
- (find-if
- #'(lambda (class)
- (subtypep (class-name class) 'alien-instance))
- (pcl::class-direct-superclasses class)))
-
-
- (defmethod shared-initialize ((class alien-class) names
- &rest initargs &key size alien-name name)
- (declare (ignore initargs))
- (call-next-method)
-
- ;; For some reason I can't figure out, accessors for only the
- ;; first direct slot in an alien class gets defined by
- ;; PCL. Therefore it has to be done here.
- (pcl::fix-slot-accessors class (class-direct-slots class) 'pcl::add)
-
- (when alien-name
- (setf (alien-type-name (or name (class-name class))) (first alien-name)))
- (when size
- (setf (slot-value class 'size) (first size))))
-
-
- (defmethod shared-initialize :after ((class alien-class) names
- &rest initargs &key)
- (declare (ignore initargs names))
- (let* ((super (alien-class-superclass class))
- (actual-size
- (if (eq (class-name super) 'alien-instance)
- 0
- (alien-class-size super))))
- (dolist (slotd (class-slots class))
- (when (eq (slot-definition-allocation slotd) :alien)
- (with-slots (offset type) slotd
- (setq actual-size (max actual-size (+ offset (size-of type)))))))
- (cond
- ((not (slot-boundp class 'size))
- (setf (slot-value class 'size) actual-size))
- ((> actual-size (slot-value class 'size))
- (warn "The actual size of class ~A is lager than specified" class)))))
-
-
- (defmethod direct-slot-definition-class ((class alien-class) initargs)
- (case (getf initargs :allocation)
- ((nil :alien) (find-class 'direct-alien-slot-definition))
-; (:instance (error "Allocation :instance not allowed in class ~A" class))
- (t (call-next-method))))
-
-
- (defmethod effective-slot-definition-class ((class alien-class) initargs)
- (case (getf initargs :allocation)
- (:alien (find-class 'effective-alien-slot-definition))
- (:virtual (find-class 'effective-virtual-alien-slot-definition))
- (t (call-next-method))))
-
-
- (defmethod compute-virtual-slot-location
- ((class alien-class) (slotd effective-alien-slot-definition)
- direct-slotds)
- (with-slots (offset type) slotd
- (setf offset (%direct-slot-definitions-slot-value direct-slotds 'offset))
- (let ((reader (get-reader-function type))
- (writer (get-writer-function type))
- (destroy (get-destroy-function type)))
- (list
- #'(lambda (object)
- (funcall reader (alien-instance-location object) offset))
- #'(lambda (value object)
- (let ((location (alien-instance-location object)))
- (funcall destroy location offset)
- (funcall writer value location offset)))))))
-
-
- (defmethod compute-virtual-slot-location
- ((class alien-class)
- (slotd effective-virtual-alien-slot-definition)
- direct-slotds)
- (let ((location (call-next-method)))
- (if (or (stringp location) (consp location))
- (destructuring-bind (reader &optional writer) (mklist location)
- (with-slots (type) slotd
- (list
- (if (stringp reader)
- (let* ((alien-type (translate-type-spec type))
- (alien
- (alien::%heap-alien
- (alien::make-heap-alien-info
- :type (alien::parse-alien-type
- `(function ,alien-type system-area-pointer))
- :sap-form (system:foreign-symbol-address reader))))
- (from-alien (get-from-alien-function type)))
- #'(lambda (object)
- (funcall
- from-alien
- (alien-funcall
- alien (alien-instance-location object)))))
- reader)
- (if (stringp writer)
- (let* ((alien-type (translate-type-spec type))
- (alien
- (alien::%heap-alien
- (alien::make-heap-alien-info
- :type (alien::parse-alien-type
- `(function
- void ,alien-type system-area-pointer))
- :sap-form (system:foreign-symbol-address writer))))
- (to-alien (get-to-alien-function type))
- (cleanup (get-cleanup-function type)))
- #'(lambda (value object)
- (let ((alien-value (funcall to-alien value))
- (location (alien-instance-location object)))
- (alien-funcall alien location alien-value)
- (funcall cleanup alien-value))))
- writer))))
- location)))
-
-
- (defmethod compute-slots ((class alien-class))
- ;; Translating the user supplied relative (to previous slot) offsets
- ;; to absolute offsets.
- ;; This code is broken and have to be fixed for real use.
- (with-slots (direct-slots) class
- (let* ((super (alien-class-superclass class))
- (slot-offset
- (if (eq (class-name super) 'alien-instance)
- 0
- (alien-class-size super))))
- (dolist (slotd direct-slots)
- (when (eq (slot-definition-allocation slotd) :alien)
- (with-slots (offset type) slotd
- (setf
- offset (+ slot-offset offset)
- slot-offset (+ offset (size-of type)))))))
-
- ;; Reverse the direct slot definitions so the effective slots
- ;; will be in correct order.
- (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)
- (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)))))
-