- (defmethod compute-virtual-slot-accessors
- ((class proxy-class) (slotd effective-alien-slot-definition)
- direct-slotds)
- (with-slots (offset type) slotd
- (let ((reader (intern-reader-function type))
- (writer (intern-writer-function type))
- (destroy (intern-destroy-function type)))
- (setf offset (slot-definition-offset (first direct-slotds)))
- (list
- #'(lambda (object)
- (funcall reader (proxy-location object) offset))
- #'(lambda (value object)
- (let ((location (proxy-location object)))
- (funcall destroy location offset)
- (funcall writer value location offset)))))))
-
- (defmethod compute-virtual-slot-accessors
- ((class proxy-class)
- (slotd effective-virtual-alien-slot-definition)
- direct-slotds)
- (destructuring-bind (getter setter) (call-next-method)
- (let ((class-name (class-name class)))
- (with-slots (type) slotd
- (list
- (if (stringp getter)
- (mkbinding getter type class-name)
- getter)
- (if (stringp setter)
- (let ((setter (mkbinding setter 'nil class-name type)))
- #'(lambda (value object)
- (funcall setter object value)))
- setter))))))
+
+ (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
+ (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
+ (nconc
+ (list :offset (most-specific-slot-value direct-slotds 'offset))
+ (call-next-method))
+ (call-next-method)))
+
+
+ (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
+ (with-slots (offset) slotd
+ (let* ((type (slot-definition-type slotd))
+ (reader (intern-reader-function type))
+ (writer (intern-writer-function type))
+ (destroy (intern-destroy-function type)))
+ (unless (slot-boundp slotd 'reader-function)
+ (setf
+ (slot-value slotd 'reader-function)
+ #'(lambda (object)
+ (funcall reader (proxy-location object) offset))))
+
+ (unless (slot-boundp slotd 'writer-function)
+ (setf
+ (slot-value slotd 'writer-function)
+ #'(lambda (value object)
+ (let ((location (proxy-location object)))
+ (funcall destroy location offset)
+ (funcall writer value location offset)))))
+
+ (unless (slot-boundp slotd 'boundp-function)
+ (setf
+ (slot-value slotd 'boundp-function)
+ #'(lambda (object)
+ (declare (ignore object))
+ t)))))
+ (call-next-method))
+
+
+ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-alien-slot-definition))
+ (with-slots (getter setter type) slotd
+ (when (and (not (slot-boundp slotd 'reader-function)) (stringp getter))
+ (let ((reader (mkbinding-late getter type 'pointer)))
+ (setf (slot-value slotd 'reader-function)
+ #'(lambda (object)
+ (funcall reader (proxy-location object))))))
+
+ (when (and (not (slot-boundp slotd 'writer-function)) (stringp setter))
+ (let ((writer (mkbinding-late setter 'nil 'pointer type)))
+ (setf (slot-value slotd 'writer-function)
+ #'(lambda (value object)
+ (funcall writer (proxy-location object) value))))))
+ (call-next-method))
+
+ ;; TODO: call some C code to detect this a compile time
+ (defconstant +struct-alignmen+ 4)