diff options
author | Joakim Verona <joakim@verona.se> | 2015-02-08 21:55:28 +0100 |
---|---|---|
committer | Joakim Verona <joakim@verona.se> | 2015-02-08 21:55:28 +0100 |
commit | 5e1d5ef39ca0d2fbff26d659f2ec6ce863b14529 (patch) | |
tree | 860e0d53399626aee6249ebb5f972879f403b228 /lisp/emacs-lisp | |
parent | 148262ce3db990ed16989341345e232570b3a338 (diff) | |
parent | 7d631aa0ffab875e4979727f632703ad5b4100a2 (diff) | |
download | emacs-xwidget.tar.gz |
merge masterxwidget
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 59 | ||||
-rw-r--r-- | lisp/emacs-lisp/cconv.el | 31 | ||||
-rw-r--r-- | lisp/emacs-lisp/eieio-base.el | 3 | ||||
-rw-r--r-- | lisp/emacs-lisp/eieio-compat.el | 7 | ||||
-rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 43 | ||||
-rw-r--r-- | lisp/emacs-lisp/package.el | 60 | ||||
-rw-r--r-- | lisp/emacs-lisp/seq.el | 55 |
7 files changed, 186 insertions, 72 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2bd8d07851b..548aaa9626b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -31,6 +31,10 @@ ;; faster. [`LAP' == `Lisp Assembly Program'.] ;; The user entry points are byte-compile-file and byte-recompile-directory. +;;; Todo: + +;; - Turn "not bound at runtime" functions into autoloads. + ;;; Code: ;; ======================================================================== @@ -450,7 +454,7 @@ Return the compile-time value of FORM." (eval-when-compile . ,(lambda (&rest body) (let ((result nil)) (byte-compile-recurse-toplevel - (cons 'progn body) + (macroexp-progn body) (lambda (form) (setf result (byte-compile-eval @@ -459,7 +463,7 @@ Return the compile-time value of FORM." (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel - (cons 'progn body) + (macroexp-progn body) (lambda (form) ;; Don't compile here, since we don't know ;; whether to compile as byte-compile-form @@ -1458,7 +1462,7 @@ extra args." ;; These would sometimes be warned about ;; but such warnings are never useful, ;; so don't warn about them. - macroexpand cl-macroexpand-all + macroexpand cl--compiling-file)))) (byte-compile-warn "function `%s' from cl package called at runtime" func))) @@ -2319,10 +2323,12 @@ list that represents a doc string reference. form)) (put 'define-abbrev-table 'byte-hunk-handler - 'byte-compile-file-form-define-abbrev-table) -(defun byte-compile-file-form-define-abbrev-table (form) - (if (eq 'quote (car-safe (car-safe (cdr form)))) - (byte-compile--declare-var (car-safe (cdr (cadr form))))) + 'byte-compile-file-form-defvar-function) +(put 'defvaralias 'byte-hunk-handler 'byte-compile-file-form-defvar-function) + +(defun byte-compile-file-form-defvar-function (form) + (pcase-let (((or `',name (let name nil)) (nth 1 form))) + (if name (byte-compile--declare-var name))) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2330,8 +2336,7 @@ list that represents a doc string reference. (defun byte-compile-file-form-custom-declare-variable (form) (when (byte-compile-warning-enabled-p 'callargs) (byte-compile-nogroup-warn form)) - (byte-compile--declare-var (nth 1 (nth 1 form))) - (byte-compile-keep-pending form)) + (byte-compile-file-form-defvar-function form)) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -2580,17 +2585,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." fun) (t (when (symbolp form) - (unless (memq (car-safe fun) '(closure lambda)) - (error "Don't know how to compile %S" fun)) (setq lexical-binding (eq (car fun) 'closure)) (setq fun (byte-compile--reify-function fun))) - (unless (eq (car-safe fun) 'lambda) - (error "Don't know how to compile %S" fun)) ;; Expand macros. (setq fun (byte-compile-preprocess fun)) - ;; Get rid of the `function' quote added by the `lambda' macro. - (if (eq (car-safe fun) 'function) (setq fun (cadr fun))) - (setq fun (byte-compile-lambda fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) (if macro (push 'macro fun)) (if (symbolp form) (fset form fun) @@ -2966,6 +2965,16 @@ for symbols generated by the byte compiler itself." (interactive-only (or (get fn 'interactive-only) (memq fn byte-compile-interactive-only-functions)))) + (when (memq fn '(set symbol-value run-hooks ;; add-to-list + add-hook remove-hook run-hook-with-args + run-hook-with-args-until-success + run-hook-with-args-until-failure)) + (pcase (cdr form) + (`(',var . ,_) + (when (assq var byte-compile-lexical-variables) + (byte-compile-log-warning + (format "%s cannot use lexical var `%s'" fn var) + nil :error))))) (when (macroexp--const-symbol-p fn) (byte-compile-warn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only) @@ -3079,8 +3088,9 @@ for symbols generated by the byte compiler itself." (dotimes (_ (- (/ (1+ fmax2) 2) alen)) (byte-compile-push-constant nil))) ((zerop (logand fmax2 1)) - (byte-compile-log-warning "Too many arguments for inlined function" - nil :error) + (byte-compile-log-warning + (format "Too many arguments for inlined function %S" form) + nil :error) (byte-compile-discard (- alen (/ fmax2 2)))) (t ;; Turn &rest args into a list. @@ -3453,15 +3463,22 @@ discarding." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (let* ((vars (nth 1 form)) (env (nth 2 form)) - (body (nthcdr 3 form)) + (docstring-exp (nth 3 form)) + (body (nthcdr 4 form)) (fun (byte-compile-lambda `(lambda ,vars . ,body) nil (length env)))) - (cl-assert (> (length env) 0)) ;Otherwise, we don't need a closure. + (cl-assert (or (> (length env) 0) + docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) (byte-compile-form `(make-byte-code ',(aref fun 0) ',(aref fun 1) (vconcat (vector . ,env) ',(aref fun 2)) - ,@(nthcdr 3 (mapcar (lambda (x) `',x) fun))))))) + ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) + (if docstring-exp + `(,(car rest) + ,docstring-exp + ,@(cddr rest)) + rest))))))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e9d33e6c646..fa824075933 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -48,7 +48,7 @@ ;; if the function is suitable for lambda lifting (if all calls are known) ;; ;; (lambda (v0 ...) ... fv0 .. fv1 ...) => -;; (internal-make-closure (v0 ...) (fv1 ...) +;; (internal-make-closure (v0 ...) (fv0 ...) <doc> ;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) ;; ;; If the function has no free variables, we don't do anything. @@ -65,6 +65,14 @@ ;; ;;; Code: +;; PROBLEM cases found during conversion to lexical binding. +;; We should try and detect and warn about those cases, even +;; for lexical-binding==nil to help prepare the migration. +;; - Uses of run-hooks, and friends. +;; - Cases where we want to apply the same code to different vars depending on +;; some test. These sometimes use a (let ((foo (if bar 'a 'b))) +;; ... (symbol-value foo) ... (set foo ...)). + ;; TODO: (not just for cconv but also for the lexbind changes in general) ;; - let (e)debug find the value of lexical variables from the stack. ;; - make eval-region do the eval-sexp-add-defvars dance. @@ -87,9 +95,8 @@ ;; the bytecomp only compiles it once. ;; - Since we know here when a variable is not mutated, we could pass that ;; info to the byte-compiler, e.g. by using a new `immutable-let'. -;; - add tail-calls to bytecode.c and the byte compiler. ;; - call known non-escaping functions with `goto' rather than `call'. -;; - optimize mapcar to a while loop. +;; - optimize mapc to a dolist loop. ;; (defmacro dlet (binders &rest body) ;; ;; Works in both lexical and non-lexical mode. @@ -195,7 +202,7 @@ Returns a form where all lambdas don't have any free variables." (unless (memq (car b) s) (push b res))) (nreverse res))) -(defun cconv--convert-function (args body env parentform) +(defun cconv--convert-function (args body env parentform &optional docstring) (cl-assert (equal body (caar cconv-freevars-alist))) (let* ((fvs (cdr (pop cconv-freevars-alist))) (body-new '()) @@ -240,11 +247,11 @@ Returns a form where all lambdas don't have any free variables." `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) (cond - ((null envector) ;if no freevars - do nothing + ((not (or envector docstring)) ;If no freevars - do nothing. `(function (lambda ,args . ,body-new))) (t `(internal-make-closure - ,args ,envector . ,body-new))))) + ,args ,envector ,docstring . ,body-new))))) (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. @@ -407,7 +414,9 @@ places where they originally did not directly appear." cond-forms))) (`(function (lambda ,args . ,body) . ,_) - (cconv--convert-function args body env form)) + (let ((docstring (if (eq :documentation (car-safe (car body))) + (cconv-convert (cadr (pop body)) env extend)))) + (cconv--convert-function args body env form docstring))) (`(internal-make-closure . ,_) (byte-compile-report-error @@ -533,7 +542,7 @@ FORM is the parent form that binds this var." ;; use = `(,binder ,read ,mutated ,captured ,called) (pcase vardata (`(,_ nil nil nil nil) nil) - (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_) + (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) (byte-compile-log-warning (format "%s `%S' not left unused" varkind var)))) @@ -643,6 +652,8 @@ and updates the data stored in ENV." (cconv--analyze-use vardata form "variable")))) (`(function (lambda ,vrs . ,body-forms)) + (when (eq :documentation (car-safe (car body-forms))) + (cconv-analyze-form (cadr (pop body-forms)) env)) (cconv--analyze-function vrs body-forms env form)) (`(setq . ,forms) @@ -665,6 +676,10 @@ and updates the data stored in ENV." (dolist (forms cond-forms) (dolist (form forms) (cconv-analyze-form form env)))) + ;; ((and `(quote ,v . ,_) (guard (assq v env))) + ;; (byte-compile-log-warning + ;; (format "Possible confusion variable/symbol for `%S'" v))) + (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 46585ee76c6..fcf02b92736 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -290,8 +290,7 @@ constructor functions are considered valid. Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. - (let ((slot-idx (eieio--slot-name-index class - nil slot)) + (let ((slot-idx (eieio--slot-name-index class slot)) (type nil) (classtype nil)) (setq slot-idx (- slot-idx diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index fcca99d79d5..7468c040e10 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -188,11 +188,10 @@ Summary: (args (help-function-arglist code 'preserve-names)) (doc-only (if docstring (let ((split (help-split-fundoc docstring nil))) - (if split (cdr split) docstring)))) - (new-docstring (help-add-fundoc-usage doc-only - (cons 'cl-cnm args)))) - ;; FIXME: ¡Add new-docstring to those closures! + (if split (cdr split) docstring))))) (lambda (cnm &rest args) + (:documentation + (help-add-fundoc-usage doc-only (cons 'cl-cnm args))) (cl-letf (((symbol-function 'call-next-method) cnm) ((symbol-function 'next-method-p) (lambda () (cl--generic-isnot-nnm-p cnm)))) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 77d8c01388b..fa8fefa1df0 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -288,16 +288,17 @@ It creates an autoload function for CNAME's constructor." (defun eieio-make-class-predicate (class) (lambda (obj) - ;; (:docstring (format "Test OBJ to see if it's an object of type %S." - ;; class)) + (:documentation + (format "Return non-nil if OBJ is an object of type `%S'.\n\n(fn OBJ)" + class)) (and (eieio-object-p obj) (same-class-p obj class)))) (defun eieio-make-child-predicate (class) (lambda (obj) - ;; (:docstring (format - ;; "Test OBJ to see if it's an object is a child of type %S." - ;; class)) + (:documentation + (format "Return non-nil if OBJ is an object of type `%S' or a subclass. +\n(fn OBJ)" class)) (and (eieio-object-p obj) (object-of-class-p obj class)))) @@ -312,8 +313,7 @@ See `defclass' for more information." (run-hooks 'eieio-hook) (setq eieio-hook nil) - (let* ((pname superclasses) - (oldc (let ((c (eieio--class-v cname))) (if (eieio--class-p c) c))) + (let* ((oldc (let ((c (eieio--class-v cname))) (if (eieio--class-p c) c))) (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) ;; The oldc class is a stub setup by eieio-defclass-autoload. ;; Reuse it instead of creating a new one, so that existing @@ -338,9 +338,9 @@ See `defclass' for more information." (setf (eieio--class-children newc) children) (remhash cname eieio-defclass-autoload-map)))) - (if pname + (if superclasses (progn - (dolist (p pname) + (dolist (p superclasses) (if (not (and p (symbolp p))) (error "Invalid parent class %S" p) (let ((c (eieio--class-v p))) @@ -396,7 +396,7 @@ See `defclass' for more information." ;; Before adding new slots, let's add all the methods and classes ;; in from the parent class. - (eieio-copy-parents-into-subclass newc superclasses) + (eieio-copy-parents-into-subclass newc) ;; Store the new class vector definition into the symbol. We need to ;; do this first so that we can call defmethod for the accessor. @@ -784,7 +784,7 @@ if default value is nil." )) )) -(defun eieio-copy-parents-into-subclass (newc _parents) +(defun eieio-copy-parents-into-subclass (newc) "Copy into NEWC the slots of PARENTS. Follow the rules of not overwriting early parents when applying to the new child class." @@ -911,7 +911,7 @@ Argument FN is the function calling this verifier." (if (eieio--class-p c) (eieio-class-un-autoload obj)) c)) (t (eieio--object-class-object obj)))) - (c (eieio--slot-name-index class obj slot))) + (c (eieio--slot-name-index class slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. ;; Let's check that info out. @@ -935,7 +935,7 @@ Fills in OBJ's SLOT with its default value." (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) (t (eieio--object-class-object obj)))) - (c (eieio--slot-name-index cl obj slot))) + (c (eieio--slot-name-index cl slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. ;; Let's check that info out. @@ -973,7 +973,7 @@ Fills in OBJ's SLOT with VALUE." (cl-check-type obj eieio-object) (cl-check-type slot symbol) (let* ((class (eieio--object-class-object obj)) - (c (eieio--slot-name-index class obj slot))) + (c (eieio--slot-name-index class slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. ;; Let's check that info out. @@ -997,7 +997,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (setq class (eieio--class-object class)) (cl-check-type class eieio--class) (cl-check-type slot symbol) - (let* ((c (eieio--slot-name-index class nil slot))) + (let* ((c (eieio--slot-name-index class slot))) (if (not c) ;; It might be missing because it is a :class allocated slot. ;; Let's check that info out. @@ -1021,12 +1021,9 @@ Fills in the default value in CLASS' in SLOT with VALUE." ;;; EIEIO internal search functions ;; -(defun eieio--slot-name-index (class obj slot) - "In CLASS for OBJ find the index of the named SLOT. -The slot is a symbol which is installed in CLASS by the `defclass' -call. OBJ can be nil, but if it is an object, and the slot in question -is protected, access will be allowed if OBJ is a child of the currently -scoped class. +(defun eieio--slot-name-index (class slot) + "In CLASS find the index of the named SLOT. +The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call @@ -1035,7 +1032,7 @@ reverse-lookup that name, and recurse with the associated slot value." (if (integerp fsi) (+ (eval-when-compile eieio--object-num-slots) fsi) (let ((fn (eieio--initarg-to-attribute class slot))) - (if fn (eieio--slot-name-index class obj fn) nil))))) + (if fn (eieio--slot-name-index class fn) nil))))) (defun eieio--class-slot-name-index (class slot) "In CLASS find the index of the named SLOT. @@ -1255,7 +1252,7 @@ method invocation orders of the involved classes." (eieio--class-precedence-list tag)))) -;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "b568ffb3c90ed5d0ae673f0051d608ee") +;;;### (autoloads nil "eieio-compat" "eieio-compat.el" "5b04c9a8fff2bd3f3d3ac54aba0f65b7") ;;; Generated autoloads from eieio-compat.el (autoload 'eieio--defalias "eieio-compat" "\ diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 67cd44d6758..c3a2061aae2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -161,6 +161,7 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'epg)) ;For setf accessors. @@ -1510,6 +1511,11 @@ with PKG-DESC entry removed." (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p)))) (car p)))))) +(defun package--newest-p (pkg) + "Return t if PKG is the newest package with its name." + (equal (cadr (assq (package-desc-name pkg) package-alist)) + pkg)) + (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. @@ -1527,7 +1533,10 @@ If NOSAVE is non-nil, the package is not removed from ;; don't want it marked as selected, so we remove it from ;; `package-selected-packages' even if it can't be deleted. (when (and (null nosave) - (package--user-selected-p name)) + (package--user-selected-p name) + ;; Don't delesect if this is an older version of an + ;; upgraded package. + (package--newest-p pkg-desc)) (customize-save-variable 'package-selected-packages (remove name package-selected-packages))) (cond ((not (string-prefix-p (file-name-as-directory @@ -2262,7 +2271,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-mark-install (&optional _num) "Mark a package for installation and move to the next line." (interactive "p") - (if (member (package-menu-get-status) '("available" "new")) + (if (member (package-menu-get-status) '("available" "new" "dependency")) (tabulated-list-put-tag "I" t) (forward-line))) @@ -2351,6 +2360,40 @@ call will upgrade the package." (length upgrades) (if (= (length upgrades) 1) "" "s"))))) +(defun package--sort-deps-in-alist (package only) + "Return a list of dependencies for PACKAGE sorted by dependency. +PACKAGE is included as the first element of the returned list. +ONLY is an alist associating package names to package objects. +Only these packages will be in the return value an their cdrs are +destructively set to nil in ONLY." + (let ((out)) + (dolist (dep (package-desc-reqs package)) + (when-let ((cell (assq (car dep) only)) + (dep-package (cdr-safe cell))) + (setcdr cell nil) + (setq out (append (package--sort-deps-in-alist dep-package only) + out)))) + (cons package out))) + +(defun package--sort-by-dependence (package-list) + "Return PACKAGE-LIST sorted by dependence. +That is, any element of the returned list is guaranteed to not +directly depend on any elements that come before it. + +PACKAGE-LIST is a list of package-desc objects. +Indirect dependencies are guaranteed to be returned in order only +if all the in-between dependencies are also in PACKAGE-LIST." + (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) + out-list) + (dolist (cell alist out-list) + ;; `package--sort-deps-in-alist' destructively changes alist, so + ;; some cells might already be empty. We check this here. + (when-let ((pkg-desc (cdr cell))) + (setcdr cell nil) + (setq out-list + (append (package--sort-deps-in-alist pkg-desc alist) + out-list)))))) + (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. Packages marked for installation are downloaded and installed; @@ -2384,7 +2427,13 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (mapconcat #'package-desc-full-name install-list ", "))))) (mapc (lambda (p) - (package-install p (null (package-installed-p p)))) + ;; Mark as selected if it's the exact version of a + ;; package that's already installed, or if it's not + ;; installed at all. Don't mark if it's a new + ;; version of an installed package. + (package-install p (or (package-installed-p p) + (not (package-installed-p + (package-desc-name p)))))) install-list))) ;; Delete packages, prompting if necessary. (when delete-list @@ -2398,7 +2447,7 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (length delete-list) (mapconcat #'package-desc-full-name delete-list ", "))))) - (dolist (elt delete-list) + (dolist (elt (package--sort-by-dependence delete-list)) (condition-case-unless-debug err (package-delete elt) (error (message (cadr err))))) @@ -2412,7 +2461,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (format "These %d packages are no longer needed, delete them (%s)? " (length removable) (mapconcat #'symbol-name removable ", ")))) - (mapc (lambda (p) (package-delete (cadr (assq p package-alist)))) + ;; We know these are removable, so we can use force instead of sorting them. + (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) 'force 'nosave)) removable)))) (package-menu--generate t t)))) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index b28153b7f81..025d94e10b9 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -2,9 +2,9 @@ ;; Copyright (C) 2014-2015 Free Software Foundation, Inc. -;; Author: Nicolas Petton <petton.nicolas@gmail.com> +;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 1.0 +;; Version: 1.1 ;; Maintainer: emacs-devel@gnu.org @@ -92,14 +92,14 @@ returned." (seq-subseq seq 0 (min (max n 0) (seq-length seq))))) (defun seq-drop-while (pred seq) - "Return a sequence, from the first element for which (PRED element) is nil, of SEQ. + "Return a sequence from the first element for which (PRED element) is nil in SEQ. The result is a sequence of the same type as SEQ." (if (listp seq) (seq--drop-while-list pred seq) (seq-drop seq (seq--count-successive pred seq)))) (defun seq-take-while (pred seq) - "Return a sequence of the successive elements for which (PRED element) is non-nil in SEQ. + "Return the successive elements for which (PRED element) is non-nil in SEQ. The result is a sequence of the same type as SEQ." (if (listp seq) (seq--take-while-list pred seq) @@ -152,7 +152,7 @@ If SEQ is empty, return INITIAL-VALUE and FUNCTION is not called." t)) (defun seq-count (pred seq) - "Return the number of elements for which (PRED element) returns non-nil in seq." + "Return the number of elements for which (PRED element) is non-nil in SEQ." (let ((count 0)) (seq-doseq (elt seq) (when (funcall pred elt) @@ -224,15 +224,50 @@ TYPE must be one of following symbols: vector, string or list. (`list (apply #'append (append seqs '(nil)))) (t (error "Not a sequence type name: %s" type)))) +(defun seq-mapcat (function seq &optional type) + "Concatenate the result of applying FUNCTION to each element of SEQ. +The result is a sequence of type TYPE, or a list if TYPE is nil." + (apply #'seq-concatenate (or type 'list) + (seq-map function seq))) + +(defun seq-partition (seq n) + "Return a list of the elements of SEQ grouped into sub-sequences of length N. +The last sequence may contain less than N elements. If N is a +negative integer or 0, nil is returned." + (unless (< n 1) + (let ((result '())) + (while (not (seq-empty-p seq)) + (push (seq-take seq n) result) + (setq seq (seq-drop seq n))) + (nreverse result)))) + +(defun seq-group-by (function seq) + "Apply FUNCTION to each element of SEQ. +Separate the elements of SEQ into an alist using the results as +keys. Keys are compared using `equal'." + (nreverse + (seq-reduce + (lambda (acc elt) + (let* ((key (funcall function elt)) + (cell (assoc key acc))) + (if cell + (setcdr cell (push elt (cdr cell))) + (push (list key elt) acc)) + acc)) + seq + nil))) + (defun seq--drop-list (list n) - "Optimized version of `seq-drop' for lists." + "Return a list from LIST without its first N elements. +This is an optimization for lists in `seq-drop'." (while (and list (> n 0)) (setq list (cdr list) n (1- n))) list) (defun seq--take-list (list n) - "Optimized version of `seq-take' for lists." + "Return a list from LIST made of its first N elements. +This is an optimization for lists in `seq-take'." (let ((result '())) (while (and list (> n 0)) (setq n (1- n)) @@ -240,13 +275,15 @@ TYPE must be one of following symbols: vector, string or list. (nreverse result))) (defun seq--drop-while-list (pred list) - "Optimized version of `seq-drop-while' for lists." + "Return a list from the first element for which (PRED element) is nil in LIST. +This is an optimization for lists in `seq-drop-while'." (while (and list (funcall pred (car list))) (setq list (cdr list))) list) (defun seq--take-while-list (pred list) - "Optimized version of `seq-take-while' for lists." + "Return the successive elements for which (PRED element) is non-nil in LIST. +This is an optimization for lists in `seq-take-while'." (let ((result '())) (while (and list (funcall pred (car list))) (push (pop list) result)) |