X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/e674612eb9e1a1dde2522260163a93a13ed44a0f..d9bd7c90250b7563be98f105d0a53ce66d559ea0:/src/class-output.lisp diff --git a/src/class-output.lisp b/src/class-output.lisp index b2d1ec8..dec1e4e 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -68,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) @@ -93,10 +94,17 @@ (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) @@ -139,7 +147,10 @@ ;; 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 #'varargs-message-p (sod-class-messages class)) + (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 @@ -181,7 +192,7 @@ (when varargsp (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 @@ -288,7 +299,17 @@ (princ "extern " stream) (pprint-c-type (commentify-function-type type) stream (sod-method-function-name method)) - (format stream ";~%")))))) + (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 progn ((vtable vtable) (reason (eql :h)) sequencer) (with-slots ((class %class) chain-head chain-tail) vtable @@ -452,15 +473,25 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method sod-method) (reason (eql :c)) sequencer) - (with-slots ((class %class) body) method + (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 @@ -476,6 +507,24 @@ const struct ~A ~A__classobj = {~%" (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)))))) @@ -612,15 +661,6 @@ const struct ~A ~A__classobj = {~%" (vtable-name class chain-head) (sod-class-nickname chain-tail)))))) -(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))))) - (defgeneric output-class-initializer (slot instance stream) (:method ((slot sod-class-effective-slot) (instance sod-class) stream) (let ((func (effective-slot-initializer-function slot)) @@ -633,13 +673,9 @@ 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))))))) + (format stream " /* ~15@A = */ ~A,~%" + (sod-slot-name direct-slot) + (sod-initializer-value init))))) (defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer)