;;;----- 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)
{
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)
(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))
(let ((dslot (effective-slot-direct-slot slot))
(init (effective-slot-initializer slot)))
(when init
- (format stream " ~A.~A =" isl
- (sod-slot-name dslot))
+ (unless used
+ (format stream
+ " struct ~A *sod__obj = ~A__imprint(p);~2%"
+ (ilayout-struct-tag class) class)
+ (setf used t))
+ (format stream " {~% ")
+ (pprint-c-type (sod-slot-type dslot) stream
+ *sod-tmp-val*)
+ (format stream " =")
(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))
+ (:compound (format stream " {")
(write (sod-initializer-value-form init)
:stream stream
:pretty nil :escape nil)
- (format stream "};~%"))))))))))))
+ (format stream " };~%")))
+ (format stream " ~A.~A = ~A;~% }~%"
+ isl (sod-slot-name dslot)
+ *sod-tmp-val*))))))))))
+ (unless used
+ (format stream " ~A__imprint(p);~%" class))
(format stream "~&~:
return (p);
}~2%")))
};~:^~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"))
;;;--------------------------------------------------------------------------
;;; 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)
(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