- (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)))))))