;;;----- 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
(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
(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)
',name
(lambda (,classvar)
(make-sod-slot ,classvar ,name (c-type ,type)
- (make-property-set :lisp-class 'sod-class-slot
+ (make-property-set :slot-class 'sod-class-slot
:initializer-function
(lambda (,class)
,init)
(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
(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)))
- (format stream "~&~:
-static void *~A__init(void *p)
-{
- struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
- class
- (ilayout-struct-tag 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
- (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 "};~%"))))))))))))
- (format stream "~&~:
- return (p);
-}~2%")))
-
;;;--------------------------------------------------------------------------
;;; Superclass structure.
};~:^~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)))
(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"))
+
+;;;--------------------------------------------------------------------------
+;;; 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)))))
+
+;; 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)))
+
+ ;; 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)))))
+ (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.
+ (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)))
+ (when init
+ (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)))
+ (emit-inst codegen initinst)))))
+
+ ;; 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)
+
+ (deliver-call codegen :void func-name "sod__obj")))
;;;--------------------------------------------------------------------------
;;; 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)
(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)
(finalize-sod-class class)
(add-to-module module class))))
+(export '*builtin-module*)
+(defvar *builtin-module* nil
+ "The builtin module.")
+
+(export 'make-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" "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)
+ (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 "<stddef.h>"))
+ (bootstrap-classes module))
+ (setf *builtin-module* module)))
+
+(define-clear-the-decks builtin-module
+ (unless *builtin-module* (make-builtin-module)))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff