X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a42893dda5f4dd2b89fbfe4e497da261159225ca..c34b237da0bb4bf08a3531a2e11442623df7e9d4:/src/builtin.lisp diff --git a/src/builtin.lisp b/src/builtin.lisp index d7d0fcb..9707578 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -85,6 +85,9 @@ (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) @@ -246,6 +249,39 @@ static const SodClass *const ~A__cpl[] = { (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 + "~@" + flags var)) + ;; Initialization. (defclass initialization-message (lifecycle-message) @@ -258,13 +294,37 @@ static const SodClass *const ~A__cpl[] = { ((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) @@ -278,7 +338,46 @@ static const SodClass *const ~A__cpl[] = { (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. @@ -297,6 +396,7 @@ static const SodClass *const ~A__cpl[] = { (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) @@ -307,8 +407,9 @@ static const SodClass *const ~A__cpl[] = { ;; 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)) @@ -317,6 +418,19 @@ static const SodClass *const ~A__cpl[] = { (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. @@ -341,7 +455,8 @@ static const SodClass *const ~A__cpl[] = { 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. @@ -449,8 +564,6 @@ static const SodClass *const ~A__cpl[] = { :case :common) :state nil))) (with-module-environment (module) - (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t")) - (add-to-module module (make-instance 'type-item :name name))) (flet ((header-name (name) (concatenate 'string "\"" (string-downcase name) ".h\"")) (add-includes (reason &rest names)