mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -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)
(cons (cl--class-name class)
(merge-ordered-lists (mapcar #'cl--class-allparents
(cl--class-parents class)))))
(let* ((parents (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
(: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)
(let ((result '()))
(setq lists (remq nil lists)) ;Don't mutate the original `lists' argument.
(while (cdr (setq lists (delq nil lists)))
;; Try to find the next element of the result. This
;; is achieved by considering the first element of each
;; (non-empty) input list and accepting a candidate if it is
;; consistent with the rests of the input lists.
(let* ((next nil)
(tail lists))
(while tail
(let ((candidate (caar tail))
(other-lists lists))
;; Ensure CANDIDATE is not in any position but the first
;; in any of the element lists of LISTS.
(while other-lists
(if (not (memql candidate (cdr (car other-lists))))
(setq other-lists (cdr other-lists))
(setq candidate nil)
(setq other-lists nil)))
(if (not candidate)
(setq tail (cdr tail))
(setq next candidate)
(setq tail nil))))
(while (cdr lists)
;; Try to find the next element of the result. This is achieved
;; by considering the first element of each input list and accepting
;; a candidate if it is consistent with the rest of the input lists.
(let* ((find-next
(lambda (lists)
(let ((next nil)
(tail lists))
(while tail
(let ((candidate (caar tail))
(other-lists lists))
;; Ensure CANDIDATE is not in any position but the first
;; in any of the element lists of LISTS.
(while other-lists
(if (not (memql candidate (cdr (car other-lists))))
(setq other-lists (cdr other-lists))
(setq candidate nil)
(setq other-lists nil)))
(if (not candidate)
(setq tail (cdr tail))
(setq next candidate)
(setq tail nil))))
next)))
(next (funcall find-next lists)))
(unless next ;; The graph is inconsistent.
(setq next (funcall (or error-function #'caar) lists))
(unless (assoc next lists #'eql)
(error "Invalid candidate returned by error-function: %S" next)))
(let ((tail lists))
;; Try and reduce the "remaining-list" such that its `caar`
;; 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
;; merge input lists, dropping NEXT from their heads where
;; applicable.
(push next result)
(setq lists
(mapcar (lambda (l) (if (eql (car l) next) (cdr l) l))
lists))))
(delq nil
(mapcar (lambda (l) (if (eql (car l) next) (cdr l) l))
lists)))))
(if (null result) (car lists) ;; Common case.
(append (nreverse result) (car lists)))))