X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/c2438e62e7c3cf1b7006522cef61e8c6f797600b..a142609c5dc2a7c3df02497235881beaf47088bf:/src/builtin.lisp diff --git a/src/builtin.lisp b/src/builtin.lisp index 696bcf6..6374e6d 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 @@ -90,8 +90,8 @@ (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; @@ -109,56 +109,6 @@ static void *~A__imprint(void *p) (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. @@ -254,6 +204,104 @@ static const SodClass *const ~A__cpl[] = { "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)))) + +;; 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 lifecycle-method-kernel + ((method initialization-effective-method) codegen target) + (let* ((class (effective-method-class method)) + (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))) + + ;; 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))) + + ;; 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)))))))))))) + + ;; Done making the initialization function. + (codegen-pop-function codegen func-name func-type + "Instance initialization function ~:_~ + for class `~A'." + class) + + (deliver-call codegen :void func-name "sod__obj"))) + +;;;-------------------------------------------------------------------------- ;;; Bootstrapping the class graph. (defun bootstrap-classes (module) @@ -268,6 +316,12 @@ static const SodClass *const ~A__cpl[] = { (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)) + ;; Sort out the recursion. (setf (slot-value sod-class 'chain-link) sod-object) (dolist (class classes) @@ -313,7 +367,7 @@ static const SodClass *const ~A__cpl[] = { :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\"")) @@ -332,4 +386,7 @@ static const SodClass *const ~A__cpl[] = { (bootstrap-classes module)) (setf *builtin-module* module))) +(define-clear-the-decks builtin-module + (unless *builtin-module* (make-builtin-module))) + ;;;----- That's all, folks --------------------------------------------------