Another day, another commit.

[sod] / builtin.lisp

diff --git a/builtin.lisp b/builtin.lisp
index 21fa1e3..67c04c1 100644 (file)
--- a/builtin.lisp
+++ b/builtin.lisp
@@ -31,18 +31,22 @@
 (defun output-imprint-function (class stream)
   (let ((ilayout (sod-class-ilayout class)))
     (format stream "~&~:
 (defun output-imprint-function (class stream)
   (let ((ilayout (sod-class-ilayout class)))
     (format stream "~&~:

+/* Imprint raw memory with instance structure. */

 static void *~A__imprint(void *p)
 {
   struct ~A *sod__obj = p;
 
 static void *~A__imprint(void *p)
 {
   struct ~A *sod__obj = p;
 

-  ~:{sod__obj.~A._vt = &~A;~:^~%  ~}
+  ~:{sod__obj.~A.~A._vt = &~A;~:^~%  ~}

   return (p);
 }~2%"
            class
            (ilayout-struct-tag class)
            (mapcar (lambda (ichain)
   return (p);
 }~2%"
            class
            (ilayout-struct-tag class)
            (mapcar (lambda (ichain)

-                     (list (sod-class-nickname (ichain-head ichain))
-                           (vtable-name class (ichain-head ichain))))
+                     (let* ((head (ichain-head ichain))
+                            (tail (ichain-tail ichain)))
+                       (list (sod-class-nickname head)
+                             (sod-class-nickname tail)
+                             (vtable-name class head))))

                    (ilayout-ichains ilayout)))))
 
 (defun output-init-function (class stream)
                    (ilayout-ichains ilayout)))))
 
 (defun output-init-function (class stream)


@@ -55,8 +59,9 @@ static void *~A__init(void *p)
            class
            (ilayout-struct-tag class))
     (dolist (ichain (ilayout-ichains ilayout))
            class
            (ilayout-struct-tag class))
     (dolist (ichain (ilayout-ichains ilayout))

-      (let ((ich (format nil "sod__obj.~A"
-                        (sod-class-nickname (ichain-head ichain)))))
+      (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
        (dolist (item (ichain-body ichain))
          (etypecase item
            (vtable-pointer


@@ -73,11 +78,11 @@ static void *~A__init(void *p)
                     (ecase (sod-initializer-value-kind init)
                       (:single
                        (format stream "  ~A = ~A;~%"
                     (ecase (sod-initializer-value-kind init)
                       (:single
                        (format stream "  ~A = ~A;~%"

-                               isl (sod-initializer-value-form slot)))
+                               isl (sod-initializer-value-form init)))

                       (:compound
                        (format stream "  ~A = (~A)~A;~%"
                                isl (sod-slot-type dslot)
                       (:compound
                        (format stream "  ~A = (~A)~A;~%"
                                isl (sod-slot-type dslot)

-                               (sod-initializer-value-form slot)))))))))))))
+                               (sod-initializer-value-form init)))))))))))))

     (format stream "~&~:
   return (p);
 }~2%")))
     (format stream "~&~:
   return (p);
 }~2%")))


@@ -86,6 +91,7 @@ static void *~A__init(void *p)
   (let ((supers (sod-class-direct-superclasses class)))
     (when supers
       (format stream "~&~:
   (let ((supers (sod-class-direct-superclasses class)))
     (when supers
       (format stream "~&~:

+/* Direct superclasses. */

 static const SodClass *const ~A__supers[] = {
   ~{~A__class~^,~%  ~}
 };~2%"
 static const SodClass *const ~A__supers[] = {
   ~{~A__class~^,~%  ~}
 };~2%"


@@ -93,6 +99,7 @@ static const SodClass *const ~A__supers[] = {
 
 (defun output-cpl-vector (class stream)
   (format stream "~&~:
 
 (defun output-cpl-vector (class stream)
   (format stream "~&~:

+/* Class precedence list. */

 static const SodClass *const ~A__cpl[] = {
   ~{~A__class~^,~%  ~}
 };~2%"
 static const SodClass *const ~A__cpl[] = {
   ~{~A__class~^,~%  ~}
 };~2%"


@@ -101,8 +108,9 @@ static const SodClass *const ~A__cpl[] = {
 (defun output-chains-vector (class stream)
   (let ((chains (sod-class-chains class)))
     (format stream "~&~:
 (defun output-chains-vector (class stream)
   (let ((chains (sod-class-chains class)))
     (format stream "~&~:

+/* Chain structure. */

 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {

-~{  ~A__class~^,~%~}
+  ~{~A__class~^,~%  ~}

 };~:^~2%~}
 
 ~0@*static const struct sod_chain ~A__chains[] = {
 };~:^~2%~}
 
 ~0@*static const struct sod_chain ~A__chains[] = {


@@ -137,6 +145,14 @@ static const SodClass *const ~A__cpl[] = {
    of the information (name, type, and how to initialize them) about these
    slots in one place, so that's what we do here."))
 
    of the information (name, type, and how to initialize them) about these
    slots in one place, so that's what we do here."))
 

+(defclass sod-magic-class-initializer (sod-class-initializer)
+  ((initializer-function :initarg :initializer-function
+                        :type (or symbol function)
+                        :reader sod-initializer-function)
+   (prepare-function  :initarg :prepare-function
+                     :type (or symbol function)
+                     :reader sod-initializer-prepare-function)))
+

 (defmethod shared-initialize :after
     ((slot sod-class-slot) slot-names &key pset)
   (declare (ignore slot-names))
 (defmethod shared-initialize :after
     ((slot sod-class-slot) slot-names &key pset)
   (declare (ignore slot-names))


@@ -160,7 +176,7 @@ static const SodClass *const ~A__cpl[] = {
 
 (defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
   (make-instance 'sod-class-effective-slot
 
 (defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
   (make-instance 'sod-class-effective-slot

-                :slot slot
+                :class class :slot slot

                 :initializer-function (sod-slot-initializer-function slot)
                 :prepare-function (sod-slot-prepare-function slot)
                 :initializer (find-slot-initializer class slot)))
                 :initializer-function (sod-slot-initializer-function slot)
                 :prepare-function (sod-slot-prepare-function slot)
                 :initializer (find-slot-initializer class slot)))


@@ -188,12 +204,12 @@ static const SodClass *const ~A__cpl[] = {
                 (format nil "sizeof(struct ~A)"
                         (ilayout-struct-tag class))))
     ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
                 (format nil "sizeof(struct ~A)"
                         (ilayout-struct-tag class))))
     ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))

-              :prepare-function 'output-imprint-function
+              :prepare-function output-imprint-function

               :initializer-function
               ,(lambda (class)
                  (format nil "~A__imprint" class)))
     ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
               :initializer-function
               ,(lambda (class)
                  (format nil "~A__imprint" class)))
     ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))

-           :prepare-function 'output-init-function
+           :prepare-function output-init-function

            :initializer-function
            ,(lambda (class)
               (format nil "~A__init" class)))
            :initializer-function
            ,(lambda (class)
               (format nil "~A__init" class)))


@@ -204,7 +220,7 @@ static const SodClass *const ~A__cpl[] = {
                ,(lambda (class)
                   (length (sod-class-direct-superclasses class))))
     ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
                ,(lambda (class)
                   (length (sod-class-direct-superclasses class))))
     ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))

-             :prepare-function 'output-supers-vector
+             :prepare-function output-supers-vector

              :initializer-function
              ,(lambda (class)
                 (if (sod-class-direct-superclasses class)
              :initializer-function
              ,(lambda (class)
                 (if (sod-class-direct-superclasses class)


@@ -215,7 +231,7 @@ static const SodClass *const ~A__cpl[] = {
                ,(lambda (class)
                   (length (sod-class-precedence-list class))))
     ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
                ,(lambda (class)
                   (length (sod-class-precedence-list class))))
     ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))

-          :prepare-function 'output-cpl-vector
+          :prepare-function output-cpl-vector

           :initializer-function
           ,(lambda (class)
              (format nil "~A__cpl" class)))
           :initializer-function
           ,(lambda (class)
              (format nil "~A__cpl" class)))


@@ -241,7 +257,7 @@ static const SodClass *const ~A__cpl[] = {
                ,(lambda (class)
                   (length (sod-class-chains class))))
     ("chains" ,(c-type (* (struct "sod_chain" :const)))
                ,(lambda (class)
                   (length (sod-class-chains class))))
     ("chains" ,(c-type (* (struct "sod_chain" :const)))

-             :prepare-function 'output-chains-vector
+             :prepare-function output-chains-vector

              :initializer-function
              ,(lambda (class)
                 (format nil "~A__chains" class)))
              :initializer-function
              ,(lambda (class)
                 (format nil "~A__chains" class)))