- (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))