src/class-{finalize,layout}-*.lisp: Relocate layout interface code.

[sod] / src / class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index be42f13a5d32e05498dd25921542f58311a5eebe..a51075b6d94245aafe8ca8582d849eec462659c9 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -48,6 +48,22 @@ (cl:in-package #:sod)
 ;; Superclass Linearization for Dylan' for more detail.
 ;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
 
 ;; Superclass Linearization for Dylan' for more detail.
 ;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
 

+;;; Utilities.
+
+(export 'merge-class-lists)
+(defun merge-class-lists (lists pick)
+  "Merge the LISTS of classes, using PICK to break ties.
+
+   This is a convenience wrapper around the main `merge-lists' function.
+   Given that class linearizations (almost?) always specify a custom
+   tiebreaker function, this isn't a keyword argument.  Also, this wrapper
+   provides a standard presentation function so that any errors are presented
+   properly."
+  (merge-lists lists
+              :pick pick
+              :present (lambda (class)
+                         (format nil "`~A'" (sod-class-name class)))))
+

 ;;; Tiebreaker functions.
 
 (defun clos-tiebreaker (candidates so-far)
 ;;; Tiebreaker functions.
 
 (defun clos-tiebreaker (candidates so-far)


@@ -67,7 +83,7 @@ (defun clos-tiebreaker (candidates so-far)
        (when (member candidate (sod-class-direct-superclasses class))
          (setf winner candidate))))
     (unless winner
        (when (member candidate (sod-class-direct-superclasses class))
          (setf winner candidate))))
     (unless winner

-      (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
+      (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))

     winner))
 
 (defun c3-tiebreaker (candidates cpls)
     winner))
 
 (defun c3-tiebreaker (candidates cpls)


@@ -96,7 +112,7 @@ (defun c3-tiebreaker (candidates cpls)
     (dolist (candidate candidates)
       (when (member candidate cpl)
        (return-from c3-tiebreaker candidate))))
     (dolist (candidate candidates)
       (when (member candidate cpl)
        (return-from c3-tiebreaker candidate))))

-  (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
+  (error "SOD INTERNAL ERROR: Failed to break tie in C3"))

 
 ;;; Linearization functions.
 
 
 ;;; Linearization functions.
 


@@ -117,11 +133,11 @@ (defun clos-cpl (class)
               (remove-duplicates (cons class
                                        (mappend #'superclasses
                                                 direct-supers))))))
               (remove-duplicates (cons class
                                        (mappend #'superclasses
                                                 direct-supers))))))

-    (merge-lists (mapcar (lambda (class)
-                          (cons class
-                                (sod-class-direct-superclasses class)))
-                        (superclasses class))
-                :pick #'clos-tiebreaker)))
+    (merge-class-lists
+     (mapcar (lambda (class)
+              (cons class (sod-class-direct-superclasses class)))
+            (superclasses class))
+     #'clos-tiebreaker)))

 
 (export 'dylan-cpl)
 (defun dylan-cpl (class)
 
 (export 'dylan-cpl)
 (defun dylan-cpl (class)


@@ -143,9 +159,10 @@ (defun dylan-cpl (class)
    you're going to lose anyway."
 
   (let ((direct-supers (sod-class-direct-superclasses class)))
    you're going to lose anyway."
 
   (let ((direct-supers (sod-class-direct-superclasses class)))

-    (merge-lists (cons (cons class direct-supers)
-                      (mapcar #'sod-class-precedence-list direct-supers))
-                :pick #'clos-tiebreaker)))
+    (merge-class-lists
+     (cons (cons class direct-supers)
+          (mapcar #'sod-class-precedence-list direct-supers))
+     #'clos-tiebreaker)))

 
 (export 'c3-cpl)
 (defun c3-cpl (class)
 
 (export 'c3-cpl)
 (defun c3-cpl (class)


@@ -162,8 +179,8 @@ (defun c3-cpl (class)
 
   (let* ((direct-supers (sod-class-direct-superclasses class))
         (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 
   (let* ((direct-supers (sod-class-direct-superclasses class))
         (cpls (mapcar #'sod-class-precedence-list direct-supers)))

-    (merge-lists (cons (cons class direct-supers) cpls)
-                :pick (lambda (candidates so-far)
+    (merge-class-lists (cons (cons class direct-supers) cpls)
+                      (lambda (candidates so-far)

                         (declare (ignore so-far))
                         (c3-tiebreaker candidates cpls)))))
 
                         (declare (ignore so-far))
                         (c3-tiebreaker candidates cpls)))))
 


@@ -224,13 +241,14 @@ (defun l*loops-cpl (class)
    precedence order i.e., the direct-superclasses list orderings."
 
   (let ((dfs (flavors-cpl class)))
    precedence order i.e., the direct-superclasses list orderings."
 
   (let ((dfs (flavors-cpl class)))

-    (cons class (merge-lists (mapcar #'sod-class-precedence-list
+    (cons class
+         (merge-class-lists (mapcar #'sod-class-precedence-list

                                     (sod-class-direct-superclasses class))
                                     (sod-class-direct-superclasses class))

-                            :pick (lambda (candidates so-far)
-                                    (declare (ignore so-far))
-                                    (dolist (class dfs)
-                                      (when (member class candidates)
-                                        (return class))))))))
+                            (lambda (candidates so-far)
+                              (declare (ignore so-far))
+                              (dolist (class dfs)
+                                (when (member class candidates)
+                                  (return class))))))))

 
 ;;; Default function.
 
 
 ;;; Default function.
 


@@ -283,7 +301,7 @@ (defun maximum (items order what)
   (reduce (lambda (best this)
            (cond ((funcall order best this) best)
                  ((funcall order this best) this)
   (reduce (lambda (best this)
            (cond ((funcall order best this) best)
                  ((funcall order this best) this)

-                 (t (error "Unable to choose best ~A." what))))
+                 (t (error "Unable to choose best ~A" what))))

          items))
 
 (defmethod guess-metaclass ((class sod-class))
          items))
 
 (defmethod guess-metaclass ((class sod-class))


@@ -466,18 +484,4 @@        (default-slot (class 'metaclass) (guess-metaclass class))
       (:finalized
        t))))
 
       (:finalized
        t))))
 

-(flet ((check-class-is-finalized (class)
-        (unless (eq (sod-class-state class) :finalized)
-          (error "Class ~S is not finalized" class))))
-  (macrolet ((define-layout-slot (slot (class) &body body)
-              `(define-on-demand-slot sod-class ,slot (,class)
-                 (check-class-is-finalized ,class)
-                 ,@body)))
-    (define-layout-slot %ilayout (class)
-      (compute-ilayout class))
-    (define-layout-slot effective-methods (class)
-      (compute-effective-methods class))
-    (define-layout-slot vtables (class)
-      (compute-vtables class))))
-

 ;;;----- That's all, folks --------------------------------------------------
 ;;;----- That's all, folks --------------------------------------------------