(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)))
+ (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.
(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)
;; 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)))
- (when init
+ (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))
(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.
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.
~mdw / sod / blobdiff