X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/11e41ddf86b4ee793f44fc0e39cb4c1869335b14..ad1316527a6aa066d0abc0ada46a3616f5cb451f:/src/class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index b0e31ce..aea5058 100644
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- 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
@@ -48,6 +48,22 @@
 ;; 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)
@@ -67,7 +83,7 @@
 	(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)
@@ -96,7 +112,7 @@
     (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.
 
@@ -117,11 +133,11 @@
 	       (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)
@@ -143,9 +159,10 @@
    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)
@@ -162,8 +179,8 @@
 
   (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)))))
 
@@ -224,13 +241,14 @@
    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))
-			     :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.
 
@@ -276,6 +294,35 @@
 					 (cdr class-precedence-list)))))))))
 
 ;;;--------------------------------------------------------------------------
+;;; Metaclasses.
+
+(defun maximum (items order what)
+  "Return a maximum item according to the non-strict partial ORDER."
+  (reduce (lambda (best this)
+	    (cond ((funcall order best this) best)
+		  ((funcall order this best) this)
+		  (t (error "Unable to choose best ~A" what))))
+	  items))
+
+(defmethod guess-metaclass ((class sod-class))
+  "Default metaclass-guessing function for classes.
+
+   Return the most specific metaclass of any of the CLASS's direct
+   superclasses."
+
+  ;; During bootstrapping, our superclasses might not have their own
+  ;; metaclasses resolved yet.  If we find this, then throw `bootstrapping'
+  ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
+  ;; across the bows of anyone else who calls us).
+  (maximum (mapcar (lambda (super)
+		     (if (slot-boundp super 'metaclass)
+			 (slot-value super 'metaclass)
+			 (throw 'bootstrapping nil)))
+		   (sod-class-direct-superclasses class))
+	   #'sod-subclass-p
+	   (format nil "metaclass for `~A'" class)))
+
+;;;--------------------------------------------------------------------------
 ;;; Sanity checking.
 
 (defmethod check-sod-class ((class sod-class))
@@ -314,6 +361,41 @@
 	(error "In `~A~, chain-to class `~A' is not a proper superclass"
 	       class chain-link)))
 
+    ;; Check that the initargs declare compatible types.  Duplicate entries,
+    ;; even within a class, are harmless, but at most one initarg in any
+    ;; class should declare a default value.
+    (with-slots (class-precedence-list) class
+      (let ((seen (make-hash-table :test #'equal)))
+	(dolist (super class-precedence-list)
+	  (with-slots (initargs) super
+	    (dolist (initarg (reverse initargs))
+	      (let* ((initarg-name (sod-initarg-name initarg))
+		     (initarg-type (sod-initarg-type initarg))
+		     (initarg-default (sod-initarg-default initarg))
+		     (found (gethash initarg-name seen))
+		     (found-type (and found (sod-initarg-type found)))
+		     (found-default (and found (sod-initarg-default found)))
+		     (found-class (and found (sod-initarg-class found)))
+		     (found-location (and found (file-location found))))
+		(with-default-error-location (initarg)
+		  (cond ((not found)
+			 (setf (gethash initarg-name seen) initarg))
+			((not (c-type-equal-p initarg-type found-type))
+			 (cerror* "Inititalization argument `~A' defined ~
+				   with incompatible types: ~
+				   ~A in class ~A, and ~
+				   ~A in class ~A (at ~A)"
+				initarg-name initarg-type super
+				found-type found-class found-location))
+			((and initarg-default found-default
+			      (eql super found-class))
+			 (cerror* "Initialization argument `~A' redefined ~
+				   with default value ~
+				   (previous definition at ~A)"
+				  initarg-name found-location))
+			(initarg-default
+			 (setf (gethash initarg-name seen) initarg))))))))))
+
     ;; Check for circularity in the superclass graph.  Since the superclasses
     ;; should already be acyclic, it suffices to check that our class is not
     ;; a superclass of any of its own direct superclasses.
@@ -350,7 +432,12 @@
       ((nil)
 
        ;; If this fails, mark the class as a loss.
-       (setf (sod-class-state class) :broken)
+       (setf (slot-value class 'state) :broken)
+
+       ;; Set up the metaclass if it's not been set already.  This is delayed
+       ;; to give bootstrapping a chance to set up metaclass and superclass
+       ;; circularities.
+       (default-slot (class 'metaclass) (guess-metaclass class))
 
        ;; Finalize all of the superclasses.  There's some special pleading
        ;; here to make bootstrapping work: we don't try to finalize the
@@ -366,7 +453,7 @@
 	   (finalize-sod-class metaclass)))
 
        ;; Stash the class's type.
-       (setf (sod-class-type class)
+       (setf (slot-value class '%type)
 	     (make-class-type (sod-class-name class)))
 
        ;; Clobber the lists of items if they've not been set.
@@ -388,7 +475,7 @@
 	 (setf (values chain-head chain chains) (compute-chains class)))
 
        ;; Done.
-       (setf (sod-class-state class) :finalized)
+       (setf (slot-value class 'state) :finalized)
        t)
 
       (:broken
@@ -397,13 +484,13 @@
       (:finalized
        t))))
 
-(macrolet ((define-layout-slot (slot (class) &body body)
-	     `(define-on-demand-slot sod-class ,slot (,class)
-		(check-class-is-finalized ,class)
-		,@body)))
-  (flet ((check-class-is-finalized (class)
-	   (unless (eq (sod-class-state class) :finalized)
-	     (error "Class ~S is not finalized" class))))
+(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)