X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/16f9fb7227bf77da748dd6fc03e58c6a9e84ab70..c05a49772af66d4059f856218f0bea74d2462d45:/src/class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 6bbc4f1..ce3282f 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,17 @@ (cl:in-package #:sod)
 ;; 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."
+  (merge-lists lists :pick pick))
+
 ;;; Tiebreaker functions.
 
 (defun clos-tiebreaker (candidates so-far)
@@ -67,7 +78,7 @@ (defun clos-tiebreaker (candidates so-far)
 	(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 +107,7 @@ (defun c3-tiebreaker (candidates cpls)
     (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 +128,11 @@ (defun clos-cpl (class)
 	       (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 +154,10 @@ (defun dylan-cpl (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)
@@ -162,8 +174,8 @@ (defun c3-cpl (class)
 
   (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 +236,14 @@ (defun l*loops-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))
-			     :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.
 
@@ -251,6 +264,7 @@ (defmethod compute-chains ((class sod-class))
 		       class))
 	     (chain (cons class (and chain-link
 				     (sod-class-chain chain-link))))
+	     (state (make-inheritance-path-reporter-state class))
 	     (table (make-hash-table)))
 
 	;; Check the chains.  We work through each superclass, maintaining a
@@ -259,13 +273,15 @@ (defmethod compute-chains ((class sod-class))
 	;; we've found an error.  By the end of all of this, the classes
 	;; which don't have an entry are the chain tails.
 	(dolist (super class-precedence-list)
-	  (let ((link (sod-class-chain-link super)))
-	    (when link
-	      (when (gethash link table)
-		(error "Conflicting chains in class ~A: ~
-			(~A and ~A both link to ~A)"
-		       class super (gethash link table) link))
-	      (setf (gethash link table) super))))
+	  (let* ((link (sod-class-chain-link super))
+		 (found (and link (gethash link table))))
+	    (cond ((not found) (setf (gethash link table) super))
+		  (t
+		   (cerror* "Conflicting chains in class `~A': ~
+			     (`~A' and `~A' both link to `~A')"
+			    class super found link)
+		   (report-inheritance-path state super)
+		   (report-inheritance-path state found)))))
 
 	;; Done.
 	(values head chain
@@ -275,6 +291,27 @@ (defmethod compute-chains ((class sod-class))
 					   (gethash super table))
 					 (cdr class-precedence-list)))))))))
 
