;;;----- 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
;; Superclass Linearization for Dylan' for more detail.
;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
+;;; Utilities.
+
+(export 'report-class-list-merge-error)
+(defun report-class-list-merge-error (class lists error)
+ "Report a failure to merge superclasseses.
+
+ Here, CLASS is the class whose class precedence list we're trying to
+ compute; the LISTS are the individual superclass orderings being merged;
+ and ERROR is an `inconsistent-merge-error' describing the problem that was
+ encountered.
+
+ Each of the LISTS is assumed to begin with the class from which the
+ corresponding constraint originates; see `merge-class-lists'."
+
+ (let* ((state (make-inheritance-path-reporter-state class))
+ (candidates (merge-error-candidates error))
+ (focus (remove-duplicates
+ (remove nil
+ (mapcar (lambda (list)
+ (cons (car list)
+ (remove-if-not
+ (lambda (item)
+ (member item candidates))
+ list)))
+ lists)
+ :key #'cddr)
+ :test #'equal :key #'cdr)))
+
+ (cerror*-with-location class "Ill-formed superclass graph: ~
+ can't construct class precedence list ~
+ for `~A'"
+ class)
+ (dolist (offenders focus)
+ (let ((super (car offenders)))
+ (info-with-location super
+ "~{Class `~A' orders `~A' before ~
+ ~#[<BUG>~;`~A'~;`~A' and `~A'~:;~
+ ~@{`~A', ~#[~;and `~A'~]~}~]~}"
+ offenders)
+ (report-inheritance-path state super)))))
+
+(export 'merge-class-lists)
+(defun merge-class-lists (class lists pick)
+ "Merge the LISTS of superclasses of CLASS, 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.
+
+ If a merge error occurs, this function translates it into a rather more
+ useful form, and tries to provide helpful notes.
+
+ For error reporting purposes, it's assumed that each of the LISTS begins
+ with the class from which the corresponding constraint originates. This
+ initial class does double-duty: it is also considered to be part of the
+ list for the purpose of the merge."
+
+ (handler-case (merge-lists lists :pick pick)
+ (inconsistent-merge-error (error)
+ (report-class-list-merge-error class lists error)
+ (continue error))))
+
;;; Tiebreaker functions.
(defun clos-tiebreaker (candidates so-far)
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))
+ (dolist (class so-far)
+ (dolist (candidate candidates)
+ (when (member candidate (sod-class-direct-superclasses class))
+ (return-from clos-tiebreaker candidate))))
+ (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
(defun c3-tiebreaker (candidates cpls)
"The C3 linearization tiebreaker function.
(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.
+(export 'clos-cpl)
(defun clos-cpl (class)
"Compute the class precedence list of CLASS using CLOS linearization rules.
(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 class
+ (mapcar (lambda (c)
+ (cons c (sod-class-direct-superclasses c)))
+ (superclasses class))
+ #'clos-tiebreaker)))
+(export 'dylan-cpl)
(defun dylan-cpl (class)
"Compute the class precedence list of CLASS using Dylan linearization
rules.
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-lists (cons (cons class direct-supers)
- (mapcar #'sod-class-precedence-list direct-supers))
- :pick #'clos-tiebreaker)))
+ (let* ((direct-supers (sod-class-direct-superclasses class))
+ (cpls (mapcar #'sod-class-precedence-list direct-supers)))
+ (merge-class-lists class
+ (cons (cons class direct-supers) cpls)
+ #'clos-tiebreaker)))
+(export 'c3-cpl)
(defun c3-cpl (class)
"Compute the class precedence list of CLASS using C3 linearization rules.
(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 class
+ (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.
(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.
(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.
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 class
+ (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.
(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)))))
+ (c3-cpl class))
;;;--------------------------------------------------------------------------
;;; Chains.
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
;; 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
;;; 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 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))))))
+ ;; Check the names of things are valid.
+ (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* ((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.)
+ (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
+ ;; 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
+ (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.
+ (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.
- (setf (sod-class-state class) :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 (sod-class-type class)
- (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 (sod-class-state class) :finalized)
- t)
-
+ ;; If this fails, leave the class marked as a loss.
+ (setf (slot-value class 'state) :broken)
+
+ ;; 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))))
+(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.
+
+ ;; 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 --------------------------------------------------
~mdw / sod / blobdiff