src/class-*.lisp: Improve metaclass selection.

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

;;; -*-lisp-*-
;;;
;;; Class finalization implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; 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
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Class precedence lists.

;; Just for fun, we implement a wide selection of precedence list algorithms.
;; C3 seems to be clearly the best, with fewer sharp edges for the unwary.
;;
;; The extended precedence graph (EPG) is constructed by adding edges to the
;; superclass graph.  If A and B are classes, then write A < B if A is a
;; (maybe indirect) subclass of B.  For every two classes A and B, and for
;; every /maximal/ subclass of both A and B (i.e., every C for which C < A
;; and C < B, but there does not exist D such that D < A, D < B and C < D):
;; if A precedes B in C's direct superclass list, then draw an edge A -> B,
;; otherwise draw the edge B -> A.
;;
;; A linearization respects the EPG if, whenever A precedes B in the
;; linearization, there is a path from A to B.  The EPG can be cyclic; in
;; that case, we don't care which order the classes in the cycle are
;; linearized.
;;
;; See Barrett, Cassels, Haahr, Moon, Playford, Withington, `A Monotonic
;; 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)
  "The CLOS linearization tiebreaker function.

   Intended for use with `merge-lists'.  Returns the member of CANDIDATES
   which has a direct subclass furthest to the right in the list SO-FAR.

   This must disambiguate.  The SO-FAR list cannot be empty, since the class
   under construction precedes all of the others.  If two classes share a
   direct subclass then that subclass's direct superclasses list must order
   them relative to each other."

  (let (winner)
    (dolist (class so-far)
      (dolist (candidate candidates)
	(when (member candidate (sod-class-direct-superclasses class))
	  (setf winner candidate))))
    (unless winner
      (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
    winner))

(defun c3-tiebreaker (candidates cpls)
  "The C3 linearization tiebreaker function.

   Intended for use with `merge-lists'.  Returns the member of CANDIDATES
   which appears in the earliest element of CPLS, which should be the list of
   the class precedence lists of the direct superclasses of the class in
   question, in the order specified in the class declaration.

   The only class in the class precedence list which does not appear in one
   of these lists is the new class itself, which must precede all of the
   others.

   This must disambiguate, since if two classes are in the same class
   precedence list, then one must appear in it before the other, which
   provides an ordering between them.  (In this situation we return the one
   that matches earliest anyway, which would still give the right answer.)

   Note that this will merge the CPLs of superclasses /as they are/, not
   necessarily as C3 would have computed them.  This ensures monotonicity
   assuming that the superclass CPLs are already monotonic.  If they aren't,
   you're going to lose anyway."

  (dolist (cpl cpls)
    (dolist (candidate candidates)
      (when (member candidate cpl)
	(return-from c3-tiebreaker candidate))))
  (error "SOD INTERNAL ERROR: Failed to break tie in C3"))

;;; Linearization functions.

(export 'clos-cpl)
(defun clos-cpl (class)
  "Compute the class precedence list of CLASS using CLOS linearization rules.

   We merge the direct-superclass lists of all of CLASS's superclasses,
   disambiguating using `clos-tiebreaker'.

   The CLOS linearization preserves local class ordering, but is not
   monotonic, and does not respect the extended precedence graph.  CLOS
   linearization will succeed whenever Dylan or C3 linearization succeeds;
   the converse is not true."

  (labels ((superclasses (class)
	     (let ((direct-supers (sod-class-direct-superclasses class)))
	       (remove-duplicates (cons class
					(mappend #'superclasses
						 direct-supers))))))
    (merge-class-lists
     (mapcar (lambda (class)
	       (cons class (sod-class-direct-superclasses class)))
	     (superclasses class))
     #'clos-tiebreaker)))

(export 'dylan-cpl)
(defun dylan-cpl (class)
  "Compute the class precedence list of CLASS using Dylan linearization
   rules.

   We merge the direct-superclass list of CLASS with the full class
   precedence lists of its direct superclasses, disambiguating using
   `clos-tiebreaker'.  (Inductively, these lists will be consistent with the
   CPLs of indirect superclasses, since those CPLs' orderings are reflected
   in the CPLs of the direct superclasses.)

   The Dylan linearization preserves local class ordering and is monotonic,
   but does not respect the extended precedence graph.

   Note that this will merge the CPLs of superclasses /as they are/, not
   necessarily as Dylan would have computed them.  This ensures monotonicity
   assuming that the superclass CPLs are already monotonic.  If they aren't,
   you're going to lose anyway."

  (let ((direct-supers (sod-class-direct-superclasses class)))
    (merge-class-lists
     (cons (cons class direct-supers)
	   (mapcar #'sod-class-precedence-list direct-supers))
     #'clos-tiebreaker)))

(export 'c3-cpl)
(defun c3-cpl (class)
  "Compute the class precedence list of CLASS using C3 linearization rules.

   We merge the direct-superclass list of CLASS with the full class
   precedence lists of its direct superclasses, disambiguating using
   `c3-tiebreaker'.

   The C3 linearization preserves local class ordering, is monotonic, and
   respects the extended precedence graph.  It is the linearization used in
   Python, Perl 6 and other languages.  It is the recommended linearization
   for SOD."

  (let* ((direct-supers (sod-class-direct-superclasses class))
	 (cpls (mapcar #'sod-class-precedence-list direct-supers)))
    (merge-class-lists (cons (cons class direct-supers) cpls)
		       (lambda (candidates so-far)
			 (declare (ignore so-far))
			 (c3-tiebreaker candidates cpls)))))

(export 'flavors-cpl)
(defun flavors-cpl (class)
  "Compute the class precedence list of CLASS using Flavors linearization
   rules.

   We do a depth-first traversal of the superclass graph, ignoring duplicates
   of classes we've already visited.  Interestingly, this has the property of
   being able to tolerate cyclic superclass graphs, though defining cyclic
   graphs is syntactically impossible in SOD.

   This linearization has few other redeeming features, however.  In
   particular, the top class tends not to be at the end of the CPL, despite
   it being unequivocally less specific than any other class."

  (let ((done nil))
    (labels ((walk (class)
	       (unless (member class done)
		 (push class done)
		 (dolist (super (sod-class-direct-superclasses class))
		   (walk super)))))
      (walk class)
      (nreverse done))))

(export 'python-cpl)
(defun python-cpl (class)
  "Compute the class precedence list of CLASS using the documented Python 2.2
   linearization rules.

   We do a depth-first traversal of the superclass graph, retaining only the
   last occurrence of each class visited.

   This linearization has few redeeming features.  It was never actually
   implemented; the true Python 2.2 linearization seems closer to (but
   different from) L*LOOPS."

  (let ((done nil))
    (labels ((walk (class)
	       (push class done)
	       (dolist (super (sod-class-direct-superclasses class))
		 (walk super))))
      (walk class)
      (delete-duplicates (nreverse done)))))

(export 'l*loops-cpl)
(defun l*loops-cpl (class)
  "Compute the class precedence list of CLASS using L*LOOPS linearization
   rules.

   We merge the class precedence lists of the direct superclasses of CLASS,
   disambiguating by choosing the earliest candidate which appears in a
   depth-first walk of the superclass graph.

   The L*LOOPS rules are monotonic and respect the extended precedence
   graph.  However (unlike Dylan and CLOS) they don't respect local
   precedence order i.e., the direct-superclasses list orderings."

  (let ((dfs (flavors-cpl class)))
    (cons class
	  (merge-class-lists (mapcar #'sod-class-precedence-list
				     (sod-class-direct-superclasses class))
			     (lambda (candidates so-far)
			       (declare (ignore so-far))
			       (dolist (class dfs)
				 (when (member class candidates)
				   (return class))))))))

;;; Default function.

(defmethod compute-cpl ((class sod-class))
  (handler-case (c3-cpl class)
    (inconsistent-merge-error ()
      (error "Failed to compute class precedence list for `~A'"
	     (sod-class-name class)))))

;;;--------------------------------------------------------------------------
;;; Chains.

(defmethod compute-chains ((class sod-class))
  (with-default-error-location (class)
    (with-slots (chain-link class-precedence-list) class
      (let* ((head (if chain-link
		       (sod-class-chain-head chain-link)
		       class))
	     (chain (cons class (and chain-link
				     (sod-class-chain chain-link))))
	     (table (make-hash-table)))

	;; Check the chains.  We work through each superclass, maintaining a
	;; hash table keyed by class.  If we encounter a class C which links
	;; to L, then we store C as L's value; if L already has a value then
	;; 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))))

	;; Done.
	(values head chain
		(cons chain
		      (mapcar #'sod-class-chain
			      (remove-if (lambda (super)
					   (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).
  (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.

(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)))
		 (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)))

    ;; 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)))

    ;; 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.
    (let ((circle (find-if (lambda (super)
			     (sod-subclass-p super class))
			   (sod-class-direct-superclasses class))))
      (when circle
	(error "Circularity: ~A is already a superclass of ~A"
	       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.

(defmethod finalize-sod-class :around ((class sod-class))
  "Common functionality for `finalize-sod-class'.

     * 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, leave the class marked as a loss.
       (setf (slot-value class 'state) :broken)

       ;; Invoke the finalization method proper.
       (call-next-method)
       (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))))

(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.
  (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.
  (setf (values (slot-value class 'chain-head)
		(slot-value class 'chain)
		(slot-value class 'chains))
	(compute-chains class)))

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