From: Mark Wooding Date: Thu, 26 May 2016 08:26:09 +0000 (+0100) Subject: src/utilities.lisp, src/class-finalize-impl.lisp: Improve error reports. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/e2838dc5e1dbdc1558d3ec225fbc9fdd581b5b26 src/utilities.lisp, src/class-finalize-impl.lisp: Improve error reports. * Arrange for `inconsistent-merge-error' to present the list of candidates more pleasantly for human reading. * Give `merge-lists' a new argument to turn items into presentable names. * Make a wrapper function for merging lists of classes to apply the right kind of presentation. --- diff --git a/doc/SYMBOLS b/doc/SYMBOLS index e167b03..36a700b 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -196,6 +196,7 @@ class-finalize-impl.lisp dylan-cpl function flavors-cpl function l*loops-cpl function + merge-class-lists function python-cpl function class-finalize-proto.lisp diff --git a/doc/meta.tex b/doc/meta.tex index 640473e..7de1fbe 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -304,6 +304,9 @@ \begin{describe}{gf}{compute-cpl @ @> @} \end{describe} +\begin{describe}{fun}{merge-class-lists @ @ @> @} +\end{describe} + \begin{describe}{gf}{compute-chains @ @> @} \end{describe} diff --git a/doc/misc.tex b/doc/misc.tex index 87ddf4d..ae1fd2b 100644 --- a/doc/misc.tex +++ b/doc/misc.tex @@ -136,7 +136,7 @@ These symbols are defined in the @|sod-utilities| package. \end{describe} \begin{describe}{fun} - {merge-lists @ \&key :pick (:test \#'eql) @> @} + {merge-lists @ \&key :pick (:test \#'eql) :present @> @} \end{describe} \begin{describe}{mac} diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 5abcc6e..aea5058 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -48,6 +48,22 @@ (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. 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) @@ -117,11 +133,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 +159,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 +179,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 +241,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. diff --git a/src/utilities.lisp b/src/utilities.lisp index 49ac335..1d58fa3 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -446,11 +446,13 @@ (define-condition inconsistent-merge-error (error) (:documentation "Reports an inconsistency in the arguments passed to `merge-lists'.") (:report (lambda (condition stream) - (format stream "Merge inconsistency: failed to decide among ~A" + (format stream "Merge inconsistency: failed to decide between ~ + ~{~#[~;~A~;~A and ~A~:;~ + ~@{~A, ~#[~;and ~A~]~}~]~}" (merge-error-candidates condition))))) (export 'merge-lists) -(defun merge-lists (lists &key pick (test #'eql)) +(defun merge-lists (lists &key pick (test #'eql) (present #'identity)) "Return a merge of the given LISTS. The resulting list contains the items of the given LISTS, with duplicates @@ -458,7 +460,10 @@ (defun merge-lists (lists &key pick (test #'eql)) the input LISTS in the sense that if A precedes B in some input list then A will also precede B in the output list. If the lists aren't consistent (e.g., some list contains A followed by B, and another contains B followed - by A) then an error of type `inconsistent-merge-error' is signalled. + by A) then an error of type `inconsistent-merge-error' is signalled. The + offending items are filtered for presentation through the PRESENT function + before being attached to the condition, so as to produce a more useful + diagnostic message. Item equality is determined by TEST. @@ -500,7 +505,7 @@ (defun merge-lists (lists &key pick (test #'eql)) candidates)) (winner (cond ((null leasts) (error 'inconsistent-merge-error - :candidates candidates)) + :candidates (mapcar present candidates))) ((null (cdr leasts)) (car leasts)) (pick