diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/autoload.el | 39 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 60 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 25 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-seq.el | 10 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 3 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert-x.el | 40 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/map.el | 57 | ||||
| -rw-r--r-- | lisp/emacs-lisp/nadvice.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/radix-tree.el | 60 | ||||
| -rw-r--r-- | lisp/emacs-lisp/seq.el | 20 | ||||
| -rw-r--r-- | lisp/emacs-lisp/subr-x.el | 165 | ||||
| -rw-r--r-- | lisp/emacs-lisp/syntax.el | 3 |
15 files changed, 392 insertions, 102 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 6473e31e56e..fbb08fc3268 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -736,20 +736,22 @@ FILE's modification time." package--builtin-versions)) (princ "\n"))))) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n\f") - (cond - ((looking-at (regexp-quote generate-autoload-cookie)) - ;; If not done yet, figure out where to insert this text. - (unless output-start - (setq output-start (autoload--setup-output - otherbuf outbuf absfile load-name))) - (autoload--print-cookie-text output-start load-name file)) - ((looking-at ";") - ;; Don't read the comment. - (forward-line 1)) - (t + ;; Do not insert autoload entries for excluded files. + (unless (member absfile autoload-excludes) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n\f") + (cond + ((looking-at (regexp-quote generate-autoload-cookie)) + ;; If not done yet, figure out where to insert this text. + (unless output-start + (setq output-start (autoload--setup-output + otherbuf outbuf absfile load-name))) + (autoload--print-cookie-text output-start load-name file)) + ((looking-at ";") + ;; Don't read the comment. + (forward-line 1)) + (t ;; Avoid (defvar <foo>) by requiring a trailing space. ;; Also, ignore this prefix business ;; for ;;;###tramp-autoload and friends. @@ -767,8 +769,8 @@ FILE's modification time." "define-erc-response-handler" "defun-rcirc-command")))) (push (match-string 2) defs)) - (forward-sexp 1) - (forward-line 1)))))) + (forward-sexp 1) + (forward-line 1))))))) (when (and autoload-compute-prefixes defs) ;; This output needs to always go in the main loaddefs.el, @@ -1058,9 +1060,7 @@ write its autoloads into the specified file instead." ((not (stringp file))) ((or (not (file-exists-p file)) ;; Remove duplicates as well, just in case. - (member file done) - ;; If the file is actually excluded. - (member (expand-file-name file) autoload-excludes)) + (member file done)) ;; Remove the obsolete section. (setq changed t) (autoload-remove-section (match-beginning 0))) @@ -1086,7 +1086,6 @@ write its autoloads into the specified file instead." (let ((no-autoloads-time (or last-time '(0 0 0 0))) file-time) (dolist (file files) (cond - ((member (expand-file-name file) autoload-excludes) nil) ;; Passing nil as second argument forces ;; autoload-generate-file-autoloads to look for the right ;; spot where to insert each autoloads section. diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 8bf0675f54b..0033a94fb5c 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -173,7 +173,9 @@ the elements themselves. (defun cl-mapcan (cl-func cl-seq &rest cl-rest) "Like `cl-mapcar', but nconc's together the values returned by the function. \n(fn FUNCTION SEQUENCE...)" - (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))) + (if cl-rest + (apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest)) + (mapcan cl-func cl-seq))) ;;;###autoload (defun cl-mapcon (cl-func cl-list &rest cl-rest) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 0144daf3793..b7c8395f715 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -353,6 +353,26 @@ the specializer used will be the one returned by BODY." ,nbody)))))) (f (error "Unexpected macroexpansion result: %S" f)))))) +(put 'cl-defmethod 'function-documentation + '(cl--generic-make-defmethod-docstring)) + +(defun cl--generic-make-defmethod-docstring () + ;; FIXME: Copy&paste from pcase--make-docstring. + (let* ((main (documentation (symbol-function 'cl-defmethod) 'raw)) + (ud (help-split-fundoc main 'cl-defmethod))) + ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works, + ;; where cl-lib is anything using pcase-defmacro. + (require 'help-fns) + (with-temp-buffer + (insert (or (cdr ud) main)) + (insert "\n\n\tCurrently supported forms for TYPE:\n\n") + (dolist (method (reverse (cl--generic-method-table + (cl--generic 'cl-generic-generalizers)))) + (let* ((info (cl--generic-method-info method))) + (when (nth 2 info) + (insert (nth 2 info) "\n\n")))) + (let ((combined-doc (buffer-string))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) ;;;###autoload (defmacro cl-defmethod (name args &rest body) @@ -370,15 +390,17 @@ modifies how the method is combined with other methods, including: :after - Method will be called after the primary :around - Method will be called around everything else The absence of QUALIFIER means this is a \"primary\" method. +The set of acceptable qualifiers and their meaning is defined +\(and can be extended) by the methods of `cl-generic-combine-methods'. -TYPE can be one of the basic types (see the full list and their -hierarchy in `cl--generic-typeof-types'), CL struct type, or an -EIEIO class. +ARGS can also include so-called context specializers, introduced by +`&context' (which should appear right after the mandatory arguments, +before any &optional or &rest). They have the form (EXPR TYPE) where +EXPR is an Elisp expression whose value should match TYPE for the +method to be applicable. -Other than that, TYPE can also be of the form `(eql VAL)' in -which case this method will be invoked when the argument is `eql' -to VAL, or `(head VAL)', in which case the argument is required -to be a cons with VAL as its head. +The set of acceptable TYPEs (also called \"specializers\") is defined +\(and can be extended) by the various methods of `cl-generic-generalizers'. \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" (declare (doc-string 3) (indent 2) @@ -464,7 +486,8 @@ to be a cons with VAL as its head. (cons method mt) ;; Keep the ordering; important for methods with :extra qualifiers. (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) - (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) + (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) + ,qualifiers . ,specializers)) current-load-list :test #'equal) ;; FIXME: Try to avoid re-constructing a new function if the old one ;; is still valid (e.g. still empty method cache)? @@ -737,7 +760,7 @@ methods.") (fset 'cl-generic-combine-methods #'cl--generic-standard-method-combination)) (cl-defmethod cl-generic-generalizers (specializer) - "Support for the catch-all t specializer." + "Support for the catch-all t specializer which always matches." (if (eq specializer t) (list cl--generic-t-generalizer) (error "Unknown specializer %S" specializer))) @@ -909,8 +932,9 @@ MET-NAME is a cons (SYMBOL . SPECIALIZERS)." (let* ((info (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. (insert (format "%s%S" (nth 0 info) (nth 1 info))) - (let* ((met-name (cons function - (cl--generic-method-specializers method))) + (let* ((met-name `(,function + ,(cl--generic-method-qualifiers method) + . ,(cl--generic-method-specializers method))) (file (find-lisp-object-file-name met-name 'cl-defmethod))) (when file (insert (substitute-command-keys " in `")) @@ -994,7 +1018,8 @@ The value returned is a list of elements of the form (lambda (tag &rest _) (if (eq (car-safe tag) 'head) (list tag)))) (cl-defmethod cl-generic-generalizers :extra "head" (specializer) - "Support for the `(head VAL)' specializers." + "Support for (head VAL) specializers. +These match if the argument is a cons cell whose car is `eql' to VAL." ;; We have to implement `head' here using the :extra qualifier, ;; since we can't use the `head' specializer to implement itself. (if (not (eq (car-safe specializer) 'head)) @@ -1014,7 +1039,8 @@ The value returned is a list of elements of the form (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag)))) (cl-defmethod cl-generic-generalizers ((specializer (head eql))) - "Support for the `(eql VAL)' specializers." + "Support for (eql VAL) specializers. +These match if the argument is `eql' to VAL." (puthash (cadr specializer) specializer cl--generic-eql-used) (list cl--generic-eql-generalizer)) @@ -1069,7 +1095,7 @@ The value returned is a list of elements of the form #'cl--generic-struct-specializers) (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) - "Support for dispatch on cl-struct types." + "Support for dispatch on types defined by `cl-defstruct'." (or (when (symbolp type) ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than @@ -1113,7 +1139,8 @@ The value returned is a list of elements of the form (and (symbolp tag) (assq tag cl--generic-typeof-types)))) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) - "Support for dispatch on builtin types." + "Support for dispatch on builtin types. +See the full list and their hierarchy in `cl--generic-typeof-types'." ;; FIXME: Add support for other types accepted by `cl-typep' such ;; as `character', `atom', `face', `function', ... (or @@ -1151,7 +1178,8 @@ The value returned is a list of elements of the form #'cl--generic-derived-specializers) (cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode))) - "Support for the `(derived-mode MODE)' specializers." + "Support for (derived-mode MODE) specializers. +Used internally for the (major-mode MODE) context specializers." (list cl--generic-derived-generalizer)) (cl-generic-define-context-rewriter major-mode (mode &rest modes) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 121738df576..56170e6a71b 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -851,9 +851,9 @@ This is compatible with Common Lisp, but note that `defun' and "The Common Lisp `loop' macro. Valid clauses include: For clauses: - for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 by EXPR3 + for VAR from/upfrom/downfrom EXPR1 to/upto/downto/above/below EXPR2 [by EXPR3] for VAR = EXPR1 then EXPR2 - for VAR in/on/in-ref LIST by FUNC + for VAR in/on/in-ref LIST [by FUNC] for VAR across/across-ref ARRAY for VAR being: the elements of/of-ref SEQUENCE [using (index VAR2)] @@ -1808,6 +1808,27 @@ Labels have lexical scope and dynamic extent." `(throw ',catch-tag ',label)))) ,@macroexpand-all-environment))))) +(defun cl--prog (binder bindings body) + (let (decls) + (while (eq 'declare (car-safe (car body))) + (push (pop body) decls)) + `(cl-block nil + (,binder ,bindings + ,@(nreverse decls) + (cl-tagbody . ,body))))) + +;;;###autoload +(defmacro cl-prog (bindings &rest body) + "Run BODY like a `cl-tagbody' after setting up the BINDINGS. +Shorthand for (cl-block nil (let BINDINGS (cl-tagbody BODY)))" + (cl--prog 'let bindings body)) + +;;;###autoload +(defmacro cl-prog* (bindings &rest body) + "Run BODY like a `cl-tagbody' after setting up the BINDINGS. +Shorthand for (cl-block nil (let* BINDINGS (cl-tagbody BODY)))" + (cl--prog 'let* bindings body)) + ;;;###autoload (defmacro cl-do-symbols (spec &rest body) "Loop over all symbols. diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 21aec6cdfcd..443a147b3d2 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -116,6 +116,16 @@ (defun cl-reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key + +Return the result of calling FUNCTION with the first and the +second element of SEQ, then calling FUNCTION with that result and +the third element of SEQ, then with that result and the fourth +element of SEQ, etc. + +If :INITIAL-VALUE is specified, it is added to the front of SEQ. +If SEQ is empty, return :INITIAL-VALUE and FUNCTION is not +called. + \n(fn FUNCTION SEQ [KEYWORD VALUE]...)" (cl--parsing-keywords (:from-end (:start 0) :end :initial-value :key) () (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index e48376bbabd..fac600e4e13 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -154,7 +154,6 @@ every some mapcon - mapcan mapl maplist map diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index fd8ae2abecb..0567c87dd39 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -1065,6 +1065,7 @@ method invocation orders of the involved classes." (eieio--class-precedence-list (symbol-value tag)))))) (cl-defmethod cl-generic-generalizers :extra "class" (specializer) + "Support for dispatch on types defined by EIEIO's `defclass'." ;; CLHS says: ;; A class must be defined before it can be used as a parameter ;; specializer in a defmethod form. @@ -1093,6 +1094,8 @@ method invocation orders of the involved classes." #'eieio--generic-subclass-specializers) (cl-defmethod cl-generic-generalizers ((_specializer (head subclass))) + "Support for (subclass CLASS) specializers. +These match if the argument is the name of a subclass of CLASS." (list eieio--generic-subclass-generalizer)) (provide 'eieio-core) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 67cb102a67c..2a2418fa7d2 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -285,46 +285,6 @@ BUFFER defaults to current buffer. Does not modify BUFFER." (kill-buffer clone))))))) -(defmacro ert-with-function-mocked (name mock &rest body) - "Mocks function NAME with MOCK and run BODY. - -Once BODY finishes (be it normally by returning a value or -abnormally by throwing or signaling), the old definition of -function NAME is restored. - -BODY may further change the mock with `fset'. - -If MOCK is nil, the function NAME is mocked with a function -`ert-fail'ing when called. - -For example: - - ;; Regular use, function is mocked inside the BODY: - (should (eq 2 (+ 1 1))) - (ert-with-function-mocked ((+ (lambda (a b) (- a b)))) - (should (eq 0 (+ 1 1)))) - (should (eq 2 (+ 1 1))) - - ;; Macro correctly recovers from a throw or signal: - (should - (catch 'done - (ert-with-function-mocked ((+ (lambda (a b) (- a b)))) - (should (eq 0 (+ 1 1)))) - (throw 'done t))) - (should (eq 2 (+ 1 1))) -" - (declare (indent 2)) - (let ((old-var (make-symbol "old-var")) - (mock-var (make-symbol "mock-var"))) - `(let ((,old-var (symbol-function (quote ,name))) (,mock-var ,mock)) - (fset (quote ,name) - (or ,mock-var (lambda (&rest _) - (ert-fail (concat "`" ,(symbol-name name) - "' unexpectedly called."))))) - (unwind-protect - (progn ,@body) - (fset (quote ,name) ,old-var))))) - (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index ed4d6e49a93..310ca29e9a1 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -261,7 +261,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (format "%s quoted with ' rather than with #'" (list 'lambda (nth 1 f) '...)) (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) - (`(funcall (,(or 'quote 'function) ,(and f (pred symbolp)) . ,_) . ,args) + (`(funcall #',(and f (pred symbolp)) . ,args) ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' ;; has a compiler-macro. (macroexp--expand-all `(,f . ,args))) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index ba15a65f5e1..98a88711aa5 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 1.0 +;; Version: 1.1 ;; Package: map ;; Maintainer: emacs-devel@gnu.org @@ -43,6 +43,7 @@ ;;; Code: (require 'seq) +(eval-when-compile (require 'cl-lib)) (pcase-defmacro map (&rest args) "Build a `pcase' pattern matching map elements. @@ -200,6 +201,16 @@ MAP can be a list, hash-table or array." function map)) +(defun map-do (function map) + "Apply FUNCTION to each element of MAP and return nil. +FUNCTION.is called with two arguments, the key and the value." + (funcall (map--dispatch map + :list #'map--do-alist + :hash-table #'maphash + :array #'map--do-array) + function + map)) + (defun map-keys-apply (function map) "Return the result of applying FUNCTION to each key of MAP. @@ -249,7 +260,7 @@ MAP can be a list, hash-table or array." :hash-table (zerop (hash-table-count map)))) (defun map-contains-key (map key &optional testfn) - "Return non-nil if MAP contain KEY, nil otherwise. + "If MAP contain KEY return KEY, nil otherwise. Equality is defined by TESTFN if non-nil or by `equal' if nil. MAP can be a list, hash-table or array." @@ -282,27 +293,33 @@ MAP can be a list, hash-table or array." "Merge into a map of type TYPE all the key/value pairs in MAPS. MAP can be a list, hash-table or array." - (let (result) + (let ((result (map-into (pop maps) type))) (while maps + ;; FIXME: When `type' is `list', we get an O(N^2) behavior. + ;; For small tables, this is fine, but for large tables, we + ;; should probably use a hash-table internally which we convert + ;; to an alist in the end. (map-apply (lambda (key value) - (setf (map-elt result key) value)) - (pop maps))) - (map-into result type))) + (setf (map-elt result key) value)) + (pop maps))) + result)) (defun map-merge-with (type function &rest maps) "Merge into a map of type TYPE all the key/value pairs in MAPS. When two maps contain the same key, call FUNCTION on the two values and use the value returned by it. MAP can be a list, hash-table or array." - (let (result) + (let ((result (map-into (pop maps) type)) + (not-found (cons nil nil))) (while maps (map-apply (lambda (key value) - (setf (map-elt result key) - (if (map-contains-key result key) - (funcall function (map-elt result key) value) - value))) - (pop maps))) - (map-into result type))) + (cl-callf (lambda (old) + (if (eq old not-found) + value + (funcall function old value))) + (map-elt result key not-found))) + (pop maps))) + result)) (defun map-into (map type) "Convert the map MAP into a map of type TYPE. @@ -347,6 +364,20 @@ MAP can be a list, hash-table or array." (setq index (1+ index)))) map))) +(defun map--do-alist (function alist) + "Private function used to iterate over ALIST using FUNCTION." + (seq-do (lambda (pair) + (funcall function + (car pair) + (cdr pair))) + alist)) + +(defun map--do-array (function array) + "Private function used to iterate over ARRAY using FUNCTION." + (seq-do-indexed (lambda (elt index) + (funcall function index elt)) + array)) + (defun map--into-hash-table (map) "Convert MAP into a hash-table." (let ((ht (make-hash-table :size (map-length map) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 1d4c3f0586c..1b30499bf19 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -114,7 +114,10 @@ Each element has the form (WHERE BYTECODE STACK) where: (usage (help-split-fundoc origdoc function))) (setq usage (if (null usage) (let ((arglist (help-function-arglist flist))) - (help--make-usage-docstring function arglist)) + ;; "[Arg list not available until function + ;; definition is loaded]", bug#21299 + (if (stringp arglist) t + (help--make-usage-docstring function arglist))) (setq origdoc (cdr usage)) (car usage))) (help-add-fundoc-usage (concat docstring origdoc) usage)))) diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index d4b5cd211e4..8146bb3c283 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -103,6 +103,47 @@ (if (integerp val) `(t . ,val) val) i)))) +;; (defun radix-tree--trim (tree string i) +;; (if (= i (length string)) +;; tree +;; (pcase tree +;; (`((,prefix . ,ptree) . ,rtree) +;; (let* ((ni (+ i (length prefix))) +;; (cmp (compare-strings prefix nil nil string i ni)) +;; ;; FIXME: We could compute nrtree more efficiently +;; ;; whenever cmp is not -1 or 1. +;; (nrtree (radix-tree--trim rtree string i))) +;; (if (eq t cmp) +;; (pcase (radix-tree--trim ptree string ni) +;; (`nil nrtree) +;; (`((,pprefix . ,pptree)) +;; `((,(concat prefix pprefix) . ,pptree) . ,nrtree)) +;; (nptree `((,prefix . ,nptree) . ,nrtree))) +;; (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1)))) +;; (cond +;; ((equal (+ n i) (length string)) +;; `((,prefix . ,ptree) . ,nrtree)) +;; (t nrtree)))))) +;; (val val)))) + +(defun radix-tree--prefixes (tree string i prefixes) + (pcase tree + (`((,prefix . ,ptree) . ,rtree) + (let* ((ni (+ i (length prefix))) + (cmp (compare-strings prefix nil nil string i ni)) + ;; FIXME: We could compute prefixes more efficiently + ;; whenever cmp is not -1 or 1. + (prefixes (radix-tree--prefixes rtree string i prefixes))) + (if (eq t cmp) + (radix-tree--prefixes ptree string ni prefixes) + prefixes))) + (val + (if (null val) + prefixes + (cons (cons (substring string 0 i) + (if (eq (car-safe val) t) (cdr val) val)) + prefixes))))) + (defun radix-tree--subtree (tree string i) (if (equal (length string) i) tree (pcase tree @@ -143,6 +184,16 @@ If not found, return nil." "Return the subtree of TREE rooted at the prefix STRING." (radix-tree--subtree tree string 0)) +;; (defun radix-tree-trim (tree string) +;; "Return a TREE which only holds entries \"related\" to STRING. +;; \"Related\" is here defined as entries where there's a `string-prefix-p' relation +;; between STRING and the key." +;; (radix-tree-trim tree string 0)) + +(defun radix-tree-prefixes (tree string) + "Return an alist of all bindings in TREE for prefixes of STRING." + (radix-tree--prefixes tree string 0 nil)) + (eval-and-compile (pcase-defmacro radix-tree-leaf (vpat) ;; FIXME: We'd like to use a negative pattern (not consp), but pcase @@ -181,8 +232,15 @@ PREFIX is only used internally." (defun radix-tree-count (tree) (let ((i 0)) - (radix-tree-iter-mappings tree (lambda (_ _) (setq i (1+ i)))) + (radix-tree-iter-mappings tree (lambda (_k _v) (setq i (1+ i)))) i)) +(defun radix-tree-from-map (map) + ;; Aka (cl-defmethod map-into (map (type (eql radix-tree)))) ...) + (require 'map) + (let ((rt nil)) + (map-apply (lambda (k v) (setq rt (radix-tree-insert rt k v))) map) + rt)) + (provide 'radix-tree) ;;; radix-tree.el ends here diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 92f0ad78566..e5004f8cdab 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 2.14 +;; Version: 2.18 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -117,6 +117,16 @@ Return SEQUENCE." (defalias 'seq-each #'seq-do) +(defun seq-do-indexed (function sequence) + "Apply FUNCTION to each element of SEQUENCE and return nil. +Unlike `seq-map', FUNCTION takes two arguments: the element of +the sequence, and its index within the sequence." + (let ((index 0)) + (seq-do (lambda (elt) + (funcall function elt index) + (setq index (1+ index))) + sequence))) + (cl-defgeneric seqp (sequence) "Return non-nil if SEQUENCE is a sequence, nil otherwise." (sequencep sequence)) @@ -339,7 +349,8 @@ found or not." "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-some (lambda (e) - (funcall (or testfn #'equal) elt e)) + (when (funcall (or testfn #'equal) elt e) + e)) sequence)) (cl-defgeneric seq-position (sequence elt &optional testfn) @@ -471,10 +482,7 @@ If no element is found, return nil." (cl-defmethod seq-drop ((list list) n) "Optimized implementation of `seq-drop' for lists." - (while (and list (> n 0)) - (setq list (cdr list) - n (1- n))) - list) + (nthcdr n list)) (cl-defmethod seq-take ((list list) n) "Optimized implementation of `seq-take' for lists." diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index e8d1939865f..173cd11fba4 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -198,6 +198,171 @@ to bind a single value, BINDINGS can just be a plain tuple." (substring string 0 (- (length string) (length suffix))) string)) +(defun read-multiple-choice (prompt choices) + "Ask user a multiple choice question. +PROMPT should be a string that will be displayed as the prompt. + +CHOICES is an alist where the first element in each entry is a +character to be entered, the second element is a short name for +the entry to be displayed while prompting (if there's room, it +might be shortened), and the third, optional entry is a longer +explanation that will be displayed in a help buffer if the user +requests more help. + +This function translates user input into responses by consulting +the bindings in `query-replace-map'; see the documentation of +that variable for more information. In this case, the useful +bindings are `recenter', `scroll-up', and `scroll-down'. If the +user enters `recenter', `scroll-up', or `scroll-down' responses, +perform the requested window recentering or scrolling and ask +again. + +The return value is the matching entry from the CHOICES list. + +Usage example: + +\(read-multiple-choice \"Continue connecting?\" + '((?a \"always\") + (?s \"session only\") + (?n \"no\")))" + (let* ((altered-names nil) + (full-prompt + (format + "%s (%s): " + prompt + (mapconcat + (lambda (elem) + (let* ((name (cadr elem)) + (pos (seq-position name (car elem))) + (altered-name + (cond + ;; Not in the name string. + ((not pos) + (format "[%c] %s" (car elem) name)) + ;; The prompt character is in the name, so highlight + ;; it on graphical terminals... + ((display-supports-face-attributes-p + '(:underline t) (window-frame)) + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) + 'face 'read-multiple-choice-face + name) + name) + ;; And put it in [bracket] on non-graphical terminals. + (t + (concat + (substring name 0 pos) + "[" + (upcase (substring name pos (1+ pos))) + "]" + (substring name (1+ pos))))))) + (push (cons (car elem) altered-name) + altered-names) + altered-name)) + (append choices '((?? "?"))) + ", "))) + tchar buf wrong-char answer) + (save-window-excursion + (save-excursion + (while (not tchar) + (message "%s%s" + (if wrong-char + "Invalid choice. " + "") + full-prompt) + (setq tchar + (if (and (display-popup-menus-p) + last-input-event ; not during startup + (listp last-nonmenu-event) + use-dialog-box) + (x-popup-dialog + t + (cons prompt + (mapcar + (lambda (elem) + (cons (capitalize (cadr elem)) + (car elem))) + choices))) + (condition-case nil + (let ((cursor-in-echo-area t)) + (read-char)) + (error nil)))) + (setq answer (lookup-key query-replace-map (vector tchar) t)) + (setq tchar + (cond + ((eq answer 'recenter) + (recenter) t) + ((eq answer 'scroll-up) + (ignore-errors (scroll-up-command)) t) + ((eq answer 'scroll-down) + (ignore-errors (scroll-down-command)) t) + ((eq answer 'scroll-other-window) + (ignore-errors (scroll-other-window)) t) + ((eq answer 'scroll-other-window-down) + (ignore-errors (scroll-other-window-down)) t) + (t tchar))) + (when (eq tchar t) + (setq wrong-char nil + tchar nil)) + ;; The user has entered an invalid choice, so display the + ;; help messages. + (when (and (not (eq tchar nil)) + (not (assq tchar choices))) + (setq wrong-char (not (memq tchar '(?? ?\C-h))) + tchar nil) + (when wrong-char + (ding)) + (with-help-window (setq buf (get-buffer-create + "*Multiple Choice Help*")) + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) + (goto-char start) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (bolp) + (insert line "\n") + (insert line)) + (forward-line 1))))))))))) + (when (buffer-live-p buf) + (kill-buffer buf)) + (assq tchar choices))) + (provide 'subr-x) ;;; subr-x.el ends here diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 31fc67ec815..ac509b3465d 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -316,6 +316,9 @@ END) suitable for `syntax-propertize-function'." (unless (eq funs (cdr syntax-propertize-extend-region-functions)) (setq funs syntax-propertize-extend-region-functions))))) + ;; Flush ppss cache between the original value of `start' and that + ;; set above by syntax-propertize-extend-region-functions. + (syntax-ppss-flush-cache start) ;; Move the limit before calling the function, so the function ;; can use syntax-ppss. (setq syntax-propertize--done end) |