X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/51c0b1b050c81385c7acfabf916066625df5a839..6afec9101d5ea87e3df4bda2239ffd05f8154fa6:/src/class-layout-impl.lisp diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp index 7a2d9cc..1794e5a 100644 --- a/src/class-layout-impl.lisp +++ b/src/class-layout-impl.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -41,16 +41,34 @@ :key #'sod-initializer-slot)) (sod-class-precedence-list class))) +(defmethod find-slot-initargs ((class sod-class) (slot sod-slot)) + (mappend (lambda (super) + (remove-if-not (lambda (initarg) + (and (typep initarg 'sod-slot-initarg) + (eq (sod-initarg-slot initarg) slot))) + (sod-class-initargs super))) + (sod-class-precedence-list class))) + (defmethod compute-effective-slot ((class sod-class) (slot sod-slot)) (make-instance 'effective-slot :slot slot :class class - :initializer (find-slot-initializer class slot))) + :initializer (find-slot-initializer class slot) + :initargs (find-slot-initargs class slot))) + +(defmethod find-class-initializer ((slot effective-slot) (class sod-class)) + (let ((dslot (effective-slot-direct-slot slot))) + (or (some (lambda (super) + (find dslot (sod-class-class-initializers super) + :key #'sod-initializer-slot)) + (sod-class-precedence-list class)) + (effective-slot-initializer slot)))) ;;;-------------------------------------------------------------------------- ;;; Special-purpose slot objects. -(export 'sod-class-slot) +(export '(sod-class-slot + sod-slot-initializer-function sod-slot-prepare-function)) (defclass sod-class-slot (sod-slot) ((initializer-function :initarg :initializer-function :type (or symbol function) @@ -72,7 +90,9 @@ (default-slot (slot 'prepare-function) (get-property pset :prepare-function :func nil))) -(export 'sod-class-effective-slot) +(export '(sod-class-effective-slot + effective-slot-initializer-function + effective-slot-prepare-function)) (defclass sod-class-effective-slot (effective-slot) ((initializer-function :initarg :initializer-function :type (or symbol function) @@ -109,15 +129,19 @@ (sod-class-nickname (method-entry-chain-head entry)) (method-entry-role entry)))) +(defmethod sod-message-applicable-methods + ((message sod-message) (class sod-class)) + (mappend (lambda (super) + (remove message + (sod-class-methods super) + :key #'sod-method-message + :test-not #'eql)) + (sod-class-precedence-list class))) + (defmethod compute-sod-effective-method ((message sod-message) (class sod-class)) - (let ((direct-methods (mappend (lambda (super) - (remove message - (sod-class-methods super) - :key #'sod-method-message - :test-not #'eql)) - (sod-class-precedence-list class)))) - (make-instance (message-effective-method-class message) + (let ((direct-methods (sod-message-applicable-methods message class))) + (make-instance (sod-message-effective-method-class message) :message message :class class :direct-methods direct-methods))) @@ -243,17 +267,19 @@ ((class sod-class) (chain-head sod-class) (metaclass sod-class) (meta-chain-head sod-class)) - ;; Slightly tricky. We don't necessarily want a pointer to the metaclass, - ;; but to its most specific subclass on the given chain. Fortunately, CL - ;; is good at this game. - (let* ((meta-chains (sod-class-chains metaclass)) - (meta-chain-tails (mapcar #'car meta-chains)) - (meta-chain-tail (find meta-chain-head meta-chain-tails - :key #'sod-class-chain-head))) + ;; Rather tricky. This is a class pointer on a vtable for the CHAIN-HEAD + ;; chain, pointing into the META-CHAIN-HEAD chain of the metaclass. We + ;; need to produce a pointer to the most specific superclass of the + ;; metaclass on the right chain that is a superclass of the metaclass of + ;; the most specific class in the superclass chain headed by CHAIN-HEAD. + (flet ((chain-tail (class head) + (find head (mapcar #'car (sod-class-chains class)) + :key #'sod-class-chain-head))) (make-instance 'class-pointer - :class class - :chain-head chain-head - :metaclass meta-chain-tail + :class class :chain-head chain-head + :metaclass (chain-tail (sod-class-metaclass + (chain-tail class chain-head)) + meta-chain-head) :meta-chain-head meta-chain-head))) ;;; base-offset @@ -304,7 +330,8 @@ ;; If this class introduces new metaclass chains, then emit pointers to ;; them. - (let* ((metasuper (sod-class-metaclass super)) + (let* ((metaclass (sod-class-metaclass class)) + (metasuper (sod-class-metaclass super)) (metasuper-chains (sod-class-chains metasuper)) (metasuper-chain-heads (mapcar (lambda (chain) (sod-class-chain-head (car chain))) @@ -313,7 +340,7 @@ (unless (member metasuper-chain-head *done-metaclass-chains*) (funcall emit (make-class-pointer class chain-head - metasuper + metaclass metasuper-chain-head)) (push metasuper-chain-head *done-metaclass-chains*)))) @@ -378,4 +405,22 @@ (compute-vtable class (reverse chain))) (sod-class-chains class))) +;;;-------------------------------------------------------------------------- +;;; Layout interface. + +;; Just arrange to populate the necessary slots on demand. +(flet ((check-class-is-finalized (class) + (unless (eq (sod-class-state class) :finalized) + (error "Class ~S is not finalized" class)))) + (macrolet ((define-layout-slot (slot (class) &body body) + `(define-on-demand-slot sod-class ,slot (,class) + (check-class-is-finalized ,class) + ,@body))) + (define-layout-slot %ilayout (class) + (compute-ilayout class)) + (define-layout-slot effective-methods (class) + (compute-effective-methods class)) + (define-layout-slot vtables (class) + (compute-vtables class)))) + ;;;----- That's all, folks --------------------------------------------------