+;;;--------------------------------------------------------------------------
+;;; Metaclasses.
+
+(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).
+  (finalization-error (:bad-metaclass)
+    (select-minimal-class-property (sod-class-direct-superclasses class)
+				   (lambda (super)
+				     (if (slot-boundp super 'metaclass)
+					 (slot-value super 'metaclass)
+					 (throw 'bootstrapping nil)))
+				   #'sod-subclass-p class "metaclass")))
+
 ;;;--------------------------------------------------------------------------
 ;;; Sanity checking.
 
@@ -282,37 +319,132 @@ (defmethod check-sod-class ((class sod-class))
   (with-default-error-location (class)
 
     ;; Check the names of things are valid.
-    (with-slots (name nickname messages) class
-      (unless (valid-name-p name)
-	(error "Invalid class name `~A'" class))
-      (unless (valid-name-p nickname)
-	(error "Invalid class nickname `~A' on class `~A'" nickname class))
-      (dolist (message messages)
-	(unless (valid-name-p (sod-message-name message))
-	  (error "Invalid message name `~A' on class `~A'"
-		 (sod-message-name message) class))))
-
-    ;; Check that the slots and messages have distinct names.
-    (with-slots (slots messages class-precedence-list) class
-      (flet ((check-list (list what namefunc)
-	       (let ((table (make-hash-table :test #'equal)))
+    (flet ((check-list (list what namefunc)
+	     (dolist (item list)
+	       (let ((name (funcall namefunc item)))
+		 (unless (valid-name-p name)
+		   (cerror*-with-location item
+					  "Invalid ~A name `~A' ~
+					   in class `~A'"
+					  what name class))))))
+      (unless (valid-name-p (sod-class-name class))
+	(cerror* "Invalid class name `~A'" class))
+      (unless (valid-name-p (sod-class-nickname class))
+	(cerror* "Invalid class nickname `~A' for class `~A'"
+		 (sod-class-nickname class) class))
+      (check-list (sod-class-messages class) "message" #'sod-message-name)
+      (check-list (sod-class-slots class) "slot" #'sod-slot-name))
+
+    ;; Check that the class doesn't define conflicting things.
+    (labels ((check-list (list keyfunc complain)
+	       (let ((seen (make-hash-table :test #'equal)))
 		 (dolist (item list)
-		   (let ((name (funcall namefunc item)))
-		     (if (gethash name table)
-			 (error "Duplicate ~A name `~A' on class `~A'"
-				what name class)
-			 (setf (gethash name table) item)))))))
-	(check-list slots "slot" #'sod-slot-name)
-	(check-list messages "message" #'sod-message-name)
-	(check-list class-precedence-list "nickname" #'sod-class-name)))
+		   (let* ((key (funcall keyfunc item))
+			  (found (gethash key seen)))
+		     (if found (funcall complain item found)
+			 (setf (gethash key seen) item))))))
+	     (simple-previous (previous)
+	       (info-with-location previous "Previous definition was here"))
+	     (simple-complain (what namefunc)
+	       (lambda (item previous)
+		 (cerror*-with-location item
+					"Duplicate ~A `~A' in class `~A'"
+					what (funcall namefunc item) class)
+		 (simple-previous previous))))
+
+	;; Make sure direct slots have distinct names.
+	(check-list (sod-class-slots class) #'sod-slot-name
+		    (simple-complain "slot name" #'sod-slot-name))
+
+	;; Make sure there's at most one initializer for each slot.
+	(flet ((check-initializer-list (list kind)
+		 (check-list list #'sod-initializer-slot
+			     (lambda (initializer previous)
+			       (let ((slot
+				      (sod-initializer-slot initializer)))
+				 (cerror*-with-location initializer
+							"Duplicate ~
+							 initializer for ~
+							 ~A slot `~A' ~
+							 in class `~A'"
+							kind slot class)
+				 (simple-previous previous))))))
+	  (check-initializer-list (sod-class-instance-initializers class)
+				  "instance")
+	  (check-initializer-list (sod-class-class-initializers class)
+				  "class"))
+
+	;; Make sure messages have distinct names.
+	(check-list (sod-class-messages class) #'sod-message-name
+		    (simple-complain "message name" #'sod-message-name))
+
+	;; Make sure methods are sufficiently distinct.
+	(check-list (sod-class-methods class) #'sod-method-function-name
+		    (lambda (method previous)
+		      (cerror*-with-location method
+					     "Duplicate ~A direct method ~
+					      for message `~A' ~
+					      in classs `~A'"
+					     (sod-method-description method)
+					     (sod-method-message method)
+					     class)
+		      (simple-previous previous)))
+
+	;; Make sure superclasses have distinct nicknames.
+	(let ((state (make-inheritance-path-reporter-state class)))
+	  (check-list (sod-class-precedence-list class) #'sod-class-nickname
+		      (lambda (super previous)
+			(cerror*-with-location class
+					       "Duplicate nickname `~A' ~
+						in superclasses of `~A': ~
+						used by `~A' and `~A'"
+					       (sod-class-nickname super)
+					       class super previous)
+			(report-inheritance-path state super)
+			(report-inheritance-path state previous)))))
 
     ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
     ;; eliminates hairy things like a class being its own link.)
-    (with-slots (class-precedence-list chain-link) class
-      (unless (or (not chain-link)
-		  (member chain-link (cdr class-precedence-list)))
-	(error "In `~A~, chain-to class `~A' is not a proper superclass"
-	       class chain-link)))
+    (let ((link (sod-class-chain-link class)))
+      (unless (or (not link)
+		  (member link (cdr (sod-class-precedence-list class))))
+	(cerror* "In `~A~, chain-to class `~A' is not a proper superclass"
+		 class 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.
+    (let ((seen (make-hash-table :test #'equal))
+	  (state (make-inheritance-path-reporter-state class)))
+      (dolist (super (sod-class-precedence-list class))
+	(dolist (initarg (reverse (sod-class-initargs super)))
+	  (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', but ~A in class `~A'"
+			      initarg-name initarg-type super
+			      found-type found-class found-location)
+		     (report-inheritance-path state super))
+		    ((and initarg-default found-default
+			  (eql super found-class))
+		     (cerror* "Initialization argument `~A' redefined ~
+			       with default value"
+			      initarg-name)
+		     (info-with-location found-location
+					 "Previous definition is here"))
+		    (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
@@ -321,94 +453,134 @@ (defmethod check-sod-class ((class sod-class))
 			     (sod-subclass-p super class))
 			   (sod-class-direct-superclasses class))))
       (when circle
-	(error "Circularity: ~A is already a superclass of ~A"
-	       class circle)))
+	(cerror* "`~A' is already a superclass of `~A'" class circle)
+	(report-inheritance-path (make-inheritance-path-reporter-state class)
+				 circle)))
 
     ;; Check that the class has a unique root superclass.
     (find-root-superclass class)
 
     ;; Check that the metaclass is a subclass of each direct superclass's
     ;; metaclass.
-    (with-slots (metaclass direct-superclasses) class
-      (dolist (super direct-superclasses)
-	(unless (sod-subclass-p metaclass (sod-class-metaclass super))
-	  (error "Incompatible metaclass for `~A': ~
-		  `~A' isn't a subclass of `~A' (of `~A')"
-		 class metaclass (sod-class-metaclass super) super))))))
+    (finalization-error (:bad-metaclass)
+      (let ((meta (sod-class-metaclass class)))
+	(dolist (super (sod-class-direct-superclasses class))
+	  (let ((supermeta (sod-class-metaclass super)))
+	    (unless (sod-subclass-p meta supermeta)
+	      (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'"
+		       meta class supermeta)
+	      (info-with-location super
+				  "Direct superclass `~A' defined here ~
+				   has metaclass `~A'"
+				  super supermeta))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Finalization.
 
-(defmethod finalize-sod-class ((class sod-class))
+(defmethod finalize-sod-class :around ((class sod-class))
+  "Common functionality for `finalize-sod-class'.
 
-  ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
-  ;; clone of the CPL and chain establishment code.  If the interface changes
-  ;; then `bootstrap-classes' will need to be changed too.
+     * If an attempt to finalize the CLASS has been made before, then we
+       don't try again.  Similarly, attempts to finalize a class recursively
+       will fail.
 
+     * A condition handler is established to keep track of whether any errors
+       are signalled during finalization.  The CLASS is only marked as
+       successfully finalized if no (unhandled) errors are encountered."
   (with-default-error-location (class)
     (ecase (sod-class-state class)
       ((nil)
 
-       ;; If this fails, mark the class as a loss.
+       ;; If this fails, leave the class marked as a loss.
        (setf (slot-value class 'state) :broken)
 
-       ;; Finalize all of the superclasses.  There's some special pleading
-       ;; here to make bootstrapping work: we don't try to finalize the
-       ;; metaclass if we're a root class (no direct superclasses -- because
-       ;; in that case the metaclass will have to be a subclass of us!), or
-       ;; if it's equal to us.  This is enough to tie the knot at the top of
-       ;; the class graph.
-       (with-slots (name direct-superclasses metaclass) class
-	 (dolist (super direct-superclasses)
-	   (finalize-sod-class super))
-	 (unless (or (null direct-superclasses)
-		     (eq class metaclass))
-	   (finalize-sod-class metaclass)))
-
-       ;; Stash the class's type.
-       (setf (slot-value class '%type)
-	     (make-class-type (sod-class-name class)))
-
-       ;; Clobber the lists of items if they've not been set.
-       (dolist (slot '(slots instance-initializers class-initializers
-		       messages methods))
-	 (unless (slot-boundp class slot)
-	   (setf (slot-value class slot) nil)))
-
-       ;; If the CPL hasn't been done yet, compute it.
-       (with-slots (class-precedence-list) class
-	 (unless (slot-boundp class 'class-precedence-list)
-	   (setf class-precedence-list (compute-cpl class))))
-
-       ;; Check that the class is fairly sane.
-       (check-sod-class class)
-
-       ;; Determine the class's layout.
-       (with-slots (chain-head chain chains) class
-	 (setf (values chain-head chain chains) (compute-chains class)))
-
-       ;; Done.
-       (setf (slot-value class 'state) :finalized)
-       t)
-
+       ;; Invoke the finalization method proper.  If it signals any
+       ;; continuable errors, take note of them so that we can report failure
+       ;; properly.
+       ;;
+       ;; Catch: we get called recursively to clean up superclasses and
+       ;; metaclasses, but there should only be one such handler, so don't
+       ;; add another.  (In turn, this means that other methods mustn't
+       ;; actually trap their significant errors.)
+       (let ((have-handler-p (boundp '*finalization-errors*))
+	     (*finalization-errors* nil)
+	     (*finalization-error-token* nil))
+	 (catch '%finalization-failed
+	   (if have-handler-p (call-next-method)
+	       (handler-bind ((error (lambda (cond)
+				       (declare (ignore cond))
+				       (pushnew *finalization-error-token*
+						*finalization-errors*
+						:test #'equal)
+				       :decline)))
+		 (call-next-method)))
+	   (when *finalization-errors* (finalization-failed))
+	   (setf (slot-value class 'state) :finalized)
+	   t)))
+
+      ;; If the class is broken, we're not going to be able to fix it now.
       (:broken
        nil)
 
+      ;; If we already finalized it, there's no point doing it again.
       (: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))))
-    (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))))
+(defmethod finalize-sod-class ((class sod-class))
+
+  ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
+  ;; clone of the CPL and chain establishment code.  If the interface changes
+  ;; then `bootstrap-classes' will need to be changed too.
+
+  ;; 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 metaclass if we're
+  ;; a root class (no direct superclasses -- because in that case the
+  ;; metaclass will have to be a subclass of us!), or if it's equal to us.
+  ;; This is enough to tie the knot at the top of the class graph.  If we
+  ;; can't manage this then we're doomed.
+  (flet ((try-finalizing (what other-class)
+	   (unless (finalize-sod-class other-class)
+	     (cerror* "Class `~A' has broken ~A `~A'" class what other-class)
+	     (info-with-location other-class
+				 "Class `~A' defined here" other-class)
+	     (finalization-failed))))
+    (let ((supers (sod-class-direct-superclasses class))
+	  (meta (sod-class-metaclass class)))
+      (dolist (super supers)
+	(try-finalizing "direct superclass" super))
+      (unless (or (null supers) (eq class meta))
+	(try-finalizing "metaclass" meta))))
+
+  ;; Stash the class's type.
+  (setf (slot-value class '%type)
+	(make-class-type (sod-class-name class)))
+
+  ;; Clobber the lists of items if they've not been set.
+  (dolist (slot '(slots instance-initializers class-initializers
+		  messages methods))
+    (unless (slot-boundp class slot)
+      (setf (slot-value class slot) nil)))
+
+  ;; If the CPL hasn't been done yet, compute it.  If we can't manage this
+  ;; then there's no hope at all.
+  (unless (slot-boundp class 'class-precedence-list)
+    (restart-case
+	(setf (slot-value class 'class-precedence-list) (compute-cpl class))
+      (continue () :report "Continue"
+	(finalization-failed))))
+
+  ;; Check that the class is fairly sane.
+  (check-sod-class class)
+
+  ;; Determine the class's layout.
+  (setf (values (slot-value class 'chain-head)
+		(slot-value class 'chain)
+		(slot-value class 'chains))
+	(compute-chains class)))
 
 ;;;----- That's all, folks --------------------------------------------------