mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-24 06:20:43 -08:00
Code Issues Projects Releases Wiki Activity

(cl--class-allparents): Fix bug#78989

Browse source 
Give more control over ordering when linearizing the
parent graph and avoid pathological misbehavior (such as
placing `t` in the middle of the linearization instead of the
end) when we can't "do it right".

* lisp/subr.el (merge-ordered-lists): Degrade more gracefully in case
of inconsistent hierarchies and don't do it silently.

* lisp/emacs-lisp/cl-preloaded.el (cl--class-allparents): Use the local
ordering to break ties, as in the C3 algorithm.
This commit is contained in:
Stefan Monnier 2025-07-14 12:37:11 -04:00
parent c8b6e90b4e
commit 7f1cae9637
2 changed files with 50 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

10
lisp/emacs-lisp/cl-preloaded.el
View file

@ -285,8 +285,14 @@
(defun cl--class-allparents (class) (defun cl--class-allparents (class)
(cons (cl--class-name class) (cons (cl--class-name class)
(merge-ordered-lists (mapcar #'cl--class-allparents (let* ((parents (cl--class-parents class))
(cl--class-parents class))))) (aps (mapcar #'cl--class-allparents parents)))
(if (null (cdr aps)) ;; Single-inheritance fast-path.
(car aps)
(merge-ordered-lists
;; Add the list of immediate parents, to control which
;; linearization is chosen. doi:10.1145/236337.236343
(nconc aps (list (mapcar #'cl--class-name parents))))))))
(cl-defstruct (built-in-class (cl-defstruct (built-in-class
(:include cl--class) (:include cl--class)

68
lisp/subr.el
View file

@ -2860,38 +2860,54 @@ By default we choose the head of the first list."
;; [C3](https://en.wikipedia.org/wiki/C3_linearization) ;; [C3](https://en.wikipedia.org/wiki/C3_linearization)
(let ((result '())) (let ((result '()))
(setq lists (remq nil lists)) ;Don't mutate the original `lists' argument. (setq lists (remq nil lists)) ;Don't mutate the original `lists' argument.
(while (cdr (setq lists (delq nil lists))) (while (cdr lists)
;; Try to find the next element of the result. This ;; Try to find the next element of the result. This is achieved
;; is achieved by considering the first element of each ;; by considering the first element of each input list and accepting
;; (non-empty) input list and accepting a candidate if it is ;; a candidate if it is consistent with the rest of the input lists.
;; consistent with the rests of the input lists. (let* ((find-next
(let* ((next nil) (lambda (lists)
(tail lists)) (let ((next nil)
(while tail (tail lists))
(let ((candidate (caar tail)) (while tail
(other-lists lists)) (let ((candidate (caar tail))
;; Ensure CANDIDATE is not in any position but the first (other-lists lists))
;; in any of the element lists of LISTS. ;; Ensure CANDIDATE is not in any position but the first
(while other-lists ;; in any of the element lists of LISTS.
(if (not (memql candidate (cdr (car other-lists)))) (while other-lists
(setq other-lists (cdr other-lists)) (if (not (memql candidate (cdr (car other-lists))))
(setq candidate nil) (setq other-lists (cdr other-lists))
(setq other-lists nil))) (setq candidate nil)
(if (not candidate) (setq other-lists nil)))
(setq tail (cdr tail)) (if (not candidate)
(setq next candidate) (setq tail (cdr tail))
(setq tail nil)))) (setq next candidate)
(setq tail nil))))
next)))
(next (funcall find-next lists)))
(unless next ;; The graph is inconsistent. (unless next ;; The graph is inconsistent.
(setq next (funcall (or error-function #'caar) lists)) (let ((tail lists))
(unless (assoc next lists #'eql) ;; Try and reduce the "remaining-list" such that its `caar`
(error "Invalid candidate returned by error-function: %S" next))) ;; participates in the inconsistency (is part of an actual cycle).
(while (and (cdr tail) (null (funcall find-next (cdr tail))))
(setq tail (cdr tail)))
(setq next (funcall (or error-function
(lambda (remaining-lists)
(message "Inconsistent hierarchy: %S"
remaining-lists)
(caar remaining-lists)))
tail))
(unless (assoc next lists #'eql)
(error "Invalid candidate returned by error-function: %S" next))
;; Break the cycle, while keeping other dependencies.
(dolist (list lists) (setcdr list (remq next (cdr list))))))
;; The graph is consistent so far, add NEXT to result and ;; The graph is consistent so far, add NEXT to result and
;; merge input lists, dropping NEXT from their heads where ;; merge input lists, dropping NEXT from their heads where
;; applicable. ;; applicable.
(push next result) (push next result)
(setq lists (setq lists
(mapcar (lambda (l) (if (eql (car l) next) (cdr l) l)) (delq nil
lists)))) (mapcar (lambda (l) (if (eql (car l) next) (cdr l) l))
lists)))))
(if (null result) (car lists) ;; Common case. (if (null result) (car lists) ;; Common case.
(append (nreverse result) (car lists))))) (append (nreverse result) (car lists)))))