X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/52a79ab8b310a785f2c2f1a11069f3a5ad53810c..3b2ec4790da6b3f64189a58896957ac63169dd5e:/src/builtin.lisp diff --git a/src/builtin.lisp b/src/builtin.lisp index 8b4407b..c10e5ad 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -85,17 +85,20 @@ (define-class-slot "nick" (class) const-string (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) (let ((ilayout (sod-class-ilayout class))) (format stream "~&~: -/* Imprint raw memory with instance structure. */ -static void *~A__imprint(void *p) +/* Imprint raw memory with class `~A' instance structure. */ +static void *~:*~A__imprint(void *p) { struct ~A *sod__obj = p; - ~:{sod__obj->~A.~A._vt = &~A;~:^~% ~} + ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~} return (p); }~2%" class @@ -105,59 +108,10 @@ (define-class-slot "imprint" (class stream) (tail (ichain-tail ichain))) (list (sod-class-nickname head) (sod-class-nickname tail) - (vtable-name class head)))) + (vtable-name class head) + (sod-class-nickname tail)))) (ilayout-ichains ilayout))))) -(define-class-slot "init" (class stream) - (* (fun (* void) ("/*p*/" (* void)))) - (format nil "~A__init" class) - - ;; FIXME this needs a metaobject protocol - (let ((ilayout (sod-class-ilayout class)) - (used nil)) - (format stream "~&~: -/* Provide initial values for an instance's slots. */ -static void *~A__init(void *p)~%{~%" class) - (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 - (unless used - (format stream - " struct ~A *sod__obj = ~A__imprint(p);~2%" - (ilayout-struct-tag class) class) - (setf used t)) - (format stream " ~A.~A =" isl - (sod-slot-name dslot)) - (ecase (sod-initializer-value-kind init) - (:simple (write (sod-initializer-value-form init) - :stream stream - :pretty nil :escape nil) - (format stream ";~%")) - (:compound (format stream " (~A) {" - (sod-slot-type dslot)) - (write (sod-initializer-value-form init) - :stream stream - :pretty nil :escape nil) - (format stream "};~%")))))))))))) - (unless used - (format stream " ~A__imprint(p);~%" class)) - (format stream "~&~: - return (p); -}~2%"))) - ;;;-------------------------------------------------------------------------- ;;; Superclass structure. @@ -252,6 +206,296 @@ (define-class-slot "islotsz" (class) size-t (islots-struct-tag class)) "0")) +;;;-------------------------------------------------------------------------- +;;; Built-in methods. + +;; Common protocol. + +(defclass lifecycle-message (standard-message) + ()) + +(defclass lifecycle-effective-method (standard-effective-method) + ()) + +(defmethod effective-method-live-p ((method lifecycle-effective-method)) + t) + +(defgeneric lifecycle-method-kernel (method codegen target) + (:documentation + "Compute (into CODEGEN) the class-specific part of the METHOD. + + The result, if any, needs to find its way to the TARGET, as usual.")) + +(defmethod simple-method-body + ((method lifecycle-effective-method) codegen target) + (invoke-delegation-chain codegen target + (effective-method-basic-argument-names method) + (effective-method-primary-methods method) + (lambda (target) + (lifecycle-method-kernel method + 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 + "~@" + flags var)) + +;; Initialization. + +(defclass initialization-message (lifecycle-message) + ()) + +(defclass initialization-effective-method (lifecycle-effective-method) + ()) + +(defmethod sod-message-effective-method-class + ((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)) + (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) + + (labels ((set-from-initializer (var type init) + ;; Store the value of INIT, which has the given TYPE, in VAR. + ;; INIT has the syntax of an initializer: declare and + ;; initialize a temporary, and then copy the result. + ;; Compilers seem to optimize this properly. Return the + ;; resulting code as an instruction. + (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)) + (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 + "Instance initialization function ~:_~ + for class `~A'." + class) + + (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. @@ -267,6 +511,14 @@ (defun bootstrap-classes (module) (make-property-set :nick 'cls))) (classes (list sod-object sod-class))) + ;; Attach the built-in messages. + (make-sod-message sod-object "init" + (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) (dolist (class classes) @@ -312,7 +564,7 @@ (defun make-builtin-module () :case :common) :state nil))) (with-module-environment (module) - (dolist (name '("va_list" "size_t" "ptrdiff_t")) + (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\"")) @@ -331,4 +583,7 @@ (defun make-builtin-module () (bootstrap-classes module)) (setf *builtin-module* module))) +(define-clear-the-decks builtin-module + (unless *builtin-module* (make-builtin-module))) + ;;;----- That's all, folks --------------------------------------------------