(define-class-slot "initsz" (class) size-t
(format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
+(define-class-slot "align" (class) size-t
+ (format nil "SOD__ALIGNOF(struct ~A)" (ilayout-struct-tag class)))
+
(define-class-slot "imprint" (class stream)
(* (fun (* void) ("/*p*/" (* void))))
(format nil "~A__imprint" class)
codegen
target))))
+;; Utilities.
+
+(defun declare-me (codegen class)
+ "Emit, to CODEGEN, a declaration of `me' as a pointer to CLASS.
+
+ The pointer refers to a part of the prevailing `sod__obj' object, which is
+ assumed to be a pointer to an appropriate `ilayout' structure."
+ (emit-decl codegen (make-var-inst "me" (c-type (* (class class)))
+ (format nil "&sod__obj->~A.~A"
+ (sod-class-nickname
+ (sod-class-chain-head class))
+ (sod-class-nickname class)))))
+
+(defun collect-initarg-keywords (class)
+ "Return a list of keyword arguments corresponding to CLASS's initargs.
+
+ For each distinct name among the initargs defined on CLASS and its
+ superclasses, return a single `argument' object containing the (agreed
+ common) type, and the (unique, if present) default value from the most
+ specific defining superclass.
+
+ The arguments are not returned in any especially meaningful order."
+
+ (let ((map (make-hash-table :test #'equal))
+ (default-map (make-hash-table :test #'equal))
+ (list nil))
+ (dolist (super (sod-class-precedence-list class))
+ (dolist (initarg (sod-class-initargs super))
+ (let ((name (sod-initarg-name initarg))
+ (default (sod-initarg-default initarg)))
+ (unless (gethash name default-map)
+ (when (or default (not (gethash name map)))
+ (setf (gethash name map) (sod-initarg-argument initarg)))
+ (when default
+ (setf (gethash name default-map) t))))))
+ (maphash (lambda (key value)
+ (declare (ignore key))
+ (push value list))
+ map)
+ list))
+
+(definst suppliedp-struct (stream) (flags var)
+ (format stream
+ "~@<struct { ~2I~_~{unsigned ~A : 1;~^ ~_~} ~I~_} ~A;~:>"
+ flags var))
+
;; Initialization.
(defclass initialization-message (lifecycle-message)
((message initialization-message))
'initialization-effective-method)
+(defmethod method-keyword-argument-lists
+ ((method initialization-effective-method) direct-methods)
+ (append (call-next-method)
+ (delete-duplicates
+ (mapcan (lambda (class)
+ (let ((initargs (sod-class-initargs class)))
+ (and initargs
+ (list (cons (mapcar #'sod-initarg-argument
+ initargs)
+ (format nil "initargs for ~A"
+ class))))))
+ (sod-class-precedence-list
+ (effective-method-class method)))
+ :key #'argument-name)))
+
(defmethod lifecycle-method-kernel
((method initialization-effective-method) codegen target)
(let* ((class (effective-method-class method))
+ (keywords (collect-initarg-keywords class))
(ilayout (sod-class-ilayout class))
(obj-tag (ilayout-struct-tag class))
- (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
- (func-name (format nil "~A__init" class)))
+ (kw-tag (effective-method-keyword-struct-tag method))
+ (kw-tail (and keywords
+ (list (make-argument
+ "sod__kw"
+ (c-type (* (struct kw-tag :const)))))))
+ (func-type (c-type (fun void
+ ("sod__obj" (* (struct obj-tag)))
+ . kw-tail)))
+ (func-name (format nil "~A__init" class))
+ (done-setup-p nil))
;; Start building the initialization function.
(codegen-push codegen)
(codegen-push codegen)
(emit-decl codegen (make-var-inst *sod-tmp-val* type init))
(deliver-expr codegen var *sod-tmp-val*)
- (codegen-pop-block codegen)))
-
- ;; Loop over the instance layout emitting initializers as we find them.
- (dolist (ichain (ilayout-ichains ilayout))
- (let ((ich (format nil "sod__obj->~A.~A"
- (sod-class-nickname (ichain-head ichain))
- (sod-class-nickname (ichain-tail ichain)))))
- (dolist (item (ichain-body ichain))
- (etypecase item
- (vtable-pointer
- nil)
- (islots
- (let ((isl (format nil "~A.~A"
- ich
- (sod-class-nickname (islots-class item)))))
- (dolist (slot (islots-slots item))
- (let ((dslot (effective-slot-direct-slot slot))
- (init (effective-slot-initializer slot)))
- (when init
- (let* ((slot-type (sod-slot-type dslot))
- (slot-default (sod-initializer-value init))
- (target (format nil "~A.~A"
- isl (sod-slot-name dslot)))
- (initinst (set-from-initializer target
- slot-type
- slot-default)))
- (emit-inst codegen initinst))))))))))))
+ (codegen-pop-block codegen))
+ (setup ()
+ ;; Do any necessary one-time initialization required to set up
+ ;; the environment for the initialization code.
+ (unless done-setup-p
+
+ ;; Extract the keyword arguments into local variables.
+ (when keywords
+ (emit-decl codegen
+ (make-suppliedp-struct-inst
+ (mapcar #'argument-name keywords)
+ "suppliedp"))
+ (emit-banner codegen "Collect the keyword arguments.")
+ (dolist (arg keywords)
+ (let* ((name (argument-name arg))
+ (type (argument-type arg))
+ (default (argument-default arg))
+ (kwvar (format nil "sod__kw->~A" name))
+ (kwset (make-set-inst name kwvar))
+ (suppliedp (format nil "suppliedp.~A" name)))
+ (emit-decl codegen (make-var-inst name type))
+ (deliver-expr codegen suppliedp
+ (format nil "sod__kw->~A__suppliedp"
+ name))
+ (emit-inst
+ codegen
+ (if default
+ (make-if-inst suppliedp kwset
+ (set-from-initializer name
+ type
+ default))
+ kwset))))
+
+ (deliver-call codegen :void
+ "SOD__IGNORE" "suppliedp")
+ (dolist (arg keywords)
+ (deliver-call codegen :void
+ "SOD__IGNORE" (argument-name arg))))
+
+ (setf done-setup-p t))))
+
+ ;; Initialize the structure defined by the various superclasses, in
+ ;; reverse precedence order.
+ (dolist (super (reverse (sod-class-precedence-list class)))
+ (let* ((ichain (find (sod-class-chain-head super)
+ (ilayout-ichains ilayout)
+ :key #'ichain-head))
+ (islots (find super (ichain-body ichain)
+ :test (lambda (class item)
+ (and (typep item 'islots)
+ (eq (islots-class item) class)))))
+ (frags (sod-class-initfrags super))
+ (this-class-focussed-p nil)
+ (isl (format nil "me->~A" (sod-class-nickname super))))
+
+ (flet ((focus-this-class ()
+ ;; Delayed initial preparation. Don't bother defining the
+ ;; `me' pointer if there's actually nothing to do.
+ (setup)
+ (unless this-class-focussed-p
+ (emit-banner codegen
+ "Initialization for class `~A'." super)
+ (codegen-push codegen)
+ (declare-me codegen super)
+ (setf this-class-focussed-p t))))
+
+ ;; Work through each slot in turn.
+ (dolist (slot (and islots (islots-slots islots)))
+ (let ((dslot (effective-slot-direct-slot slot))
+ (init (effective-slot-initializer slot))
+ (initargs (effective-slot-initargs slot)))
+ (when (or init initargs)
+ (focus-this-class)
+ (let* ((slot-type (sod-slot-type dslot))
+ (slot-default (sod-initializer-value init))
+ (target (format nil "~A.~A"
+ isl (sod-slot-name dslot)))
+ (initinst (set-from-initializer target
+ slot-type
+ slot-default)))
+
+ ;; If there are applicable initialization arguments,
+ ;; check to see whether they were supplied.
+ (dolist (initarg (reverse (remove-duplicates
+ initargs
+ :key #'sod-initarg-name
+ :test #'string=)))
+ (let ((arg-name (sod-initarg-name initarg)))
+ (setf initinst (make-if-inst
+ (format nil "suppliedp.~A" arg-name)
+ (make-set-inst target arg-name)
+ initinst))))
+
+ (emit-inst codegen initinst)))))
+
+ ;; Emit the class's initialization fragments.
+ (when frags
+ (let ((used-me-p this-class-focussed-p))
+ (focus-this-class)
+ (unless used-me-p
+ (deliver-call codegen :void "SOD__IGNORE" "me")))
+ (dolist (frag frags)
+ (codegen-push codegen)
+ (emit-inst codegen frag)
+ (emit-inst codegen (codegen-pop-block codegen))))
+
+ ;; If we opened a block to initialize this class then close it
+ ;; again.
+ (when this-class-focussed-p
+ (emit-inst codegen (codegen-pop-block codegen)))))))
;; Done making the initialization function.
(codegen-pop-function codegen func-name func-type
for class `~A'."
class)
- (deliver-call codegen :void func-name "sod__obj")))
+ (apply #'deliver-call codegen :void func-name
+ "sod__obj" (and keywords (list (keyword-struct-pointer))))))
+
+;; Teardown.
+
+(defclass teardown-message (lifecycle-message)
+ ())
+
+(defclass teardown-effective-method (lifecycle-effective-method)
+ ())
+
+(defmethod sod-message-effective-method-class ((message teardown-message))
+ 'teardown-effective-method)
+
+(defmethod lifecycle-method-kernel
+ ((method teardown-effective-method) codegen target)
+ (let* ((class (effective-method-class method))
+ (obj-tag (ilayout-struct-tag class))
+ (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
+ (func-name (format nil "~A__teardown" class)))
+ (codegen-push codegen)
+ (dolist (super (sod-class-precedence-list class))
+ (let ((frags (sod-class-tearfrags super)))
+ (when frags
+ (emit-banner codegen "Teardown for class `~A'." super)
+ (codegen-push codegen)
+ (declare-me codegen super)
+ (deliver-call codegen :void "SOD__IGNORE" "me")
+ (dolist (frag frags)
+ (codegen-push codegen)
+ (emit-inst codegen frag)
+ (emit-inst codegen (codegen-pop-block codegen)))
+ (emit-inst codegen (codegen-pop-block codegen)))))
+ (codegen-pop-function codegen func-name func-type
+ "Instance teardown function ~:_~
+ for class `~A'."
+ class)
+ (deliver-call codegen :void
+ (format nil "~A__teardown" class) "sod__obj")
+ (deliver-expr codegen target 0)))
;;;--------------------------------------------------------------------------
;;; Bootstrapping the class graph.
(c-type (fun void :keys))
(make-property-set
:message-class 'initialization-message))
+ (make-sod-message sod-object "teardown" (c-type (fun int))
+ (make-property-set :message-class 'teardown-message))
;; Sort out the recursion.
(setf (slot-value sod-class 'chain-link) sod-object)
~mdw / sod / blobdiff