X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/b426ab51d0598242a4c2b57d563341db66d71f7b..6e409901b7540867631f5163750d3e95ae633c5f:/src/class-output.lisp diff --git a/src/class-output.lisp b/src/class-output.lisp index 2ab6363..49453e9 100644 --- a/src/class-output.lisp +++ b/src/class-output.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 @@ -26,9 +26,37 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Classes. +;;; Walking the layout tree. -(defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer) +(defmethod hook-output :after ((class sod-class) reason sequencer) + (with-slots ((ilayout %ilayout) vtables methods effective-methods) class + (hook-output ilayout reason sequencer) + (dolist (method methods) (hook-output method reason sequencer)) + (dolist (method effective-methods) (hook-output method reason sequencer)) + (dolist (vtable vtables) (hook-output vtable reason sequencer)))) + +(defmethod hook-output :after ((ilayout ilayout) reason sequencer) + (with-slots (ichains) ilayout + (dolist (ichain ichains) (hook-output ichain reason sequencer)))) + +(defmethod hook-output :after ((ichain ichain) reason sequencer) + (dolist (item (ichain-body ichain)) (hook-output item reason sequencer))) + +(defmethod hook-output :after ((islots islots) reason sequencer) + (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer))) + +(defmethod hook-output :after ((vtable vtable) reason sequencer) + (with-slots (body) vtable + (dolist (item body) (hook-output item reason sequencer)))) + +(defmethod hook-output :after ((vtmsgs vtmsgs) reason sequencer) + (with-slots (entries) vtmsgs + (dolist (entry entries) (hook-output entry reason sequencer)))) + +;;;-------------------------------------------------------------------------- +;;; Class declarations. + +(defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer) ;; Main output sequencing. (sequence-output (stream sequencer) @@ -40,7 +68,8 @@ (class :vtmsgs :start) (class :vtmsgs :end) (class :vtables :start) (class :vtables :end) (class :vtable-externs) (class :vtable-externs-after) - (class :methods :start) (class :methods) (class :methods :end) + (class :methods :start) (class :methods :defs) + (class :methods) (class :methods :end) (class :ichains :start) (class :ichains :end) (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end) (class :conversions) @@ -65,15 +94,20 @@ (metaroot (find-root-metaclass class))) (format stream "/* The class object. */~@ extern const struct ~A ~A__classobj;~@ - #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%" + #define ~:*~A__class (&~:*~A__classobj.~A.~A)~%" (ilayout-struct-tag metaclass) class (sod-class-nickname (sod-class-chain-head metaroot)) - (sod-class-nickname metaroot))))) + (sod-class-nickname metaroot)) + (dolist (chain (sod-class-chains metaclass)) + (let ((tail (car chain))) + (unless (eq tail metaroot) + (format stream "#define ~A__cls_~A (&~2:*~A__classobj.~A.~A)~%" + class (sod-class-nickname (sod-class-chain-head tail)) + (sod-class-nickname tail))))) + (terpri stream)))) ;; Maybe generate an islots structure. (when (sod-class-slots class) - (dolist (slot (sod-class-slots class)) - (hook-output slot 'islots sequencer)) (sequence-output (stream sequencer) ((class :islots :start) (format stream "/* Instance slots. */~@ @@ -98,8 +132,8 @@ (format stream "/* Conversion macros. */~%") (dolist (super (cdr (sod-class-precedence-list class))) (let ((super-head (sod-class-chain-head super))) - (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~ - ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%" + (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~ + ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%" class (sod-class-nickname super) super (eq chain-head super-head) (sod-class-nickname super-head)))) @@ -111,6 +145,14 @@ ;; We need each message's method entry type for this, so we need to dig it ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains ;; entries for precisely the messages we want to make macros for. + (when (some (lambda (message) + (or (keyword-message-p message) + (varargs-message-p message))) + (sod-class-messages class)) + (one-off-output 'varargs-macros sequencer :early-decls + (lambda (stream) + (format stream + "~%SOD__VARARGS_MACROS_PREAMBLE~%")))) (when (sod-class-messages class) (sequence-output (stream sequencer) ((class :message-macros) @@ -146,9 +188,9 @@ (push name in-names) (push name out-names))))) (when varargsp - (format stream "#if __STDC_VERSION__ >= 199901~%")) + (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%")) (format stream "#define ~A(~{~A~^, ~}) ~ - ~A->_vt->~A.~A(~{~A~^, ~})~%" + (~A)->_vt->~A.~A(~{~A~^, ~})~%" (message-macro-name class entry) (nreverse in-names) me @@ -157,54 +199,43 @@ (nreverse out-names)) (when varargsp (format stream "#endif~%")))) - (terpri stream))))) + (terpri stream)))))) - ;; Generate vtmsgs structure for all superclasses. - (hook-output (car (sod-class-vtables class)) - 'vtmsgs - sequencer)) +(defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer) -(defmethod hook-output progn ((class sod-class) reason sequencer) - (with-slots (ilayout vtables methods effective-methods) class - (hook-output ilayout reason sequencer) - (dolist (method methods) (hook-output method reason sequencer)) - (dolist (method effective-methods) (hook-output method reason sequencer)) - (dolist (vtable vtables) (hook-output vtable reason sequencer)))) + ;; Output a structure member definition for each instance slot. + (dolist (slot (sod-class-slots class)) + (hook-output slot 'islots sequencer)) + + ;; Generate a vtmsgs structure for all superclasses. + (hook-output (car (sod-class-vtables class)) 'vtmsgs sequencer)) ;;;-------------------------------------------------------------------------- ;;; Instance structure. -(defmethod hook-output progn ((slot sod-slot) - (reason (eql 'islots)) - sequencer) +(defmethod hook-output ((slot sod-slot) (reason (eql 'islots)) sequencer) (sequence-output (stream sequencer) (((sod-slot-class slot) :islots :slots) (pprint-logical-block (stream nil :prefix " " :suffix ";") (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot))) (terpri stream)))) -(defmethod hook-output progn ((ilayout ilayout) reason sequencer) - (with-slots (ichains) ilayout - (dolist (ichain ichains) (hook-output ichain reason sequencer)))) - -(defmethod hook-output progn ((ichain ichain) reason sequencer) - (dolist (item (ichain-body ichain)) - (hook-output item reason sequencer))) - -(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer) - (with-slots (class ichains) ilayout +(defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer) + (with-slots ((class %class)) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) (format stream "/* Instance layout. */~@ struct ~A {~%" (ilayout-struct-tag class))) ((class :ilayout :end) - (format stream "};~2%"))) - (dolist (ichain ichains) - (hook-output ichain 'ilayout sequencer)))) + (format stream "};~2%"))))) + +(defmethod hook-output :after ((ilayout ilayout) (reason (eql :h)) sequencer) + (dolist (ichain (ilayout-ichains ilayout)) + (hook-output ichain 'ilayout sequencer))) -(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) ichain +(defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer) + (with-slots ((class %class) chain-head chain-tail) ichain (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :ichains :start) @@ -232,58 +263,57 @@ (sod-class-nickname super))) (sod-class-chain chain-tail)))))))) -(defmethod hook-output progn ((ichain ichain) - (reason (eql 'ilayout)) - sequencer) - (with-slots (class chain-head chain-tail) ichain +(defmethod hook-output ((ichain ichain) (reason (eql 'ilayout)) sequencer) + (with-slots ((class %class) chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) (format stream " union ~A ~A;~%" (ichain-union-tag chain-tail chain-head) (sod-class-nickname chain-head)))))) -(defmethod hook-output progn ((vtptr vtable-pointer) - (reason (eql :h)) - sequencer) - (with-slots (class chain-head chain-tail) vtptr - (sequence-output (stream sequencer) - ((class :ichain chain-head :slots) - (format stream " const struct ~A *_vt;~%" - (vtable-struct-tag chain-tail chain-head)))))) - -(defmethod hook-output progn ((islots islots) reason sequencer) - (dolist (slot (islots-slots islots)) - (hook-output slot reason sequencer))) - -(defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer) - (with-slots (class subclass slots) islots - (sequence-output (stream sequencer) - ((subclass :ichain (sod-class-chain-head class) :slots) - (format stream " struct ~A ~A;~%" - (islots-struct-tag class) - (sod-class-nickname class)))))) +(defmethod hook-output ((vtptr vtable-pointer) (reason (eql :h)) sequencer) + (with-slots ((class %class) chain-head chain-tail) vtptr + (when (eq class chain-tail) + (sequence-output (stream sequencer) + ((class :ichain chain-head :slots) + (format stream " const struct ~A *_vt;~%" + (vtable-struct-tag chain-tail chain-head))))))) + +(defmethod hook-output ((islots islots) (reason (eql :h)) sequencer) + (with-slots ((class %class) subclass slots) islots + (let ((head (sod-class-chain-head class))) + (when (eq head (sod-class-chain-head subclass)) + (sequence-output (stream sequencer) + ((subclass :ichain (sod-class-chain-head class) :slots) + (format stream " struct ~A ~A;~%" + (islots-struct-tag class) + (sod-class-nickname class)))))))) ;;;-------------------------------------------------------------------------- ;;; Vtable structure. -(defmethod hook-output progn ((vtable vtable) reason sequencer) - (with-slots (body) vtable - (dolist (item body) (hook-output item reason sequencer)))) - -(defmethod hook-output progn ((method sod-method) - (reason (eql :h)) - sequencer) - (with-slots (class) method +(defmethod hook-output ((method sod-method) (reason (eql :h)) sequencer) + (with-slots ((class %class)) method (sequence-output (stream sequencer) ((class :methods) (let ((type (sod-method-function-type method))) (princ "extern " stream) (pprint-c-type (commentify-function-type type) stream (sod-method-function-name method)) - (format stream ";~%")))))) - -(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) vtable + (format stream ";~%"))) + ((class :methods :defs) + (let* ((type (sod-method-type method)) + (keys (and (typep type 'c-keyword-function-type) + (c-function-keywords type)))) + (when keys + (format stream "struct ~A {~%~ + ~{ unsigned ~A: 1;~%~}~ + };~2%" + (direct-method-suppliedp-struct-tag method) + (mapcar #'argument-name keys)))))))) + +(defmethod hook-output ((vtable vtable) (reason (eql :h)) sequencer) + (with-slots ((class %class) chain-head chain-tail) vtable (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :vtables :start) @@ -296,26 +326,37 @@ struct ~A {~%" (vtable-struct-tag chain-tail chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%")))) + (format stream "};~2%") + (format stream "/* Union of equivalent superclass vtables. */~@ + union ~A {~@ + ~:{ struct ~A ~A;~%~}~ + };~2%" + (vtable-union-tag chain-tail chain-head) + + ;; As for the ichain union, make sure the most specific + ;; class is first. + (mapcar (lambda (super) + (list (vtable-struct-tag super chain-head) + (sod-class-nickname super))) + (sod-class-chain chain-tail)))))) (sequence-output (stream sequencer) ((class :vtable-externs) - (format stream "~@~%" - (vtable-struct-tag chain-tail chain-head) - class (sod-class-nickname chain-head)))))) + (format stream "~@~%" + (vtable-union-tag chain-tail chain-head) + (vtable-name class chain-head)))))) -(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) - (with-slots (class subclass chain-head chain-tail) vtmsgs - (sequence-output (stream sequencer) - ((subclass :vtable chain-head :slots) - (format stream " struct ~A ~A;~%" - (vtmsgs-struct-tag subclass class) - (sod-class-nickname class)))))) - -(defmethod hook-output progn ((vtmsgs vtmsgs) - (reason (eql 'vtmsgs)) - sequencer) +(defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) + (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs + (when (eq subclass chain-tail) + (sequence-output (stream sequencer) + ((subclass :vtable chain-head :slots) + (format stream " struct ~A ~A;~%" + (vtmsgs-struct-tag subclass class) + (sod-class-nickname class))))))) + +(defmethod hook-output ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer) (when (vtmsgs-entries vtmsgs) - (with-slots (class subclass) vtmsgs + (with-slots ((class %class) subclass) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtmsgs :start) (subclass :vtmsgs class :start) @@ -330,13 +371,8 @@ ((subclass :vtmsgs class :end) (format stream "};~2%")))))) -(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer) - (with-slots (entries) vtmsgs - (dolist (entry entries) (hook-output entry reason sequencer)))) - -(defmethod hook-output progn ((entry method-entry) - (reason (eql 'vtmsgs)) - sequencer) +(defmethod hook-output ((entry method-entry) + (reason (eql 'vtmsgs)) sequencer) (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) (class (effective-method-class method)) @@ -349,38 +385,46 @@ (pprint-c-type pointer-type stream (method-entry-slot-name entry))) (terpri stream))))) -(defmethod hook-output progn ((cptr class-pointer) - (reason (eql :h)) - sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr - (sequence-output (stream sequencer) - ((class :vtable chain-head :slots) - (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" - metaclass - (and (sod-class-direct-superclasses meta-chain-head) - (sod-class-nickname meta-chain-head))))))) - -(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer) - (with-slots (class chain-head) boff - (sequence-output (stream sequencer) - ((class :vtable chain-head :slots) - (write-line " size_t _base;" stream))))) +(defmethod hook-output ((cptr class-pointer) (reason (eql :h)) sequencer) + (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr + (when (eq chain-head (sod-class-chain-head class)) + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" + metaclass + (and (sod-class-direct-superclasses meta-chain-head) + (sod-class-nickname meta-chain-head)))))))) + +(defmethod hook-output ((boff base-offset) (reason (eql :h)) sequencer) + (with-slots ((class %class) chain-head) boff + (when (eq chain-head (sod-class-chain-head class)) + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (write-line " size_t _base;" stream)))))) -(defmethod hook-output progn ((choff chain-offset) - (reason (eql :h)) - sequencer) - (with-slots (class chain-head target-head) choff - (sequence-output (stream sequencer) - ((class :vtable chain-head :slots) - (format stream " ptrdiff_t _off_~A;~%" - (sod-class-nickname target-head)))))) +(defmethod hook-output ((choff chain-offset) (reason (eql :h)) sequencer) + (with-slots ((class %class) chain-head target-head) choff + (when (eq chain-head (sod-class-chain-head class)) + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (format stream " ptrdiff_t _off_~A;~%" + (sod-class-nickname target-head))))))) ;;;-------------------------------------------------------------------------- ;;; Implementation output. -(defvar *instance-class*) +(export '*instance-class*) +(defvar *instance-class* nil + "The class currently being output. -(defmethod hook-output progn ((class sod-class) (reason (eql :c)) sequencer) + This is bound during the `hook-output' traversal of a class layout for + `:c' output, since some of the objects traversed actually `belong' to + superclasses and there's no other way to find out what the reference class + actually is. + + It may be bound at other times.") + +(defmethod hook-output ((class sod-class) (reason (eql :c)) sequencer) (sequence-output (stream sequencer) :constraint @@ -402,20 +446,19 @@ const struct ~A ~A__classobj = {~%" (ilayout-struct-tag (sod-class-metaclass class)) class)) ((class :object :end) - (format stream "};~2%"))) + (format stream "};~2%")))) +(defmethod hook-output :after ((class sod-class) (reason (eql :c)) sequencer) (let ((*instance-class* class)) (hook-output (sod-class-ilayout (sod-class-metaclass class)) - 'class - sequencer))) + 'class sequencer))) ;;;-------------------------------------------------------------------------- ;;; Direct and effective methods. -(defmethod hook-output progn ((method delegating-direct-method) - (reason (eql :c)) - sequencer) - (with-slots (class body) method +(defmethod hook-output ((method delegating-direct-method) + (reason (eql :c)) sequencer) + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -425,20 +468,29 @@ const struct ~A ~A__classobj = {~%" (c-function-arguments (sod-method-next-method-type method))))) ((class :direct-method method :end) - (format stream "#undef CALL_NEXT_METHOD~%"))))) + (format stream "#undef CALL_NEXT_METHOD~%")))) + (call-next-method)) -(defmethod hook-output progn ((method sod-method) - (reason (eql :c)) - sequencer) - (with-slots (class body) method +(defmethod hook-output ((method sod-method) (reason (eql :c)) sequencer) + (with-slots ((class %class) role body message) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) :constraint ((class :direct-methods :start) + (class :direct-method method :banner) (class :direct-method method :start) (class :direct-method method :body) (class :direct-method method :end) (class :direct-methods :end)) + ((class :direct-method method :banner) + (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~ + on `~A.~A' ~:_defined by `~A'." + role + (sod-class-nickname + (sod-message-class message)) + (sod-message-name message) + class) + (fresh-line stream)) ((class :direct-method method :body) (pprint-c-type (sod-method-function-type method) stream @@ -449,20 +501,37 @@ const struct ~A ~A__classobj = {~%" ((class :direct-method method :end) (terpri stream))))) -(defmethod hook-output progn ((method basic-effective-method) - (reason (eql :c)) - sequencer) - (with-slots (class functions) method +(defmethod hook-output ((method basic-effective-method) + (reason (eql :c)) sequencer) + (with-slots ((class %class) functions) method (sequence-output (stream sequencer) ((class :effective-methods) + (let* ((keys (effective-method-keywords method)) + (message (effective-method-message method)) + (msg-class (sod-message-class message))) + (when keys + (format-banner-comment stream "Keyword argument structure ~:_~ + for `~A.~A' ~:_on class `~A'." + (sod-class-nickname msg-class) + (sod-message-name message) + class) + (format stream "~&struct ~A {~%" + (effective-method-keyword-struct-tag method)) + (format stream "~{ unsigned ~A__suppliedp: 1;~%~}" + (mapcar #'argument-name keys)) + (dolist (key keys) + (write-string " " stream) + (pprint-c-type (argument-type key) stream (argument-name key)) + (format stream ";~%")) + (format stream "};~2%"))) (dolist (func functions) (write func :stream stream :escape nil :circle nil)))))) ;;;-------------------------------------------------------------------------- ;;; Vtables. -(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer) - (with-slots (class chain-head chain-tail) vtable +(defmethod hook-output ((vtable vtable) (reason (eql :c)) sequencer) + (with-slots ((class %class) chain-head chain-tail) vtable (sequence-output (stream sequencer) :constraint ((class :vtables :start) (class :vtable chain-head :start) @@ -470,17 +539,15 @@ const struct ~A ~A__classobj = {~%" (class :vtables :end)) ((class :vtable chain-head :start) (format stream "/* Vtable for ~A chain. */~@ - const struct ~A ~A = {~%" + const union ~A ~A = { {~%" chain-head - (vtable-struct-tag chain-tail chain-head) + (vtable-union-tag chain-tail chain-head) (vtable-name class chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%"))))) + (format stream "} };~2%"))))) -(defmethod hook-output progn ((cptr class-pointer) - (reason (eql :c)) - sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr +(defmethod hook-output ((cptr class-pointer) (reason (eql :c)) sequencer) + (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :class-pointer metaclass) @@ -495,8 +562,8 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname meta-chain-head) (sod-class-nickname metaclass)))))) -(defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer) - (with-slots (class chain-head) boff +(defmethod hook-output ((boff base-offset) (reason (eql :c)) sequencer) + (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :base-offset) @@ -507,10 +574,8 @@ const struct ~A ~A__classobj = {~%" (ilayout-struct-tag class) (sod-class-nickname chain-head)))))) -(defmethod hook-output progn ((choff chain-offset) - (reason (eql :c)) - sequencer) - (with-slots (class chain-head target-head) choff +(defmethod hook-output ((choff chain-offset) (reason (eql :c)) sequencer) + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :chain-offset target-head) @@ -522,8 +587,8 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname chain-head) (sod-class-nickname target-head)))))) -(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) - (with-slots (class subclass chain-head) vtmsgs +(defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) + (with-slots ((class %class) subclass chain-head) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtable chain-head :start) (subclass :vtable chain-head :vtmsgs class :start) @@ -536,10 +601,8 @@ const struct ~A ~A__classobj = {~%" ((subclass :vtable chain-head :vtmsgs class :end) (format stream " },~%"))))) -(defmethod hook-output progn ((entry method-entry) - (reason (eql :c)) - sequencer) - (with-slots (method chain-head chain-tail role) entry +(defmethod hook-output ((entry method-entry) (reason (eql :c)) sequencer) + (with-slots ((method %method) chain-head chain-tail role) entry (let* ((message (effective-method-message method)) (class (effective-method-class method)) (super (sod-message-class message))) @@ -552,10 +615,8 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; Filling in the class object. -(defmethod hook-output progn ((ichain ichain) - (reason (eql 'class)) - sequencer) - (with-slots (class chain-head) ichain +(defmethod hook-output ((ichain ichain) (reason (eql 'class)) sequencer) + (with-slots ((class %class) chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) (*instance-class* :object chain-head :ichain :start) @@ -567,10 +628,8 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object chain-head :ichain :end) (format stream " } },~%"))))) -(defmethod hook-output progn ((islots islots) - (reason (eql 'class)) - sequencer) - (with-slots (class) islots +(defmethod hook-output ((islots islots) (reason (eql 'class)) sequencer) + (with-slots ((class %class)) islots (let ((chain-head (sod-class-chain-head class))) (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) @@ -583,26 +642,18 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object class :slots :end) (format stream " },~%")))))) -(defmethod hook-output progn ((vtptr vtable-pointer) - (reason (eql 'class)) - sequencer) - (with-slots (class chain-head chain-tail) vtptr +(defmethod hook-output ((vtptr vtable-pointer) + (reason (eql 'class)) sequencer) + (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) (*instance-class* :object chain-head :vtable) (*instance-class* :object chain-head :ichain :end)) ((*instance-class* :object chain-head :vtable) - (format stream " &~A__vtable_~A,~%" - class (sod-class-nickname chain-head)))))) - -(defgeneric find-class-initializer (slot class) - (:method ((slot effective-slot) (class sod-class)) - (let ((dslot (effective-slot-direct-slot slot))) - (or (some (lambda (super) - (find dslot (sod-class-class-initializers super) - :test #'sod-initializer-slot)) - (sod-class-precedence-list class)) - (effective-slot-initializer slot))))) + (format stream " /* ~17@A = */ &~A.~A,~%" + "_vt" + (vtable-name class chain-head) + (sod-class-nickname chain-tail)))))) (defgeneric output-class-initializer (slot instance stream) (:method ((slot sod-class-effective-slot) (instance sod-class) stream) @@ -616,28 +667,23 @@ const struct ~A ~A__classobj = {~%" (:method ((slot effective-slot) (instance sod-class) stream) (let ((init (find-class-initializer slot instance)) (direct-slot (effective-slot-direct-slot slot))) - (ecase (sod-initializer-value-kind init) - (:simple (format stream " /* ~15@A = */ ~A,~%" - (sod-slot-name direct-slot) - (sod-initializer-value-form init))) - (:compound (format stream " /* ~15@A = */ ~@<{ ~;~A~; },~:>~%" - (sod-slot-name direct-slot) - (sod-initializer-value-form init))))))) - -(defmethod hook-output progn ((slot sod-class-effective-slot) - (reason (eql 'class)) - sequencer) + (format stream " /* ~15@A = */ ~A,~%" + (sod-slot-name direct-slot) + (sod-initializer-value init))))) + +(defmethod hook-output ((slot sod-class-effective-slot) + (reason (eql 'class)) sequencer) (let ((instance *instance-class*) (func (effective-slot-prepare-function slot))) (when func (sequence-output (stream sequencer) ((instance :object :prepare) - (funcall func instance stream)))))) + (funcall func instance stream))))) + (call-next-method)) -(defmethod hook-output progn ((slot effective-slot) - (reason (eql 'class)) - sequencer) - (with-slots (class (dslot slot)) slot +(defmethod hook-output ((slot effective-slot) + (reason (eql 'class)) sequencer) + (with-slots ((class %class) (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) (sequence-output (stream sequencer)