X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/dea4d05507e59ab779ed4bb209e05971d87e260c..9ec578d9fe450b7e7f9030dc9d930185593aa991:/src/builtin.lisp diff --git a/src/builtin.lisp b/src/builtin.lisp index 7ea022e..73de860 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -31,7 +31,7 @@ (defvar *class-slot-alist* nil) (defun add-class-slot-function (name function) - "Attach a slot function to the *class-slot-alist*. + "Attach a slot function to the `*class-slot-alist*'. The FUNCTION is invoked with one argument, which is a `sod-class' object to which it should add a slot. If a function with the same NAME is @@ -49,11 +49,11 @@ (name (class &optional stream) type init &body prepare) "Define a new class slot. - The slot will be caled NAME, and will be of TYPE (which should be a type - S-expression). The slot's (static) initializer will be constructed by - printing the value of INIT, which is evaluated with CLASS bound to the - class object being constructed. If any PREPARE forms are provided, then - they are evaluated as a progn; they are evaluated with CLASS bound to the + The slot will be called NAME (a string) and will be of TYPE (which should + be a type S-expression). The slot's (static) initializer will be + constructed by printing the value of INIT, which is evaluated with CLASS + bound to the class object being constructed. If any PREPARE forms are + provided, then they are evaluated as a progn, with CLASS bound to the class object, and STREAM bound to the output stream it should write on." (with-gensyms (classvar) @@ -95,7 +95,7 @@ static void *~A__imprint(void *p) { struct ~A *sod__obj = p; - ~:{sod__obj.~A.~A._vt = &~A;~:^~% ~} + ~:{sod__obj->~A.~A._vt = &~A;~:^~% ~} return (p); }~2%" class @@ -113,15 +113,13 @@ static void *~A__imprint(void *p) (format nil "~A__init" class) ;; FIXME this needs a metaobject protocol - (let ((ilayout (sod-class-ilayout class))) + (let ((ilayout (sod-class-ilayout class)) + (used nil)) (format stream "~&~: -static void *~A__init(void *p) -{ - struct ~A *sod__obj = ~0@*~A__imprint(p);~2%" - class - (ilayout-struct-tag class)) +/* 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" + (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)) @@ -136,6 +134,11 @@ static void *~A__init(void *p) (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) @@ -149,6 +152,8 @@ static void *~A__init(void *p) :stream stream :pretty nil :escape nil) (format stream "};~%")))))))))))) + (unless used + (format stream " ~A__imprint(p);~%" class)) (format stream "~&~: return (p); }~2%"))) @@ -212,40 +217,51 @@ static const SodClass *const ~A__cpl[] = { };~:^~2%~} ~0@*static const struct sod_chain ~A__chains[] = { -~:{ { ~3@*~A, - ~0@*&~A__chain_~A, - ~4@*offsetof(struct ~A, ~A), - (const struct sod_vtable *)&~A, - sizeof(struct ~A) }~:^,~%~} +~:{ { ~ + /* n_classes = */ ~3@*~A, + /* classes = */ ~0@*~A__chain_~A, + /* off_ichain = */ ~4@*offsetof(struct ~A, ~A), + /* vt = */ (const struct sod_vtable *)&~A, + /* ichainsz = */ sizeof(struct ~A) }~:^,~%~} };~2%" class ;0 (mapcar (lambda (chain) ;1 (let* ((head (sod-class-chain-head (car chain))) + (tail (sod-class-chain-head (car chain))) (chain-nick (sod-class-nickname head))) - (list class chain-nick ;0 1 - (reverse chain) ;2 - (length chain) ;3 - (ilayout-struct-tag class) chain-nick ;4 5 - (vtable-name class head) ;6 - (ichain-struct-tag class head)))) ;7 + (list class chain-nick ;0 1 + (reverse chain) ;2 + (length chain) ;3 + (ilayout-struct-tag class) chain-nick ;4 5 + (vtable-name class head) ;6 + (ichain-struct-tag (car chain) head)))) ;7 chains)))) ;;;-------------------------------------------------------------------------- ;;; Class-specific layout. (define-class-slot "off_islots" (class) size-t - (format nil "offsetof(struct ~A, ~A)" - (ichain-struct-tag class (sod-class-chain-head class)) - (sod-class-nickname class))) + (if (sod-class-slots class) + (format nil "offsetof(struct ~A, ~A)" + (ichain-struct-tag class (sod-class-chain-head class)) + (sod-class-nickname class)) + "0")) (define-class-slot "islotsz" (class) size-t - (format nil "sizeof(struct ~A)" - (islots-struct-tag class))) + (if (sod-class-slots class) + (format nil "sizeof(struct ~A)" + (islots-struct-tag class)) + "0")) ;;;-------------------------------------------------------------------------- ;;; Bootstrapping the class graph. (defun bootstrap-classes (module) + "Bootstrap the braid in MODULE. + + This builds the fundamental recursive braid, where `SodObject' is an + 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))) (sod-class (make-sod-class "SodClass" (list sod-object) @@ -277,30 +293,41 @@ static const SodClass *const ~A__cpl[] = { (finalize-sod-class class) (add-to-module module class)))) +(defvar *builtin-module* nil + "The builtin module.") + (defun make-builtin-module () + "Construct the builtin module. + + This involves constructing the braid (which is done in + `bootstrap-classes') and defining a few obvious type names which users + will find handy. + + Returns the newly constructed module, and stores it in the variable + `*builtin-module*'." (let ((module (make-instance 'module :name (make-pathname :name "SOD-BASE" :type "SOD" :case :common) - :state nil)) - (include (format nil "#include \"~A\"~%" - (make-pathname :name "SOD" :type "H" - :case :common)))) - (call-with-module-environment - (lambda () - (dolist (name '("va_list" "size_t" "ptrdiff_t")) - (add-to-module module (make-instance 'type-item :name name))) - (add-to-module module (make-instance 'code-fragment-item - :reason :c - :constraints nil - :name :includes - :fragment include)) - (bootstrap-classes module))) - module)) - -(defvar *builtin-module* nil) - -(define-clear-the-decks reset-builtin-module - (setf *builtin-module* (make-builtin-module))) + :state nil))) + (with-module-environment (module) + (dolist (name '("va_list" "size_t" "ptrdiff_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) + (let ((text (with-output-to-string (out) + (dolist (name names) + (format out "#include ~A~%" name))))) + (add-to-module module + (make-instance 'code-fragment-item + :reason reason + :constraints nil + :name :includes + :fragment text))))) + (add-includes :c (header-name "sod")) + (add-includes :h "")) + (bootstrap-classes module)) + (setf *builtin-module* module))) ;;;----- That's all, folks --------------------------------------------------