From 267aeb614f1d2bdbd92019abb126a52de642ba21 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 8 Aug 2019 20:07:48 +0100 Subject: [PATCH] src/class-layout-impl.lisp: Fix class pointers in secondary chains. MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit Consider: [link = SodClass] class MyClass: SodClass { } [metaclass = MyClass] class Foo: SodObject { } GCC reports: /tmp/mdw/t.c:258:33: warning: initialization from incompatible pointer type [-Wincompatible-pointer-types] /* _class = */ &Foo__classobj.obj.myclass, ^ /tmp/mdw/t.c:258:33: note: (near initialization for ‘Foo__vtable_obj.obj._class’) What's going on here is that it's writing the wrong metaclass pointer into the `_class' pointer on `Foo''s secondary `obj' chain. Fix this by choosing, for each class pointer, the most specific superclass of the overall metaclass that is (a) on the correct chain of the metaclass, and (b) is a superclass of the metaclass of the most specific class in the chain whose vtable we're writing. Whew! --- src/class-layout-impl.lisp | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp index e93f401..1794e5a 100644 --- a/src/class-layout-impl.lisp +++ b/src/class-layout-impl.lisp @@ -267,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 @@ -328,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))) @@ -337,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*)))) -- 2.11.0