-;;; -*-lisp-*-
-;;;
-;;; Output functions for classes
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Classes.
-
-(defmethod hook-output progn ((class sod-class) (reason (eql :h))
- sequencer)
-
- ;; Main output sequencing.
- (sequence-output (stream sequencer)
-
- :constraint
- ((:classes :start)
- (class :banner)
- (class :islots :start) (class :islots :slots) (class :islots :end)
- (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 :ichains :start) (class :ichains :end)
- (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
- (class :conversions)
- (class :object)
- (:classes :end))
-
- (:typedefs
- (format stream "typedef struct ~A ~A;~%"
- (ichain-struct-tag class (sod-class-chain-head class)) class))
-
- ((class :banner)
- (banner (format nil "Class ~A" class) stream))
- ((class :vtable-externs-after)
- (terpri stream))
-
- ((class :vtable-externs)
- (format stream "/* Vtable structures. */~%"))
-
- ((class :object)
- (let ((metaclass (sod-class-metaclass class))
- (metaroot (find-root-metaclass class)))
- (format stream "/* The class object. */~@
- extern const struct ~A ~A__classobj;~@
- #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
- (ilayout-struct-tag metaclass) class
- (sod-class-nickname (sod-class-chain-head metaroot))
- (sod-class-nickname metaroot)))))
-
- ;; 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. */~@
- struct ~A {~%"
- (islots-struct-tag class)))
- ((class :islots :end)
- (format stream "};~2%"))))
-
- ;; Declare the direct methods.
- (when (sod-class-methods class)
- (sequence-output (stream sequencer)
- ((class :methods :start)
- (format stream "/* Direct methods. */~%"))
- ((class :methods :end)
- (terpri stream))))
-
- ;; Provide upcast macros which do the right thing.
- (when (sod-class-direct-superclasses class)
- (sequence-output (stream sequencer)
- ((class :conversions)
- (let ((chain-head (sod-class-chain-head class)))
- (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)~])~%"
- class (sod-class-nickname super) super
- (eq chain-head super-head)
- (sod-class-nickname super-head))))
- (terpri stream)))))
-
- ;; Generate vtmsgs structure for all superclasses.
- (hook-output (car (sod-class-vtables class))
- 'vtmsgs
- 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))))
-
-;;;--------------------------------------------------------------------------
-;;; Instance structure.
-
-(defmethod hook-output progn ((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
- (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))))
-
-(defmethod hook-output progn ((ichain ichain) (reason (eql :h))
- sequencer)
- (with-slots (class chain-head chain-tail) ichain
- (when (eq class chain-tail)
- (sequence-output (stream sequencer)
- :constraint ((class :ichains :start)
- (class :ichain chain-head :start)
- (class :ichain chain-head :slots)
- (class :ichain chain-head :end)
- (class :ichains :end))
- ((class :ichain chain-head :start)
- (format stream "/* Instance chain structure. */~@
- struct ~A {~%"
- (ichain-struct-tag chain-tail chain-head)))
- ((class :ichain chain-head :end)
- (format stream "};~2%")
- (format stream "/* Union of equivalent superclass chains. */~@
- union ~A {~@
- ~:{ struct ~A ~A;~%~}~
- };~2%"
- (ichain-union-tag chain-tail chain-head)
-
- ;; Make sure the most specific class is first: only the
- ;; first element of a union can be statically initialized in
- ;; C90.
- (mapcar (lambda (super)
- (list (ichain-struct-tag super chain-head)
- (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
- (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))))))
-
-;;;--------------------------------------------------------------------------
-;;; 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
- (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
- (when (eq class chain-tail)
- (sequence-output (stream sequencer)
- :constraint ((class :vtables :start)
- (class :vtable chain-head :start)
- (class :vtable chain-head :slots)
- (class :vtable chain-head :end)
- (class :vtables :end))
- ((class :vtable chain-head :start)
- (format stream "/* Vtable structure. */~@
- struct ~A {~%"
- (vtable-struct-tag chain-tail chain-head)))
- ((class :vtable chain-head :end)
- (format stream "};~2%"))))
- (sequence-output (stream sequencer)
- ((class :vtable-externs)
- (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
- (vtable-struct-tag chain-tail chain-head)
- class (sod-class-nickname 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)
- (when (vtmsgs-entries vtmsgs)
- (with-slots (class subclass) vtmsgs
- (sequence-output (stream sequencer)
- :constraint ((subclass :vtmsgs :start)
- (subclass :vtmsgs class :start)
- (subclass :vtmsgs class :slots)
- (subclass :vtmsgs class :end)
- (subclass :vtmsgs :end))
- ((subclass :vtmsgs class :start)
- (format stream "/* Messages protocol from class ~A */~@
- struct ~A {~%"
- class
- (vtmsgs-struct-tag subclass class)))
- ((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 sequencer)
- (with-slots (method) entry
- (hook-output method reason sequencer)))
-
-(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
- sequencer)
- (let* ((method (method-entry-effective-method entry))
- (message (effective-method-message method))
- (class (effective-method-class method))
- (type (method-entry-function-type entry))
- (commented-type (commentify-function-type type)))
- (sequence-output (stream sequencer)
- ((class :vtmsgs (sod-message-class message) :slots)
- (pprint-logical-block (stream nil :prefix " " :suffix ";")
- (pprint-c-type commented-type stream (sod-message-name message)))
- (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
- (if (sod-class-direct-superclasses meta-chain-head)
- (sod-class-nickname meta-chain-head)
- nil))))))
-
-(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 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))))))
-
-;;;--------------------------------------------------------------------------
-;;; Implementation output.
-
-(defvar *instance-class*)
-
-(defmethod hook-output progn ((class sod-class) (reason (eql :c))
- sequencer)
- (sequence-output (stream sequencer)
-
- :constraint
- ((:classes :start)
- (class :banner)
- (class :direct-methods :start) (class :direct-methods :end)
- (class :effective-methods)
- (class :vtables :start) (class :vtables :end)
- (class :object :prepare) (class :object :start) (class :object :end)
- (:classes :end))
-
- ((class :banner)
- (banner (format nil "Class ~A" class) stream))
-
- ((class :object :start)
- (format stream "~
-/* The class object. */
-const struct ~A ~A__classobj = {~%"
- (ilayout-struct-tag (sod-class-metaclass class))
- class))
- ((class :object :end)
- (format stream "};~2%")))
-
- (let ((*instance-class* class))
- (hook-output (sod-class-ilayout (sod-class-metaclass class))
- 'class
- sequencer)))
-
-;;;--------------------------------------------------------------------------
-;;; Direct methods.
-
-(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
- sequencer)
- (with-slots (class body) method
- (unless body
- (return-from hook-output))
- (sequence-output (stream sequencer)
- ((class :direct-method method :start)
- (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
- (mapcar #'argument-name
- (c-function-arguments (sod-method-next-method-type
- method)))))
- ((class :direct-method method :end)
- (format stream "#undef CALL_NEXT_METHOD~%")))))
-
-(defmethod hook-output progn ((method sod-method) (reason (eql :c))
- sequencer)
- (with-slots (class body) method
- (unless body
- (return-from hook-output))
- (sequence-output (stream sequencer)
- :constraint ((class :direct-methods :start)
- (class :direct-method method :start)
- (class :direct-method method :body)
- (class :direct-method method :end)
- (class :direct-methods :end))
- ((class :direct-method method :body)
- (pprint-c-type (sod-method-function-type method)
- stream
- (sod-method-function-name method))
- (format stream "~&{~%")
- (write body :stream stream :pretty nil :escape nil)
- (format stream "~&}~%"))
- ((class :direct-method method :end)
- (terpri stream)))))
-
-;;;--------------------------------------------------------------------------
-;;; Vtables.
-
-(defmethod hook-output progn ((vtable vtable) (reason (eql :c))
- sequencer)
- (with-slots (class chain-head chain-tail) vtable
- (sequence-output (stream sequencer)
- :constraint ((class :vtables :start)
- (class :vtable chain-head :start)
- (class :vtable chain-head :end)
- (class :vtables :end))
- ((class :vtable chain-head :start)
- (format stream "/* Vtable for ~A chain. */~@
- static const struct ~A ~A = {~%"
- chain-head
- (vtable-struct-tag chain-tail chain-head)
- (vtable-name chain-tail chain-head)))
- ((class :vtable chain-head :end)
- (format stream "};~2%")))))
-
-(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
- sequencer)
- (with-slots (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)
- (class :vtable chain-head :end))
- ((class :vtable chain-head :class-pointer metaclass)
- (format stream " &~A__classobj.~A.~A,~%"
- (sod-class-metaclass class)
- (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
- (sequence-output (stream sequencer)
- :constraint ((class :vtable chain-head :start)
- (class :vtable chain-head :base-offset)
- (class :vtable chain-head :end))
- ((class :vtable chain-head :base-offset)
- (format stream " offsetof(struct ~A, ~A),~%"
- (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
- (sequence-output (stream sequencer)
- :constraint ((class :vtable chain-head :start)
- (class :vtable chain-head :chain-offset target-head)
- (class :vtable chain-head :end))
- ((class :vtable chain-head :chain-offset target-head)
- (format stream " SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
- (ilayout-struct-tag class)
- (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
- (sequence-output (stream sequencer)
- :constraint ((subclass :vtable chain-head :start)
- (subclass :vtable chain-head :vtmsgs class :start)
- (subclass :vtable chain-head :vtmsgs class :slots)
- (subclass :vtable chain-head :vtmsgs class :end)
- (subclass :vtable chain-head :end))
- ((subclass :vtable chain-head :vtmsgs class :start)
- (format stream " { /* Method entries for ~A messages. */~%"
- class))
- ((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) entry
- (let* ((message (effective-method-message method))
- (class (effective-method-class method))
- (super (sod-message-class message)))
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :vtmsgs super :slots)
- (format stream " ~A,~%"
- (method-entry-function-name method chain-head)))))))
-
-;;;--------------------------------------------------------------------------
-;;; Filling in the class object.
-
-(defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
- sequencer)
- (with-slots (class chain-head) ichain
- (sequence-output (stream sequencer)
- :constraint ((*instance-class* :object :start)
- (*instance-class* :object chain-head :ichain :start)
- (*instance-class* :object chain-head :ichain :end)
- (*instance-class* :object :end))
- ((*instance-class* :object chain-head :ichain :start)
- (format stream " { { /* ~A ichain */~%"
- (sod-class-nickname chain-head)))
- ((*instance-class* :object chain-head :ichain :end)
- (format stream " } },~%")))))
-
-(defmethod hook-output progn ((islots islots) (reason (eql 'class))
- sequencer)
- (with-slots (class) islots
- (let ((chain-head (sod-class-chain-head class)))
- (sequence-output (stream sequencer)
- :constraint ((*instance-class* :object chain-head :ichain :start)
- (*instance-class* :object class :slots :start)
- (*instance-class* :object class :slots)
- (*instance-class* :object class :slots :end)
- (*instance-class* :object chain-head :ichain :end))
- ((*instance-class* :object class :slots :start)
- (format stream " { /* Class ~A */~%" class))
- ((*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
- (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)))))
-
-(defgeneric output-class-initializer (slot instance stream)
- (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
- (let ((func (effective-slot-initializer-function slot)))
- (if func
- (format stream " ~A,~%" (funcall func instance))
- (call-next-method))))
- (:method ((slot effective-slot) (instance sod-class) stream)
- (let ((init (find-class-initializer slot instance)))
- (ecase (sod-initializer-value-kind init)
- (:simple (format stream " ~A,~%"
- (sod-initializer-value-form init)))
- (:compound (format stream " ~@<{ ~;~A~; },~:>~%"
- (sod-initializer-value-form init)))))))
-
-(defmethod hook-output progn ((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))))))
-
-(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
- sequencer)
- (with-slots (class (dslot slot)) slot
- (let ((instance *instance-class*)
- (super (sod-slot-class dslot)))
- (sequence-output (stream sequencer)
- ((instance :object super :slots)
- (output-class-initializer slot instance stream))))))
-
-;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(defun test (name)
- (let ((sequencer (make-instance 'sequencer))
- (class (find-sod-class name)))
- (hook-output class :h sequencer)
- (invoke-sequencer-items sequencer *standard-output*)
- sequencer))
-
-;;;----- That's all, folks --------------------------------------------------