(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)
(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 sod-message-keyword-argument-lists
+ ((message initialization-message) (class sod-class) direct-methods state)
+ (append (call-next-method)
+ (mapcan (lambda (class)
+ (let* ((initargs (sod-class-initargs class))
+ (map (make-hash-table))
+ (arglist (mapcar
+ (lambda (initarg)
+ (let ((arg (sod-initarg-argument
+ initarg)))
+ (setf (gethash arg map) initarg)
+ arg))
+ initargs)))
+ (and initargs
+ (list (cons (lambda (arg)
+ (info-with-location
+ (gethash arg map)
+ "Type `~A' from initarg ~
+ in class `~A' (here)"
+ (argument-type arg) class)
+ (report-inheritance-path
+ state class))
+ arglist)))))
+ (sod-class-precedence-list class))))
+
(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.
: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)
;; 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))
(target (format nil "~A.~A"
isl (sod-slot-name dslot)))
- (initinst (set-from-initializer target
- slot-type
- slot-default)))
+ (initinst (and init
+ (set-from-initializer
+ target slot-type
+ (sod-initializer-value init)))))
+
+ ;; 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=
+ :from-end t)))
+ (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
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.
instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
an instance of itself)."
(let* ((sod-object (make-sod-class "SodObject" nil
- (make-property-set :nick 'obj)))
+ (make-property-set :nick 'obj
+ :%bootstrapping t)))
(sod-class (make-sod-class "SodClass" (list sod-object)
- (make-property-set :nick 'cls)))
+ (make-property-set :nick 'cls
+ :%bootstrapping t)))
(classes (list sod-object sod-class)))
;; Attach the built-in messages.
(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)
;; Done.
(dolist (class classes)
- (finalize-sod-class class)
+ (unless (finalize-sod-class class)
+ (error "Failed to finalize built-in class"))
(add-to-module module class))))
(export '*builtin-module*)
-(defvar *builtin-module* nil
+(defvar-unbound *builtin-module*
"The builtin module.")
(export 'make-builtin-module)
: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)
(setf *builtin-module* module)))
(define-clear-the-decks builtin-module
- (unless *builtin-module* (make-builtin-module)))
+ (unless (boundp '*builtin-module*) (make-builtin-module)))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff