;;; Add cl-struct support to pcase
-;;In use by comp.el
-(defun cl--struct-all-parents (class) ;FIXME: Merge with `cl--class-allparents'
- (when (cl--struct-class-p class)
- (let ((res ())
- (classes (list class)))
- ;; BFS precedence.
- (while (let ((class (pop classes)))
- (push class res)
- (setq classes
- (append classes
- (cl--class-parents class)))))
- (nreverse res))))
-
;;;###autoload
(pcase-defmacro cl-struct (type &rest fields)
"Pcase patterns that match cl-struct EXPVAL of type TYPE.
(let ((c1 (cl--find-class t1))
(c2 (cl--find-class t2)))
(and c1 c2
- (not (or (memq c1 (cl--struct-all-parents c2))
- (memq c2 (cl--struct-all-parents c1)))))))
+ (not (or (memq t1 (cl--class-allparents c2))
+ (memq t2 (cl--class-allparents c1)))))))
(let ((c1 (and (symbolp t1) (cl--find-class t1))))
(and c1 (cl--struct-class-p c1)
(funcall orig (cl--defstruct-predicate t1)
(cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
(defun cl--class-allparents (class)
- (let ((parents ())
- (classes (list class)))
- ;; BFS precedence. FIXME: Use a topological sort.
- (while (let ((class (pop classes)))
- (cl-pushnew (cl--class-name class) parents)
- (setq classes
- (append classes
- (cl--class-parents class)))))
- (nreverse parents)))
+ (cons (cl--class-name class)
+ (merge-ordered-lists (mapcar #'cl--class-allparents
+ (cl--class-parents class)))))
(eval-and-compile
(cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object)))))
(cdr tuple)
nil)))
-;;;
-;; Method Invocation order: C3
-(defun eieio--c3-candidate (class remaining-inputs)
- "Return CLASS if it can go in the result now, otherwise nil."
- ;; Ensure CLASS is not in any position but the first in any of the
- ;; element lists of REMAINING-INPUTS.
- (and (not (let ((found nil))
- (while (and remaining-inputs (not found))
- (setq found (member class (cdr (car remaining-inputs)))
- remaining-inputs (cdr remaining-inputs)))
- found))
- class))
-
-(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
- "Try to merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order.
-If a consistent order does not exist, signal an error."
- (setq remaining-inputs (delq nil remaining-inputs))
- (if (null remaining-inputs)
- ;; If all remaining inputs are empty lists, we are done.
- (nreverse reversed-partial-result)
- ;; Otherwise, we 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* ((found nil)
- (tail remaining-inputs)
- (next (progn
- (while (and tail (not found))
- (setq found (eieio--c3-candidate (caar tail)
- remaining-inputs)
- tail (cdr tail)))
- found)))
- (if next
- ;; The graph is consistent so far, add NEXT to result and
- ;; merge input lists, dropping NEXT from their heads where
- ;; applicable.
- (eieio--c3-merge-lists
- (cons next reversed-partial-result)
- (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l))
- remaining-inputs))
- ;; The graph is inconsistent, give up
- (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
-
(defsubst eieio--class/struct-parents (class)
(or (eieio--class-parents class)
`(,eieio-default-superclass)))
(defun eieio--class-precedence-c3 (class)
"Return all parents of CLASS in c3 order."
(let ((parents (eieio--class-parents class)))
- (eieio--c3-merge-lists
- (list class)
- (append
- (or
- (mapcar #'eieio--class-precedence-c3 parents)
- `((,eieio-default-superclass)))
- (list parents))))
- )
+ (cons class
+ (merge-ordered-lists
+ (append
+ (or
+ (mapcar #'eieio--class-precedence-c3 parents)
+ `((,eieio-default-superclass)))
+ (list parents))
+ (lambda (remaining-inputs)
+ (signal 'inconsistent-class-hierarchy
+ (list remaining-inputs)))))))
;;;
;; Method Invocation Order: Depth First
this function to insert characters when necessary.
In binary overwrite mode, this function does overwrite, and octal
-(or decimal or hex) digits are interpreted as a character code. This
+\(or decimal or hex) digits are interpreted as a character code. This
is intended to be useful for editing binary files."
(interactive "*p")
(let* ((char
;; PUBLIC: find if the current mode derives from another.
+(defun merge-ordered-lists (lists &optional error-function)
+ "Merge LISTS in a consistent order.
+LISTS is a list of lists of elements.
+Merge them into a single list containing the same elements (removing
+duplicates) using the C3 linearization, so as to obeying their relative
+positions in each list. Equality of elements is tested with `eql'.
+
+If a consistent order does not exist, call ERROR-FUNCTION with
+a remaining list of lists that we do not know how to merge.
+It should return the candidate to use to continue the merge, which
+has to be the head of one of the lists.
+By default we choose the head of the first list."
+ (let ((result '()))
+ (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))))
+ (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)))
+ ;; 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))))
+ (if (null result) (car lists) ;; Common case.
+ (append (nreverse result) (car lists)))))
+
(defun derived-mode-all-parents (mode &optional known-children)
"Return all the parents of MODE, starting with MODE.
The returned list is not fresh, don't modify it.
\n(fn MODE)" ;`known-children' is for internal use only.
;; Can't use `with-memoization' :-(
(let ((ps (get mode 'derived-mode--all-parents)))
- (if ps ps
- (if (memq mode known-children)
- (error "Cycle in the major mode hierarchy: %S" mode)
- (push mode known-children))
+ (cond
+ (ps ps)
+ ((memq mode known-children)
+ ;; These things happen, better not get all worked up about it.
+ ;;(error "Cycle in the major mode hierarchy: %S" mode)
+ nil)
+ (t
+ (push mode known-children)
;; The mode hierarchy (or DAG, actually), is very static, but we
;; need to react to changes because `parent' may not be defined
;; yet (e.g. it's still just an autoload), so the recursive call
;; If MODE is an alias, then follow the alias.
(let ((alias (symbol-function mode)))
(and (symbolp alias) alias))))
- (parents (cons mode (if parent (funcall all-parents parent))))
(extras (get mode 'derived-mode-extra-parents)))
(put mode 'derived-mode--all-parents
- (if (null extras) ;; Common case.
- parents
- (delete-dups
- (apply #'append
- parents (mapcar (lambda (extra)
- (copy-sequence
- (funcall all-parents extra)))
- extras)))))))))
+ (cons mode
+ (merge-ordered-lists
+ (cons (if (and parent (not (memq parent extras)))
+ (funcall all-parents parent))
+ (mapcar all-parents extras))))))))))
(defun provided-mode-derived-p (mode &rest modes)
"Non-nil if MODE is derived from one of MODES.
projects / emacs.git / commitdiff