X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/981b6fb624186a54320cea34e53e16276aee2bdb..ad1316527a6aa066d0abc0ada46a3616f5cb451f:/src/class-finalize-impl.lisp diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 23d7107..aea5058 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -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. @@ -283,7 +301,7 @@ (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)) @@ -343,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. @@ -431,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)